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 (I)
!     #################################################################################
!
!!****  *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_n, ONLY : isba_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 yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
!*      0.2    declarations of local variables
!
!
TYPE(isba_t), INTENT(INOUT) :: i
!
INTEGER                         :: jl        ! loop counter on layers
INTEGER                         :: jp        ! loop counter on patches
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_ISBA',0,zhook_handle)
ALLOCATE(zwgi_clim_grad(SIZE(i%XWG,1),SIZE(i%XWG,2),SIZE(i%XWG,3)))
!
zwgi_clim_grad(:,:,:) = zgradx * exp( - i%XDG(:,:,:) / zh0 )
!-------------------------------------------------------------------------------------
!
!*      1.1    Temperature profile
!
ALLOCATE(ztg_ls(SIZE(i%XTG,1),SIZE(i%XTG,2),SIZE(i%XTG,3)))
ztg_ls(:,:,:) = i%XTG(:,:,:)
!
DO jp=1,SIZE(i%XTG,3)
  DO jl=1,SIZE(i%XTG,2)
    WHERE(i%XTG(:,jl,jp)/=xundef) &
      i%XTG(:,jl,jp) = i%XTG(:,jl,jp) + xt_clim_grad  * (i%XZS - xzs_ls)  
  END DO
END DO
!
!-------------------------------------------------------------------------------------
!
!*      1.2    Water and ice in the soil
!
ALLOCATE(zzsfreeze(SIZE(i%XWG,1)))
ALLOCATE(zwgtot(SIZE(i%XWG,1)))
ALLOCATE(zdw(SIZE(i%XWG,1)))
!
!* general case
!
IF(i%LTEMP_ARP)THEN
  iwork=SIZE(i%XWG,2)
ELSE
  iwork=SIZE(i%XTG,2)
ENDIF
!
DO jp=1,SIZE(i%XWG,3)
  !
  DO jl=1,iwork
    !
    zdw(:) = 0.
    ! altitude where deep soil freezes (diurnal surface response is not treated)
    zzsfreeze(:) = i%XZS + (xtt - i%XTG(:,jl,jp)) / xt_clim_grad
    !
    WHERE(i%XTG(:,jl,jp)/=xundef) 
      !
      WHERE (ztg_ls(:,jl,jp) < xtt)
        !
        WHERE (i%XZS <= xzs_ls)
          !
          WHERE (i%XZS > zzsfreeze) 
            zdw(:) = zwgi_clim_grad(:,jl,jp) * (i%XZS - xzs_ls)
          ELSEWHERE
            zdw(:) = zwgi_clim_grad(:,jl,jp) * (zzsfreeze - xzs_ls) + zgradx * (i%XZS - zzsfreeze)
          ENDWHERE
          !
        ELSEWHERE
          !
          zdw(:) = zwgi_clim_grad(:,jl,jp) * (i%XZS - xzs_ls)
          !
        ENDWHERE
        !
      ELSEWHERE
        !
        WHERE (i%XZS <= xzs_ls)
          !
          zdw(:) = zgradx * (i%XZS - xzs_ls)
          !
        ELSEWHERE
          !
          zdw(:) = zwgi_clim_grad(:,jl,jp) * (i%XZS - zzsfreeze)
          !
        END WHERE
        !
      END WHERE 
      !
      zwgtot(:) = xundef
      !
      WHERE(i%XWG(:,jl,jp)/=xundef)        
        zwgtot(:) = i%XWG(:,jl,jp) + i%XWGI(:,jl,jp)
      ENDWHERE
      !
      WHERE(i%XWG(:,jl,jp)/=xundef)        
        i%XWGI(:,jl,jp) = i%XWGI(:,jl,jp) + zdw(:)
        i%XWG (:,jl,jp) = i%XWG (:,jl,jp) - zdw(:)
      ENDWHERE
      !
      WHERE (i%XWGI(:,jl,jp)<0.0.AND.i%XWGI(:,jl,jp)/=xundef) 
        i%XWGI(:,jl,jp) = 0.
        i%XWG (:,jl,jp) = zwgtot(:)
      END WHERE
      !
      WHERE (i%XWG(:,jl,jp)<xwgmin.AND.i%XWG(:,jl,jp)/=xundef)
        i%XWG (:,jl,jp) = xwgmin
        i%XWGI(:,jl,jp) = zwgtot(:) - xwgmin
      END WHERE
      !
      WHERE(i%XWGI(:,jl,jp)>0.0.AND.i%XWGI(:,jl,jp)/=xundef)
        i%XTG(:,jl,jp) = min(xtt,i%XTG(:,jl,jp))
      ELSEWHERE
        i%XTG(:,jl,jp) = max(xtt,i%XTG(:,jl,jp))
      ENDWHERE
      !
    END WHERE
    !
  END DO
  !
END DO

!
!* limits in force-restore case
!
IF (i%CISBA=='2-L'.OR.i%CISBA=='3-L') THEN
i%XWG(:,2,:)=max(i%XWG(:,1,:)*i%XDG(:,1,:),i%XWG(:,2,:)*i%XDG(:,2,:))/i%XDG(:,2,:)
i%XWGI(:,2,:)=max(i%XWGI(:,1,:)*i%XDG(:,1,:),i%XWGI(:,2,:)*i%XDG(:,2,:))/i%XDG(:,2,:)
ENDIF
IF (i%CISBA=='3-L') THEN 
  DO jp=1,SIZE(i%XWG,3)
     WHERE (i%XWGI(:,3,jp) /= xundef)
       i%XWG (:,3,jp) = i%XWG(:,3,jp)+i%XWGI(:,3,jp)
       i%XWGI(:,3,jp) = 0.
       i%XTG (:,3,jp) = ztg_ls(:,3,jp) + xt_clim_grad  * (i%XZS - xzs_ls)       
     END WHERE
     IF(i%LTEMP_ARP)THEN
        i%XTG (:,4:SIZE(i%XTG,2),jp) = ztg_ls(:,4:SIZE(i%XTG,2),jp)
     ENDIF
  END DO
ELSEIF(i%CISBA=='2-L'.AND.i%LTEMP_ARP) THEN
  DO jp=1,SIZE(i%XWG,3)
     i%XTG (:,3:SIZE(i%XTG,2),jp) = ztg_ls(:,3:SIZE(i%XTG,2),jp)
  END DO
END IF
!
DEALLOCATE(zzsfreeze)
DEALLOCATE(zwgi_clim_grad)
DEALLOCATE(zwgtot   )
DEALLOCATE(zdw      )
!
!* masks where fields are not defined
WHERE (i%XTG(:,1:SIZE(i%XWG,2),:) == xundef)
  i%XWG (:,:,:) = xundef
  i%XWGI(:,:,:) = xundef
END WHERE
!
!-------------------------------------------------------------------------------------
!
!*      1.4    Snow variables
!
!* vertical shift
IF (.NOT.lsnow_ideal) THEN
  IF (i%CISBA=='DIF') THEN
    ideep_soil = i%NGROUND_LAYER
  ELSE
    ideep_soil = 2
  END IF        
  CALL prep_ver_snow(i%TSNOW,xzs_ls,i%XZS,ztg_ls,i%XTG,ideep_soil)
ENDIF
!
!-------------------------------------------------------------------------------------
!
!*      2.     Deallocation of large-scale orography
!
DEALLOCATE(ztg_ls)
IF (lhook) CALL dr_hook('PREP_VER_ISBA',1,zhook_handle)
!-------------------------------------------------------------------------------------
!
END SUBROUTINE prep_ver_isba