prep_ver_teb_garden.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_teb_garden (TGD, TGDO, TGDP, TOP, TVG)
!     #################################################################################
!
!!****  *PREP_VER_TEB_GARDEN* - 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
!!------------------------------------------------------------------
!

!
!
USE modd_teb_garden_n, ONLY : teb_garden_t
USE modd_teb_garden_option_n, ONLY : teb_garden_options_t
USE modd_teb_garden_pgd_n, ONLY : teb_garden_pgd_t
USE modd_teb_option_n, ONLY : teb_options_t
USE modd_teb_veg_n, ONLY : teb_veg_options_t
!
USE modd_isba_par,       ONLY : xwgmin
USE modd_surf_par,       ONLY : xundef
USE modd_prep,           ONLY : xzs_ls, xt_clim_grad
USE modd_csts,           ONLY : xtt, xday, xlmtt, xrholw
!
USE mode_thermos
USE modi_prep_ver_snow
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
!*      0.2    declarations of local variables
!
!
TYPE(teb_garden_t), INTENT(INOUT) :: tgd
TYPE(teb_garden_options_t), INTENT(INOUT) :: tgdo
TYPE(teb_garden_pgd_t), INTENT(INOUT) :: tgdp
TYPE(teb_options_t), INTENT(INOUT) :: top
TYPE(teb_veg_options_t), INTENT(INOUT) :: tvg
!
INTEGER                         :: jl        ! loop counter on layers
INTEGER                         :: iwork     ! Work integer
!
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_TEB_GARDEN',0,zhook_handle)
ALLOCATE(zwgi_clim_grad(SIZE(tgd%CUR%XWG,1),SIZE(tgd%CUR%XWG,2)))
!
zwgi_clim_grad(:,:) = zgradx * exp( - tgdp%XDG(:,:) / zh0 )
!-------------------------------------------------------------------------------------
!
!*      1.1    Temperature profile
!
ALLOCATE(ztg_ls(SIZE(tgd%CUR%XTG,1),SIZE(tgd%CUR%XTG,2)))
ztg_ls(:,:) = tgd%CUR%XTG(:,:)
!
DO jl=1,SIZE(tgd%CUR%XTG,2)
  WHERE(tgd%CUR%XTG(:,jl)/=xundef) &
    tgd%CUR%XTG(:,jl) = tgd%CUR%XTG(:,jl) + xt_clim_grad  * (top%XZS - xzs_ls)  
END DO
!
!-------------------------------------------------------------------------------------
!
!*      1.2    Water and ice in the soil
!
ALLOCATE(zzsfreeze(SIZE(tgd%CUR%XWG,1)))
ALLOCATE(zwgtot(SIZE(tgd%CUR%XWG,1)))
ALLOCATE(zdw(SIZE(tgd%CUR%XWG,1)))
!
!* general case
!
iwork=SIZE(tgd%CUR%XTG,2)
!
DO jl=1,iwork
  !
  zdw(:) = 0.
  ! altitude where deep soil freezes (diurnal surface response is not treated)
  zzsfreeze(:) = top%XZS + (xtt - tgd%CUR%XTG(:,jl)) / xt_clim_grad
  !
  WHERE(tgd%CUR%XTG(:,jl)/=xundef) 
    !
    WHERE (ztg_ls(:,jl) < xtt)
      !
      WHERE (top%XZS <= xzs_ls)
        !
        WHERE (top%XZS > zzsfreeze) 
          zdw(:) = zwgi_clim_grad(:,jl) * (top%XZS - xzs_ls)
        ELSEWHERE
          zdw(:) = zwgi_clim_grad(:,jl) * (zzsfreeze - xzs_ls) + zgradx * (top%XZS - zzsfreeze)
        ENDWHERE
        !
      ELSEWHERE
        !
        zdw(:) = zwgi_clim_grad(:,jl) * (top%XZS - xzs_ls)
        !
      ENDWHERE
      !
    ELSEWHERE
      !
      WHERE (top%XZS <= xzs_ls)
        !
        zdw(:) = zgradx * (top%XZS - xzs_ls)
        !
      ELSEWHERE
        !
        zdw(:) = zwgi_clim_grad(:,jl) * (top%XZS - zzsfreeze)
        !
      END WHERE
      !
    END WHERE
    !
    zwgtot(:) = xundef
    !
    WHERE(tgd%CUR%XWG(:,jl)/=xundef)         
      zwgtot(:) = tgd%CUR%XWG(:,jl) + tgd%CUR%XWGI(:,jl)
    ENDWHERE        
    !
    WHERE(tgd%CUR%XWG(:,jl)/=xundef)      
      tgd%CUR%XWGI(:,jl) = tgd%CUR%XWGI(:,jl) + zdw(:)
      tgd%CUR%XWG (:,jl) = tgd%CUR%XWG (:,jl) - zdw(:)
    ENDWHERE
    !
    WHERE (tgd%CUR%XWGI(:,jl) < 0..AND.tgd%CUR%XWGI(:,jl)/=xundef) 
      tgd%CUR%XWGI(:,jl) = 0.
      tgd%CUR%XWG (:,jl) = zwgtot(:)
    END WHERE
    !
    WHERE (tgd%CUR%XWG(:,jl) < xwgmin.AND.tgd%CUR%XWG(:,jl)/=xundef)
      tgd%CUR%XWG (:,jl) = xwgmin
      tgd%CUR%XWGI(:,jl) = zwgtot(:) - xwgmin
    END WHERE
    !
    WHERE(tgd%CUR%XWGI(:,jl) > 0..AND.tgd%CUR%XWGI(:,jl)/=xundef)
      tgd%CUR%XTG(:,jl) = min(xtt,tgd%CUR%XTG(:,jl))
    ELSEWHERE
      tgd%CUR%XTG(:,jl) = max(xtt,tgd%CUR%XTG(:,jl))
    ENDWHERE
    !
  ENDWHERE
  !
END DO
!
!* limits in force-restore case
!
IF (tvg%CISBA=='3-L') THEN 
  WHERE (tgd%CUR%XWGI(:,3) /= xundef)
    tgd%CUR%XWG (:,3) = tgd%CUR%XWG(:,3)+tgd%CUR%XWGI(:,3)
    tgd%CUR%XWGI(:,3) = 0.
    tgd%CUR%XTG (:,3) = ztg_ls(:,3)
  END WHERE
END IF
!
DEALLOCATE(zzsfreeze)
DEALLOCATE(zwgi_clim_grad)
DEALLOCATE(zwgtot   )
DEALLOCATE(zdw      )
!
!* masks where fields are not defined
WHERE (tgd%CUR%XTG(:,1:SIZE(tgd%CUR%XWG,2)) == xundef)
  tgd%CUR%XWG (:,:) = xundef
  tgd%CUR%XWGI(:,:) = xundef
END WHERE
!
!-------------------------------------------------------------------------------------
!
!*      1.4    Snow variables
!
!* vertical shift
IF (tvg%CISBA=='DIF') THEN
  ideep_soil = tgdo%NGROUND_LAYER
ELSE
  ideep_soil = 2
END IF
 CALL prep_ver_snow(tgd%CUR%TSNOW,xzs_ls,top%XZS,spread(ztg_ls,3,1),spread(tgd%CUR%XTG,3,1),ideep_soil)
!
!-------------------------------------------------------------------------------------
!
!*      2.     Deallocation of large-scale orography
!
DEALLOCATE(ztg_ls)
IF (lhook) CALL dr_hook('PREP_VER_TEB_GARDEN',1,zhook_handle)
!-------------------------------------------------------------------------------------
!
END SUBROUTINE prep_ver_teb_garden