isba_properties.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 isba_properties(HISBA, OTR_ML, TPSNOW, KPATCH,           &
                                 pdir_sw, psca_sw, psw_bands, ksw,        &
                                 palbnir, palbvis, palbuv,                &
                                 palbnir_veg, palbvis_veg, palbuv_veg,    &
                                 palbnir_soil, palbvis_soil, palbuv_soil, &
                                 pveg, plai, pz0, pemis, ptg,             &
                                 pasnow, panosnow, pesnow, penosnow,      &
                                 ptssnow, ptsnosnow,                      &
                                 psnowfree_alb_veg, psnowfree_alb_soil,   &
                                 palbnir_tveg, palbvis_tveg,              &
                                 palbnir_tsoil, palbvis_tsoil,            &
                                 ppsn, ppsnv_a, ppsng, ppsnv              )  
!     ##########################################################################
!
!!****  *ISBA_PROPERTIES*  
!!
!!    PURPOSE
!!    -------
!
!     Calculates grid-averaged albedo and emissivity (according to snow scheme)
!         
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    AUTHOR
!!    ------
!!
!!      S. Belair           * Meteo-France *
!!
!!    MODIFICATIONS
!!    ------------- 
!!      
!!      P. Samuelsson  02/2012  MEB
!!
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_type_snow
USE modd_snow_par   , ONLY : xemissn, xemcrin, xsnowdmin, &
                               xrhosmax_es, xrhosmin_es  
USE modd_water_par  , ONLY : xemiswat
!
USE modi_isba_snow_frac
USE modi_isba_albedo
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
 CHARACTER(LEN=*)    , INTENT(IN)   :: hisba      ! ISBA scheme
LOGICAL             , INTENT(IN)   :: otr_ml     ! new radiative transfert
TYPE(surf_snow),      INTENT(IN)   :: tpsnow     ! ISBA snow scheme
INTEGER,              INTENT(IN)   :: kpatch     ! patch being treated
!
REAL, DIMENSION(:,:), INTENT(IN)   :: pdir_sw            ! direct incoming solar radiation
REAL, DIMENSION(:,:), INTENT(IN)   :: psca_sw            ! diffus incoming solar radiation
REAL, DIMENSION(:)  , INTENT(IN)   :: psw_bands          ! mean wavelength of each shortwave band (m)
INTEGER,              INTENT(IN)   :: ksw                ! number of short-wave spectral bands
REAL, DIMENSION(:)  , INTENT(IN)   :: palbnir            ! nearIR  total albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbvis            ! visible total albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbuv             ! UV      total albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbnir_veg        ! nearIR  veg   albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbvis_veg        ! visible veg   albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbuv_veg         ! UV      veg   albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbnir_soil       ! nearIR  soil  albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbvis_soil       ! visible soil  albedo
REAL, DIMENSION(:)  , INTENT(IN)   :: palbuv_soil        ! UV      soil  albedo
!
REAL, DIMENSION(:)  , INTENT(IN)   :: pveg  ! PVEG = fraction of vegetation
REAL, DIMENSION(:)  , INTENT(IN)   :: plai  ! PLAI = leaf area index
REAL, DIMENSION(:)  , INTENT(IN)   :: pz0   ! PZ0  = roughness length for momentum
REAL, DIMENSION(:)  , INTENT(IN)   :: pemis ! PEMIS = emissivity
REAL, DIMENSION(:)  , INTENT(IN)   :: ptg   !             
!
REAL, DIMENSION(:)  , INTENT(OUT)  :: pasnow    ! = snow albedo
REAL, DIMENSION(:)  , INTENT(OUT)  :: panosnow  ! = snow free albedo 
REAL, DIMENSION(:)  , INTENT(OUT)  :: pesnow    ! = snow emissivity
REAL, DIMENSION(:)  , INTENT(OUT)  :: penosnow  ! = snow free emissivity
REAL, DIMENSION(:)  , INTENT(OUT)  :: ptssnow   ! = snow radiative temperature
REAL, DIMENSION(:)  , INTENT(OUT)  :: ptsnosnow ! = snow free radiative temperature
REAL, DIMENSION(:)  , INTENT(OUT)  :: psnowfree_alb_veg  !snow free albedo of vegetation for EBA
REAL, DIMENSION(:)  , INTENT(OUT)  :: psnowfree_alb_soil !snow free albedo of soil for EBA option
REAL, DIMENSION(:)  , INTENT(OUT)  :: palbnir_tveg       ! nearIR  veg tot albedo
REAL, DIMENSION(:)  , INTENT(OUT)  :: palbvis_tveg       ! visible veg tot albedo
REAL, DIMENSION(:)  , INTENT(OUT)  :: palbnir_tsoil      ! nearIR  soil tot albedo
REAL, DIMENSION(:)  , INTENT(OUT)  :: palbvis_tsoil      ! visible soil tot albedo
!
REAL, DIMENSION(:)  , INTENT(OUT):: ppsn    ! PPSN = grid fraction covered by snow
REAL, DIMENSION(:)  , INTENT(OUT):: ppsng   ! PPSNG = fraction of the ground covered by snow
REAL, DIMENSION(:)  , INTENT(OUT):: ppsnv   ! PPSNV = fraction of the veg covered by snow 
REAL, DIMENSION(:)  , INTENT(OUT):: ppsnv_a !fraction of the the vegetation covered by snow for EBA scheme
!
!*      0.2    declarations of local variables
!
REAL, DIMENSION(SIZE(PDIR_SW,1)) :: zglobal_sw                 ! global incoming SW rad.
REAL, DIMENSION(SIZE(PALBNIR))   :: zalbf
REAL, DIMENSION(SIZE(PALBNIR))   :: zffv
REAL, DIMENSION(SIZE(PALBNIR))   :: zffg
!
LOGICAL, PARAMETER :: gmeb=.false.
REAL, DIMENSION(SIZE(PDIR_SW,1))   :: zp_meb_sca_sw, zalbnir_tsnow, zalbvis_tsnow
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('ISBA_PROPERTIES',0,zhook_handle)
 CALL isba_snow_frac(tpsnow%SCHEME,                                        &
                    tpsnow%WSNOW(:,:,kpatch), tpsnow%RHO(:,:,kpatch),     &
                    tpsnow%ALB  (:,kpatch), pveg, plai, pz0,              &
                    ppsn, ppsnv_a, ppsng, ppsnv                           )  
!
!-------------------------------------------------------------------------------
!*      2.     Compute snow-free albedo
!              ------------------------
!
!* Snow-free surface albedo for each wavelength
!
zalbf         = 0.
zffv          = 0.
zffg          = 0.
!
 CALL isba_albedo(tpsnow%SCHEME, otr_ml, gmeb,                             &
                   pdir_sw, psca_sw, psw_bands, ksw,                       &
                   palbnir, palbvis, palbuv,                               &
                   palbnir_veg, palbvis_veg, palbuv_veg,                   &
                   palbnir_soil, palbvis_soil, palbuv_soil,                &
                   zalbf, zffv, zffg,                                      &
                   zglobal_sw, panosnow,                                   &
                   psnowfree_alb_veg, psnowfree_alb_soil,                  &
                   zp_meb_sca_sw,                                          &
                   palbnir_tveg, palbvis_tveg, palbnir_tsoil, palbvis_tsoil)

!-------------------------------------------------------------------------------
!
!*      3.     Compute aggeragted albedo and emissivity
!              ----------------------------------------
!
IF(tpsnow%SCHEME == '3-L' .OR. tpsnow%SCHEME == 'CRO' .OR. hisba == 'DIF')THEN
!
! NON-SNOW covered Grid averaged albedo and emissivity for explicit snow scheme:
!
   pasnow(:) = tpsnow%ALB(:,kpatch)
   pesnow(:) = tpsnow%EMIS(:,kpatch)
   penosnow(:) = pemis(:)

   ptssnow(:)   = tpsnow%TS(:,kpatch)
   ptsnosnow(:) = ptg(:)

ELSE
!
! Grid averaged albedo and emissivity for composite snow scheme:
!
   IF(tpsnow%SCHEME =='EBA') THEN
!
      pasnow(:) = tpsnow%ALB(:,kpatch)
      pesnow(:) = xemcrin
      penosnow(:) = pemis(:)

      ptssnow(:)   = ptg(:)
      ptsnosnow(:) = ptg(:)


   ELSE

      pasnow(:) = tpsnow%ALB(:,kpatch)
      pesnow(:) = xemissn
      penosnow(:) = pemis(:)

      ptssnow(:)   = ptg(:)
      ptsnosnow(:) = ptg(:)

   ENDIF
!
ENDIF
IF (lhook) CALL dr_hook('ISBA_PROPERTIES',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE isba_properties