SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/ccetr

Go to the documentation of this file.
00001 !     ######
00002 !
00003    SUBROUTINE CCETR_PAIR(KNIV, PABC, PABC_SUP, PIA, PXMUS, PB_DR, POMEGA_DR,&
00004                         POMEGA_DF, PB_DF, PLAI, PALB_VEG, PALB_SOIL,        &
00005                         PFD_SKY, PFD_VEG, PTR, PXIA, PLAI_EFF               )
00006    
00007 !
00008 !!***   *CCETR_PAIR* ***
00009 !!
00010 !!    PURPOSE
00011 !!    -------
00012 !!    Calculates radiative transfer within the canopy
00013 !!
00014 !!**  METHOD
00015 !!    ------
00016 !!    Carrer et al. 
00017 !!
00018 !!    EXTERNAL
00019 !!    --------
00020 !!    none
00021 !!
00022 !!    IMPLICIT ARGUMENTS
00023 !!    ------------------      
00024 !!    USE MODD_CO2V_PAR
00025 !!
00026 !!    REFERENCE
00027 !!    ---------
00028 !!    Carrer et al. ??
00029 !!      
00030 !!    AUTHOR
00031 !!    ------
00032 !!        D. Carrer           * Meteo-France *
00033 !!
00034 !!    MODIFICATIONS
00035 !!    -------------
00036 !!      Original    01/04/11 
00037 !!
00038 !-------------------------------------------------------------------------------
00039 !
00040 USE MODD_CSTS,       ONLY : XI0
00041 !
00042 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00043 USE PARKIND1  ,ONLY : JPRB
00044 !
00045 !*       0.     DECLARATIONS
00046 !               ------------
00047 !
00048 IMPLICIT NONE
00049 !
00050 !*      0.1    declarations of arguments
00051 !
00052 INTEGER, INTENT(IN)               :: KNIV
00053 REAL,    INTENT(IN)               :: PABC, PABC_SUP
00054 !                              PABC    = abscissa needed for integration
00055 !                                       of net assimilation and stomatal 
00056 !                                       conductance over canopy depth
00057 REAL, DIMENSION(:), INTENT(IN)    :: PIA, PXMUS, PB_DR, POMEGA_DR, POMEGA_DF
00058 REAL, INTENT(IN) :: PB_DF
00059 !                              PIA   = absorbed PAR / PIR
00060 !                              PXMUS = cosine of solar zenith angle
00061 !                              PLAI  = leaf area index
00062 REAL, DIMENSION(:), INTENT(IN)    :: PLAI, PALB_VEG, PALB_SOIL
00063 REAL, DIMENSION(:), INTENT(IN)    :: PFD_SKY
00064 REAL, DIMENSION(:), INTENT(INOUT) :: PFD_VEG, PTR
00065 REAL, DIMENSION(:), INTENT(OUT)   :: PXIA
00066 !                              PXIA  = abs. radiation of veg
00067 REAL, DIMENSION(:), INTENT(OUT)   :: PLAI_EFF
00068 !
00069 !*      0.2    declarations of local variables
00070 
00071 !
00072 REAL, DIMENSION(SIZE(PLAI)) :: ZSLAI_TRU, ZFD_VEG, ZTDF, ZIDR, ZIDF
00073 !                              ZIDF  = interception of diffusion
00074 !                              ZIDR  = direct interception
00075 !                              XB_DR = DH albedo of upper/lower layers
00076 REAL    :: ZGT_SUP, ZGT_INF, ZGT
00077 INTEGER :: I
00078 !
00079 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00080 !-----------------------------------------------------------------------
00081 IF (LHOOK) CALL DR_HOOK('CCETR_PAIR',0,ZHOOK_HANDLE)
00082 !
00083 PLAI_EFF(:) = 0.
00084 !
00085 !Angular projection of the leaves 
00086 !  0.5                    : spherical distribution 
00087 !  (2./!PI)*sin(zs*!Dtor) : vertical distribution
00088 !  cos(zs*!Dtor)          : horizontal distribution
00089 ZGT_SUP = 0.5 
00090 ZGT_INF = 0.5
00091 !
00092 IF (PABC.GT.0.8) THEN
00093   ZGT = ZGT_SUP
00094 ELSE
00095   ZGT = ZGT_INF
00096 ENDIF
00097 !
00098 !
00099 DO I=1,SIZE(PIA)
00100   IF (PIA(I)>0.) THEN
00101     ZSLAI_TRU(I) = (PABC_SUP-PABC)*PLAI(I)
00102     PLAI_EFF(I) = POMEGA_DR(I)*ZSLAI_TRU(I)
00103     ! transmittance of direct beam
00104     ZIDR(I) = EXP(-ZGT*PB_DR(I)*POMEGA_DR(I)*ZSLAI_TRU(I)/PXMUS(I))
00105     ! transmittance of diffuse beam
00106     ZIDF(I) = EXP(-PB_DF*POMEGA_DF(I)*ZSLAI_TRU(I))
00107     !
00108     PTR(I) = ((1.-PFD_VEG(I))*ZIDR(I) + PFD_VEG(I)*ZIDF(I))*PTR(I)
00109   ENDIF
00110 ENDDO
00111 !
00112 !
00113 IF (PABC.GT.0.8) THEN
00114   DO I=1,SIZE(PIA)
00115     IF (PIA(I)>0.) THEN
00116       ! diffuse fraction due to vegetation
00117       ZFD_VEG(I) = EXP(-(1.-PABC)*POMEGA_DR(I)*PLAI(I))
00118       ZFD_VEG(I) = (1. - ZFD_VEG(I)) / (1. - (1.-PXMUS(I))*ZFD_VEG(I))
00119       PFD_VEG(I) = MIN(ZFD_VEG(I) + PFD_SKY(I),1.)
00120     ENDIF
00121   ENDDO
00122 ENDIF
00123 !
00124 ! transmissivity of upper layers
00125 !
00126 PXIA(:) = 0.
00127 WHERE (PIA(:)>0.) PXIA(:) = (1-PALB_VEG(:))*(1.-PTR(:))*PIA(:)
00128 !
00129 IF (KNIV .EQ. 1) THEN
00130   DO I=1,SIZE(PIA)
00131     IF (PIA(I)>0.) THEN  
00132       ! -- reflection of surface ---   
00133       ! transmittance diffuse up - all layer
00134       ZTDF(I) = EXP(-PB_DF*POMEGA_DF(I)*(1.-PABC)*PLAI(I))
00135       PXIA(I)= PXIA(I) + (1.-PALB_VEG(I))**2*PALB_SOIL(I)*(1.-ZTDF(I))*PTR(I)*PIA(I)
00136     ENDIF
00137   ENDDO
00138 ENDIF
00139 !
00140 IF (LHOOK) CALL DR_HOOK('CCETR_PAIR',1,ZHOOK_HANDLE)
00141 !
00142 END SUBROUTINE CCETR_PAIR
00143