ini_var_from_patch.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 ini_var_from_patch (DTCO, I, UG, U, &
                                     hprogram,kluout,hname,pfield,kpts,pdef)
!!
!!    PURPOSE
!!    -------
!!
!!      (1) KPTS=n  interpol field with n pts
!!      (2) KPTS=0  conserve cells mass  
!!   Case 2 : simple extrapolation based on the inside cell informations.
!!             this is donne before conserving cell or global mass
!!
!!    METHOD
!!    ------ 
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    R. Alkama        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!    Original    12/2010
!!
!----------------------------------------------------------------------------
!!*    0.     DECLARATION
!            -----------
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_isba_n, ONLY : isba_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,        ONLY : xundef
!
USE modi_get_surf_mask_n
USE modi_interpol_field
USE modi_unpack_same_rank
USE modi_pack_same_rank
!
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_t), INTENT(INOUT) :: i
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 CHARACTER(LEN=6),             INTENT(IN)    :: hprogram  ! host model
INTEGER,                      INTENT(IN   ) :: kluout
INTEGER,                      INTENT(IN   ) :: kpts
 CHARACTER(LEN=*),             INTENT(IN   ) :: hname
REAL, DIMENSION(:,:),         INTENT(INOUT) :: pfield
!
REAL, DIMENSION(:  ), OPTIONAL, INTENT(IN) :: pdef 
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
LOGICAL, DIMENSION(SIZE(I%XLAI,1),SIZE(I%XLAI,2)) :: gveg
REAL,    DIMENSION(SIZE(PFIELD,1)) :: zfield1_tot, zfield2_tot
INTEGER, DIMENSION(SIZE(PFIELD,1)) :: imask  ! mask for packing from complete field to nature field
INTEGER, DIMENSION(SIZE(PFIELD,1)) :: nsize
INTEGER, DIMENSION(U%NSIZE_FULL)     :: nsize_tot
REAL,    DIMENSION(U%NSIZE_FULL)     :: zfield_tot
INTEGER                            :: ini, ipatch, ifull, inpts
INTEGER                            :: jpatch  ! loop counter on patch
REAL                               :: zratio_tot
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
! (1) & (2) INTERPOL FILED
!-------------------------
!
IF (lhook) CALL dr_hook('INI_VAR_FROM_PATCH',0,zhook_handle)
!
ini=SIZE(pfield,1)
ipatch=SIZE(pfield,2)
!
IF (kpts>0)THEN
  !
  CALL get_surf_mask_n(dtco, u, &
                       'NATURE',ini,imask,u%NSIZE_FULL,kluout)
  !
  DO jpatch=1,ipatch
    nsize(:)=0
    WHERE (pfield(:,jpatch).NE.xundef) nsize(:)=1
    WHERE (i%XPATCH(:,jpatch)==0.) nsize(:)=-1
    CALL unpack_same_rank(imask,nsize,nsize_tot,-1)
    CALL unpack_same_rank(imask,pfield(:,jpatch),zfield_tot)
    IF(present(pdef))THEN
      CALL interpol_field(ug, u, &
                          hprogram,kluout,nsize_tot,zfield_tot,hname,pdef=pdef(jpatch),knpts=kpts)
    ELSE
      CALL interpol_field(ug, u, &
                          hprogram,kluout,nsize_tot,zfield_tot,hname,knpts=kpts)
    ENDIF
    CALL pack_same_rank(imask,zfield_tot,pfield(:,jpatch))  
  ENDDO
  !
ELSE
!
!-------------------------------------------------------------------------------
! (3) Cell mass conservative + simple interpolation based on global cell
!     informations
!----------------------------
!                 
  !
  zfield1_tot(:)=0.
  zfield2_tot(:)=0.
  !
  gveg(:,:)=.true.
  !
  IF (trim(hname)=='WR')THEN
    !no interception over soil(1), roc(2) and glaciers(3)
    DO jpatch=1,ipatch
      WHERE(i%XPATCH(:,jpatch) /=0. .AND. i%XPATCH_OLD(:,jpatch) ==0..AND.i%XLAI(:,jpatch)==0.)
          pfield(:,jpatch) = 0.  
          gveg(:,jpatch) = .false.
      ENDWHERE
    END DO
  END IF
  !
  !quantity of water before restart in each grid point
  DO jpatch=1,ipatch 
    zfield1_tot(:)=zfield1_tot(:)+ i%XPATCH_OLD(:,jpatch)*pfield(:,jpatch)
  END DO
  !
  DO jpatch=1,ipatch
    !if a patch appears in a grid point, it takes the quantity of water in the
    !whole grid point before
    WHERE(i%XPATCH(:,jpatch) /=0. .AND. i%XPATCH_OLD(:,jpatch)==0. .AND. gveg(:,jpatch))
          pfield(:,jpatch)=zfield1_tot(:)
    ENDWHERE
    !quantity of water after restart and landuse in each grid point 
    zfield2_tot(:)=zfield2_tot(:)+ i%XPATCH(:,jpatch)*pfield(:,jpatch)           
  END DO
  !
  ! Conserve cell mass if not WG and WGI
  ! If WG or WGI conserve global mass via CONSERV_GLOBAL_MASS routine
  !    is recomanded 
  !
  IF (trim(hname)/='WG' .AND. trim(hname)/='WGI') THEN
    DO jpatch=1,ipatch
      WHERE(zfield2_tot(:) > 1.e-12)
        pfield(:,jpatch)=(zfield1_tot(:)/zfield2_tot(:))*pfield(:,jpatch)
      ENDWHERE
    END DO
  ENDIF
  !
  WHERE(i%XPATCH(:,:) ==0.)pfield(:,:)=xundef
  !
ENDIF
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('INI_VAR_FROM_PATCH',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE ini_var_from_patch