preps_for_meb_ebud_rad.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 preps_for_meb_ebud_rad(PPS,                                         &
     PLAICV,PSNOWRHO,PSNOWSWE,PSNOWHEAT,PSNOWLIQ,                              &
     PSNOWTEMP,PSNOWDZ,PSCOND,PHEATCAPS,PEMISNOW,PSIGMA_F,PCHIP,               &
     PTSTEP,PSR,PTA,PVMOD,PSNOWAGE,PPERMSNOWFRAC                               )
!   ############################################################################
!
!!****  *PREPS_FOR_MEB_EBUD_RAD*
!!
!!    PURPOSE
!!    -------
!
!     Get preliminary estimates of certain parameters needed for energy budget
!     solution of snowpack, and some other misc inputs needed by radiation 
!     routines for MEB.
!     
!!**  METHOD
!!    ------
!
!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!
!!      
!!    REFERENCE
!!    ---------
!!
!!      
!!    AUTHOR
!!    ------
!!
!!      A. Boone                * CNRM-GAME, Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    02/2011
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
!
USE modd_snow_par,            ONLY : xrhosmax_es, xrhosmin_es, xemissn, xsnowdmin, &
                                     xsnowthrmcond1
!
USE modd_csts,                ONLY : xtt, xlmtt, xrholw
!
USE modd_surf_par,            ONLY : xundef
!
USE modd_snow_metamo,         ONLY : xsnowdzmin
!
USE mode_snow3l,              ONLY : snow3lthrm, snow3lscap, snow3lfall,         &
                                     snow3ltransf, snow3lgrid, snow3lcompactn
!
USE mode_meb,                 ONLY : meb_shield_factor
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!
!*      0.1    Declaration of Arguments
!
REAL                                :: PTSTEP   ! time step (s)
REAL, DIMENSION(:),   INTENT(IN)    :: PLAICV
REAL, DIMENSION(:),   INTENT(IN)    :: PPS
REAL, DIMENSION(:),   INTENT(IN)    :: PSR
REAL, DIMENSION(:),   INTENT(IN)    :: PTA
REAL, DIMENSION(:),   INTENT(IN)    :: PVMOD
REAL, DIMENSION(:),   INTENT(IN)    :: PPERMSNOWFRAC 
REAL, DIMENSION(:,:), INTENT(IN)    :: PSNOWHEAT

REAL, DIMENSION(:,:), INTENT(INOUT) :: PSNOWSWE, PSNOWAGE, PSNOWRHO

REAL, DIMENSION(:),   INTENT(OUT)   :: PSIGMA_F, PCHIP
REAL, DIMENSION(:),   INTENT(OUT)   :: PEMISNOW
REAL, DIMENSION(:,:), INTENT(OUT)   :: PSNOWDZ, PSCOND, PHEATCAPS, PSNOWTEMP, PSNOWLIQ
!
!
!*      0.2    declarations of local variables
!
INTEGER                                            :: JI, JK, JJ, INLVLS, ISIZE_SNOW, INI
INTEGER, DIMENSION(SIZE(PTA))                      :: NMASK      ! indices correspondance between arrays
REAL, DIMENSION(SIZE(PLAICV,1))                    :: ZPSNA
REAL, DIMENSION(SIZE(PTA))                         :: ZSNOW, ZSNOWFALL
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!----------------------------------------------------
! 0) Initialization
!
IF (lhook) CALL dr_hook('PREPS_FOR_MEB_EBUD_RAD',0,zhook_handle)
!
ini             = SIZE(psnowrho,1)
inlvls          = SIZE(psnowrho,2)
!
WHERE(psnowrho(:,:)==xundef)
   psnowrho(:,:) = xrhosmin_es           ! arbitrary...will be correctly set if snow present
ENDWHERE
!
psnowdz(:,:)     = psnowswe(:,:)/psnowrho(:,:)
pheatcaps(:,:)   = snow3lscap(psnowrho)
pscond(:,:)      = xsnowthrmcond1        ! arbitrary...will be correctly set if snow present
psnowtemp(:,:)   = xtt
psnowliq(:,:)    = 0.0
!
! Test variables to check for existance of snow:
!
zsnowfall(:)     = psr(:)*ptstep/xrhosmax_es
!
zsnow(:)         = 0.0
DO jk=1,inlvls
   DO ji=1,ini
      zsnow(ji)  = zsnow(ji) + psnowdz(ji,jk)
   ENDDO
ENDDO
!
! Here, as in snow3l (ISBA-ES), we account for several processes
! on the snowpack before surface energy budget computations
! (i.e. snowfall on albedo, density, thickness, and compaction etc...)
!
! ===============================================================
! === Packing: Only call snow model routines when there is snow on the surface
!              exceeding a minimum threshold OR if the equivalent
!              snow depth falling during the current time step exceeds 
!              this limit.
!
! counts the number of points where the computations will be made
!
!
isize_snow = 0
nmask(:)   = 0
!
DO jj=1,ini
   IF (zsnow(jj) >= xsnowdmin .OR. zsnowfall(jj) >= xsnowdmin) THEN
      isize_snow = isize_snow + 1
      nmask(isize_snow) = jj
   ENDIF
ENDDO
!  
IF (isize_snow>0) THEN
   CALL call_snow_routines(isize_snow,inlvls,nmask)
ENDIF
!
! ===============================================================
!
!
! View factor: (1 - shielding factor)
!
zpsna(:)          = 0.
pchip(:)          = meb_shield_factor(plaicv,zpsna)
psigma_f(:)       = 1.0 - pchip(:)
!
! snow emissivity
!
pemisnow(:)       = xemissn
!
IF (lhook) CALL dr_hook('PREPS_FOR_MEB_EBUD_RAD',1,zhook_handle)
!
!
CONTAINS
!================================================================
SUBROUTINE call_snow_routines(KSIZE1,KSIZE2,KMASK)
!
! Make some snow computations only over regions with snow cover or snow falling
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: KSIZE1
INTEGER, INTENT(IN) :: KSIZE2
INTEGER, DIMENSION(:), INTENT(IN) :: KMASK
!
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWSWE
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWRHO
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWHEAT
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWTEMP
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWLIQ
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWDZ
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SCOND
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWAGE
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_SNOWDZN
REAL, DIMENSION(KSIZE1,KSIZE2) :: ZP_HEATCAPS
REAL, DIMENSION(KSIZE1)        :: ZP_SNOW
REAL, DIMENSION(KSIZE1)        :: ZP_SNOWHMASS
REAL, DIMENSION(KSIZE1)        :: ZP_PERMSNOWFRAC
REAL, DIMENSION(KSIZE1)        :: ZP_PS
REAL, DIMENSION(KSIZE1)        :: ZP_SR
REAL, DIMENSION(KSIZE1)        :: ZP_TA
REAL, DIMENSION(KSIZE1)        :: ZP_VMOD

INTEGER         :: JWRK, JJ, JI
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!----------------------------------------------------------------
!
IF (lhook) CALL dr_hook('SNOW3L_ISBA:CALL_MODEL',0,zhook_handle)
!
! pack the variables
!
DO jwrk=1,ksize2
   DO jj=1,ksize1
      ji = kmask(jj)
      zp_snowswe(jj,jwrk) = psnowswe(ji,jwrk)
      zp_snowrho(jj,jwrk) = psnowrho(ji,jwrk)
      zp_snowheat(jj,jwrk) = psnowheat(ji,jwrk)
      zp_snowage(jj,jwrk) = psnowage(ji,jwrk)
      zp_snowdz(jj,jwrk) = psnowdz(ji,jwrk)      
   ENDDO
ENDDO
!
DO jj=1,ksize1
   ji = kmask(jj)
   zp_snow(jj) = zsnow(ji)
   zp_ps(jj) = pps(ji)
   zp_sr(jj) = psr(ji)
   zp_ta(jj) = pta(ji)
   zp_vmod(jj) = pvmod(ji)
   zp_permsnowfrac(jj) = ppermsnowfrac(ji)
ENDDO
!
!---------------------------------------------------------------
!
! Local working:
!
zp_snowheat(:,:)   = zp_snowheat(:,:)*zp_snowdz(:,:) ! J/m3 to J/m2
!
!
 CALL snow3lfall(ptstep,zp_sr,zp_ta,zp_vmod,zp_snow,zp_snowrho,zp_snowdz,          &
                 zp_snowheat,zp_snowhmass,zp_snowage,zp_permsnowfrac)
!
 CALL snow3lgrid(zp_snowdzn,zp_snow,psnowdz_old=zp_snowdz)
!
 CALL snow3ltransf(zp_snow,zp_snowdz,zp_snowdzn,zp_snowrho,zp_snowheat,zp_snowage)
!
! Snow heat capacity:
!
zp_heatcaps(:,:)   = snow3lscap(zp_snowrho)                    ! J m-3 K-1
!
! Snow temperature (K) 
!
zp_snowtemp(:,:)   = xtt + ( ((zp_snowheat(:,:)/max(1.e-10,zp_snowdz(:,:)))  &
                   + xlmtt*zp_snowrho(:,:))/zp_heatcaps(:,:) )  
!
zp_snowliq(:,:)    = max(0.0,zp_snowtemp(:,:)-xtt)*zp_heatcaps(:,:)*         &
                     zp_snowdz(:,:)/(xlmtt*xrholw) 

zp_snowtemp(:,:)   = min(xtt,zp_snowtemp(:,:))

! SWE:

zp_snowswe(:,:)  = zp_snowdz(:,:)*zp_snowrho(:,:)             

 CALL snow3lcompactn(ptstep,xsnowdzmin,zp_snowrho,zp_snowdz,zp_snowtemp,zp_snow,zp_snowliq)

! Snow thermal conductivity:
!
 CALL snow3lthrm(zp_snowrho,zp_scond,zp_snowtemp,zp_ps)
!
!----------------------------------------------------------------
!
! Unpack:
!
DO jwrk=1,ksize2
   DO jj=1,ksize1
      ji = kmask(jj)
      psnowswe(ji,jwrk) = zp_snowswe(jj,jwrk)
      psnowrho(ji,jwrk) = zp_snowrho(jj,jwrk)
      psnowage(ji,jwrk) = zp_snowage(jj,jwrk)      
      psnowdz(ji,jwrk) = zp_snowdz(jj,jwrk)
      psnowtemp(ji,jwrk) = zp_snowtemp(jj,jwrk)
      psnowliq(ji,jwrk) = zp_snowliq(jj,jwrk)
      pscond(ji,jwrk) = zp_scond(jj,jwrk)
      pheatcaps(ji,jwrk) = zp_heatcaps(jj,jwrk)
   ENDDO
ENDDO
!
END SUBROUTINE call_snow_routines
!================================================================  
!
END SUBROUTINE preps_for_meb_ebud_rad