6 SUBROUTINE fapair(PABC, PFD_SKY, PIA, PLAI, PXMUS, PSSA_SUP, PSSA_INF, &
7 pb_sup, pb_inf, palb_veg, palb_soil, oshade, &
8 pfapr, pfapr_bs, plai_eff, piacan, &
9 piacan_shade, piacan_sunlit, pfrac_sun )
55 USE yomhook
,ONLY : lhook, dr_hook
56 USE parkind1
,ONLY : jprb
65 REAL,
DIMENSION(:),
INTENT(IN) :: pabc
68 REAL,
DIMENSION(:),
INTENT(IN) :: pfd_sky
69 REAL,
DIMENSION(:),
INTENT(IN) :: pia
70 REAL,
DIMENSION(:),
INTENT(IN) :: plai
71 REAL,
DIMENSION(:),
INTENT(IN) :: pxmus
72 REAL,
INTENT(IN) :: pssa_sup, pssa_inf
73 REAL,
DIMENSION(:),
INTENT(IN) :: pb_sup, pb_inf
74 REAL,
DIMENSION(:),
INTENT(IN) :: palb_veg, palb_soil
75 LOGICAL,
DIMENSION(:),
INTENT(IN) :: oshade
77 REAL,
DIMENSION(:),
INTENT(OUT) :: pfapr
78 REAL,
DIMENSION(:),
INTENT(OUT) :: pfapr_bs
79 REAL,
DIMENSION(:),
OPTIONAL,
INTENT(OUT) :: plai_eff
81 REAL,
DIMENSION(:,:),
OPTIONAL,
INTENT(OUT) :: piacan
82 REAL,
DIMENSION(:,:),
OPTIONAL,
INTENT(OUT) :: piacan_shade
83 REAL,
DIMENSION(:,:),
OPTIONAL,
INTENT(OUT) :: piacan_sunlit
84 REAL,
DIMENSION(:,:),
OPTIONAL,
INTENT(OUT) :: pfrac_sun
89 REAL,
DIMENSION(SIZE(PLAI)) :: zxia, zxia_sup, zkmusp_sup, zkmusp_inf
90 REAL,
DIMENSION(SIZE(PLAI)) :: zb_dr_sup, zb_dr_inf, zomega_dr_sup, zomega_dr_inf, &
91 zomega_df_sup, zomega_df_inf
93 REAL,
DIMENSION(SIZE(PLAI)) :: ztr, zfd_veg, zfd_sup, zlai_eff0, zlai_eff
102 REAL,
DIMENSION(SIZE(PLAI),SIZE(PABC)) :: ziacan, ziacan_sunlit, ziacan_shade, zfrac_sun
103 REAL :: zabc, zweight, zcoef, zsup, zinf, &
104 zssa_sup, zssa_inf, zb_df_sup, zb_df_inf
111 REAL(KIND=JPRB) :: zhook_handle
113 IF (lhook) CALL dr_hook(
'FAPAIR',0,zhook_handle)
132 ziacan_sunlit(:,:) = 0.
133 ziacan_shade(:,:) = 0.
142 IF (pabc(
SIZE(pabc)).GT.0.8) zfd_veg(:) = min(pfd_sky(:),1.)
145 zssa_sup = sqrt(1.-pssa_sup)
146 zssa_inf = sqrt(1.-pssa_inf)
148 zsup = - 0.461 * xxsi_sup + 3.8
149 zinf = - 0.461 * xxsi_inf + 3.8
152 IF (pia(i).NE.0.)
THEN
153 zkmusp_sup(i) = exp(-xk_sup*(acos(pxmus(i)))**zsup)
154 zkmusp_inf(i) = exp(-xk_inf*(acos(pxmus(i)))**zinf)
157 zb_dr_sup(i) = 1.-(1.-zssa_sup)/(1.+2.*pxmus(i)*zssa_sup)
158 zb_dr_inf(i) = 1.-(1.-zssa_sup)/(1.+2.*pxmus(i)*zssa_inf)
160 zomega_dr_sup(i) = 1. / (1.+ pb_sup(i)*zkmusp_sup(i))
161 zomega_dr_inf(i) = 1. / (1.+ pb_inf(i)*zkmusp_inf(i))
164 zomega_df_sup(i) = (1.+pb_sup(i)/2.)/(1.+pb_sup(i))
165 zomega_df_inf(i) = (1.+pb_inf(i)/2.)/(1.+pb_inf(i))
170 zb_df_sup = 1.-(1.-zssa_sup)/(1.+ zssa_sup)
171 zb_df_inf = 1.-(1.-zssa_inf)/(1.+ zssa_inf)
176 DO jint =
SIZE(pabc),1,-1
179 IF (jint.LT.
SIZE(pabc)) zabc = pabc(jint+1)
180 zweight = zabc - pabc(jint)
182 IF (pabc(jint).GT.0.8)
THEN
184 CALL
ccetr_pair(jint, pabc(jint), zabc, pia, pxmus, zb_dr_sup, &
185 zomega_dr_sup, zomega_df_sup, zb_df_sup, plai, &
186 palb_veg, palb_soil, pfd_sky, zfd_veg, ztr, &
189 CALL
ccetr_pair(jint, pabc(jint), zabc, pia, pxmus, zb_dr_inf, &
190 zomega_dr_inf, zomega_df_inf, zb_df_inf, plai, &
191 palb_veg, palb_soil, pfd_sky, zfd_veg, ztr, &
197 zxia(i) = max(0.,zxia(i))
198 ziacan(i,jint) = max(0.,zxia(i)-zxia_sup(i))
199 zxia_sup(i) = zxia(i)
201 zlai_eff0(i) = max(0.,zlai_eff0(i))
202 zlai_eff(i) = zlai_eff(i) + zlai_eff0(i)
205 pfapr(i) = pfapr(i) + ziacan(i,jint)
217 zcoef = (1.0-zfd_sup(i))/ztr(i)+ zfd_sup(i)
218 ziacan_sunlit(i,jint) = zcoef/(zweight*max(0.0001,plai(i)))*ziacan(i,jint)
220 ziacan_shade(i,jint) = max(0.,zfd_sup(i)/(zweight*max(0.0001,plai(i)))*ziacan(i,jint))
228 zfrac_sun(i,jint) = ztr(i)
232 ziacan_sunlit(i,jint) = max(0.,ziacan(i,jint)/(zweight*max(0.0001,plai(i))))
237 zfd_sup(i) = zfd_veg(i)
245 pfapr(:) = pfapr(:) / pia(:)
246 pfapr_bs(:)=(1.-palb_veg(:))*(1-palb_soil(:))*(1.+palb_veg(:)*palb_soil(:))*ztr(:)
247 WHERE (plai(:).EQ.0) pfapr_bs(:) = 1-palb_soil(:)
253 IF (present(plai_eff)) plai_eff = zlai_eff
254 IF (present(piacan)) piacan = ziacan
255 IF (present(piacan_sunlit)) piacan_sunlit = ziacan_sunlit
256 IF (present(piacan_shade)) piacan_shade = ziacan_shade
257 IF (present(pfrac_sun)) pfrac_sun = zfrac_sun
259 IF (lhook) CALL dr_hook(
'FAPAIR',1,zhook_handle)
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)
subroutine fapair(PABC, PFD_SKY, PIA, PLAI, PXMUS, PSSA_SUP, PSSA_INF, PB_SUP, PB_INF, PALB_VEG, PALB_SOIL, OSHADE, PFAPR, PFAPR_BS, PLAI_EFF, PIACAN, PIACAN_SHADE, PIACAN_SUNLIT, PFRAC_SUN)