!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***S/P LWTRAN - LONGWAVE RADIATIVE TRANSFER
*
#include "phy_macros_f.h"
subroutine lwtran (fu, fd, slwf, tauci, omci, 1
1 gci, fl, taual, taug, bf,
2 bs, urbf, dbf, em0, cldfrac,
3 cldm, anu, nct, ncd, ncu,
4 ncum, ncdm, lev1, cut, il1,
5 il2, ilg, lay, lev, maxc,
6 taucsg, term1, emisw, scatbk, scatfw,
7 c2)
*
#include "impnone.cdk"
*
integer ilg, lay, lev, lev1, il1, il2, l1, l2, maxc, i
integer k, km1, km2, kp1, kp2, kx, kxm, kk, km3, nanu
real cut, ubeta, epsd, epsu, zeta, taul2, ssalb
real sf, ww, cow, tau2, sanu, xx, yy, dtr2, embk
real ru, wt, sx, sy, p1, p2, zz, x2, y2, x3, y3, wgrcow
real taudtr, bkins, anutau, dtrgw, fwins, fmbk
real fu(ilg,2,lev), fd(ilg,2,lev)
real slwf(ilg), tauci(ilg,lay), omci(ilg,lay), gci(ilg,lay),
1 fl(ilg,lay), taual(ilg,lay), taug(ilg,lay), bf(ilg,lev),
2 bs(ilg),urbf(ilg,lay),dbf(ilg,lay),em0(ilg),cldfrac(ilg,lay),
3 cldm(ilg,lay), anu(ilg,lay), taul1(ilg,lay), rtaul1(ilg,lay)
real taucsg(ilg,lay), term1(ilg), emisw(ilg,lay), scatbk(ilg,lay),
1 scatfw(ilg,lay), scatsm(ilg,4,lay), taum(ilg,4,lay),
2 xd(ilg,4,lay), xu(ilg,4,lay), dtr(ilg,4,lay), fx(ilg,4,lev),
3 fy(ilg,4,lev), fw(ilg,4,lev), s1(ilg), c2(ilg)
real*8 dtr_vs(ilg,lay)
integer nct(ilg), ncd(ilg,lay), ncu(ilg,lay), ncum(lay), ncdm(lay)
*
data ru / 1.6487213 /
*
*Authors
* J. Li, M. Lazare, CCCMA, rt code for gcm4
* (Ref: J. Li, H. W. Barker, 2005:
* JAS Vol. 62, no. 2, pp. 286\226309)
* P. Vaillancourt, D. Talbot, RPN/CMC;
* adapted for CMC/RPN physics (May 2006)
*
*Revisions
* 001 P.Vaillancourt, K.Winger, M.Lazarre (Sep 2006) :
* replace int par nint, remplace 1-cld-eps par max(1-cld,eps)
*
*Object
* Calculation of longwave radiative transfer using absorption
* approximation. The finite cloud effect is properly considered
* with random and full overlap assumption. Cloud subgrid
* variability is included (based on Li, 2002 JAS p3302; Li and
* Barker JAS p3321).
*
*Arguments
*
* - Output -
* fu upward infrared flux
* fd downward infrared flux
* taucsg total scattering
* term1 surface albedo
* emisw
* scatbk backward scattering
* scatfw forward scattering
* scatsm internal scattering
* taum taum(1) a factor related to tau in zeta factor for
* linear source term; taum(2) the cumulated taum(1) for
* subgrid variability calculation
* xd the emission part in the downward flux transmission
* xu the emission part in the upward flux transmission
* (Li, 2002 JAS p3302)
* dtr direct transmission
* fx the same as fy but for the downward flux
* fy upward flux for pure clear portion (1) and pure cloud
* portion (2)
* fw a term for transfer within cldm
* s1 rmug
* c2
*
* - Intput -
* slwf input solar flux at model top level for each band
* tauci cloud optical depth for the infrared
* omci cloud single scattering albedo times optical depth
* gci cloud asymmetry factor times omci
* fl square of cloud asymmetry factor
* taual aerosol optical depth for the infrared
* taug gaseous optical depth for the infrared
* bf blackbody intensity integrated over each band at each
* level in units w / m^2 / sr. therefor a pi factor needed
* for flux
* bs the blackbody intensity at the surface.
* urbf u times the difference of log(bf) for two neighbor
* levels used for exponential source function
* dbf difference of bf for two neighbor levels used for
* linear source function
* em0 surface emission
* cldfrac cloud fraction
* cldm maximum portion in each cloud block, in which the exact
* solution for subgrid variability is applied li and
* Barker JAS p3321).
* anu nu factor for cloud subgrid variability
* nct the highest cloud top level for the longitude and
* latitude loop (ilg)
* ncd layer inside a cloud block accounted from cloud top
* ncu layer inside a cloud block accounted from cloud bottom
* ncum maximum loop number cloud vertical correlation accounted
* from lower level to higher level
* ncdm maximum loop number cloud vertical correlation accounted
* from higher level to lower level
*
**
c----------------------------------------------------------------------
c
c----------------------------------------------------------------------
c initialization for first layer. calculate the downward flux in
c the second layer
c combine the optical properties for the infrared,
c 1, aerosol + gas; 2, cloud + aerosol + gas.
c fd (fu) is down (upward) flux, fx (fy) is the incident flux
c above (below) the considered layer.
c gaussian integration and diffusivity factor, ru (li jas 2000)
c above maxc, exponential source function is used
c below maxc, linear source function is used
c----------------------------------------------------------------------
c
l1 = lev1
l2 = lev1 + 1
do 100 i = il1, il2
fd(i,1,lev1) = slwf(i)
fd(i,2,lev1) = slwf(i)
fx(i,1,lev1) = fd(i,1,lev1)
fx(i,2,lev1) = fd(i,2,lev1)
100 continue
c
do 120 k = l2, lev
km1 = k - 1
do 120 i = il1, il2
taul1(i,km1) = taual(i,km1) + taug(i,km1)
rtaul1(i,km1) = taul1(i,km1) * ru
dtr_vs(i,k-l2+1) = - rtaul1(i,km1)
120 continue
c
call vexp(dtr_vs,dtr_vs,(il2-il1+1)*(lev-l2+1))
c
do 150 k = l2, maxc
km1 = k - 1
do 125 i = il1, il2
dtr(i,1,km1) = dtr_vs(i,k-l2+1)
ubeta = urbf(i,km1) / (taul1(i,km1)+1.e-20)
epsd = ubeta + 1.0
epsu = ubeta - 1.0
c
if (abs(epsd) .gt. 0.001) then
xd(i,1,km1) = (bf(i,k) - bf(i,km1) *
1 dtr(i,1,km1)) / epsd
else
xd(i,1,km1) = rtaul1(i,km1)*bf(i,km1)*dtr(i,1,km1)
endif
c
if (abs(epsu) .gt. 0.001) then
xu(i,1,km1) = (bf(i,k) * dtr(i,1,km1) -
1 bf(i,km1)) / epsu
else
xu(i,1,km1) = rtaul1(i,km1)*bf(i,k)*dtr(i,1,km1)
endif
c
fd(i,1,k) = fd(i,1,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fd(i,2,k) = fd(i,2,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fx(i,1,k) = fd(i,2,k)
fx(i,2,k) = fd(i,2,k)
125 continue
150 continue
c
c----------------------------------------------------------------------
c add the layers downward from the second layer to the surface.
c determine the xu for the upward path.
c using exponential source function for clr flux calculation and
c also for all sky flux in cloud free layers.
c----------------------------------------------------------------------
c
if (maxc .lt. lev) then
do 250 k = maxc + 1, lev
km1 = k - 1
km2 = km1 - 1
do 225 i = il1, il2
dtr(i,1,km1) = dtr_vs(i,k-l2+1)
ubeta = urbf(i,km1)/(taul1(i,km1) + 1.e-20)
epsd = ubeta + 1.0
epsu = ubeta - 1.0
c
if (abs(epsd) .gt. 0.001) then
xd(i,1,km1) = (bf(i,k) - bf(i,km1) *
1 dtr(i,1,km1)) / epsd
else
xd(i,1,km1) = rtaul1(i,km1)*bf(i,km1)*dtr(i,1,km1)
endif
c
if (abs(epsu) .gt. 0.001) then
xu(i,1,km1) = (bf(i,k) * dtr(i,1,km1) -
1 bf(i,km1)) / epsu
else
xu(i,1,km1) = rtaul1(i,km1)*bf(i,k)*dtr(i,1,km1)
endif
c
fd(i,1,k) = fd(i,1,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
if (cldfrac(i,km1) .lt. cut) then
fd(i,2,k) = fd(i,2,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fx(i,1,k) = fd(i,2,k)
fx(i,2,k) = fd(i,2,k)
else
taul2 = tauci(i,km1) + taug(i,km1)
ssalb = omci(i,km1) / (taul2 + 1.e-20)
sf = ssalb * fl(i,km1)
ww = (ssalb - sf) / (1.0 - sf)
cow = 1.0 - ww
taum(i,1,km1) = (cow * taul2 * (1.0 - sf) +
1 taual(i,km1)) * ru
zeta = dbf(i,km1) / taum(i,1,km1)
tau2 = taum(i,1,km1) + taum(i,1,km1)
c
sanu = anu(i,km1)
xx = sanu / (sanu + taum(i,1,km1))
yy = sanu / (sanu + tau2)
c
if (sanu .le. 0.50) then
dtr(i,2,km1) = sqrt(xx)
dtr2 = sqrt(yy)
emisw(i,km1) = zeta * (sqrt(1.0 + tau2) - 1.0)
embk = 1.0 - sqrt(1.0 + tau2 + tau2)
else if (sanu .gt. 0.50 .and. sanu .le. 1.0) then
wt = 2.0 * sanu - 1.0
sx = sqrt(xx)
sy = sqrt(yy)
dtr(i,2,km1) = sx + (xx - sx) * wt
dtr2 = sy + (yy - sy) * wt
p1 = sqrt(1.0 + tau2) - 1.0
emisw(i,km1) = zeta * (p1 + (log(1.0 +
1 taum(i,1,km1)) - p1) * wt)
p2 = 1.0 - sqrt(1.0 + tau2 + tau2)
embk = p2 - (log(1.0 + tau2) + p2) * wt
else if (sanu .gt. 1.0 .and. sanu .le. 2.0) then
wt = sanu - 1.0
dtr(i,2,km1) = xx + (xx * xx - xx) * wt
dtr2 = yy + (yy * yy - yy) * wt
zz = sanu / (sanu - 1.0)
p1 = log(1.0 + taum(i,1,km1))
emisw(i,km1) = zeta * (p1 + (zz* (1.0 - xx) - p1)*
1 wt)
p2 = - log(1.0 + tau2)
embk = p2 + (zz * (yy - 1.0) - p2) * wt
else if (sanu .gt. 2.0 .and. sanu .le. 3.0) then
x2 = xx * xx
y2 = yy * yy
wt = sanu - 2.0
dtr(i,2,km1) = x2 + (xx * x2 - x2) * wt
dtr2 = y2 + (yy * y2 - y2) * wt
zz = sanu / (sanu - 1.0)
emisw(i,km1) = zz * zeta *
1 (1.0 - xx + (xx - x2) * wt)
embk = zz * (yy - 1.0 + (y2 - yy) * wt)
else if (sanu .gt. 3.0 .and. sanu .le. 4.0) then
x2 = xx * xx
y2 = yy * yy
x3 = x2 * xx
y3 = y2 * yy
wt = sanu - 3.0
dtr(i,2,km1) = x3 + (x2 * x2 - x3) * wt
dtr2 = y3 + (y2 * y2 - y3) * wt
zz = sanu / (sanu - 1.0)
emisw(i,km1) = zz * zeta *
1 (1.0 - x2 + (x2 - x3) * wt)
embk = zz * (y2 - 1.0 + (y3 - y2) * wt)
c
c----------------------------------------------------------------------
c for anu > 4, the inhomoeneity effect is very weak, for saving
c the integer anu is assumed. for anu > 20, homogenous is assumed
c----------------------------------------------------------------------
c
else if (sanu .gt. 4.0 .and. sanu .le. 20.0) then
nanu = nint(sanu)
dtr(i,2,km1) = xx ** nanu
dtr2 = yy ** nanu
zz = sanu / (sanu - 1.0)
emisw(i,km1) = zz* zeta * (1.0 - dtr(i,2,km1) /xx)
embk = zz* (dtr2 / yy - 1.0)
else
emisw(i,km1) = zeta * (1.0 - exp(- taum(i,1,km1)))
embk = (exp(- tau2) - 1.0)
endif
c
xd(i,2,km1) = bf(i,k) - bf(i,km1) *
1 dtr(i,2,km1) - emisw(i,km1)
xu(i,2,km1) = bf(i,km1) - bf(i,k) *
1 dtr(i,2,km1) + emisw(i,km1)
c
wgrcow = ww * gci(i,km1) / cow
taudtr = taum(i,1,km1) * dtr(i,2,km1)
c
scatfw(i,km1) = wgrcow * xx * taudtr
scatbk(i,km1) = 0.5 * wgrcow * (dtr2 - 1.0)
c
xx = wgrcow * (2.0 * emisw(i,km1) +
1 (0.5 * embk - taudtr) * zeta)
scatsm(i,1,km1) = - scatbk(i,km1) * bf(i,k) -
1 scatfw(i,km1) * bf(i,km1) - xx
scatsm(i,2,km1) = - scatbk(i,km1) * bf(i,km1) -
1 scatfw(i,km1) * bf(i,k) + xx
c
if (k .eq. l2) then
fx(i,1,k) = fx(i,1,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fx(i,2,k) = fx(i,2,km1) * dtr(i,2,km1) +
1 xd(i,2,km1)
else if (cldfrac(i,km1) .le. cldfrac(i,km2)) then
fx(i,1,k) = (fx(i,2,km1)+(1.0-cldfrac(i,km2)) /
1 max(1.0 - cldfrac(i,km1),1.e-10) *
2 (fx(i,1,km1) - fx(i,2,km1)) ) *
3 dtr(i,1,km1) + xd(i,1,km1)
fx(i,2,k) = fx(i,2,km1) * dtr(i,2,km1) +
1 xd(i,2,km1)
else if (cldfrac(i,km1) .gt. cldfrac(i,km2)) then
fx(i,1,k) = fx(i,1,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fx(i,2,k) = (fx(i,1,km1) +
1 cldfrac(i,km2) / cldfrac(i,km1) *
2 (fx(i,2,km1) - fx(i,1,km1))) *
3 dtr(i,2,km1) + xd(i,2,km1)
endif
c
fd(i,2,k) = fx(i,1,k) + cldfrac(i,km1) *
1 (fx(i,2,k) - fx(i,1,k))
endif
225 continue
250 continue
endif
c
c----------------------------------------------------------------------
c initialization for surface
c----------------------------------------------------------------------
c
k = lev - 1
do 300 i = il1, il2
fu(i,1,lev) = fd(i,1,lev) + em0(i) *
1 (bs(i) - fd(i,1,lev))
fy(i,1,lev) = fx(i,1,lev) + em0(i) *
1 (bs(i) - fx(i,1,lev))
fy(i,2,lev) = fx(i,2,lev) + em0(i) *
1 (bs(i) - fx(i,2,lev))
fu(i,2,lev) = fy(i,1,lev) + cldfrac(i,k) *
1 (fy(i,2,lev) - fy(i,1,lev))
fw(i,2,lev) = fy(i,2,lev)
c
c----------------------------------------------------------------------
c determining the upward flux for the first lay above surface
c----------------------------------------------------------------------
c
fu(i,1,k) = fu(i,1,lev) * dtr(i,1,k) +
1 xu(i,1,k)
c
if (cldfrac(i,k) .lt. cut) then
taucsg(i,k) = 0.0
fu(i,2,k) = fu(i,1,lev) * dtr(i,1,k) +
1 xu(i,1,k)
fy(i,1,k) = fu(i,2,k)
fy(i,2,k) = fu(i,2,k)
fw(i,2,k) = fu(i,2,k)
taum(i,2,k) = 0.0
else
taucsg(i,k) = scatbk(i,k) * fx(i,2,k) +
1 scatfw(i,k) * fy(i,2,lev) +
2 scatsm(i,2,k)
c
fy(i,1,k) = fy(i,1,lev) * dtr(i,1,k) +
1 xu(i,1,k)
fy(i,2,k) = fy(i,2,lev) * dtr(i,2,k) +
1 xu(i,2,k) + taucsg(i,k)
fu(i,2,k) = fy(i,1,k) + cldfrac(i,k) *
1 (fy(i,2,k) - fy(i,1,k))
fw(i,2,k) = fy(i,2,k)
taum(i,2,k) = taum(i,1,k)
endif
300 continue
c
c----------------------------------------------------------------------
c add the layers upward from the second layer to maxc
c scattering effect for upward path is included
c----------------------------------------------------------------------
c
do 450 k = lev - 2, maxc, - 1
kp1 = k + 1
kp2 = k + 2
do 400 i = il1, il2
if (k .ge. nct(i)) then
fu(i,1,k) = fu(i,1,kp1) * dtr(i,1,k) +
1 xu(i,1,k)
c
if (cldfrac(i,k) .lt. cut) then
fu(i,2,k) = fu(i,2,kp1) * dtr(i,1,k) +
1 xu(i,1,k)
fy(i,1,k) = fu(i,2,k)
fy(i,2,k) = fu(i,2,k)
fw(i,2,k) = fu(i,2,k)
taum(i,2,k) = 0.0
else
c
c----------------------------------------------------------------------
c fy(i,2,k) contains unperturbed + backward scattering effect +
c forward scattering effect + internal scattering effect
c (li and fu, jas 2000)
c----------------------------------------------------------------------
c
if (cldfrac(i,k) .le. cldfrac(i,kp1) .or.
1 cldfrac(i,k) - cldm(i,k) .lt. cut) then
c
fy(i,1,k) = ( fy(i,2,kp1)+(1.0-cldfrac(i,kp1)) /
1 max(1.0 - cldfrac(i,k),1.e-10) *
2 (fy(i,1,kp1) - fy(i,2,kp1)) ) *
3 dtr(i,1,k) + xu(i,1,k)
c2(i) = fy(i,2,kp1)
else
fy(i,1,k) = fy(i,1,kp1) * dtr(i,1,k) +
1 xu(i,1,k)
c2(i) = fy(i,1,kp1) +
1 (cldfrac(i,kp1) - cldm(i,kp1)) /
2 (cldfrac(i,k) - cldm(i,k)) *
3 (fy(i,2,kp1) - fy(i,1,kp1))
endif
c
bkins = scatbk(i,k) * fx(i,2,k) +
1 scatsm(i,2,k)
fy(i,2,k) = c2(i) * (dtr(i,2,k) + scatfw(i,k))+
1 xu(i,2,k) + bkins
taum(i,2,k) = taum(i,2,kp1) + taum(i,1,k)
s1(i) = 0.0
taucsg(i,k) = bkins + scatfw(i,k) * fy(i,2,kp1)
term1(i) = 0.0
c
if (ncu(i,k) .gt. 1) then
kx = k + ncu(i,k)
kxm = kx - 1
c
sanu = anu(i,kxm)
anutau = sanu / (sanu + taum(i,2,k))
if (sanu .le. 0.50) then
dtrgw = sqrt(anutau)
else if (sanu .gt. 0.50 .and. sanu .le. 1.0) then
xx = sqrt(anutau)
dtrgw = xx + 2.0 * (sanu - 0.50) *
1 (anutau - xx)
else if (sanu .gt. 1.0 .and. sanu .le. 2.0) then
dtrgw = anutau + (sanu - 1.0) * anutau *
1 (anutau - 1.0)
else if (sanu .gt. 2.0 .and. sanu .le. 3.0) then
xx = anutau * anutau
dtrgw = xx + (sanu - 2.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 3.0 .and. sanu .le. 4.0) then
xx = anutau * anutau * anutau
dtrgw = xx + (sanu - 3.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 4.0 .and. sanu .le. 20.0) then
dtrgw = anutau ** (nint(sanu))
else
dtrgw = exp(- taum(i,2,k))
endif
c
term1(i) = (fw(i,2,kx) - bf(i,kx)) * dtrgw
s1(i) = (emisw(i,kp1) + taucsg(i,kp1)) *
1 dtr(i,2,k)
endif
endif
endif
400 continue
c
c----------------------------------------------------------------------
c determining the terms going into the correlation calculations
c for subgrid variability for cldm portion.
c----------------------------------------------------------------------
c
if (ncum(k) .gt. 2) then
do 420 kk = kp2, k + ncum(k) - 1
do 420 i = il1, il2
if (k .ge. nct(i) .and. cldfrac(i,k) .ge. cut .and.
1 ncu(i,k) .gt. 2 .and. kk .le. k + ncu(i,k) - 1) then
c
sanu = anu(i,kk)
anutau = sanu / (sanu +
1 taum(i,2,k) - taum(i,2,kk))
if (sanu .le. 0.50) then
dtrgw = sqrt(anutau)
else if (sanu .gt. 0.50 .and. sanu .le. 1.0) then
xx = sqrt(anutau)
dtrgw = xx + 2.0 * (sanu - 0.50) *
1 (anutau - xx)
else if (sanu .gt. 1.0 .and. sanu .le. 2.0) then
dtrgw = anutau + (sanu - 1.0) * anutau *
1 (anutau - 1.0)
else if (sanu .gt. 2.0 .and. sanu .le. 3.0) then
xx = anutau * anutau
dtrgw = xx + (sanu - 2.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 3.0 .and. sanu .le. 4.0) then
xx = anutau * anutau * anutau
dtrgw = xx + (sanu - 3.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 4.0 .and. sanu .le. 20.0) then
dtrgw = anutau ** (nint(sanu))
else
dtrgw = exp(- taum(i,2,kk) + taum(i,2,kk))
endif
c
s1(i) = s1(i) +
1 (emisw(i,kk) + taucsg(i,kk)) * dtrgw
endif
420 continue
endif
c
c----------------------------------------------------------------------
c in cldm region consider the correlation between different layers
c----------------------------------------------------------------------
c
do 430 i = il1, il2
if (k .ge. nct(i)) then
if (cldfrac(i,k) .ge. cut) then
if (ncu(i,k) .eq. 1) then
fw(i,2,k) = fy(i,2,k)
fu(i,2,k) = fy(i,1,k)+cldfrac(i,k)*(fy(i,2,k) -
1 fy(i,1,k))
else
fw(i,2,k) = term1(i) + s1(i) + bf(i,k) +
1 emisw(i,k) + taucsg(i,k)
fu(i,2,k) = cldm(i,k) * (fw(i,2,k) -
1 fy(i,2,k)) + fy(i,1,k) +
2 cldfrac(i,k)*(fy(i,2,k)-fy(i,1,k))
endif
endif
endif
430 continue
450 continue
c
c----------------------------------------------------------------------
c add the layers upward above the highest cloud to the toa, no
c scattering
c----------------------------------------------------------------------
c
do 550 k = lev - 1, l1, - 1
kp1 = k + 1
c
do 500 i = il1, il2
if (kp1 .le. nct(i)) then
fu(i,1,k) = fu(i,1,kp1) * dtr(i,1,k) +
1 xu(i,1,k)
fu(i,2,k) = fu(i,2,kp1) * dtr(i,1,k) +
1 xu(i,1,k)
endif
c
c----------------------------------------------------------------------
c scattering effect for downward path at the top layer of the
c highest cloud
c----------------------------------------------------------------------
c
if (k .eq. nct(i)) then
fw(i,1,k) = fx(i,1,k)
fwins = scatsm(i,1,k) +
1 scatfw(i,k) * fx(i,2,k)
fmbk = fx(i,2,k) * dtr(i,2,k) +
1 xd(i,2,k) + fwins
fx(i,2,kp1) = fmbk + scatbk(i,k) * fy(i,2,kp1)
taum(i,2,k) = taum(i,1,k)
taucsg(i,k) = scatbk(i,k) * fw(i,2,kp1) + fwins
c
fw(i,1,kp1) = fmbk + scatbk(i,k) * fw(i,2,kp1)
fd(i,2,kp1) = fx(i,1,kp1) + cldfrac(i,k) *
1 (fx(i,2,kp1) - fx(i,1,kp1))
endif
500 continue
550 continue
c
c----------------------------------------------------------------------
c scattering effect for downward path in from maxc to the surface
c----------------------------------------------------------------------
c
do 750 k = maxc + 2, lev
km1 = k - 1
km2 = k - 2
km3 = k - 3
do 700 i = il1, il2
if (km2 .ge. nct(i)) then
if (cldfrac(i,km1) .lt. cut) then
fd(i,2,k) = fd(i,2,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
fx(i,1,k) = fd(i,2,k)
fx(i,2,k) = fd(i,2,k)
fw(i,1,k) = fd(i,2,k)
taum(i,2,km1) = 0.0
else
if (cldfrac(i,km1) .le. cldfrac(i,km2) .or.
1 cldfrac(i,km1) - cldm(i,km1) .lt. cut) then
c
fx(i,1,k) = (fx(i,2,km1)+(1.0-cldfrac(i,km2)) /
1 max(1.0 - cldfrac(i,km1),1.e-10) *
2 (fx(i,1,km1) - fx(i,2,km1))) *
3 dtr(i,1,km1) + xd(i,1,km1)
c2(i) = fx(i,2,km1)
else
fx(i,1,k) = fx(i,1,km1) * dtr(i,1,km1) +
1 xd(i,1,km1)
c2(i) = fx(i,1,km1) +
1 (cldfrac(i,km2) - cldm(i,km2)) /
2 (cldfrac(i,km1) - cldm(i,km1)) *
3 (fx(i,2,km1) - fx(i,1,km1))
endif
c
fx(i,2,k) = c2(i) * dtr(i,2,km1) + xd(i,2,km1)+
1 scatbk(i,km1) * fy(i,2,k) +
2 scatfw(i,km1) * c2(i) +
3 scatsm(i,1,km1)
c
taum(i,2,km1) = taum(i,2,km2) + taum(i,1,km1)
s1(i) = 0.0
taucsg(i,km1) = scatbk(i,km1) * fw(i,2,k) +
1 scatfw(i,km1) * fw(i,1,km1) +
2 scatsm(i,1,km1)
term1(i) = 0.0
c
if (ncd(i,km1) .gt. 1) then
kx = k - ncd(i,km1)
sanu = anu(i,kx)
anutau = sanu / (sanu + taum(i,2,km1))
if (sanu .le. 0.50) then
dtrgw = sqrt(anutau)
else if (sanu .gt. 0.50 .and. sanu .le. 1.0) then
xx = sqrt(anutau)
dtrgw = xx + 2.0 * (sanu - 0.50) *
1 (anutau - xx)
else if (sanu .gt. 1.0 .and. sanu .le. 2.0) then
dtrgw = anutau + (sanu - 1.0) * anutau *
1 (anutau - 1.0)
else if (sanu .gt. 2.0 .and. sanu .le. 3.0) then
xx = anutau * anutau
dtrgw = xx + (sanu - 2.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 3.0 .and. sanu .le. 4.0) then
xx = anutau * anutau * anutau
dtrgw = xx + (sanu - 3.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 4.0 .and. sanu .le. 20.0) then
dtrgw = anutau ** (nint(sanu))
else
dtrgw = exp(- taum(i,2,km1))
endif
c
term1(i) = (fw(i,1,kx) - bf(i,kx)) * dtrgw
s1(i) = (taucsg(i,km2) - emisw(i,km2)) *
1 dtr(i,2,km1)
endif
endif
endif
700 continue
c
c----------------------------------------------------------------------
c determining the terms going into the correlation calculations
c for cldm portion.
c----------------------------------------------------------------------
c
if (ncdm(km1) .gt. 2) then
c
c----------------------------------------------------------------------
c note that in the following loop, "km1" is actually the
c representative variable, so that k-ncd(i,km1) is actually
c km1-ncd(i,km1)+1. the simpler form is used only for
c computational efficiency.
c----------------------------------------------------------------------
c
do 720 kk = km3, k - ncdm(km1), - 1
do 720 i = il1, il2
if (km2 .ge. nct(i) .and. cldfrac(i,km1) .ge. cut .and.
1 ncd(i,km1) .gt. 2 .and. kk .ge. k - ncd(i,km1)) then
c
sanu = anu(i,kk)
anutau = sanu / (sanu +
1 taum(i,2,km1) - taum(i,2,kk))
if (sanu .le. 0.50) then
dtrgw = sqrt(anutau)
else if (sanu .gt. 0.50 .and. sanu .le. 1.0) then
xx = sqrt(anutau)
dtrgw = xx + 2.0 * (sanu - 0.50) *
1 (anutau - xx)
else if (sanu .gt. 1.0 .and. sanu .le. 2.0) then
dtrgw = anutau + (sanu - 1.0) * anutau *
1 (anutau - 1.0)
else if (sanu .gt. 2.0 .and. sanu .le. 3.0) then
xx = anutau * anutau
dtrgw = xx + (sanu - 2.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 3.0 .and. sanu .le. 4.0) then
xx = anutau * anutau * anutau
dtrgw = xx + (sanu - 3.0) * xx *
1 (anutau - 1.0)
else if (sanu .gt. 4.0 .and. sanu .le. 20.0) then
dtrgw = anutau ** (nint(sanu))
else
dtrgw = exp(- taum(i,2,km1) + taum(i,2,kk))
endif
c
s1(i) = s1(i) -
1 (emisw(i,kk) - taucsg(i,kk)) * dtrgw
endif
720 continue
endif
c
do 730 i = il1, il2
if (km2 .ge. nct(i)) then
if (cldfrac(i,km1) .ge. cut) then
if (ncd(i,km1) .eq. 1) then
fw(i,1,k) = fx(i,2,k)
fd(i,2,k) = fx(i,1,k) + cldfrac(i,km1) *
1 (fx(i,2,k) - fx(i,1,k))
else
fw(i,1,k) = term1(i) + s1(i) + bf(i,k) -
1 emisw(i,km1) + taucsg(i,km1)
fd(i,2,k) = cldm(i,km1) *
1 (fw(i,1,k) - fx(i,2,k)) +
2 fx(i,1,k) + cldfrac(i,km1) *
3 (fx(i,2,k) - fx(i,1,k))
endif
endif
endif
730 continue
750 continue
c
return
end