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, U, NP, NPE, PMESH_SIZE, KPATCH, &
                                      ILUOUT, PZDG, PZDG_OLD, HNAME, 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_sfx_grid_n, ONLY : grid_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_p_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 modd_surfex_mpi, ONLY : nproc, nrank, npio, ncomm
USE modi_gather_and_write_mpi
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
REAL, DIMENSION(:), INTENT(IN) :: PMESH_SIZE
INTEGER, INTENT(IN) :: KPATCH
!
INTEGER,                        INTENT(IN   ) :: ILUOUT
REAL, DIMENSION(:,:,:),         INTENT(IN   ) :: PFIELD_OLD,PZDG,PZDG_OLD
 CHARACTER(LEN=3), INTENT(IN) :: HNAME
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
TYPE(isba_p_t), POINTER :: PK
!
REAL, DIMENSION(U%NSIZE_NATURE,SIZE(NPE%AL(1)%XWG,2),KPATCH) :: ZFIELD0
REAL,    DIMENSION(U%NSIZE_NATURE) :: 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, JP, JJ  ! loop counter 
REAL                               :: ZRATIO_TOT, ZWORK1,ZWORK2
!
REAL, DIMENSION(:), ALLOCATABLE :: ZFIELD_TOT, ZFIELD_OLD_TOT, ZFRAC_NAT_TOT
INTEGER :: INFOMPI
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('CONSERV_GLOBAL_MASS',0,zhook_handle)
!
IF (trim(hname)=="WG") THEN
  DO jp = 1,kpatch
    zfield0(:,:,jp) = npe%AL(jp)%XWG(:,:)
  ENDDO
ELSEIF (trim(hname)=="WGI") THEN
  DO jp = 1,kpatch
    zfield0(:,:,jp) = npe%AL(jp)%XWGI(:,:)
  ENDDO        
ENDIF
!
ini   = SIZE(pzdg,1)
ilev  = SIZE(pzdg,2)
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(:)*pmesh_size(:)
!
zfield(:)    =0.0
zfield_old(:)=0.0
DO jp=1,kpatch
  pk => np%AL(jp)
  DO jlev=1,ilev
     DO jj=1,pk%NSIZE_P
       imask = pk%NR_P(jj)
       !
       zfield(imask)    = zfield(imask)     + zfield0(jj,jlev,jp)*pzdg(jj,jlev,jp)*pk%XPATCH(jj)
       zfield_old(imask)= zfield_old(imask) + pfield_old(jj,jlev,jp)*pzdg_old(jj,jlev,jp)*pk%XPATCH_OLD(jj)
       !
     ENDDO
  ENDDO
ENDDO
!
zwork1=0.0
zwork2=0.0
zratio_tot = 1.0
!
IF (nproc==1) THEN
  DO jj=1,ini
    zwork1=zwork1+zfield(jj)*zfrac_nat(jj)
    zwork2=zwork2+zfield_old(jj)*zfrac_nat(jj)
  ENDDO
ELSE
  IF (nrank==npio) THEN
    ALLOCATE(zfield_tot(u%NDIM_FULL),zfield_old_tot(u%NDIM_FULL),zfrac_nat_tot(u%NDIM_FULL))
  ELSE
    ALLOCATE(zfield_tot(0),zfield_old_tot(0),zfrac_nat_tot(0))
  ENDIF
  CALL gather_and_write_mpi(zfield,zfield_tot,u%NR_NATURE)
  CALL gather_and_write_mpi(zfield_old,zfield_old_tot,u%NR_NATURE)
  CALL gather_and_write_mpi(zfrac_nat,zfrac_nat_tot,u%NR_NATURE)
  IF (nrank==npio) THEN
    DO jj=1,u%NDIM_FULL
      IF (zfield_tot(jj)/=xundef) THEN
        zwork1=zwork1+zfield_tot(jj)*zfrac_nat_tot(jj)
        zwork2=zwork2+zfield_old_tot(jj)*zfrac_nat_tot(jj)
      ENDIF
    ENDDO
  ENDIF
#ifdef SFX_MPI
  CALL mpi_bcast(zwork1,kind(zwork1)/4,mpi_real,npio,ncomm,infompi)
  CALL mpi_bcast(zwork2,kind(zwork2)/4,mpi_real,npio,ncomm,infompi)
#endif
 DEALLOCATE(zfield_tot,zfield_old_tot,zfrac_nat_tot)        
ENDIF
!
IF(zwork2/= 0.)THEN
   zratio_tot = zwork1/zwork2
ENDIF
!
WHERE(zfield0(:,:,:)/=xundef) zfield0(:,:,:)= zfield0(:,:,:) * zratio_tot
!
IF (trim(hname)=="WG") THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XWG(:,:) = zfield0(:,:,jp)
  ENDDO
ELSEIF (trim(hname)=="WGI") THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XWGI(:,:) = zfield0(:,:,jp)
  ENDDO        
ENDIF
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('CONSERV_GLOBAL_MASS',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE conserv_global_mass