radiative_transfert.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 radiative_transfert(OAGRI_TO_GRASS, PVEGTYPE,          &
            palbvis_veg, palbvis_soil, palbnir_veg, palbnir_soil, &
            psw_rad, plai, pzenith, pabc,                         &
            pfaparc, pfapirc, pmus, plai_effc, oshade, piacan,    &             
            piacan_sunlit, piacan_shade, pfrac_sun,               &          
            pfapar, pfapir, pfapar_bs, pfapir_bs                  ) 
!   #########################################################################
!
!!****  *RADIATIVE_TRANSFERT*  
!!
!!    PURPOSE
!!    -------
!!
!!    Calculates the fraction of absorbed photosynthetic radiation (FAPAR), 
!!      the fraction of absorbed near-infrared radiation (FAPIR), based on 
!!      the fraction of diffuse and direct radiation (Erbs et al 1982 formulation).
!!    Calculates also the clumping index and the resulting transmittance 
!!      distinguishing between the upper part of the canopy (SUP) and the rest (INF),
!!      direct and diffuse radiation, sunlit and shaded leaves.
!!              
!!**  METHOD
!!    ------
!!    Carrer et al, 2013 (doi:10.1002/jgrg20070)
!!
!!    EXTERNAL
!!    --------
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!      
!!    USE MODD_CSTS
!!    USE MODD_CO2V_PAR
!!    USE MODD_SURF_PAR
!!    USE MODI_FAPAIR
!!
!!    REFERENCE
!!    ---------
!!
!!    Carrer et al, 2013 (doi:10.1002/jgrg20070)
!!      
!!    AUTHOR
!!    ------
!!
!!        D. Carrer           * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!     Original    04/11 
!!     C. Delire   08/13 : moved calculation of diffuse fraction from fapair to here
!!     Commented by C. Delire 07/13
!!
!-------------------------------------------------------------------------------
!!
USE modd_csts,           ONLY : xi0                              ! Solar constant
USE modd_co2v_par,       ONLY : xparcf, xlai_shade,            &
                                xxb_sup, xxb_inf,              & ! sigma parameter in clumping (Table 1, eq4)     
                                xssa_sup, xssa_inf,            & ! single scatering albedo (PAR)
                                xssa_sup_pir, xssa_inf_pir       ! single scatering albedo (NIR)
!
USE modd_data_cover_par, ONLY : nvt_c3, nvt_c4, &
                                nvt_irr, nvt_gras
!
USE modd_surf_par,       ONLY : xundef
!
USE modi_fapair
!
!*       0.     DECLARATIONS
!               ------------
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
LOGICAL,             INTENT(IN)  :: oagri_to_grass
!
REAL, DIMENSION(:,:),INTENT(IN)  :: pvegtype     ! PVEGTYPE  = type de vegetation (1 a 9)
!
REAL, DIMENSION(:), INTENT(IN)   :: palbvis_veg  ! visible snow free albedo of vegetation
REAL, DIMENSION(:), INTENT(IN)   :: palbvis_soil ! visible snow free albedo of soil
REAL, DIMENSION(:), INTENT(IN)   :: palbnir_veg  ! NIR snow free albedo of vegetation
REAL, DIMENSION(:), INTENT(IN)   :: palbnir_soil ! NIR snow free albedo of soil
!
REAL,DIMENSION(:),   INTENT(IN)  :: psw_rad      ! incident broadband solar radiation (PAR+NIR)
REAL,DIMENSION(:),   INTENT(IN)  :: plai         ! PLAI  = leaf area index
!
REAL,DIMENSION(:),    INTENT(IN)  :: pzenith     ! solar zenith angle needed 
!                                    for computation of diffusion of solar
!                                    radiation
!
REAL,DIMENSION(:),  INTENT(INOUT) :: pabc        ! normalized canopy height (0=bottom, 1=top)
!                                    
!
REAL, DIMENSION(:),   INTENT(INOUT) :: pfaparc   !fraction of absorbed photosynthetic active radiation (cumulated over patches)
REAL, DIMENSION(:),   INTENT(INOUT) :: pfapirc   !fraction of absorbed NIR (cumulated)
REAL, DIMENSION(:),   INTENT(INOUT) :: pmus      ! cosine of solar zenith angle (averaged)
REAL, DIMENSION(:),   INTENT(INOUT) :: plai_effc ! Effective LAI (cumulated)
!
LOGICAL, DIMENSION(:),INTENT(OUT) :: oshade      ! OSHADE = if 1 shading activated
REAL, DIMENSION(:,:), INTENT(OUT) :: piacan      ! APAR in the canopy at different gauss level
REAL, DIMENSION(:,:), INTENT(OUT) :: piacan_sunlit, piacan_shade
!                                                ! absorbed PAR at each level within the
!                                                ! canopy - Split into shaded and SUNLIT
REAL, DIMENSION(:,:), INTENT(OUT) :: pfrac_sun   ! fraction of sunlit leaves
!
REAL, DIMENSION(:),   INTENT(OUT) :: pfapar, pfapir, pfapar_bs, pfapir_bs
!
!*      0.2    declarations of local variables
!
!
REAL, DIMENSION(SIZE(PLAI)) :: zia, zlai, zlai_eff, zxmus, zfd_sky 
!                                ZXMUS = cosine of solar zenith angle
!                                ZFD_SKY = fraction of diffuse radiation in sky
REAL,    DIMENSION(SIZE(PLAI)) :: zb_inf, zb_sup
INTEGER, DIMENSION(1)          :: idmax
REAL                           :: ztau, zratio
!                               ZTAU = exp(-aerosol optical depth taken as 0.1)
!                               ZRATIO = clearness index K_t eq.1 from Carrer et al
INTEGER                        :: jj, i ! index for loops
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('RADIATIVE_TRANSFERT',0,zhook_handle)
!
zlai(:)   = plai(:)
zfd_sky(:) = 0.
!
WHERE (plai(:)==xundef) zlai(:) = 0.0
!
! Geometrical configuration and density of leaves induce different 
! min value of LAI to start the shading.
oshade(:)= .true.
DO jj = 1, SIZE(plai)
! CD value calculated for patch with largest fraction ?
  idmax = maxloc(pvegtype(jj,:))    
  IF(oagri_to_grass.AND.(idmax(1)==nvt_c3.OR.idmax(1)==nvt_c4.OR.idmax(1)==nvt_irr))idmax(1)=nvt_gras
  IF (plai(jj).LT.xlai_shade(idmax(1))) oshade(jj) = .false.
  zb_inf(jj) = xxb_inf(idmax(1))
  zb_sup(jj) = xxb_sup(idmax(1))
ENDDO
!
!to consider all the tickness of the canopy
pabc(1) = 0.
!
! cosine of solar zenith angle 
!
zxmus(:) = max(cos(pzenith(:)),0.01)
!
! CD Calculation of diffuse fraction done here because depends on solar radiation and not PAR
!
ztau = exp(-0.1) !  Aerosol Optical Depth fixed at low value (Carrer et al, section 2.1.2 eq. 1)
!
! Diffuse fraction based on clearness index (Carrer et la, eq. 1 & 2.) 
DO i=1,SIZE(plai)
  IF (psw_rad(i) > 0.) THEN
    ! estimates fraction of diffuse radiation by Erbs (1982)
    zratio = psw_rad(i)/xi0/zxmus(i)     
    IF (zratio < 0.22) THEN
      zfd_sky(i) = (1 - 0.09*zratio)
    ELSE IF (zratio < 0.8) THEN
      zfd_sky(i) = (0.9511 + (-0.1604 + (4.388 + (-16.64 + 12.34*zratio)*zratio)*zratio)*zratio)
    ELSE
      !!$ PXFD_SKY(I) = PIA(I)*0.165  ! original Erbs formulation
      !if clear sky, the diffuse fraction depends on aerosol load
      zfd_sky(i) = (1. - ztau) /(1. - (1.-zxmus(i))*ztau)
    ENDIF
  ENDIF
END DO
!
! NIR calculations
zia(:)     = psw_rad(:)*(1.-xparcf)
 CALL fapair(pabc, zfd_sky, zia, zlai, zxmus, xssa_sup_pir, xssa_inf_pir,  &
         zb_sup, zb_inf, palbnir_veg, palbnir_soil, oshade,      &
         pfapir, pfapir_bs                                       )
!
zia(:)     = psw_rad(:)*xparcf
 CALL fapair(pabc, zfd_sky, zia, zlai, zxmus, xssa_sup, xssa_inf,          &
         zb_sup, zb_inf, palbvis_veg, palbvis_soil, oshade,      &
         pfapar, pfapar_bs, plai_eff=zlai_eff, piacan=piacan,    &
         piacan_shade=piacan_shade, piacan_sunlit=piacan_sunlit, &
         pfrac_sun=pfrac_sun                                     )
!
DO jj = 1,SIZE(plai)
  IF (zia(jj).NE.0.) THEN
    pfapirc(jj)   = pfapirc(jj)   + pfapir(jj)   * zxmus(jj)
    pfaparc(jj)   = pfaparc(jj)   + pfapar(jj)   * zxmus(jj)
    plai_effc(jj) = plai_effc(jj) + zlai_eff(jj) * zxmus(jj)
    pmus(jj)      = pmus(jj)      + zxmus(jj)
  ENDIF
ENDDO
!
IF (lhook) CALL dr_hook('RADIATIVE_TRANSFERT',1,zhook_handle)
!
END SUBROUTINE radiative_transfert