ccetr_pair.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 ccetr_pair(KNIV, PABC, PABC_SUP, PIA, PXMUS, PB_DR, POMEGA_DR,&
                        pomega_df, pb_df, plai, palb_veg, palb_soil,        &
                        pfd_sky, pfd_veg, ptr, pxia, plai_eff               )
   
!
!!***   *CCETR_PAIR* ***
!!
!!    PURPOSE
!!    -------
!!    Calculates radiative transfer within the canopy
!!
!!**  METHOD
!!    ------
!!    Carrer et al. 
!!
!!    EXTERNAL
!!    --------
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------      
!!    USE MODD_CO2V_PAR
!!
!!    REFERENCE
!!    ---------
!!    Carrer et al. 2013
!!      
!!    AUTHOR
!!    ------
!!      D. Carrer           * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/04/11 
!!      LAI_EFF corrected 07/2013 
!-------------------------------------------------------------------------------
!
USE modd_csts,       ONLY : xi0
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
!*       0.     DECLARATIONS
!               ------------
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
INTEGER,            INTENT(IN)    :: kniv              ! layer number from 10 (top of canopy) to 1 (bottom)
REAL,               INTENT(IN)    :: pabc              ! normalized height units of the considered layer and the one above
REAL,               INTENT(IN)    :: pabc_sup          ! cumulated canopy height (0 at the bottom, 1 at the top)
REAL,               INTENT(IN)    :: pb_df             ! single_scattering albedo of considered leaf layer for diffuse rad.
REAL, DIMENSION(:), INTENT(IN)    :: pia               ! incident PAR or NIR
REAL, DIMENSION(:), INTENT(IN)    :: pxmus             ! cosine of solar zenith angle
REAL, DIMENSION(:), INTENT(IN)    :: pb_dr             ! single_scattering albedo of considered leaf layer for direct rad.
REAL, DIMENSION(:), INTENT(IN)    :: pomega_dr         !
REAL, DIMENSION(:), INTENT(IN)    :: pomega_df         !
REAL, DIMENSION(:), INTENT(IN)    :: plai              ! leaf area index
REAL, DIMENSION(:), INTENT(IN)    :: palb_veg          ! vegetation albedo in PAR or NIR
REAL, DIMENSION(:), INTENT(IN)    :: palb_soil         ! soil albedo in PAR or NIR
REAL, DIMENSION(:), INTENT(IN)    :: pfd_sky           ! fraction of incident diffuse radiation at top of canopy
!
REAL, DIMENSION(:), INTENT(INOUT) :: pfd_veg           ! fraction of incident diffuse radiation at top of considered canopy layer
REAL, DIMENSION(:), INTENT(INOUT) :: ptr               ! fraction of transmited radiation
!
REAL, DIMENSION(:), INTENT(OUT)   :: pxia              ! fraction of abs. radiation of veg
REAL, DIMENSION(:), INTENT(OUT)   :: plai_eff          ! LAI effective
!
!*      0.2    declarations of local variables

!
REAL, DIMENSION(SIZE(PLAI)) :: zslai_tru, zfd_veg, ztdf, zidr, &
                               zidf, zabc, zabc_sup, zb_df, zgt
!                              ZIDF  = interception of diffusion
!                              ZIDR  = direct interception
!                              XB_DR = DH albedo of upper/lower layers
REAL    :: zgt_sup, zgt_inf
INTEGER :: i
!
REAL(KIND=JPRB) :: zhook_handle
!
!-----------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('CCETR_PAIR',0,zhook_handle)
!
plai_eff(:) = 0.
!
!Angular projection of the leaves 
!  0.5                    : spherical distribution 
!  (2./!PI)*sin(zs*!Dtor) : vertical distribution
!  cos(zs*!Dtor)          : horizontal distribution
zgt_sup = 0.5 
zgt_inf = 0.5
!
IF (pabc.GT.0.8) THEN
  zgt(:) = zgt_sup
ELSE
  zgt(:) = zgt_inf
ENDIF
!
zabc(:) = pabc
zabc_sup(:) = pabc_sup
zb_df(:) = pb_df
!
IF (pabc.GT.0.8) THEN
  DO i=1,SIZE(pia)
    IF (pia(i)>0.) THEN
      ! diffuse fraction due to vegetation
      zfd_veg(i) = exp(-(1.-zabc(i))*pomega_dr(i)*plai(i))
      zfd_veg(i) = (1. - zfd_veg(i)) / (1. - (1.-pxmus(i))*zfd_veg(i))
      pfd_veg(i) = min(zfd_veg(i) + pfd_sky(i),1.)
    ENDIF
  ENDDO
ENDIF
!
DO i=1,SIZE(pia)
  IF (pia(i)>0.) THEN
    zslai_tru(i) = (zabc_sup(i)-zabc(i))*plai(i)
    !PLAI_EFF(I) = POMEGA_DR(I)*ZSLAI_TRU(I)
    ! transmittance of direct beam
    zidr(i) = exp(-zgt(i)*pb_dr(i)*pomega_dr(i)*zslai_tru(i)/pxmus(i))
    ! transmittance of diffuse beam
    zidf(i) = exp(-zb_df(i)*pomega_df(i)*zslai_tru(i))
    plai_eff(i) = ((1.-pfd_veg(i))*pomega_dr(i)+pfd_veg(i)*pomega_df(i))*zslai_tru(i)
    !
    ptr(i) = ((1.-pfd_veg(i))*zidr(i) + pfd_veg(i)*zidf(i))*ptr(i)
  ENDIF
ENDDO
!
!
! transmissivity of upper layers
!
pxia(:) = 0.
WHERE (pia(:)>0.) pxia(:) = (1-palb_veg(:))*(1.-ptr(:))*pia(:)
!
IF (kniv .EQ. 1) THEN
  DO i=1,SIZE(pia)
    IF (pia(i)>0.) THEN  
      ! -- reflection of surface ---   
      ! transmittance diffuse up - all layer
      ztdf(i) = exp(-zb_df(i)*pomega_df(i)*(1.-zabc(i))*plai(i))
      pxia(i)= pxia(i) + (1.-palb_veg(i))*(1.-palb_veg(i))*palb_soil(i)*(1.-ztdf(i))*ptr(i)*pia(i)
    ENDIF
  ENDDO
ENDIF
!
IF (lhook) CALL dr_hook('CCETR_PAIR',1,zhook_handle)
!
END SUBROUTINE ccetr_pair