prep_ver_isba.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 prep_ver_isba (IO, NPE, PZS, NP)
!     #################################################################################
!
!!****  *PREP_VER_ISBA* - change in ISBA fields due to altitude change
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      Modified by B. Decharme  (01/2009), Optional Arpege deep soil temperature initialization
!!      S. Riette   04/2010 Modification of XTG corrections after freezing
!!      Y. Seity    02/2016 Add limits in Force-Restore case (WG2 contains WG1)
!!------------------------------------------------------------------
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_p_t, isba_pe_t
!
USE modd_isba_par,       ONLY : xwgmin
USE modd_surf_par,       ONLY : xundef
USE modd_prep,           ONLY : xzs_ls, xt_clim_grad
USE modd_prep_isba,      ONLY : lsnow_ideal
USE modd_csts,           ONLY : xtt, xday, xlmtt, xrholw
!
USE mode_thermos
USE modi_prep_ver_snow
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
!*      0.2    declarations of local variables
!
!
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
TYPE(isba_np_t), INTENT(INOUT) :: NP
REAL, DIMENSION(:), INTENT(IN) :: PZS
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
!
INTEGER                         :: JL        ! loop counter on layers
INTEGER                         :: JP        ! loop counter on patches
INTEGER                         :: IWORK     ! Work integer
!
REAL, DIMENSION(:), ALLOCATABLE :: ZZS, ZZS_LS
REAL, DIMENSION(:), ALLOCATABLE :: ZWGTOT    ! total water content
REAL, DIMENSION(:), ALLOCATABLE :: ZDW       ! variation of water in soil
REAL, DIMENSION(:), ALLOCATABLE :: ZZSFREEZE ! altitude where soil temperature equals XTT
INTEGER                         :: IDEEP_SOIL! layer corresponding to deep soil temperature
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZWGI_CLIM_GRAD ! ice content vertical gradient
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZTG_LS! temperature on initial orography
!
REAL                            :: ZGRADX = 5.e-4 ! slope of ice content gradient
REAL                            :: ZH0    = 5.e-1 ! constant used to define ice content gradient
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------------
!
!*      1.0    Ice content climatologic gradient
!
IF (lhook) CALL dr_hook('PREP_VER_ISBA',0,zhook_handle)
!
!
IF (io%CISBA=='DIF') THEN
  ideep_soil = io%NGROUND_LAYER
ELSE
  ideep_soil = 2
END IF
!
DO jp = 1,io%NPATCH
  !
  pek => npe%AL(jp)
  pk => np%AL(jp)
  !
  IF(io%LTEMP_ARP)THEN
    iwork=SIZE(pek%XWG,2)
  ELSE
    iwork=SIZE(pek%XTG,2)
  ENDIF
  !
  ALLOCATE(zzs(pk%NSIZE_P))
  CALL pack_same_rank(pk%NR_P,pzs,zzs)
  ALLOCATE(zzs_ls(pk%NSIZE_P))
  CALL pack_same_rank(pk%NR_P,xzs_ls,zzs_ls)
  !
  ALLOCATE(zwgi_clim_grad(SIZE(pek%XWG,1),SIZE(pek%XWG,2)))
  !
  zwgi_clim_grad(:,:) = zgradx * exp( - pk%XDG(:,:) / zh0 )
  !-------------------------------------------------------------------------------------
  !
  !*      1.1    Temperature profile
  !
  ALLOCATE(ztg_ls(SIZE(pek%XTG,1),SIZE(pek%XTG,2)))
  ztg_ls(:,:) = pek%XTG(:,:)
  !
  DO jl=1,SIZE(pek%XTG,2)
    WHERE(pek%XTG(:,jl)/=xundef) &
      pek%XTG(:,jl) = pek%XTG(:,jl) + xt_clim_grad  * (zzs - zzs_ls)  
  END DO
  !
  !-------------------------------------------------------------------------------------
  !
  !*      1.2    Water and ice in the soil
  !
  ALLOCATE(zzsfreeze(SIZE(pek%XWG,1)))
  ALLOCATE(zwgtot(SIZE(pek%XWG,1)))
  ALLOCATE(zdw(SIZE(pek%XWG,1)))
  !
  !* general case
  !
  DO jl=1,iwork
    !
    zdw(:) = 0.
    ! altitude where deep soil freezes (diurnal surface response is not treated)
    zzsfreeze(:) = zzs + (xtt - pek%XTG(:,jl)) / xt_clim_grad
    !
    WHERE(pek%XTG(:,jl)/=xundef) 
      !
      WHERE (ztg_ls(:,jl) < xtt)
        !
        WHERE (zzs <= zzs_ls)
          !
          WHERE (zzs > zzsfreeze) 
            zdw(:) = zwgi_clim_grad(:,jl) * (zzs - zzs_ls)
          ELSEWHERE
            zdw(:) = zwgi_clim_grad(:,jl) * (zzsfreeze - zzs_ls) + zgradx * (zzs - zzsfreeze)
          ENDWHERE
          !
        ELSEWHERE
          !
          zdw(:) = zwgi_clim_grad(:,jl) * (zzs - zzs_ls)
          !
        ENDWHERE
        !
      ELSEWHERE
        !
        WHERE (zzs <= zzs_ls)
          !
          zdw(:) = zgradx * (zzs - zzs_ls)
          !
        ELSEWHERE
          !
          zdw(:) = zwgi_clim_grad(:,jl) * (zzs - zzsfreeze)
          !
        END WHERE
        !
      END WHERE 
      !
      zwgtot(:) = xundef
      !
      WHERE(pek%XWG(:,jl)/=xundef)        
        zwgtot(:) = pek%XWG(:,jl) + pek%XWGI(:,jl)
      ENDWHERE
      !
      WHERE(pek%XWG(:,jl)/=xundef)        
        pek%XWGI(:,jl) = pek%XWGI(:,jl) + zdw(:)
        pek%XWG (:,jl) = pek%XWG (:,jl) - zdw(:)
      ENDWHERE
      !
      WHERE (pek%XWGI(:,jl)<0.0.AND.pek%XWGI(:,jl)/=xundef) 
        pek%XWGI(:,jl) = 0.
        pek%XWG (:,jl) = zwgtot(:)
      END WHERE
      !
      WHERE (pek%XWG(:,jl)<xwgmin.AND.pek%XWG(:,jl)/=xundef)
        pek%XWG (:,jl) = xwgmin
        pek%XWGI(:,jl) = zwgtot(:) - xwgmin
      END WHERE
      !
      WHERE(pek%XWGI(:,jl)>0.0.AND.pek%XWGI(:,jl)/=xundef)
        pek%XTG(:,jl) = min(xtt,pek%XTG(:,jl))
      ELSEWHERE
        pek%XTG(:,jl) = max(xtt,pek%XTG(:,jl))
      ENDWHERE
      !
    END WHERE
    !
  END DO
  !
  !
  !* limits in force-restore case
  !
  IF (io%CISBA=='2-L'.OR.io%CISBA=='3-L') THEN
    pek%XWG (:,2) = max(pek%XWG (:,1)*pk%XDG(:,1),pek%XWG (:,2)*pk%XDG(:,2))/pk%XDG(:,2)
    pek%XWGI(:,2) = max(pek%XWGI(:,1)*pk%XDG(:,1),pek%XWGI(:,2)*pk%XDG(:,2))/pk%XDG(:,2)
  ENDIF
  !  
  IF (io%CISBA=='3-L') THEN 
    !
    WHERE (pek%XWGI(:,3) /= xundef)
      pek%XWG (:,3) = pek%XWG(:,3)+pek%XWGI(:,3)
      pek%XWGI(:,3) = 0.
      pek%XTG (:,3) = ztg_ls(:,3) + xt_clim_grad  * (zzs - zzs_ls)       
    END WHERE
    IF(io%LTEMP_ARP)THEN
       pek%XTG (:,4:SIZE(pek%XTG,2)) = ztg_ls(:,4:SIZE(pek%XTG,2))
    ENDIF
    !
  ELSEIF(io%CISBA=='2-L'.AND.io%LTEMP_ARP) THEN
    !
    pek%XTG (:,3:SIZE(pek%XTG,2)) = ztg_ls(:,3:SIZE(pek%XTG,2))
    !
  ENDIF
  !
  !* masks where fields are not defined
  WHERE (pek%XTG(:,1:SIZE(pek%XWG,2)) == xundef)
    pek%XWG (:,:) = xundef
    pek%XWGI(:,:) = xundef
  END WHERE
  !
  IF (.NOT.lsnow_ideal) THEN
    CALL prep_ver_snow(pek%TSNOW,zzs_ls,zzs,ztg_ls,pek%XTG,ideep_soil)
  ENDIF

  DEALLOCATE(zzsfreeze)
  DEALLOCATE(zwgi_clim_grad)
  DEALLOCATE(zwgtot   )
  DEALLOCATE(zdw      )
  DEALLOCATE(ztg_ls, zzs, zzs_ls)
  !
END DO
!
!
!-------------------------------------------------------------------------------------
!
!*      2.     Deallocation of large-scale orography
!
IF (lhook) CALL dr_hook('PREP_VER_ISBA',1,zhook_handle)
!-------------------------------------------------------------------------------------
!
END SUBROUTINE prep_ver_isba