conserv_global_mass.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
      SUBROUTINE conserv_global_mass (DTCO, IG, I, U, &
                                      iluout,pzdg,pzdg_old,pfield,pfield_old)
!!
!!****  *CONSERV_GLOBAL_MASS* - routine to conserve global 3D mass (LAND USE case)
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------ 
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    R. Alkama        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!    Original    07/2011
!!
!!
!!*    0.     DECLARATION
!            -----------
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_isba_grid_n, ONLY : isba_grid_t
USE modd_isba_n, ONLY : isba_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,        ONLY : xundef
!
USE modi_pack_same_rank
USE modi_get_surf_mask_n
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(isba_grid_t), INTENT(INOUT) :: ig
TYPE(isba_t), INTENT(INOUT) :: i
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
INTEGER,                        INTENT(IN   ) :: iluout
REAL, DIMENSION(:,:,:),         INTENT(IN   ) :: pfield_old,pzdg,pzdg_old
REAL, DIMENSION(:,:,:),         INTENT(INOUT) :: pfield
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
REAL,    DIMENSION(SIZE(PFIELD,1)) :: zfield,zfield_old, zfrac_nat
INTEGER, DIMENSION(SIZE(U%XNATURE))  :: imask  ! mask for packing from complete field to nature field
INTEGER                            :: ini, ipatch, ifull, ilev
INTEGER                            :: jlev, jpatch, jj  ! loop counter 
REAL                               :: zratio_tot, zwork1,zwork2
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('CONSERV_GLOBAL_MASS',0,zhook_handle)
!
ini   = SIZE(pfield,1)
ilev  = SIZE(pfield,2)
ipatch = SIZE(pfield,3)
ifull = SIZE(u%XNATURE )
!
zfrac_nat = 1.
 CALL get_surf_mask_n(dtco, u, &
                      'NATURE',ifull,imask,u%NSIZE_FULL,iluout)
 CALL pack_same_rank(imask,u%XNATURE,zfrac_nat)  
zfrac_nat(:)=zfrac_nat(:)*ig%XMESH_SIZE(:)
!
zfield(:)    =0.0
zfield_old(:)=0.0
DO jpatch=1,ipatch
  DO jlev=1,ilev
     DO jj=1,ini
        zfield(jj)    = zfield(jj)     + pfield(jj,jlev,jpatch)*pzdg(jj,jlev,jpatch)*i%XPATCH(jj,jpatch)
        zfield_old(jj)= zfield_old(jj) + pfield_old(jj,jlev,jpatch)*pzdg_old(jj,jlev,jpatch)*i%XPATCH_OLD(jj,jpatch)
     ENDDO
  ENDDO
ENDDO
!
zwork1=0.0
zwork2=0.0
zratio_tot = 1.0
!
DO jj=1,ini
   zwork1=zwork1+zfield(jj)*zfrac_nat(jj)
   zwork2=zwork2+zfield_old(jj)*zfrac_nat(jj)
ENDDO
!
IF(zwork2/= 0.)THEN
   zratio_tot = zwork1/zwork2
ENDIF
!
WHERE(pfield(:,:,:)/=xundef) pfield(:,:,:)= pfield(:,:,:) * zratio_tot
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('CONSERV_GLOBAL_MASS',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE conserv_global_mass