averaged_albedo_emis_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 averaged_albedo_emis_isba (I, &
                                            oflood, halbedo, &
                                 pzenith,pveg,pz0,plai,     &
                                 omeb_patch,pgndlitter,     &
                                 pz0litter,plaigv,          &
                                 ph_veg, ptv,               &
                                 ptg1,ppatch,               &
                                 psw_bands,                 &
                                 palbnir_veg,palbvis_veg,   &
                                 palbuv_veg,                &
                                 palbnir_soil,palbvis_soil, &
                                 palbuv_soil,               &
                                 pemis_eco,                 &
                                 tpsnow,                    &
                                 palbnir_eco,palbvis_eco,   &
                                 palbuv_eco,                &
                                 pdir_alb,psca_alb,         &
                                 pemis,ptsrad,ptsurf,       &
                                 pdir_sw, psca_sw           )
!     ###################################################
!
!!**** ** computes radiative fields used in ISBA
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    01/2004
!!     A. Bogatchev 09/2005 EBA snow option
!!     B. Decharme  2008    The fraction of vegetation covered by snow must be
!                            <= to ZSNG
!!     B. Decharme  2013    new coupling variable and optimization    
!!     P. Samuelsson 10/2014 MEB
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
USE modd_isba_n, ONLY : isba_t
!
USE modd_surf_par,  ONLY : xundef
!
USE modd_type_snow
!
USE modd_csts,      ONLY : xstefan
USE mode_meb,       ONLY : mebpalphan
!
USE modi_albedo
USE modi_average_rad
USE modi_update_rad_isba_n
USE modi_isba_lwnet_meb
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(isba_t), INTENT(INOUT) :: i
!
LOGICAL,                INTENT(IN)   :: oflood
 CHARACTER(LEN=4),       INTENT(IN)   :: halbedo     ! albedo type
! Albedo dependance with surface soil water content
!   "EVOL" = albedo evolves with soil wetness
!   "DRY " = constant albedo value for dry soil
!   "WET " = constant albedo value for wet soil
!   "MEAN" = constant albedo value for medium soil wetness
!
REAL, DIMENSION(:,:),   INTENT(IN)   :: pveg        ! vegetation fraction
REAL, DIMENSION(:,:),   INTENT(IN)   :: pz0         ! roughness length
REAL, DIMENSION(:,:),   INTENT(IN)   :: plai        ! leaf area index
LOGICAL, DIMENSION(:),  INTENT(IN)   :: omeb_patch  ! multi-energy balance logical vector
REAL, DIMENSION(:,:),   INTENT(IN)   :: pgndlitter  ! Ground litter fraction
REAL, DIMENSION(:,:),   INTENT(IN)   :: plaigv      ! Understory leaf area index
REAL, DIMENSION(:,:),   INTENT(IN)   :: pz0litter   ! Ground litter roughness length
REAL, DIMENSION(:,:),   INTENT(IN)   :: ph_veg      ! Height of vegetation
REAL, DIMENSION(:,:),   INTENT(IN)   :: ptv         ! canopy vegetation temperature
REAL, DIMENSION(:,:),   INTENT(IN)   :: ptg1        ! soil surface temperature
REAL, DIMENSION(:,:),   INTENT(IN)   :: ppatch      ! tile fraction
REAL, DIMENSION(:),     INTENT(IN)   :: psw_bands   ! middle wavelength of each band
REAL, DIMENSION(:),     INTENT(IN)   :: pzenith     

REAL, DIMENSION(:,:),   INTENT(IN)   :: palbnir_veg ! near-infra-red albedo of vegetation
REAL, DIMENSION(:,:),   INTENT(IN)   :: palbvis_veg ! visible albedo of vegetation
REAL, DIMENSION(:,:),   INTENT(IN)   :: palbuv_veg  ! UV albedo of vegetation
REAL, DIMENSION(:,:),   INTENT(IN)   :: palbnir_soil! near-infra-red albedo of soil
REAL, DIMENSION(:,:),   INTENT(IN)   :: palbvis_soil! visible albedo of soil
REAL, DIMENSION(:,:),   INTENT(IN)   :: palbuv_soil ! UV albedo of soil
REAL, DIMENSION(:,:),   INTENT(IN)   :: pemis_eco   ! emissivity (soil+vegetation)
TYPE(surf_snow),        INTENT(IN)   :: tpsnow      ! prognostic snow cover
!
REAL, DIMENSION(:,:),   INTENT(OUT)  :: palbnir_eco ! near-infra-red albedo (soil+vegetation)
REAL, DIMENSION(:,:),   INTENT(OUT)  :: palbvis_eco ! visible albedo (soil+vegetation)
REAL, DIMENSION(:,:),   INTENT(OUT)  :: palbuv_eco  ! UV albedo (soil+vegetation)
!
REAL, DIMENSION(:,:),   INTENT(OUT)  :: pdir_alb    ! averaged direct albedo  (per wavelength)
REAL, DIMENSION(:,:),   INTENT(OUT)  :: psca_alb    ! averaged diffuse albedo (per wavelength)
REAL, DIMENSION(:),     INTENT(OUT)  :: pemis       ! averaged emissivity
REAL, DIMENSION(:),     INTENT(OUT)  :: ptsrad      ! averaged radiaitve temp.
REAL, DIMENSION(:),     INTENT(OUT)  :: ptsurf      ! surface effective temperature         (K)
!
REAL, DIMENSION(:,:),   INTENT(IN), OPTIONAL   :: pdir_sw ! Downwelling direct SW radiation
REAL, DIMENSION(:,:),   INTENT(IN), OPTIONAL   :: psca_sw ! Downwelling diffuse SW radiation
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
!
REAL, DIMENSION(SIZE(PALBNIR_VEG,1),SIZE(PSW_BANDS),SIZE(PALBVIS_VEG,2)) :: zdir_alb_patch 
!                                                     ! direct albedo
REAL, DIMENSION(SIZE(PALBNIR_VEG,1),SIZE(PSW_BANDS),SIZE(PALBVIS_VEG,2)) :: zsca_alb_patch 
!                                                     ! diffuse albedo
REAL, DIMENSION(SIZE(PEMIS_ECO,  1),SIZE(PALBVIS_VEG,2)) :: zemis_patch   ! emissivity with snow-flood
REAL, DIMENSION(SIZE(PEMIS_ECO,  1),SIZE(PALBVIS_VEG,2)) :: ztsrad_patch  ! Tsrad
REAL, DIMENSION(SIZE(PEMIS_ECO,  1),SIZE(PALBVIS_VEG,2)) :: ztsurf_patch  ! Tsurf
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zemis         ! emissivity with flood
!
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zsnowdepth    ! Total snow depth
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zpalphan      ! Snow/canopy ratio factor 
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zlw_rad       ! Fake downwelling LW rad
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zlw_up        ! Upwelling LW rad
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zlwnet_n      ! LW net for snow surface
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zlwnet_v      ! LW net for canopy veg
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zlwnet_g      ! LW net for ground
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zdummy
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zemisf
REAL, DIMENSION(SIZE(PEMIS_ECO,  1)) :: zff
!
LOGICAL :: lexplicit_snow ! snow scheme key
!
INTEGER :: inp, ini
INTEGER :: jp, ji ! loop on patches
INTEGER :: jpatch ! loop on patches
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
!*    0.      Init
!             ----
!
IF (lhook) CALL dr_hook('AVERAGED_ALBEDO_EMIS_ISBA',0,zhook_handle)
!
ini=SIZE(ppatch,1)
inp=SIZE(ppatch,2)
!
pdir_alb(:,:)=0.
psca_alb(:,:)=0.
pemis(:)  =0.
ptsrad(:)  =0.
ptsurf(:)  =0.
!
zdir_alb_patch(:,:,:)=0.
zsca_alb_patch(:,:,:)=0.
zemis_patch(:,:  )=0.
!
lexplicit_snow = (tpsnow%SCHEME=='3-L'.OR.tpsnow%SCHEME=='CRO')
!
ztsrad_patch(:,:) = ptg1(:,:)
ztsurf_patch(:,:) = ptg1(:,:)
!
!
!*    1.      averaged albedo on natural continental surfaces (except prognostic snow)
!             -----------------------------------------------
!
 CALL albedo(halbedo,                                    &
              palbvis_veg,palbnir_veg,palbuv_veg,pveg,    &
              palbvis_soil,palbnir_soil,palbuv_soil,      &
              palbvis_eco,palbnir_eco,palbuv_eco          )  

!
!*    2.      averaged albedo and emis. on natural continental surfaces (with prognostic snow)
!             ---------------------------------------------------------
!
! A dummy downwelling LW radiation can be used for calculation of radiative surface temp 
!
zlw_rad(:) = 300.0
!    
!* Initialization of albedo for each wavelength, emissivity and snow/flood fractions
!
IF(present(pdir_sw))THEN
!
! For the case when MEB patch albedo is requested downweeling SW is needed
!
  CALL update_rad_isba_n(i, &
                         oflood, tpsnow%SCHEME,pzenith,psw_bands,pveg,plai,pz0, &
                         omeb_patch,plaigv,pgndlitter,pz0litter, ph_veg,        &
                         palbnir_eco,palbvis_eco,palbuv_eco,pemis_eco,          &
                         zdir_alb_patch,zsca_alb_patch,zemis_patch,             &
                         pdir_sw, psca_sw,                                      &
                         palbnir_veg, palbnir_soil,                             &
                         palbvis_veg, palbvis_soil                              )
ELSE
!
! For cases when MEB patch albedo is not requested no downweeling SW is needed
!
  CALL update_rad_isba_n(i, &
                         oflood, tpsnow%SCHEME,pzenith,psw_bands,pveg,plai,pz0, &
                         omeb_patch,plaigv,pgndlitter,pz0litter, ph_veg,        &
                         palbnir_eco,palbvis_eco,palbuv_eco,pemis_eco,          &
                         zdir_alb_patch,zsca_alb_patch,zemis_patch              )
ENDIF
!
!
!* radiative surface temperature
!
DO jpatch=1,SIZE(palbvis_veg,2)
!
  IF(omeb_patch(jpatch))THEN  ! MEB patches
!
!   ZPALPHAN is needed as input to ISBA_LWNET_MEB
!
    zsnowdepth(:) = sum(tpsnow%WSNOW(:,:,jpatch)/tpsnow%RHO(:,:,jpatch),2)
    zpalphan(:)   = mebpalphan(zsnowdepth,ph_veg(:,jpatch))
!
!   ZLWNET_N,ZLWNET_V,ZLWNET_G are needed for ZLW_UP and ZTSRAD_PATCH
!
    IF(oflood)THEN
      zemisf(:) = i%XEMISF(:,jpatch)
      zff(:) = i%XFF   (:,jpatch)
    ELSE
      zemisf(:) = xundef
      zff(:) = 0.0
    ENDIF
!
    CALL isba_lwnet_meb(plai(:,jpatch),i%XPSN(:,jpatch),zpalphan,   &
        tpsnow%EMIS(:,jpatch),zemisf(:),zff(:),                   &
        ptv(:,jpatch),ptg1(:,jpatch),tpsnow%TS(:,jpatch),         &
        zlw_rad,zlwnet_n,zlwnet_v,zlwnet_g,                       &
        zdummy,zdummy,zdummy,                                     &
        zdummy,zdummy,zdummy,                                     &
        zdummy,zdummy,zdummy,                                     &
        zdummy,zdummy,zdummy                                      )
!
    zlw_up(:)   = zlw_rad(:) - (zlwnet_v(:) + zlwnet_g(:) + zlwnet_n(:))
!
!   MEB patch radiative temperature
!
    WHERE (zemis_patch(:,jpatch)/=0.)
      ztsrad_patch(:,jpatch) = ((zlw_up(:) - zlw_rad(:)*(1.0-zemis_patch(:,jpatch)))/ &
                              (xstefan*zemis_patch(:,jpatch)))**0.25
    END WHERE
!
  ELSE   ! Non-MEB patches

    zemis(:) = pemis_eco(:,jpatch)
!
    IF(oflood.AND.lexplicit_snow)THEN
      WHERE(i%XPSN(:,jpatch)<1.0.AND.pemis_eco(:,jpatch)/=xundef)          
        zemis(:) = ((1.-i%XFF(:,jpatch)-i%XPSN(:,jpatch))*pemis_eco(:,jpatch) + i%XFF(:,jpatch)*i%XEMISF(:,jpatch)) &
                   /(1.-i%XPSN(:,jpatch))
      ENDWHERE   
    ENDIF
!
    IF (.NOT.lexplicit_snow) THEN
      ztsrad_patch(:,jpatch) = ptg1(:,jpatch)
    ELSE IF (lexplicit_snow) THEN
      WHERE (pemis_eco(:,jpatch)/=xundef .AND. zemis_patch(:,jpatch)/=0.)
        ztsrad_patch(:,jpatch) =( ( (1.-i%XPSN(:,jpatch))*zemis(:)       *ptg1(:,jpatch)**4            &
                                    +    i%XPSN(:,jpatch) *tpsnow%EMIS(:,jpatch)*tpsnow%TS(:,jpatch)**4 ) )**0.25  &
                                 / zemis_patch(:,jpatch)**0.25  
      END WHERE
    END IF
  ENDIF
END DO
!
!* averaged radiative fields
!
 CALL average_rad(ppatch,                                                     &
                   zdir_alb_patch, zsca_alb_patch, zemis_patch, ztsrad_patch, &
                   pdir_alb,       psca_alb,       pemis,       ptsrad        )  
!
!* averaged effective temperature
!
IF(lexplicit_snow)THEN
  ztsurf_patch(:,:) = ptg1(:,:)*(1.-i%XPSN(:,:)) + tpsnow%TS(:,:)*i%XPSN(:,:)
ENDIF
!
DO jp=1,inp
  DO ji=1,ini
     ptsurf(ji) = ptsurf(ji) + ppatch(ji,jp) * ztsurf_patch(ji,jp)
  ENDDO
ENDDO
!
IF (lhook) CALL dr_hook('AVERAGED_ALBEDO_EMIS_ISBA',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE averaged_albedo_emis_isba