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, UG, U, NP, NPE, KPATCH,& 
                           HPROGRAM,KLUOUT,HNAME,KPTS,KLAYER,KLAYER2,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_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_p_t, isba_pe_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(surf_atm_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
!
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
INTEGER, INTENT(IN) :: KPATCH
!
 CHARACTER(LEN=6),            INTENT(IN) :: HPROGRAM  ! host model
INTEGER,                      INTENT(IN) :: KLUOUT
INTEGER,                      INTENT(IN) :: KPTS
 CHARACTER(LEN=*),            INTENT(IN) :: HNAME
!
INTEGER, INTENT(IN), OPTIONAL :: KLAYER
INTEGER, INTENT(IN), OPTIONAL :: KLAYER2
!
REAL, DIMENSION(:), OPTIONAL, INTENT(IN) :: PDEF 
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
LOGICAL, DIMENSION(U%NSIZE_NATURE,KPATCH) :: GVEG
REAL,    DIMENSION(U%NSIZE_NATURE) :: ZFIELD1_TOT, ZFIELD2_TOT
INTEGER, DIMENSION(U%NSIZE_NATURE) :: IMASK  ! mask for packing from complete field to nature field
INTEGER, DIMENSION(U%NSIZE_NATURE) :: NSIZE
INTEGER, DIMENSION(U%NSIZE_NATURE) :: NSIZE_NAT
INTEGER, DIMENSION(U%NSIZE_FULL)     :: NSIZE_TOT
REAL,    DIMENSION(U%NSIZE_FULL)     :: ZFIELD_TOT
REAL, DIMENSION(U%NSIZE_NATURE) :: ZFIELD_NAT
REAL, DIMENSION(U%NSIZE_NATURE,KPATCH) :: ZFIELD
INTEGER                            :: INI, IPATCH, IFULL, INPTS, JI
INTEGER                            :: JP, IMASK0  ! 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=u%NSIZE_NATURE
!
IF (trim(hname)=='WR') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XWR(:)
  ENDDO
ELSEIF (trim(hname)=='ICE_STO') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XICE_STO(:)
  ENDDO   
ELSEIF (trim(hname)=='TEMP GRO') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XTG(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='ALBSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%ALB(:)
  ENDDO
ELSEIF (trim(hname)=='EMISSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%EMIS(:)
  ENDDO
ELSEIF (trim(hname)=='TSSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%TS(:)
  ENDDO
ELSEIF (trim(hname)=='WSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%WSNOW(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='TEMPSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%TEMP(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='HEATSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%HEAT(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='AGESNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%AGE(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='TSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%T(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='GR1SNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%GRAN1(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='GR2SNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%GRAN2(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='HISTSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%HIST(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='WG') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XWG(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='WGI') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XWGI(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='RESA') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XRESA(:)
  ENDDO
ELSEIF (trim(hname)=='RHOSNOW') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%TSNOW%RHO(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='AN') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XAN(:)
  ENDDO
ELSEIF (trim(hname)=='ANDAY') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XANDAY(:)
  ENDDO
ELSEIF (trim(hname)=='ANFM') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XANFM(:)
  ENDDO
ELSEIF (trim(hname)=='LE') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XLE(:)
  ENDDO
ELSEIF (trim(hname)=='RESPBIOM') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XRESP_BIOMASS(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='BIOMASS') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XBIOMASS(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='LIGNINST') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XLIGNIN_STRUC(:,klayer)
  ENDDO
ELSEIF (trim(hname)=='LITTER') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XLITTER(:,klayer,klayer2)
  ENDDO
ELSEIF (trim(hname)=='SOILCARB') THEN
  DO jp = 1,kpatch
    zfield(:,jp) = npe%AL(jp)%XSOILCARB(:,klayer)
  ENDDO  
ENDIF

IF (kpts>0)THEN
  !
  CALL get_surf_mask_n(dtco, u, 'NATURE',ini,imask,u%NSIZE_FULL,kluout)
  !
  DO jp=1,kpatch
    !
    nsize(:)=0
    WHERE (zfield(:,jp).NE.xundef) nsize(:)=1
    WHERE (np%AL(jp)%XPATCH(:)==0.) nsize(:)=-1
    !
    CALL unpack_same_rank(np%AL(jp)%NR_P,nsize,nsize_nat,-1)
    CALL unpack_same_rank(imask,nsize_nat,nsize_tot,-1)
    !
    CALL unpack_same_rank(np%AL(jp)%NR_P,zfield(:,jp),zfield_nat)
    CALL unpack_same_rank(imask,zfield_nat,zfield_tot)
    !
    IF(PRESENT(pdef))THEN
      CALL interpol_field(ug, u, &
                          hprogram,kluout,nsize_tot,zfield_tot,hname,pdef=pdef(jp),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,zfield_nat)
    CALL pack_same_rank(np%AL(jp)%NR_P,zfield_nat,zfield(:,jp))
    !  
  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 jp=1,kpatch
      pk => np%AL(jp)
      pek => npe%AL(jp)

      WHERE(pk%XPATCH(:) /=0. .AND. pk%XPATCH_OLD(:) ==0..AND.pek%XLAI(:)==0.)
          zfield(:,jp) = 0.  
          gveg(:,jp) = .false.
      ENDWHERE
    END DO
  END IF
  !
  !quantity of water before restart in each grid point
  zfield1_tot(:) = 0.0
  DO jp = 1,kpatch 
    pk => np%AL(jp)
    DO ji = 1,pk%NSIZE_P
      imask0 = pk%NR_P(ji)
      zfield1_tot(imask0)=zfield1_tot(imask0)+ pk%XPATCH_OLD(ji) * zfield(ji,jp)
    ENDDO
  END DO
  !
  zfield2_tot(:) = 0.0
  DO jp=1,kpatch
    pk => np%AL(jp)
    DO ji = 1,pk%NSIZE_P
      imask0 = pk%NR_P(ji)  
      !if a patch appears in a grid point, it takes the quantity of water in the
      !whole grid point before
      IF(pk%XPATCH(ji) /=0. .AND. pk%XPATCH_OLD(ji)==0. .AND. gveg(ji,jp)) THEN
        zfield(ji,jp)=zfield1_tot(imask0)
      ENDIF
      !quantity of water after restart and landuse in each grid point 
      zfield2_tot(imask0)=zfield2_tot(imask0)+ pk%XPATCH(ji)*zfield(ji,jp)
    ENDDO      
  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 jp=1,kpatch
      pk => np%AL(jp)
      DO ji = 1,pk%NSIZE_P
        imask0 = pk%NR_P(ji)  
        IF (zfield2_tot(imask0) > 1.e-12) THEN
          zfield(ji,jp)=(zfield1_tot(imask0)/zfield2_tot(imask0))*zfield(ji,jp)
        ENDIF
      END DO
    END DO
  ENDIF
  !
  DO jp = 1,kpatch
    WHERE(np%AL(jp)%XPATCH(:) ==0.)zfield(:,jp)=xundef
  ENDDO
  !
ENDIF
!
IF (trim(hname)=='WR') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XWR(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='ICE_STO') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XICE_STO(:) = zfield(:,jp)
  ENDDO   
ELSEIF (trim(hname)=='TEMP GRO') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XTG(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='ALBSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%ALB(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='EMISSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%EMIS(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='TSSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%TS(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='WSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%WSNOW(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='TEMPSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%TEMP(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='HEATSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%HEAT(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='AGESNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%AGE(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='TSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%T(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='GR1SNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%GRAN1(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='GR2SNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%GRAN2(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='HISTSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%HIST(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='WG') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XWG(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='WGI') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XWGI(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='RESA') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XRESA(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='RHOSNOW') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%TSNOW%RHO(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='AN') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XAN(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='ANDAY') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XANDAY(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='ANFM') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XANFM(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='LE') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XLE(:) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='RESPBIOM') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XRESP_BIOMASS(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='BIOMASS') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XBIOMASS(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='LIGNINST') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XLIGNIN_STRUC(:,klayer) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='LITTER') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XLITTER(:,klayer,klayer2) = zfield(:,jp)
  ENDDO
ELSEIF (trim(hname)=='SOILCARB') THEN
  DO jp = 1,kpatch
    npe%AL(jp)%XSOILCARB(:,klayer) = zfield(:,jp)
  ENDDO  
ENDIF
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('INI_VAR_FROM_PATCH',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE ini_var_from_patch