278 module module_radlw_main
286 use mersenne_twister
, only : random_setseed, random_number, &
299 character(40),
parameter :: &
300 & VTAGLW=
'NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 '
310 real (kind=kind_phys),
parameter :: eps = 1.0e-6
311 real (kind=kind_phys),
parameter :: oneminus= 1.0-eps
312 real (kind=kind_phys),
parameter :: cldmin = 1.0e-80
313 real (kind=kind_phys),
parameter :: bpade = 1.0/0.278
314 real (kind=kind_phys),
parameter :: stpfac = 296.0/1013.0
315 real (kind=kind_phys),
parameter :: wtdiff = 0.5
316 real (kind=kind_phys),
parameter :: tblint =
ntbl
317 real (kind=kind_phys),
parameter :: f_zero = 0.0
318 real (kind=kind_phys),
parameter :: f_one = 1.0
325 integer,
dimension(nbands) :: nspa, nspb
327 data nspa / 1, 1, 9, 9, 9, 1, 9, 1, 9, 1, 1, 9, 9, 1, 9, 9 /
328 data nspb / 1, 1, 5, 5, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0 /
348 real (kind=kind_phys),
dimension(nbands) :: a0, a1, a2
350 data a0 / 1.66, 1.55, 1.58, 1.66, 1.54, 1.454, 1.89, 1.33,
352 data a1 / 0.00, 0.25, 0.22, 0.00, 0.13, 0.446, -0.10, 0.40,
354 data a2 / 0.00, -12.0, -11.7, 0.00, -0.72,-0.243, 0.19,-0.062,
359 logical :: lhlwb = .false.
360 logical :: lhlw0 = .false.
361 logical :: lflxprf= .false.
369 real (kind=kind_phys) :: fluxfac, heatfac, semiss0(
nbands)
370 data semiss0(:) /
nbands*1.0 /
372 real (kind=kind_phys) :: tau_tbl(0:
ntbl)
373 real (kind=kind_phys) :: exp_tbl(0:
ntbl)
374 real (kind=kind_phys) :: tfn_tbl(0:
ntbl)
381 integer,
parameter :: ipsdlw0 =
ngptlw
456 & clouds,icseed,aerosols,sfemis,sfgtmp,
634 integer,
intent(in) :: npts, nlay, nlp1
635 integer,
intent(in) :: icseed(npts)
637 logical,
intent(in) :: lprnt
639 real (kind=kind_phys),
dimension(npts,nlp1),
intent(in) :: plvl, &
641 real (kind=kind_phys),
dimension(npts,nlay),
intent(in) :: plyr, &
644 real (kind=kind_phys),
dimension(npts,nlay,9),
intent(in):: gasvmr
645 real (kind=kind_phys),
dimension(npts,nlay,9),
intent(in):: clouds
647 real (kind=kind_phys),
dimension(npts),
intent(in) :: sfemis, &
650 real (kind=kind_phys),
dimension(npts,nlay,nbands,3),
intent(in):: &
654 real (kind=kind_phys),
dimension(npts,nlay),
intent(out) :: hlwc
656 type(
topflw_type),
dimension(npts),
intent(out) :: topflx
657 type(
sfcflw_type),
dimension(npts),
intent(out) :: sfcflx
660 real (kind=kind_phys),
dimension(npts,nlay,nbands),
optional, &
661 & intent(out) :: hlwb
662 real (kind=kind_phys),
dimension(npts,nlay),
optional, &
663 & intent(out) :: hlw0
664 type (
proflw_type),
dimension(npts,nlp1),
optional, &
665 & intent(out) :: flxprf
668 real (kind=kind_phys),
dimension(0:nlp1) :: cldfrc
670 real (kind=kind_phys),
dimension(0:nlay) :: totuflux, totdflux, &
671 & totuclfl, totdclfl, tz
673 real (kind=kind_phys),
dimension(nlay) :: htr, htrcl
675 real (kind=kind_phys),
dimension(nlay) :: pavel, tavel, delp, &
676 & clwp, ciwp, relw, reiw, cda1, cda2, cda3, cda4,
681 real (kind=kind_phys),
dimension(nbands,0:nlay) :: pklev, pklay
683 real (kind=kind_phys),
dimension(nlay,nbands) :: htrb
684 real (kind=kind_phys),
dimension(nbands,nlay) :: taucld, tauaer
685 real (kind=kind_phys),
dimension(ngptlw,nlay) :: fracs, tautot, &
688 real (kind=kind_phys),
dimension(nbands) :: semiss, secdiff
692 real (kind=kind_phys) :: colamt(nlay,
maxgas)
696 real (kind=kind_phys) :: wx(nlay,
maxxsec)
700 real (kind=kind_phys) :: rfrate(nlay,
nrates,2)
702 real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp
704 integer,
dimension(npts) :: ipseed
705 integer,
dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor
706 integer :: laytrop, iplon, i, j, k, k1
715 lhlwb =
present ( hlwb )
716 lhlw0 =
present ( hlw0 )
717 lflxprf=
present ( flxprf )
727 ipseed(i) = ipsdlw0 + i
731 ipseed(i) = icseed(i)
742 lab_do_iplon :
do iplon = 1, npts
745 if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0)
then
747 semiss(j) = sfemis(iplon)
751 semiss(j) = semiss0(j)
755 stemp = sfgtmp(iplon)
770 tz(0) = tlvl(iplon,nlp1)
774 pavel(k)= plyr(iplon,k1)
775 delp(k) = plvl(iplon,k1+1) - plvl(iplon,k1)
776 tavel(k)= tlyr(iplon,k1)
777 tz(k) = tlvl(iplon,k1)
786 h2ovmr(k)= max(f_zero,qlyr(iplon,k1)
788 o3vmr(k)= max(f_zero,olyr(iplon,k1)*amdo3)
792 coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k)))
793 temcol(k) = 1.0e-12 * coldry(k)
795 colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k))
796 colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k1,1))
797 colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k))
807 colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,2))
808 colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,3))
809 colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k1,4))
810 colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k1,5))
812 wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k1,9) )
813 wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k1,6) )
814 wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k1,7) )
815 wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k1,8) )
836 tauaer(j,k) = aerosols(iplon,k1,j,1)
845 cldfrc(k)= clouds(iplon,k1,1)
846 clwp(k) = clouds(iplon,k1,2)
847 relw(k) = clouds(iplon,k1,3)
848 ciwp(k) = clouds(iplon,k1,4)
849 reiw(k) = clouds(iplon,k1,5)
850 cda1(k) = clouds(iplon,k1,6)
851 cda2(k) = clouds(iplon,k1,7)
852 cda3(k) = clouds(iplon,k1,8)
853 cda4(k) = clouds(iplon,k1,9)
858 cldfrc(k)= clouds(iplon,k1,1)
859 cda1(k) = clouds(iplon,k1,2)
864 cldfrc(nlp1) = f_zero
871 tem1 = tem1 + coldry(k) + colamt(k,1)
872 tem2 = tem2 + colamt(k,1)
875 tem0 = 10.0 * tem2 / (amdw * tem1 *
con_g)
876 pwvcm = tem0 * plvl(iplon,nlp1)
882 tz(0) = tlvl(iplon,1)
885 pavel(k)= plyr(iplon,k)
886 delp(k) = plvl(iplon,k) - plvl(iplon,k+1)
887 tavel(k)= tlyr(iplon,k)
888 tz(k) = tlvl(iplon,k+1)
896 h2ovmr(k)= max(f_zero,qlyr(iplon,k)
898 o3vmr(k)= max(f_zero,olyr(iplon,k)*amdo3)
902 coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k)))
903 temcol(k) = 1.0e-12 * coldry(k)
905 colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k))
906 colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k,1))
907 colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k))
915 colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k,2))
916 colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k,3))
917 colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k,4))
918 colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k,5))
920 wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k,9) )
921 wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k,6) )
922 wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k,7) )
923 wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k,8) )
943 tauaer(j,k) = aerosols(iplon,k,j,1)
950 cldfrc(k)= clouds(iplon,k,1)
951 clwp(k) = clouds(iplon,k,2)
952 relw(k) = clouds(iplon,k,3)
953 ciwp(k) = clouds(iplon,k,4)
954 reiw(k) = clouds(iplon,k,5)
955 cda1(k) = clouds(iplon,k,6)
956 cda2(k) = clouds(iplon,k,7)
957 cda3(k) = clouds(iplon,k,8)
958 cda4(k) = clouds(iplon,k,9)
962 cldfrc(k)= clouds(iplon,k,1)
963 cda1(k) = clouds(iplon,k,2)
968 cldfrc(nlp1) = f_zero
975 tem1 = tem1 + coldry(k) + colamt(k,1)
976 tem2 = tem2 + colamt(k,1)
979 tem0 = 10.0 * tem2 / (amdw * tem1 *
con_g)
980 pwvcm = tem0 * plvl(iplon,1)
989 summol = summol + colamt(k,i)
991 colbrd(k) = coldry(k) - summol
999 if (j==1 .or. j==4 .or. j==10)
then
1002 secdiff(j) = min( tem1, max( tem2,
1026 lab_do_k0 :
do k = 1, nlay
1027 if ( cldfrc(k) > eps )
then
1037 & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4,
1062 & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd,
1065 & laytrop,pklay,pklev,jp,jt,jt1,
1098 & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer,
1136 & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev,
1139 & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb
1146 & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev,
1149 & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb
1158 & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev,
1161 & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb
1168 topflx(iplon)%upfxc = totuflux(nlay)
1169 topflx(iplon)%upfx0 = totuclfl(nlay)
1171 sfcflx(iplon)%upfxc = totuflux(0)
1172 sfcflx(iplon)%upfx0 = totuclfl(0)
1173 sfcflx(iplon)%dnfxc = totdflux(0)
1174 sfcflx(iplon)%dnfx0 = totdclfl(0)
1182 flxprf(iplon,k1)%upfxc = totuflux(k)
1183 flxprf(iplon,k1)%dnfxc = totdflux(k)
1184 flxprf(iplon,k1)%upfx0 = totuclfl(k)
1185 flxprf(iplon,k1)%dnfx0 = totdclfl(k)
1191 hlwc(iplon,k1) = htr(k)
1198 hlw0(iplon,k1) = htrcl(k)
1207 hlwb(iplon,k1,j) = htrb(k,j)
1217 flxprf(iplon,k+1)%upfxc = totuflux(k)
1218 flxprf(iplon,k+1)%dnfxc = totdflux(k)
1219 flxprf(iplon,k+1)%upfx0 = totuclfl(k)
1220 flxprf(iplon,k+1)%dnfx0 = totdclfl(k)
1225 hlwc(iplon,k) = htr(k)
1231 hlw0(iplon,k) = htrcl(k)
1239 hlwb(iplon,k,j) = htrb(k,j)
1249 end subroutine lwrad
1329 integer,
intent(in) :: me
1334 real (kind=kind_phys),
parameter :: expeps = 1.e-20
1336 real (kind=kind_phys) :: tfn, pival, explimit
1344 print *,
' *** Error in specification of cloud overlap flag',
1345 ' IOVRLW=',
iovrlw,
' in RLWINIT !!'
1349 print *,
' *** IOVRLW=2 - maximum cloud overlap, is not yet',
1350 ' available for ISUBCLW=0 setting!!'
1351 print *,
' The program uses maximum/random overlap',
1359 print *,
' - Using AER Longwave Radiation, Version: ', vtaglw
1362 print *,
' --- Include rare gases N2O, CH4, O2, CFCs ',
1365 print *,
' --- Rare gases effect is NOT included in LW'
1369 print *,
' --- Using standard grid average clouds, no ',
1370 'sub-column clouds approximation applied'
1372 print *,
' --- Using MCICA sub-colum clouds approximation ',
1373 'with a prescribed sequence of permutaion seeds'
1375 print *,
' --- Using MCICA sub-colum clouds approximation ',
1376 'with provided input array of permutation seeds'
1378 print *,
' *** Error in specification of sub-column cloud ',
1379 ' control flag isubclw =',
isubclw,
' !!'
1388 print *,
' *** Model cloud scheme inconsistent with LW',
1389 ' radiation cloud radiative property setup !!'
1400 pival = 2.0 * asin(f_one)
1401 fluxfac = pival * 2.0d4
1427 tau_tbl(
ntbl) = 1.e10
1428 exp_tbl(
ntbl) = expeps
1429 tfn_tbl(
ntbl) = f_one
1431 explimit = aint( -log(tiny(exp_tbl(0))) )
1436 tfn =
real(i, kind_phys) /
real(
ntbl-i, kind_phys)
1437 tau_tbl(i) = bpade * tfn
1438 if (tau_tbl(i) >= explimit)
then
1441 exp_tbl(i) = exp( -tau_tbl(i) )
1444 if (tau_tbl(i) < 0.06)
then
1445 tfn_tbl(i) = tau_tbl(i) / 6.0
1447 tfn_tbl(i) = f_one - 2.0*( (f_one / tau_tbl(i))
1488 & nlay, nlp1, ipseed,
1586 integer,
intent(in) :: nlay, nlp1, ipseed
1588 real (kind=kind_phys),
dimension(0:nlp1),
intent(in) :: cfrac
1589 real (kind=kind_phys),
dimension(nlay),
intent(in) :: cliqp, &
1590 & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4
1593 real (kind=kind_phys),
dimension(ngptlw,nlay),
intent(out):: cldfmc
1594 real (kind=kind_phys),
dimension(nbands,nlay),
intent(out):: taucld
1597 real (kind=kind_phys),
dimension(nbands) :: tauliq, tauice
1598 real (kind=kind_phys),
dimension(nlay) :: cldf
1600 real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, &
1601 & cldliq, refliq, cldice, refice
1603 logical :: lcloudy(
ngptlw,nlay)
1604 integer :: ia, ib, ig, k, index
1611 taucld(ib,k) = f_zero
1617 cldfmc(ig,k) = f_zero
1630 lab_if_ilwcliq :
if (
ilwcliq > 0)
then
1632 lab_do_k :
do k = 1, nlay
1633 lab_if_cld :
if (cfrac(k) > cldmin)
then
1643 if (cdat3(k)>f_zero .and. cdat4(k)>10.0_kind_phys)
then
1644 tausnw =
abssnow0*1.05756*cdat3(k)/cdat4(k)
1658 if ( cldliq <= f_zero )
then
1665 factor = refliq - 1.5
1666 index = max( 1, min( 57, int( factor ) ))
1667 fint = factor - float(index)
1670 tauliq(ib) = max(f_zero, cldliq*(
absliq1(index,ib)
1678 if ( cldice <= f_zero )
then
1688 refice = min(130.0, max(13.0,
real(refice) ))
1692 tauice(ib) = max(f_zero, cldice*(
absice1(1,ia)
1702 factor = (refice - 2.0) / 3.0
1703 index = max( 1, min( 42, int( factor ) ))
1704 fint = factor - float(index)
1707 tauice(ib) = max(f_zero, cldice*(
absice2(index,ib)
1717 dgeice = max(5.0, 1.0315*refice)
1718 factor = (dgeice - 2.0) / 3.0
1719 index = max( 1, min( 45, int( factor ) ))
1720 fint = factor - float(index)
1723 tauice(ib) = max(f_zero, cldice*(
absice3(index,ib)
1731 taucld(ib,k) = tauice(ib) + tauliq(ib) + tauran + tausnw
1740 if (cfrac(k) > cldmin)
then
1742 taucld(ib,k) = cdat1(k)
1747 endif lab_if_ilwcliq
1754 if ( cfrac(k) < cldmin )
then
1765 & ( cldf, nlay, ipseed,
1772 if ( lcloudy(ig,k) )
then
1773 cldfmc(ig,k) = f_one
1775 cldfmc(ig,k) = f_zero
1821 integer,
intent(in) :: nlay, ipseed
1823 real (kind=kind_phys),
dimension(nlay),
intent(in) :: cldf
1826 logical,
dimension(ngptlw,nlay),
intent(out) :: lcloudy
1829 real (kind=kind_phys) :: cdfunc(
ngptlw,nlay), rand1d(
ngptlw), &
1830 & rand2d(nlay*ngptlw), tem1
1832 type(random_stat) :: stat
1862 cdfunc(n,k) = rand2d(k1)
1877 cdfunc(n,k) = rand2d(k1)
1889 tem1 = f_one - cldf(k1)
1892 if ( cdfunc(n,k1) > tem1 )
then
1893 cdfunc(n,k) = cdfunc(n,k1)
1895 cdfunc(n,k) = cdfunc(n,k) * tem1
1938 tem1 = f_one - cldf(k)
1941 lcloudy(n,k) = cdfunc(n,k) >= tem1
1994 & rfrate,fac00,fac01,fac10,fac11,
2052 integer,
intent(in) :: nlay, nlp1
2054 real (kind=kind_phys),
dimension(nlay,maxgas),
intent(in):: colamt
2055 real (kind=kind_phys),
dimension(0:nlay),
intent(in):: tz
2057 real (kind=kind_phys),
dimension(nlay),
intent(in) :: pavel, &
2058 & tavel, h2ovmr, coldry, colbrd
2060 real (kind=kind_phys),
intent(in) :: stemp
2063 integer,
dimension(nlay),
intent(out) :: jp, jt, jt1, indself, &
2066 integer,
intent(out) :: laytrop
2068 real (kind=kind_phys),
dimension(nlay,nrates,2),
intent(out) :: &
2070 real (kind=kind_phys),
dimension(nbands,0:nlay),
intent(out) :: &
2073 real (kind=kind_phys),
dimension(nlay),
intent(out) :: &
2074 & fac00, fac01, fac10, fac11, selffac, selffrac, forfac,
2078 real (kind=kind_phys) :: tlvlfr, tlyrfr, plog, fp, ft, ft1, &
2081 integer :: i, k, jp1, indlev, indlay
2090 indlay = min(180, max(1, int(stemp-159.0) ))
2091 indlev = min(180, max(1, int(tz(0)-159.0) ))
2092 tlyrfr = stemp - int(stemp)
2093 tlvlfr = tz(0) - int(tz(0))
2097 pklay(i,0) = delwave(i) * (
totplnk(indlay,i) + tlyrfr*tem1)
2098 pklev(i,0) = delwave(i) * (
totplnk(indlev,i) + tlvlfr*tem2)
2109 indlay = min(180, max(1, int(tavel(k)-159.0) ))
2110 tlyrfr = tavel(k) - int(tavel(k))
2112 indlev = min(180, max(1, int(tz(k)-159.0) ))
2113 tlvlfr = tz(k) - int(tz(k))
2118 pklay(i,k) = delwave(i) * (
totplnk(indlay,i) + tlyrfr
2129 plog = log(pavel(k))
2130 jp(k)= max(1, min(58, int(36.0 - 5.0*(plog+0.04)) ))
2133 fp = max(f_zero, min(f_one, 5.0*(preflog(jp(k))-plog) ))
2144 tem1 = (tavel(k)-tref(jp(k))) / 15.0
2145 tem2 = (tavel(k)-tref(jp1 )) / 15.0
2146 jt(k) = max(1, min(4, int(3.0 + tem1) ))
2147 jt1(k) = max(1, min(4, int(3.0 + tem2) ))
2149 ft = max(-0.5, min(1.5, tem1 - float(jt(k) - 3) ))
2150 ft1 = max(-0.5, min(1.5, tem2 - float(jt1(k) - 3) ))
2162 fac10(k) = tem1 * ft
2163 fac00(k) = tem1 * (f_one - ft)
2165 fac01(k) = fp * (f_one - ft1)
2167 forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k)))
2168 selffac(k) = h2ovmr(k) * forfac(k)
2173 scaleminor(k) = pavel(k) / tavel(k)
2174 scaleminorn2(k) = (pavel(k) / tavel(k))
2183 if (plog > 4.56)
then
2185 laytrop = laytrop + 1
2187 tem1 = (332.0 - tavel(k)) / 36.0
2188 indfor(k) = min(2, max(1, int(tem1)))
2189 forfrac(k) = tem1 - float(indfor(k))
2194 tem1 = (tavel(k) - 188.0) / 7.2
2195 indself(k) = min(9, max(1, int(tem1)-7))
2196 selffrac(k) = tem1 - float(indself(k) + 7)
2201 rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k))
2202 rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1)
2204 rfrate(k,2,1) = chi_mls(1,jp(k)) / chi_mls(3,jp(k))
2205 rfrate(k,2,2) = chi_mls(1,jp(k)+1) / chi_mls(3,jp(k)+1)
2207 rfrate(k,3,1) = chi_mls(1,jp(k)) / chi_mls(4,jp(k))
2208 rfrate(k,3,2) = chi_mls(1,jp(k)+1) / chi_mls(4,jp(k)+1)
2210 rfrate(k,4,1) = chi_mls(1,jp(k)) / chi_mls(6,jp(k))
2211 rfrate(k,4,2) = chi_mls(1,jp(k)+1) / chi_mls(6,jp(k)+1)
2213 rfrate(k,5,1) = chi_mls(4,jp(k)) / chi_mls(2,jp(k))
2214 rfrate(k,5,2) = chi_mls(4,jp(k)+1) / chi_mls(2,jp(k)+1)
2218 tem1 = (tavel(k) - 188.0) / 36.0
2220 forfrac(k) = tem1 - f_one
2223 selffrac(k) = f_zero
2228 rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k))
2229 rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1)
2231 rfrate(k,6,1) = chi_mls(3,jp(k)) / chi_mls(2,jp(k))
2232 rfrate(k,6,2) = chi_mls(3,jp(k)+1) / chi_mls(2,jp(k)+1)
2238 selffac(k) = colamt(k,1) * selffac(k)
2239 forfac(k) = colamt(k,1) * forfac(k)
2286 & fracs,secdif, nlay,nlp1,
2389 integer,
intent(in) :: nlay, nlp1
2391 real (kind=kind_phys),
dimension(0:nlp1),
intent(in) :: cldfrc
2392 real (kind=kind_phys),
dimension(nbands),
intent(in) :: semiss, &
2394 real (kind=kind_phys),
dimension(nlay),
intent(in) :: delp
2396 real (kind=kind_phys),
dimension(nbands,nlay),
intent(in):: taucld
2397 real (kind=kind_phys),
dimension(ngptlw,nlay),
intent(in):: fracs, &
2400 real (kind=kind_phys),
dimension(nbands,0:nlay),
intent(in) :: &
2404 real (kind=kind_phys),
dimension(nlay),
intent(out) :: htr, htrcl
2406 real (kind=kind_phys),
dimension(nlay,nbands),
intent(out) :: htrb
2408 real (kind=kind_phys),
dimension(0:nlay),
intent(out) :: &
2409 & totuflux, totdflux, totuclfl, totdclfl
2412 real (kind=kind_phys),
parameter :: rec_6 = 0.166667
2414 real (kind=kind_phys),
dimension(0:nlay,nbands) :: clrurad, &
2415 & clrdrad, toturad, totdrad
2417 real (kind=kind_phys),
dimension(nlay) :: gassrcu, totsrcu, &
2418 & trngas, efclrfr, rfdelp
2419 real (kind=kind_phys),
dimension(0:nlay) :: fnet, fnetc
2421 real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
2422 & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac,
2427 integer :: ittot, itgas, ib, ig, k
2433 toturad(k,ib) = f_zero
2434 totdrad(k,ib) = f_zero
2435 clrurad(k,ib) = f_zero
2436 clrdrad(k,ib) = f_zero
2441 totuflux(k) = f_zero
2442 totdflux(k) = f_zero
2443 totuclfl(k) = f_zero
2444 totdclfl(k) = f_zero
2461 odepth = max( f_zero, secdif(ib)*tautot(ig,k) )
2462 if (odepth <= 0.06)
then
2463 atrgas = odepth - 0.5*odepth*odepth
2464 trng = f_one - atrgas
2465 gasfac = rec_6 * odepth
2467 tblind = odepth / (bpade + odepth)
2468 itgas = tblint*tblind + 0.5
2469 trng = exp_tbl(itgas)
2470 atrgas = f_one - trng
2471 gasfac = tfn_tbl(itgas)
2472 odepth = tau_tbl(itgas)
2475 plfrac = fracs(ig,k)
2478 dplnku = pklev(ib,k ) - blay
2479 dplnkd = pklev(ib,k-1) - blay
2480 bbdgas = plfrac * (blay + dplnkd*gasfac)
2481 bbugas = plfrac * (blay + dplnku*gasfac)
2482 gassrcd= bbdgas * atrgas
2483 gassrcu(k)= bbugas * atrgas
2489 if (clfr >= eps)
then
2492 odcld = secdif(ib) * taucld(ib,k)
2493 efclrfr(k) = f_one-(f_one - exp(-odcld))*clfr
2494 odtot = odepth + odcld
2495 if (odtot < 0.06)
then
2496 totfac = rec_6 * odtot
2497 atrtot = odtot - 0.5*odtot*odtot
2499 tblind = odtot / (bpade + odtot)
2500 ittot = tblint*tblind + 0.5
2501 totfac = tfn_tbl(ittot)
2502 atrtot = f_one - exp_tbl(ittot)
2505 bbdtot = plfrac * (blay + dplnkd*totfac)
2506 bbutot = plfrac * (blay + dplnku*totfac)
2507 totsrcd= bbdtot * atrtot
2508 totsrcu(k)= bbutot * atrtot
2511 radtotd = radtotd*trng*efclrfr(k) + gassrcd
2516 radclrd = radclrd*trng + gassrcd
2517 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
2523 radtotd = radtotd*trng + gassrcd
2524 totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
2527 radclrd = radclrd*trng + gassrcd
2528 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
2541 reflct = f_one - semiss(ib)
2542 rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
2545 radtotu = rad0 + reflct*radtotd
2546 toturad(0,ib) = toturad(0,ib) + radtotu
2549 radclru = rad0 + reflct*radclrd
2550 clrurad(0,ib) = clrurad(0,ib) + radclru
2559 if (clfr >= eps)
then
2563 radtotu = radtotu*trng*efclrfr(k) + gasu
2568 radclru = radclru*trng + gasu
2569 clrurad(k,ib) = clrurad(k,ib) + radclru
2575 radtotu = radtotu*trng + gasu
2576 toturad(k,ib) = toturad(k,ib) + radtotu
2579 radclru = radclru*trng + gasu
2580 clrurad(k,ib) = clrurad(k,ib) + radclru
2591 flxfac = wtdiff * fluxfac
2595 totuflux(k) = totuflux(k) + toturad(k,ib)
2596 totdflux(k) = totdflux(k) + totdrad(k,ib)
2597 totuclfl(k) = totuclfl(k) + clrurad(k,ib)
2598 totdclfl(k) = totdclfl(k) + clrdrad(k,ib)
2601 totuflux(k) = totuflux(k) * flxfac
2602 totdflux(k) = totdflux(k) * flxfac
2603 totuclfl(k) = totuclfl(k) * flxfac
2604 totdclfl(k) = totdclfl(k) * flxfac
2608 fnet(0) = totuflux(0) - totdflux(0)
2611 rfdelp(k) = heatfac / delp(k)
2612 fnet(k) = totuflux(k) - totdflux(k)
2613 htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
2618 fnetc(0) = totuclfl(0) - totdclfl(0)
2621 fnetc(k) = totuclfl(k) - totdclfl(k)
2622 htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
2629 fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
2632 fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
2633 htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
2669 & fracs,secdif, nlay,nlp1,
2771 integer,
intent(in) :: nlay, nlp1
2773 real (kind=kind_phys),
dimension(0:nlp1),
intent(in) :: cldfrc
2774 real (kind=kind_phys),
dimension(nbands),
intent(in) :: semiss, &
2776 real (kind=kind_phys),
dimension(nlay),
intent(in) :: delp
2778 real (kind=kind_phys),
dimension(nbands,nlay),
intent(in):: taucld
2779 real (kind=kind_phys),
dimension(ngptlw,nlay),
intent(in):: fracs, &
2782 real (kind=kind_phys),
dimension(nbands,0:nlay),
intent(in) :: &
2786 real (kind=kind_phys),
dimension(nlay),
intent(out) :: htr, htrcl
2788 real (kind=kind_phys),
dimension(nlay,nbands),
intent(out) :: htrb
2790 real (kind=kind_phys),
dimension(0:nlay),
intent(out) :: &
2791 & totuflux, totdflux, totuclfl, totdclfl
2794 real (kind=kind_phys),
parameter :: rec_6 = 0.166667
2796 real (kind=kind_phys),
dimension(0:nlay,nbands) :: clrurad, &
2797 & clrdrad, toturad, totdrad
2799 real (kind=kind_phys),
dimension(nlay) :: gassrcu, totsrcu, &
2800 & trngas, trntot, rfdelp
2801 real (kind=kind_phys),
dimension(0:nlay) :: fnet, fnetc
2803 real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
2804 & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac,
2810 integer :: ittot, itgas, ib, ig, k
2813 real (kind=kind_phys),
dimension(nlp1) :: faccld1u, faccld2u, &
2814 & facclr1u, facclr2u, faccmb1u, faccmb2u
2815 real (kind=kind_phys),
dimension(0:nlay) :: faccld1d, faccld2d, &
2816 & facclr1d, facclr2d, faccmb1d, faccmb2d
2818 logical :: lstcldu(nlay), lstcldd(nlay)
2823 faccld1u(k) = f_zero
2824 faccld2u(k) = f_zero
2825 facclr1u(k) = f_zero
2826 facclr2u(k) = f_zero
2827 faccmb1u(k) = f_zero
2828 faccmb2u(k) = f_zero
2831 lstcldu(1) = cldfrc(1) > eps
2837 lstcldu(k+1) = cldfrc(k+1)>eps .and. cldfrc(k)<=eps
2839 if (cldfrc(k) > eps)
then
2843 if (cldfrc(k+1) >= cldfrc(k))
then
2844 if (lstcldu(k))
then
2845 if (cldfrc(k) < f_one)
then
2846 facclr2u(k+1) = (cldfrc(k+1) - cldfrc(k))
2849 facclr2u(k) = f_zero
2850 faccld2u(k) = f_zero
2852 fmax = max(cldfrc(k), cldfrc(k-1))
2853 if (cldfrc(k+1) > fmax)
then
2854 facclr1u(k+1) = rat2
2855 facclr2u(k+1) = (cldfrc(k+1) - fmax)/(f_one - fmax)
2856 elseif (cldfrc(k+1) < fmax)
then
2857 facclr1u(k+1) = (cldfrc(k+1) - cldfrc(k))
2860 facclr1u(k+1) = rat2
2864 if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero)
then
2872 if (lstcldu(k))
then
2873 faccld2u(k+1) = (cldfrc(k) - cldfrc(k+1)) / cldfrc(k)
2874 facclr2u(k) = f_zero
2875 faccld2u(k) = f_zero
2877 fmin = min(cldfrc(k), cldfrc(k-1))
2878 if (cldfrc(k+1) <= fmin)
then
2879 faccld1u(k+1) = rat1
2880 faccld2u(k+1) = (fmin - cldfrc(k+1)) / fmin
2882 faccld1u(k+1) = (cldfrc(k) - cldfrc(k+1))
2887 if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero)
then
2896 faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrc(k-1)
2897 faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k)
2904 faccld1d(k) = f_zero
2905 faccld2d(k) = f_zero
2906 facclr1d(k) = f_zero
2907 facclr2d(k) = f_zero
2908 faccmb1d(k) = f_zero
2909 faccmb2d(k) = f_zero
2912 lstcldd(nlay) = cldfrc(nlay) > eps
2918 lstcldd(k-1) = cldfrc(k-1) > eps .and. cldfrc(k)<=eps
2920 if (cldfrc(k) > eps)
then
2922 if (cldfrc(k-1) >= cldfrc(k))
then
2923 if (lstcldd(k))
then
2924 if (cldfrc(k) < f_one)
then
2925 facclr2d(k-1) = (cldfrc(k-1) - cldfrc(k))
2929 facclr2d(k) = f_zero
2930 faccld2d(k) = f_zero
2932 fmax = max(cldfrc(k), cldfrc(k+1))
2934 if (cldfrc(k-1) > fmax)
then
2935 facclr1d(k-1) = rat2
2936 facclr2d(k-1) = (cldfrc(k-1) - fmax) / (f_one - fmax)
2937 elseif (cldfrc(k-1) < fmax)
then
2938 facclr1d(k-1) = (cldfrc(k-1) - cldfrc(k))
2941 facclr1d(k-1) = rat2
2945 if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero)
then
2953 if (lstcldd(k))
then
2954 faccld2d(k-1) = (cldfrc(k) - cldfrc(k-1)) / cldfrc(k)
2955 facclr2d(k) = f_zero
2956 faccld2d(k) = f_zero
2958 fmin = min(cldfrc(k), cldfrc(k+1))
2960 if (cldfrc(k-1) <= fmin)
then
2961 faccld1d(k-1) = rat1
2962 faccld2d(k-1) = (fmin - cldfrc(k-1)) / fmin
2964 faccld1d(k-1) = (cldfrc(k) - cldfrc(k-1))
2969 if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero)
then
2978 faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrc(k+1)
2979 faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k)
2989 toturad(k,ib) = f_zero
2990 totdrad(k,ib) = f_zero
2991 clrurad(k,ib) = f_zero
2992 clrdrad(k,ib) = f_zero
2997 totuflux(k) = f_zero
2998 totdflux(k) = f_zero
2999 totuclfl(k) = f_zero
3000 totdclfl(k) = f_zero
3017 odepth = max( f_zero, secdif(ib)*tautot(ig,k) )
3018 if (odepth <= 0.06)
then
3019 atrgas = odepth - 0.5*odepth*odepth
3020 trng = f_one - atrgas
3021 gasfac = rec_6 * odepth
3023 tblind = odepth / (bpade + odepth)
3024 itgas = tblint*tblind + 0.5
3025 trng = exp_tbl(itgas)
3026 atrgas = f_one - trng
3027 gasfac = tfn_tbl(itgas)
3028 odepth = tau_tbl(itgas)
3031 plfrac = fracs(ig,k)
3034 dplnku = pklev(ib,k ) - blay
3035 dplnkd = pklev(ib,k-1) - blay
3036 bbdgas = plfrac * (blay + dplnkd*gasfac)
3037 bbugas = plfrac * (blay + dplnku*gasfac)
3038 gassrcd = bbdgas * atrgas
3039 gassrcu(k)= bbugas * atrgas
3045 if (lstcldd(k))
then
3046 totradd = clfr * radtotd
3047 clrradd = radtotd - totradd
3051 if (clfr >= eps)
then
3054 odcld = secdif(ib) * taucld(ib,k)
3055 odtot = odepth + odcld
3056 if (odtot < 0.06)
then
3057 totfac = rec_6 * odtot
3058 atrtot = odtot - 0.5*odtot*odtot
3059 trnt = f_one - atrtot
3061 tblind = odtot / (bpade + odtot)
3062 ittot = tblint*tblind + 0.5
3063 totfac = tfn_tbl(ittot)
3064 trnt = exp_tbl(ittot)
3065 atrtot = f_one - trnt
3068 bbdtot = plfrac * (blay + dplnkd*totfac)
3069 bbutot = plfrac * (blay + dplnku*totfac)
3070 totsrcd = bbdtot * atrtot
3071 totsrcu(k)= bbutot * atrtot
3074 totradd = totradd*trnt + clfr*totsrcd
3075 clrradd = clrradd*trng + (f_one - clfr)*gassrcd
3078 radtotd = totradd + clrradd
3079 totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3082 radclrd = radclrd*trng + gassrcd
3083 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3085 radmod = rad*(facclr1d(k-1)*trng + faccld1d(k-1)*trnt)
3097 radtotd = radtotd*trng + gassrcd
3098 totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3101 radclrd = radclrd*trng + gassrcd
3102 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3115 reflct = f_one - semiss(ib)
3116 rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
3119 radtotu = rad0 + reflct*radtotd
3120 toturad(0,ib) = toturad(0,ib) + radtotu
3123 radclru = rad0 + reflct*radclrd
3124 clrurad(0,ib) = clrurad(0,ib) + radclru
3134 if (lstcldu(k))
then
3135 totradu = clfr * radtotu
3136 clrradu = radtotu - totradu
3140 if (clfr >= eps)
then
3145 totradu = totradu*trnt + clfr*totu
3146 clrradu = clrradu*trng + (f_one - clfr)*gasu
3149 radtotu = totradu + clrradu
3150 toturad(k,ib) = toturad(k,ib) + radtotu
3153 radclru = radclru*trng + gasu
3154 clrurad(k,ib) = clrurad(k,ib) + radclru
3156 radmod = rad*(facclr1u(k+1)*trng + faccld1u(k+1)*trnt)
3167 radtotu = radtotu*trng + gasu
3168 toturad(k,ib) = toturad(k,ib) + radtotu
3171 radclru = radclru*trng + gasu
3172 clrurad(k,ib) = clrurad(k,ib) + radclru
3183 flxfac = wtdiff * fluxfac
3187 totuflux(k) = totuflux(k) + toturad(k,ib)
3188 totdflux(k) = totdflux(k) + totdrad(k,ib)
3189 totuclfl(k) = totuclfl(k) + clrurad(k,ib)
3190 totdclfl(k) = totdclfl(k) + clrdrad(k,ib)
3193 totuflux(k) = totuflux(k) * flxfac
3194 totdflux(k) = totdflux(k) * flxfac
3195 totuclfl(k) = totuclfl(k) * flxfac
3196 totdclfl(k) = totdclfl(k) * flxfac
3200 fnet(0) = totuflux(0) - totdflux(0)
3203 rfdelp(k) = heatfac / delp(k)
3204 fnet(k) = totuflux(k) - totdflux(k)
3205 htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3210 fnetc(0) = totuclfl(0) - totdclfl(0)
3213 fnetc(k) = totuclfl(k) - totdclfl(k)
3214 htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
3221 fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
3224 fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
3225 htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3262 & fracs,secdif, nlay,nlp1,
3366 integer,
intent(in) :: nlay, nlp1
3368 real (kind=kind_phys),
dimension(nbands),
intent(in) :: semiss, &
3370 real (kind=kind_phys),
dimension(nlay),
intent(in) :: delp
3372 real (kind=kind_phys),
dimension(nbands,nlay),
intent(in):: taucld
3373 real (kind=kind_phys),
dimension(ngptlw,nlay),
intent(in):: fracs, &
3376 real (kind=kind_phys),
dimension(nbands,0:nlay),
intent(in) :: &
3380 real (kind=kind_phys),
dimension(nlay),
intent(out) :: htr, htrcl
3382 real (kind=kind_phys),
dimension(nlay,nbands),
intent(out) :: htrb
3384 real (kind=kind_phys),
dimension(0:nlay),
intent(out) :: &
3385 & totuflux, totdflux, totuclfl, totdclfl
3388 real (kind=kind_phys),
parameter :: rec_6 = 0.166667
3390 real (kind=kind_phys),
dimension(0:nlay,nbands) :: clrurad, &
3391 & clrdrad, toturad, totdrad
3393 real (kind=kind_phys),
dimension(nlay) :: gassrcu, totsrcu, &
3394 & trngas, efclrfr, rfdelp
3395 real (kind=kind_phys),
dimension(0:nlay) :: fnet, fnetc
3397 real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
3398 & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac,
3403 integer :: ittot, itgas, ib, ig, k
3409 toturad(k,ib) = f_zero
3410 totdrad(k,ib) = f_zero
3411 clrurad(k,ib) = f_zero
3412 clrdrad(k,ib) = f_zero
3417 totuflux(k) = f_zero
3418 totdflux(k) = f_zero
3419 totuclfl(k) = f_zero
3420 totdclfl(k) = f_zero
3442 odepth = max( f_zero, secdif(ib)*tautot(ig,k) )
3443 if (odepth <= 0.06)
then
3444 atrgas = odepth - 0.5*odepth*odepth
3445 trng = f_one - atrgas
3446 gasfac = rec_6 * odepth
3448 tblind = odepth / (bpade + odepth)
3449 itgas = tblint*tblind + 0.5
3450 trng = exp_tbl(itgas)
3451 atrgas = f_one - trng
3452 gasfac = tfn_tbl(itgas)
3453 odepth = tau_tbl(itgas)
3456 plfrac = fracs(ig,k)
3459 dplnku = pklev(ib,k ) - blay
3460 dplnkd = pklev(ib,k-1) - blay
3461 bbdgas = plfrac * (blay + dplnkd*gasfac)
3462 bbugas = plfrac * (blay + dplnku*gasfac)
3463 gassrcd= bbdgas * atrgas
3464 gassrcu(k)= bbugas * atrgas
3470 if (clfm >= eps)
then
3473 odcld = secdif(ib) * taucld(ib,k)
3474 efclrfr(k) = f_one - (f_one - exp(-odcld))*clfm
3475 odtot = odepth + odcld
3476 if (odtot < 0.06)
then
3477 totfac = rec_6 * odtot
3478 atrtot = odtot - 0.5*odtot*odtot
3480 tblind = odtot / (bpade + odtot)
3481 ittot = tblint*tblind + 0.5
3482 totfac = tfn_tbl(ittot)
3483 atrtot = f_one - exp_tbl(ittot)
3486 bbdtot = plfrac * (blay + dplnkd*totfac)
3487 bbutot = plfrac * (blay + dplnku*totfac)
3488 totsrcd= bbdtot * atrtot
3489 totsrcu(k)= bbutot * atrtot
3492 radtotd = radtotd*trng*efclrfr(k) + gassrcd
3497 radclrd = radclrd*trng + gassrcd
3498 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3504 radtotd = radtotd*trng + gassrcd
3505 totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3508 radclrd = radclrd*trng + gassrcd
3509 clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3522 reflct = f_one - semiss(ib)
3523 rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
3526 radtotu = rad0 + reflct*radtotd
3527 toturad(0,ib) = toturad(0,ib) + radtotu
3530 radclru = rad0 + reflct*radclrd
3531 clrurad(0,ib) = clrurad(0,ib) + radclru
3545 if (clfm > eps)
then
3549 radtotu = radtotu*trng*efclrfr(k) + gasu
3554 radclru = radclru*trng + gasu
3555 clrurad(k,ib) = clrurad(k,ib) + radclru
3561 radtotu = radtotu*trng + gasu
3562 toturad(k,ib) = toturad(k,ib) + radtotu
3565 radclru = radclru*trng + gasu
3566 clrurad(k,ib) = clrurad(k,ib) + radclru
3577 flxfac = wtdiff * fluxfac
3581 totuflux(k) = totuflux(k) + toturad(k,ib)
3582 totdflux(k) = totdflux(k) + totdrad(k,ib)
3583 totuclfl(k) = totuclfl(k) + clrurad(k,ib)
3584 totdclfl(k) = totdclfl(k) + clrdrad(k,ib)
3587 totuflux(k) = totuflux(k) * flxfac
3588 totdflux(k) = totdflux(k) * flxfac
3589 totuclfl(k) = totuclfl(k) * flxfac
3590 totdclfl(k) = totdclfl(k) * flxfac
3594 fnet(0) = totuflux(0) - totdflux(0)
3597 rfdelp(k) = heatfac / delp(k)
3598 fnet(k) = totuflux(k) - totdflux(k)
3599 htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3604 fnetc(0) = totuclfl(0) - totdclfl(0)
3607 fnetc(k) = totuclfl(k) - totdclfl(k)
3608 htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
3615 fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
3618 fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
3619 htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3676 & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1,
3797 integer,
intent(in) :: nlay, laytrop
3799 integer,
dimension(nlay),
intent(in) :: jp, jt, jt1, indself, &
3802 real (kind=kind_phys),
dimension(nlay),
intent(in) :: pavel, &
3803 & coldry, colbrd, fac00, fac01, fac10, fac11, selffac,
3807 real (kind=kind_phys),
dimension(nlay,maxgas),
intent(in):: colamt
3808 real (kind=kind_phys),
dimension(nlay,maxxsec),
intent(in):: wx
3810 real (kind=kind_phys),
dimension(nbands,nlay),
intent(in):: tauaer
3812 real (kind=kind_phys),
dimension(nlay,nrates,2),
intent(in) :: &
3816 real (kind=kind_phys),
dimension(ngptlw,nlay),
intent(out) :: &
3820 real (kind=kind_phys),
dimension(ngptlw,nlay) :: taug
3822 integer :: ib, ig, k
3849 tautot(ig,k) = taug(ig,k) + tauaer(ib,k)
3878 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
3881 real (kind=kind_phys) :: pp, corradj, scalen2, tauself, taufor, &
3893 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(1) + 1
3894 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(1) + 1
3906 scalen2 = colbrd(k) * scaleminorn2(k)
3907 if (pp < 250.0)
then
3908 corradj = f_one - 0.15 * (250.0-pp) / 154.4
3914 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
3932 do k = laytrop+1, nlay
3933 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(1) + 1
3934 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(1) + 1
3943 scalen2 = colbrd(k) * scaleminorn2(k)
3944 corradj = f_one - 0.15 * (pavel(k) / 95.6)
3947 taufor = forfac(k) * (
forref(ig,indf) + forfrac(k)
3977 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
3980 real (kind=kind_phys) :: corradj, tauself, taufor
3987 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(2) + 1
3988 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(2) + 1
3997 corradj = f_one - 0.05 * (pavel(k) - 100.0) / 900.0
4000 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
4016 do k = laytrop+1, nlay
4017 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(2) + 1
4018 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(2) + 1
4026 taufor = forfac(k) * (
forref(ig,indf) + forfrac(k)
4056 integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
4057 & id000, id010, id100, id110, id200, id210, jmn2o, jmn2op,
4061 real (kind=kind_phys) :: absn2o, ratn2o, adjfac, adjcoln2o, &
4062 & speccomb, specparm, specmult, fs,
4078 refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
4079 refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
4080 refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
4081 refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
4086 speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2)
4087 specparm = colamt(k,1) / speccomb
4088 specmult = 8.0 * min(specparm, oneminus)
4089 js = 1 + int(specmult)
4090 fs = mod(specmult, f_one)
4091 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(3) + js
4093 speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2)
4094 specparm1 = colamt(k,1) / speccomb1
4095 specmult1 = 8.0 * min(specparm1, oneminus)
4096 js1 = 1 + int(specmult1)
4097 fs1 = mod(specmult1, f_one)
4098 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(3) + js1
4100 speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,2)
4101 specparm_mn2o = colamt(k,1) / speccomb_mn2o
4102 specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus)
4103 jmn2o = 1 + int(specmult_mn2o)
4104 fmn2o = mod(specmult_mn2o, f_one)
4106 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2)
4107 specparm_planck = colamt(k,1) / speccomb_planck
4108 specmult_planck = 8.0 * min(specparm_planck, oneminus)
4109 jpl = 1 + int(specmult_planck)
4110 fpl = mod(specmult_planck, f_one)
4125 p = coldry(k) * chi_mls(4,jp(k)+1)
4126 ratn2o = colamt(k,4) / p
4127 if (ratn2o > 1.5)
then
4128 adjfac = 0.5 + (ratn2o - 0.5)**0.65
4129 adjcoln2o = adjfac * p
4131 adjcoln2o = colamt(k,4)
4134 if (specparm < 0.125)
then
4138 fk1 = f_one - p - 2.0*p4
4146 else if (specparm > 0.875)
then
4150 fk1 = f_one - p - 2.0*p4
4170 fac000 = fk0*fac00(k)
4171 fac100 = fk1*fac00(k)
4172 fac200 = fk2*fac00(k)
4173 fac010 = fk0*fac10(k)
4174 fac110 = fk1*fac10(k)
4175 fac210 = fk2*fac10(k)
4177 if (specparm1 < 0.125)
then
4181 fk1 = f_one - p - 2.0*p4
4189 elseif (specparm1 > 0.875)
then
4193 fk1 = f_one - p - 2.0*p4
4213 fac001 = fk0*fac01(k)
4214 fac101 = fk1*fac01(k)
4215 fac201 = fk2*fac01(k)
4216 fac011 = fk0*fac11(k)
4217 fac111 = fk1*fac11(k)
4218 fac211 = fk2*fac11(k)
4221 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
4251 do k = laytrop+1, nlay
4252 speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2)
4253 specparm = colamt(k,1) / speccomb
4254 specmult = 4.0 * min(specparm, oneminus)
4255 js = 1 + int(specmult)
4256 fs = mod(specmult, f_one)
4257 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(3) + js
4259 speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2)
4260 specparm1 = colamt(k,1) / speccomb1
4261 specmult1 = 4.0 * min(specparm1, oneminus)
4262 js1 = 1 + int(specmult1)
4263 fs1 = mod(specmult1, f_one)
4264 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(3) + js1
4266 speccomb_mn2o = colamt(k,1) + refrat_m_b*colamt(k,2)
4267 specparm_mn2o = colamt(k,1) / speccomb_mn2o
4268 specmult_mn2o = 4.0 * min(specparm_mn2o, oneminus)
4269 jmn2o = 1 + int(specmult_mn2o)
4270 fmn2o = mod(specmult_mn2o, f_one)
4272 speccomb_planck = colamt(k,1) + refrat_planck_b*colamt(k,2)
4273 specparm_planck = colamt(k,1) / speccomb_planck
4274 specmult_planck = 4.0 * min(specparm_planck, oneminus)
4275 jpl = 1 + int(specmult_planck)
4276 fpl = mod(specmult_planck, f_one)
4298 p = coldry(k) * chi_mls(4,jp(k)+1)
4299 ratn2o = colamt(k,4) / p
4300 if (ratn2o > 1.5)
then
4301 adjfac = 0.5 + (ratn2o - 0.5)**0.65
4302 adjcoln2o = adjfac * p
4304 adjcoln2o = colamt(k,4)
4309 fac000 = fk0*fac00(k)
4310 fac010 = fk0*fac10(k)
4311 fac100 = fk1*fac00(k)
4312 fac110 = fk1*fac10(k)
4316 fac001 = fk0*fac01(k)
4317 fac011 = fk0*fac11(k)
4318 fac101 = fk1*fac01(k)
4319 fac111 = fk1*fac11(k)
4322 taufor = forfac(k) * (
forref(ig,indf) + forfrac(k)
4362 integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, &
4363 & id000, id010, id100, id110, id200, id210, ig, js, js1,
4366 real (kind=kind_phys) :: tauself, taufor, p, p4, fk0, fk1, fk2, &
4367 & speccomb, specparm, specmult, fs,
4376 refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
4377 refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
4382 speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2)
4383 specparm = colamt(k,1) / speccomb
4384 specmult = 8.0 * min(specparm, oneminus)
4385 js = 1 + int(specmult)
4386 fs = mod(specmult, f_one)
4387 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(4) + js
4389 speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2)
4390 specparm1 = colamt(k,1) / speccomb1
4391 specmult1 = 8.0 * min(specparm1, oneminus)
4392 js1 = 1 + int(specmult1)
4393 fs1 = mod(specmult1, f_one)
4394 ind1 = ( jp(k)*5 + (jt1(k)-1)) * nspa(4) + js1
4396 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2)
4397 specparm_planck = colamt(k,1) / speccomb_planck
4398 specmult_planck = 8.0 * min(specparm_planck, oneminus)
4399 jpl = 1 + int(specmult_planck)
4400 fpl = mod(specmult_planck, 1.0)
4408 if (specparm < 0.125)
then
4412 fk1 = f_one - p - 2.0*p4
4420 elseif (specparm > 0.875)
then
4424 fk1 = f_one - p - 2.0*p4
4444 fac000 = fk0*fac00(k)
4445 fac100 = fk1*fac00(k)
4446 fac200 = fk2*fac00(k)
4447 fac010 = fk0*fac10(k)
4448 fac110 = fk1*fac10(k)
4449 fac210 = fk2*fac10(k)
4451 if (specparm1 < 0.125)
then
4455 fk1 = f_one - p - 2.0*p4
4463 elseif (specparm1 > 0.875)
then
4467 fk1 = f_one - p - 2.0*p4
4487 fac001 = fk0*fac01(k)
4488 fac101 = fk1*fac01(k)
4489 fac201 = fk2*fac01(k)
4490 fac011 = fk0*fac11(k)
4491 fac111 = fk1*fac11(k)
4492 fac211 = fk2*fac11(k)
4495 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
4519 do k = laytrop+1, nlay
4520 speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2)
4521 specparm = colamt(k,3) / speccomb
4522 specmult = 4.0 * min(specparm, oneminus)
4523 js = 1 + int(specmult)
4524 fs = mod(specmult, f_one)
4525 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(4) + js
4527 speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2)
4528 specparm1 = colamt(k,3) / speccomb1
4529 specmult1 = 4.0 * min(specparm1, oneminus)
4530 js1 = 1 + int(specmult1)
4531 fs1 = mod(specmult1, f_one)
4532 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(4) + js1
4534 speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2)
4535 specparm_planck = colamt(k,3) / speccomb_planck
4536 specmult_planck = 4.0 * min(specparm_planck, oneminus)
4537 jpl = 1 + int(specmult_planck)
4538 fpl = mod(specmult_planck, f_one)
4552 fac000 = fk0*fac00(k)
4553 fac010 = fk0*fac10(k)
4554 fac100 = fk1*fac00(k)
4555 fac110 = fk1*fac10(k)
4559 fac001 = fk0*fac01(k)
4560 fac011 = fk0*fac11(k)
4561 fac101 = fk1*fac01(k)
4562 fac111 = fk1*fac11(k)
4565 tau_major = speccomb
4581 taug(ns04+ 8,k) = taug(ns04+ 8,k) * 0.92
4582 taug(ns04+ 9,k) = taug(ns04+ 9,k) * 0.88
4583 taug(ns04+10,k) = taug(ns04+10,k) * 1.07
4584 taug(ns04+11,k) = taug(ns04+11,k) * 1.1
4585 taug(ns04+12,k) = taug(ns04+12,k) * 0.99
4586 taug(ns04+13,k) = taug(ns04+13,k) * 0.88
4587 taug(ns04+14,k) = taug(ns04+14,k) * 0.943
4608 integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
4609 & id000, id010, id100, id110, id200, id210, jmo3, jmo3p,
4613 real (kind=kind_phys) :: tauself, taufor, o3m1, o3m2, abso3, &
4614 & speccomb, specparm, specmult, fs,
4632 refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
4633 refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
4634 refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
4639 speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2)
4640 specparm = colamt(k,1) / speccomb
4641 specmult = 8.0 * min(specparm, oneminus)
4642 js = 1 + int(specmult)
4643 fs = mod(specmult, f_one)
4644 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(5) + js
4646 speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2)
4647 specparm1 = colamt(k,1) / speccomb1
4648 specmult1 = 8.0 * min(specparm1, oneminus)
4649 js1 = 1 + int(specmult1)
4650 fs1 = mod(specmult1, f_one)
4651 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(5) + js1
4653 speccomb_mo3 = colamt(k,1) + refrat_m_a*colamt(k,2)
4654 specparm_mo3 = colamt(k,1) / speccomb_mo3
4655 specmult_mo3 = 8.0 * min(specparm_mo3, oneminus)
4656 jmo3 = 1 + int(specmult_mo3)
4657 fmo3 = mod(specmult_mo3, f_one)
4659 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2)
4660 specparm_planck = colamt(k,1) / speccomb_planck
4661 specmult_planck = 8.0 * min(specparm_planck, oneminus)
4662 jpl = 1 + int(specmult_planck)
4663 fpl = mod(specmult_planck, f_one)
4674 if (specparm < 0.125 .and. specparm1 < 0.125)
then
4678 fk10 = f_one - p0 - 2.0*p40
4684 fk11 = f_one - p1 - 2.0*p41
4700 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
4704 fk10 = f_one - p0 - 2.0*p40
4710 fk11 = f_one - p1 - 2.0*p41
4750 fac000 = fk00 * fac00(k)
4751 fac100 = fk10 * fac00(k)
4752 fac200 = fk20 * fac00(k)
4753 fac010 = fk00 * fac10(k)
4754 fac110 = fk10 * fac10(k)
4755 fac210 = fk20 * fac10(k)
4757 fac001 = fk01 * fac01(k)
4758 fac101 = fk11 * fac01(k)
4759 fac201 = fk21 * fac01(k)
4760 fac011 = fk01 * fac11(k)
4761 fac111 = fk11 * fac11(k)
4762 fac211 = fk21 * fac11(k)
4765 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
4792 do k = laytrop+1, nlay
4793 speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2)
4794 specparm = colamt(k,3) / speccomb
4795 specmult = 4.0 * min(specparm, oneminus)
4796 js = 1 + int(specmult)
4797 fs = mod(specmult, f_one)
4798 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(5) + js
4800 speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2)
4801 specparm1 = colamt(k,3) / speccomb1
4802 specmult1 = 4.0 * min(specparm1, oneminus)
4803 js1 = 1 + int(specmult1)
4804 fs1 = mod(specmult1, f_one)
4805 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(5) + js1
4807 speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2)
4808 specparm_planck = colamt(k,3) / speccomb_planck
4809 specmult_planck = 4.0 * min(specparm_planck, oneminus)
4810 jpl = 1 + int(specmult_planck)
4811 fpl = mod(specmult_planck, f_one)
4829 fac000 = fk00 * fac00(k)
4830 fac010 = fk00 * fac10(k)
4831 fac100 = fk10 * fac00(k)
4832 fac110 = fk10 * fac10(k)
4834 fac001 = fk01 * fac01(k)
4835 fac011 = fk01 * fac11(k)
4836 fac101 = fk11 * fac01(k)
4837 fac111 = fk11 * fac11(k)
4840 taug(ns05+ig,k) = speccomb
4871 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
4874 real (kind=kind_phys) :: ratco2, adjfac, adjcolco2, tauself, &
4875 & taufor, absco2, temp
4886 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(6) + 1
4887 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(6) + 1
4902 temp = coldry(k) * chi_mls(2,jp(k)+1)
4903 ratco2 = colamt(k,2) / temp
4904 if (ratco2 > 3.0)
then
4905 adjfac = 2.0 + (ratco2-2.0)**0.77
4906 adjcolco2 = adjfac * temp
4908 adjcolco2 = colamt(k,2)
4912 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
4932 do k = laytrop+1, nlay
4934 taug(ns06+ig,k) = wx(k,2)*
cfc11adj(ig) + wx(k,3)*cfc12(ig)
4958 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
4959 & id000, id010, id100, id110, id200, id210, indm, indmp,
4963 real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, &
4964 & speccomb, specparm, specmult, fs,
4982 refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
4983 refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
4988 speccomb = colamt(k,1) + rfrate(k,2,1)*colamt(k,3)
4989 specparm = colamt(k,1) / speccomb
4990 specmult = 8.0 * min(specparm, oneminus)
4991 js = 1 + int(specmult)
4992 fs = mod(specmult, f_one)
4993 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(7) + js
4995 speccomb1 = colamt(k,1) + rfrate(k,2,2)*colamt(k,3)
4996 specparm1 = colamt(k,1) / speccomb1
4997 specmult1 = 8.0 * min(specparm1, oneminus)
4998 js1 = 1 + int(specmult1)
4999 fs1 = mod(specmult1, f_one)
5000 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(7) + js1
5002 speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,3)
5003 specparm_mco2 = colamt(k,1) / speccomb_mco2
5004 specmult_mco2 = 8.0 * min(specparm_mco2, oneminus)
5005 jmco2 = 1 + int(specmult_mco2)
5006 fmco2 = mod(specmult_mco2, f_one)
5008 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,3)
5009 specparm_planck = colamt(k,1) / speccomb_planck
5010 specmult_planck = 8.0 * min(specparm_planck, oneminus)
5011 jpl = 1 + int(specmult_planck)
5012 fpl = mod(specmult_planck, f_one)
5029 temp = coldry(k) * chi_mls(2,jp(k)+1)
5030 ratco2 = colamt(k,2) / temp
5031 if (ratco2 > 3.0)
then
5032 adjfac = 3.0 + (ratco2-3.0)**0.79
5033 adjcolco2 = adjfac * temp
5035 adjcolco2 = colamt(k,2)
5038 if (specparm < 0.125 .and. specparm1 < 0.125)
then
5042 fk10 = f_one - p0 - 2.0*p40
5048 fk11 = f_one - p1 - 2.0*p41
5064 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
5068 fk10 = f_one - p0 - 2.0*p40
5074 fk11 = f_one - p1 - 2.0*p41
5114 fac000 = fk00 * fac00(k)
5115 fac100 = fk10 * fac00(k)
5116 fac200 = fk20 * fac00(k)
5117 fac010 = fk00 * fac10(k)
5118 fac110 = fk10 * fac10(k)
5119 fac210 = fk20 * fac10(k)
5121 fac001 = fk01 * fac01(k)
5122 fac101 = fk11 * fac01(k)
5123 fac201 = fk21 * fac01(k)
5124 fac011 = fk01 * fac11(k)
5125 fac111 = fk11 * fac11(k)
5126 fac211 = fk21 * fac11(k)
5129 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
5160 do k = laytrop+1, nlay
5161 temp = coldry(k) * chi_mls(2,jp(k)+1)
5162 ratco2 = colamt(k,2) / temp
5163 if (ratco2 > 3.0)
then
5164 adjfac = 2.0 + (ratco2-2.0)**0.79
5165 adjcolco2 = adjfac * temp
5167 adjcolco2 = colamt(k,2)
5170 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(7) + 1
5171 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(7) + 1
5179 absco2 =
kb_mco2(ig,indm) + minorfrac(k)
5193 taug(ns07+ 6,k) = taug(ns07+ 6,k) * 0.92
5194 taug(ns07+ 7,k) = taug(ns07+ 7,k) * 0.88
5195 taug(ns07+ 8,k) = taug(ns07+ 8,k) * 1.07
5196 taug(ns07+ 9,k) = taug(ns07+ 9,k) * 1.1
5197 taug(ns07+10,k) = taug(ns07+10,k) * 0.99
5198 taug(ns07+11,k) = taug(ns07+11,k) * 0.855
5219 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5222 real (kind=kind_phys) :: tauself, taufor, absco2, abso3, absn2o, &
5223 & ratco2, adjfac, adjcolco2, temp
5238 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(8) + 1
5239 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(8) + 1
5254 temp = coldry(k) * chi_mls(2,jp(k)+1)
5255 ratco2 = colamt(k,2) / temp
5256 if (ratco2 > 3.0)
then
5257 adjfac = 2.0 + (ratco2-2.0)**0.65
5258 adjcolco2 = adjfac * temp
5260 adjcolco2 = colamt(k,2)
5264 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
5288 do k = laytrop+1, nlay
5289 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(8) + 1
5290 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(8) + 1
5301 temp = coldry(k) * chi_mls(2,jp(k)+1)
5302 ratco2 = colamt(k,2) / temp
5303 if (ratco2 > 3.0)
then
5304 adjfac = 2.0 + (ratco2-2.0)**0.65
5305 adjcolco2 = adjfac * temp
5307 adjcolco2 = colamt(k,2)
5311 absco2 = (
kb_mco2(ig,indm) + minorfrac(k)
5344 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5345 & id000, id010, id100, id110, id200, id210, indm, indmp,
5349 real (kind=kind_phys) :: tauself, taufor, n2om1, n2om2, absn2o, &
5350 & speccomb, specparm, specmult, fs,
5368 refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
5369 refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
5374 speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5)
5375 specparm = colamt(k,1) / speccomb
5376 specmult = 8.0 * min(specparm, oneminus)
5377 js = 1 + int(specmult)
5378 fs = mod(specmult, f_one)
5379 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(9) + js
5381 speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5)
5382 specparm1 = colamt(k,1) / speccomb1
5383 specmult1 = 8.0 * min(specparm1, oneminus)
5384 js1 = 1 + int(specmult1)
5385 fs1 = mod(specmult1, f_one)
5386 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(9) + js1
5388 speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,5)
5389 specparm_mn2o = colamt(k,1) / speccomb_mn2o
5390 specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus)
5391 jmn2o = 1 + int(specmult_mn2o)
5392 fmn2o = mod(specmult_mn2o, f_one)
5394 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5)
5395 specparm_planck = colamt(k,1) / speccomb_planck
5396 specmult_planck = 8.0 * min(specparm_planck, oneminus)
5397 jpl = 1 + int(specmult_planck)
5398 fpl = mod(specmult_planck, f_one)
5413 temp = coldry(k) * chi_mls(4,jp(k)+1)
5414 ratn2o = colamt(k,4) / temp
5415 if (ratn2o > 1.5)
then
5416 adjfac = 0.5 + (ratn2o-0.5)**0.65
5417 adjcoln2o = adjfac * temp
5419 adjcoln2o = colamt(k,4)
5422 if (specparm < 0.125 .and. specparm1 < 0.125)
then
5426 fk10 = f_one - p0 - 2.0*p40
5432 fk11 = f_one - p1 - 2.0*p41
5449 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
5453 fk10 = f_one - p0 - 2.0*p40
5459 fk11 = f_one - p1 - 2.0*p41
5499 fac000 = fk00 * fac00(k)
5500 fac100 = fk10 * fac00(k)
5501 fac200 = fk20 * fac00(k)
5502 fac010 = fk00 * fac10(k)
5503 fac110 = fk10 * fac10(k)
5504 fac210 = fk20 * fac10(k)
5506 fac001 = fk01 * fac01(k)
5507 fac101 = fk11 * fac01(k)
5508 fac201 = fk21 * fac01(k)
5509 fac011 = fk01 * fac11(k)
5510 fac111 = fk11 * fac11(k)
5511 fac211 = fk21 * fac11(k)
5514 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
5541 do k = laytrop+1, nlay
5542 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(9) + 1
5543 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(9) + 1
5554 temp = coldry(k) * chi_mls(4,jp(k)+1)
5555 ratn2o = colamt(k,4) / temp
5556 if (ratn2o > 1.5)
then
5557 adjfac = 0.5 + (ratn2o - 0.5)**0.65
5558 adjcoln2o = adjfac * temp
5560 adjcoln2o = colamt(k,4)
5564 absn2o =
kb_mn2o(ig,indm) + minorfrac(k)
5592 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5595 real (kind=kind_phys) :: tauself, taufor
5602 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(10) + 1
5603 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(10) + 1
5613 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
5629 do k = laytrop+1, nlay
5630 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(10) + 1
5631 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(10) + 1
5639 taufor = forfac(k) * (
forref(ig,indf) + forfrac(k)
5669 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5672 real (kind=kind_phys) :: scaleo2, tauself, taufor, tauo2
5683 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(11) + 1
5684 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(11) + 1
5695 scaleo2 = colamt(k,6) * scaleminor(k)
5698 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
5716 do k = laytrop+1, nlay
5717 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(11) + 1
5718 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(11) + 1
5727 scaleo2 = colamt(k,6) * scaleminor(k)
5730 taufor = forfac(k) * (
forref(ig,indf) + forfrac(k)
5760 integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, &
5761 & id000, id010, id100, id110, id200, id210, ig, js, js1,
5764 real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, &
5765 & speccomb, specparm, specmult, fs,
5777 refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
5782 speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2)
5783 specparm = colamt(k,1) / speccomb
5784 specmult = 8.0 * min(specparm, oneminus)
5785 js = 1 + int(specmult)
5786 fs = mod(specmult, f_one)
5787 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(12) + js
5789 speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2)
5790 specparm1 = colamt(k,1) / speccomb1
5791 specmult1 = 8.0 * min(specparm1, oneminus)
5792 js1 = 1 + int(specmult1)
5793 fs1 = mod(specmult1, f_one)
5794 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(12) + js1
5796 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2)
5797 specparm_planck = colamt(k,1) / speccomb_planck
5798 if (specparm_planck >= oneminus) specparm_planck=oneminus
5799 specmult_planck = 8.0 * specparm_planck
5800 jpl = 1 + int(specmult_planck)
5801 fpl = mod(specmult_planck, f_one)
5809 if (specparm < 0.125 .and. specparm1 < 0.125)
then
5813 fk10 = f_one - p0 - 2.0*p40
5819 fk11 = f_one - p1 - 2.0*p41
5835 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
5839 fk10 = f_one - p0 - 2.0*p40
5845 fk11 = f_one - p1 - 2.0*p41
5885 fac000 = fk00 * fac00(k)
5886 fac100 = fk10 * fac00(k)
5887 fac200 = fk20 * fac00(k)
5888 fac010 = fk00 * fac10(k)
5889 fac110 = fk10 * fac10(k)
5890 fac210 = fk20 * fac10(k)
5892 fac001 = fk01 * fac01(k)
5893 fac101 = fk11 * fac01(k)
5894 fac201 = fk21 * fac01(k)
5895 fac011 = fk01 * fac11(k)
5896 fac111 = fk11 * fac11(k)
5897 fac211 = fk21 * fac11(k)
5900 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
5922 do k = laytrop+1, nlay
5924 taug(ns12+ig,k) = f_zero
5925 fracs(ns12+ig,k) = f_zero
5945 integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
5946 & id000, id010, id100, id110, id200, id210, jmco2, jpl,
5950 real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, &
5951 & speccomb, specparm, specmult, fs,
5972 refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
5973 refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
5974 refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
5979 speccomb = colamt(k,1) + rfrate(k,3,1)*colamt(k,4)
5980 specparm = colamt(k,1) / speccomb
5981 specmult = 8.0 * min(specparm, oneminus)
5982 js = 1 + int(specmult)
5983 fs = mod(specmult, f_one)
5984 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(13) + js
5986 speccomb1 = colamt(k,1) + rfrate(k,3,2)*colamt(k,4)
5987 specparm1 = colamt(k,1) / speccomb1
5988 specmult1 = 8.0 * min(specparm1, oneminus)
5989 js1 = 1 + int(specmult1)
5990 fs1 = mod(specmult1, f_one)
5991 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(13) + js1
5993 speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,4)
5994 specparm_mco2 = colamt(k,1) / speccomb_mco2
5995 specmult_mco2 = 8.0 * min(specparm_mco2, oneminus)
5996 jmco2 = 1 + int(specmult_mco2)
5997 fmco2 = mod(specmult_mco2, f_one)
6003 speccomb_mco = colamt(k,1) + refrat_m_a3*colamt(k,4)
6004 specparm_mco = colamt(k,1) / speccomb_mco
6005 specmult_mco = 8.0 * min(specparm_mco, oneminus)
6006 jmco = 1 + int(specmult_mco)
6007 fmco = mod(specmult_mco, f_one)
6009 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,4)
6010 specparm_planck = colamt(k,1) / speccomb_planck
6011 specmult_planck = 8.0 * min(specparm_planck, oneminus)
6012 jpl = 1 + int(specmult_planck)
6013 fpl = mod(specmult_planck, f_one)
6029 temp = coldry(k) * 3.55e-4
6030 ratco2 = colamt(k,2) / temp
6031 if (ratco2 > 3.0)
then
6032 adjfac = 2.0 + (ratco2-2.0)**0.68
6033 adjcolco2 = adjfac * temp
6035 adjcolco2 = colamt(k,2)
6038 if (specparm < 0.125 .and. specparm1 < 0.125)
then
6042 fk10 = f_one - p0 - 2.0*p40
6048 fk11 = f_one - p1 - 2.0*p41
6064 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
6068 fk10 = f_one - p0 - 2.0*p40
6074 fk11 = f_one - p1 - 2.0*p41
6114 fac000 = fk00 * fac00(k)
6115 fac100 = fk10 * fac00(k)
6116 fac200 = fk20 * fac00(k)
6117 fac010 = fk00 * fac10(k)
6118 fac110 = fk10 * fac10(k)
6119 fac210 = fk20 * fac10(k)
6121 fac001 = fk01 * fac01(k)
6122 fac101 = fk11 * fac01(k)
6123 fac201 = fk21 * fac01(k)
6124 fac011 = fk01 * fac11(k)
6125 fac111 = fk11 * fac11(k)
6126 fac211 = fk21 * fac11(k)
6129 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
6162 do k = laytrop+1, nlay
6167 abso3 = kb_mo3(ig,indm) + minorfrac(k)
6192 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
6195 real (kind=kind_phys) :: tauself, taufor
6202 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(14) + 1
6203 ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(14) + 1
6213 tauself = selffac(k) * (
selfref(ig,inds) + selffrac(k)
6229 do k = laytrop+1, nlay
6230 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(14) + 1
6231 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(14) + 1
6237 taug(ns14+ig,k) = colamt(k,2)
6263 integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
6264 & id000, id010, id100, id110, id200, id210, jpl, jplp,
6268 real (kind=kind_phys) :: scalen2, tauself, taufor, &
6269 & speccomb, specparm, specmult, fs,
6286 refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
6287 refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
6292 speccomb = colamt(k,4) + rfrate(k,5,1)*colamt(k,2)
6293 specparm = colamt(k,4) / speccomb
6294 specmult = 8.0 * min(specparm, oneminus)
6295 js = 1 + int(specmult)
6296 fs = mod(specmult, f_one)
6297 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(15) + js
6299 speccomb1 = colamt(k,4) + rfrate(k,5,2)*colamt(k,2)
6300 specparm1 = colamt(k,4) / speccomb1
6301 specmult1 = 8.0 * min(specparm1, oneminus)
6302 js1 = 1 + int(specmult1)
6303 fs1 = mod(specmult1, f_one)
6304 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(15) + js1
6306 speccomb_mn2 = colamt(k,4) + refrat_m_a*colamt(k,2)
6307 specparm_mn2 = colamt(k,4) / speccomb_mn2
6308 specmult_mn2 = 8.0 * min(specparm_mn2, oneminus)
6309 jmn2 = 1 + int(specmult_mn2)
6310 fmn2 = mod(specmult_mn2, f_one)
6312 speccomb_planck = colamt(k,4) + refrat_planck_a*colamt(k,2)
6313 specparm_planck = colamt(k,4) / speccomb_planck
6314 specmult_planck = 8.0 * min(specparm_planck, oneminus)
6315 jpl = 1 + int(specmult_planck)
6316 fpl = mod(specmult_planck, f_one)
6318 scalen2 = colbrd(k) * scaleminor(k)
6330 if (specparm < 0.125 .and. specparm1 < 0.125)
then
6334 fk10 = f_one - p0 - 2.0*p40
6340 fk11 = f_one - p1 - 2.0*p41
6356 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
6360 fk10 = f_one - p0 - 2.0*p40
6366 fk11 = f_one - p1 - 2.0*p41
6406 fac000 = fk00 * fac00(k)
6407 fac100 = fk10 * fac00(k)
6408 fac200 = fk20 * fac00(k)
6409 fac010 = fk00 * fac10(k)
6410 fac110 = fk10 * fac10(k)
6411 fac210 = fk20 * fac10(k)
6413 fac001 = fk01 * fac01(k)
6414 fac101 = fk11 * fac01(k)
6415 fac201 = fk21 * fac01(k)
6416 fac011 = fk01 * fac11(k)
6417 fac111 = fk11 * fac11(k)
6418 fac211 = fk21 * fac11(k)
6421 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
6448 do k = laytrop+1, nlay
6450 taug(ns15+ig,k) = f_zero
6452 fracs(ns15+ig,k) = f_zero
6472 integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
6473 & id000, id010, id100, id110, id200, id210, jpl, jplp,
6476 real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, &
6477 & speccomb, specparm, specmult, fs,
6489 refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
6494 speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5)
6495 specparm = colamt(k,1) / speccomb
6496 specmult = 8.0 * min(specparm, oneminus)
6497 js = 1 + int(specmult)
6498 fs = mod(specmult, f_one)
6499 ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(16) + js
6501 speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5)
6502 specparm1 = colamt(k,1) / speccomb1
6503 specmult1 = 8.0 * min(specparm1, oneminus)
6504 js1 = 1 + int(specmult1)
6505 fs1 = mod(specmult1, f_one)
6506 ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(16) + js1
6508 speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5)
6509 specparm_planck = colamt(k,1) / speccomb_planck
6510 specmult_planck = 8.0 * min(specparm_planck, oneminus)
6511 jpl = 1 + int(specmult_planck)
6512 fpl = mod(specmult_planck, f_one)
6520 if (specparm < 0.125 .and. specparm1 < 0.125)
then
6524 fk10 = f_one - p0 - 2.0*p40
6530 fk11 = f_one - p1 - 2.0*p41
6546 elseif (specparm > 0.875 .and. specparm1 > 0.875)
then
6550 fk10 = f_one - p0 - 2.0*p40
6556 fk11 = f_one - p1 - 2.0*p41
6596 fac000 = fk00 * fac00(k)
6597 fac100 = fk10 * fac00(k)
6598 fac200 = fk20 * fac00(k)
6599 fac010 = fk00 * fac10(k)
6600 fac110 = fk10 * fac10(k)
6601 fac210 = fk20 * fac10(k)
6603 fac001 = fk01 * fac01(k)
6604 fac101 = fk11 * fac01(k)
6605 fac201 = fk21 * fac01(k)
6606 fac011 = fk01 * fac11(k)
6607 fac111 = fk11 * fac11(k)
6608 fac211 = fk21 * fac11(k)
6611 tauself = selffac(k)* (
selfref(ig,inds) + selffrac(k)
6633 do k = laytrop+1, nlay
6634 ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(16) + 1
6635 ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(16) + 1
6641 taug(ns16+ig,k) = colamt(k,5)
6660 end module module_radlw_main
real(kind=kind_phys), dimension(ng09, mmn09), public kb_mn2o
the array kb_mxxx contains the absorption coefficient for a minor species at the NG09=12 chosen g-val...
real(kind=kind_phys), dimension(ng08, mmc08), public ka_mco2
minor gas mapping level:lower - co2, p = 1053.63 mb, t = 294.2 k
subroutine mcica_subcol
This suroutine computes sub-colum cloud profile flag array.
This module sets up absorption coefficients for band 12: 1800-2080 cm-1 (low - h2o, co2; high - /)
real(kind=kind_phys), dimension(ng09), public fracrefb
planck fraction mapping level : p 3.20e-2 mb, t = 197.92 k
integer, parameter ngptlw
num of total g-points
Define type construct for radiation fluxes at surface.
real(kind=kind_phys), dimension(ng07, msb07), public absb
the array absb(NG07,235) = kb(NG07,5,13:59) contains absorption coefs at the NG07=12 chosen g-values ...
real(kind=kind_phys), parameter con_amw
molecular wght of water vapor ( )
real(kind=kind_phys), dimension(ng15, msa15), public absa
the array absa(NG15,585) = ka(NG15,9,5,13) contains absorption coefs at the NG15=2 g-intervals for a ...
real(kind=kind_phys), dimension(ng05, mbf05), public fracrefb
planck fraction mapping level : p = 0.2369280 mbar, t = 253.60 k
subroutine taugb10
Band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
subroutine cldprop
This subroutine computes the cloud optical depth(s) for each cloudy layer and g-point interval...
real(kind=kind_phys), dimension(ng04, msf04), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng15, msf15), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng06, msa06), public absa
the array absa(NG06,65) = ka(NG06,5,13) contains absorption coefs at the NG06=8 g-intervals for a ran...
real(kind=kind_phys), dimension(ng08, mmc08), public ka_mo3
minor gas mapping level:lower - o3, p = 317.348 mb, t = 240.77 k
real(kind=kind_phys), dimension(ng08, msb08), public absb
the array absb(NG08,235) = kb(NG08,5,13:59) contains absorption coefs at the NG08=8 chosen g-values f...
real(kind=kind_phys), dimension(ng09, maf09), public fracrefa
planck fractions mapping level : p=212.7250 mb, t = 223.06 k
real(kind=kind_phys), parameter con_g
gravity ( )
This module sets up absorption coefficients for band 15: 2380-2600 cm-1 (low - n2o, co2; high - /)
real(kind=kind_phys), dimension(ng04, msa04), public absa
the array absa(NG04,585) = ka(NG04,9,5,13) contains absorption coefs at the NG04=14 g-intervals for a...
real(kind=kind_phys), dimension(ng01, msf01), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(58, nbands) absliq1
Hu and Stamnes method . the liquid water absorption coefficients are listed for a range of effective...
subroutine setcoef
This subroutine computes various coefficients needed in radiative transfer calculations.
real(kind=kind_phys), dimension(ng10, msa10), public absa
the array absa(NG10,65) = ka(NG10,5,13) contains absorption coefs at the NG10=6 chosen g-values for a...
real(kind=kind_phys), dimension(ng03, maf03), public fracrefa
planck fraction mapping level: p=212.7250 mbar, t = 223.06 k
integer, parameter ilwrate
LW heating rate unit (1:k/day; 2:k/second): =1:k/day; =2:k/second.
real(kind=kind_phys), dimension(ng11, msa11), public absa
the array absa(NG11,65) = ka(NG11,5,13) contains absorption coefs at the NG11=8 chosen g-values for a...
real(kind=kind_phys), dimension(ng13, msf13), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng09, msa09), public absa
the array absa(NG09,585) = ka(NG09,9,5,13) contains absorption coefs at the NG09=12 g-intervals for a...
This module sets up absorption coefficients for band 06: 820-980 cm-1 (low - h2o; high - /) ...
real(kind=kind_phys), dimension(ng16, maf16), public fracrefa
planck fraction mapping level: p = 387.6100 mbar, t = 250.17 k
real(kind=kind_phys), dimension(ng14), public fracrefa
planck fraction mapping level : p = 142.5940 mb, t = 215.70 k
real(kind=kind_phys), dimension(ng07), public fracrefb
planck data fraction mapping level : p=95.58 mbar, t= 215.70 k
real(kind=kind_phys), dimension(ng10), public fracrefb
planck fraction mapping level : p = 95.58350 mb, t = 215.70 k
real(kind=kind_phys), dimension(ng13), public fracrefb
planck fraction mapping level : p=4.758820 mb, t = 250.85 k
real(kind=kind_phys), dimension(ng09, mfr09), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng05), public ccl4
minor gas (o3, ccl4) mapping level : p = 317.34 mbar, t = 240.77 k
subroutine taugb15
Band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) (high - nothing)
real(kind=kind_phys), dimension(43, nbands) absice2
for iflagice =2, absice2 are the ice water absorption coefficients used for streamer method...
real(kind=kind_phys), dimension(ng04, msb04), public absb
the array absb(NG04,1175) = kb(NG04,5,5,13:59) contains absorption coefs at the NG04=14 g-intervals f...
real(kind=kind_phys), dimension(ng08, mfr08), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng14, mfr14), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
integer, parameter maxxsec
num of halocarbon gasees
This module sets up absorption coefficients for band 09: 1180-1390 cm-1 (low - h2o, ch4; high - ch4)
real(kind=kind_phys), dimension(ng08), public cfc22adj
original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1 and 1290-1335 cm-1 bands...
subroutine taumol
This subroutine contains optical depths developed for the rapid radiative transfer model...
This module sets up absorption coefficients for band 11: 1480-1800 cm-1 (low - h2o; high - h2o) ...
real(kind=kind_phys), dimension(ng01, msb01), public absb
the array absb(NG01,235) = kb(NG01,5,13:59) contains absorption coefs at the NG01=10 chosen g-values ...
real(kind=kind_phys), dimension(ng05, mfr05), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng09, maf09, mmn09), public ka_mn2o
the array ka_mxxx contains the absorption coefficient for a minor species at the 16 chosen g-values f...
real(kind=kind_phys), dimension(ng01), public fracrefb
planck fraction mapping level: p = 212.7250 mbar, t = 223.06 k these planck fractions were calculated...
real(kind=kind_phys), dimension(ng16, msf16), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng08), public cfc12
minor gas mapping level:lower - cfc12
real(kind=kind_phys), dimension(ng03, mbf03), public fracrefb
planck fraction mapping level: p = 95.8 mbar, t = 215.7 k
real(kind=kind_phys), dimension(ng08, msa08), public absa
the array absa(NG08,65) = ka(NG08,5,13) contains absorption coefs at the NG08=8 g-intervals for a ran...
real(kind=kind_phys), dimension(ng02, msa02), public absa
the array absa(NG02,65) = ka(NG02,5,13) contains absorption coefs at the NG02=12 chosen g-values for ...
This module sets up absorption coefficients for band 02: 250-500 cm-1 (low - h2o; high - h2o) ...
subroutine taugb16
Band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
real(kind=kind_phys), parameter absrain
absrain is the rain drop absorption coefficient .
real(kind=kind_phys), dimension(ng11, mfr11), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
Define type construct for optional radiation flux profiles.
real(kind=kind_phys), dimension(ng14, msa14), public absa
the array absa(NG14,65) = ka(NG14,5,13) contains absorption coefs at the NG14=2 chosen g-values for a...
real(kind=kind_phys), dimension(ng09, msb09), public absb
the array absb(NG09,235) = kb(NG09,5,13:59) contains absorption coefs at the NG09=12 chosen g-values ...
real(kind=kind_phys), dimension(ng06, mmc06), public ka_mco2
the array kao_mxx contains the absorption coefficient for a minor species at the NG06=8 chosen g-valu...
real(kind=kind_phys), dimension(ng11, msb11), public absb
the array absb(NG11,235) = kb(NG11,5,13:59) contains absorption coefs at the NG11=8 chosen g-values f...
integer, dimension(nbands) ipat
ipat is bands index for ebert&curry ice cloud (for iflagice=1)
This module sets up absorption coefficients for band 05: 700-820 cm-1 (low - h2o, co2; high - co2...
subroutine taugb13
Band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor)
real(kind=kind_phys), dimension(ng14), public fracrefb
planck fraction mapping level : p = 4.758820mb, t = 250.85 k
real(kind=kind_phys), dimension(ng04, mbf04), public fracrefb
planck fraction mapping level : p = 95.58350 mb, t = 215.70 k
real(kind=kind_phys), dimension(ng02), public fracrefa
planck fraction mapping level: p = 1053.630 mbar, t = 294.2 k
integer, save icldflg
cloud optical property scheme control flag
real(kind=kind_phys), dimension(ng03, mbf03, mmn03), public kb_mn2o
the array kb_mxxx contains the absorption coefficient for a minor species at the NG03=16 chosen g-val...
real(kind=kind_phys), parameter abssnow0
abssnow0 is the snow flake absorption coefficient (micron), fu coeff
real(kind=kind_phys), dimension(ng08, mmc08), public kb_mco2
minor gas mapping level:upper - co2, p = 35.1632 mb, t = 223.28 k
real(kind=kind_phys), dimension(ng01, msa01), public absa
the array absa(NG01,65) = ka(NG01,5,13) contains absorption coefs at the NG01=10 chosen g-values for ...
real(kind=kind_phys), dimension(ng07, maf07, mmc07), public ka_mco2
the array ka_mxxx contains the absorption coefficient for a minor species at the NG07=12 chosen g-val...
real(kind=kind_phys), dimension(ng12, msf12), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng03, msb03), public absb
the array absb(NG03,1175) = kb(NG03,5,5,13:59) contains absorption coefs at the NG03=16 g-intervals f...
real(kind=kind_phys), dimension(ng08), public fracrefb
planck fraction mapping level : p=95.5835 mb, t= 215.7 k
integer, parameter ilwrgas
LW rare gases effect control flag (ch4,n2o,o2,cfcs...): =0:no; =1:yes.
real(kind=kind_phys), dimension(ng02), public fracrefb
planck fraction mapping level: p = 3.206e-2 mb, t = 197.92 k
real(kind=kind_phys), dimension(ng11, mmo11), public ka_mo2
the array ka_mxx contains the absorption coefficient for a minor species at the NG11=8 chosen g-value...
real(kind=kind_phys), dimension(ng12, mfr12), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
This module contains reference temperature and pressure.
subroutine taugb08
Band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) (high key - o3; high minor - co2...
real(kind=kind_phys), dimension(nplnk, nbands), public totplnk
plank flux data
real(kind=kind_phys), parameter con_cp
spec heat air at p ( )
real(kind=kind_phys), dimension(ng15, mfr15), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
This module sets up absorption coefficients for band 14: 2250-2380 cm-1 (low - co2; high - co2) ...
real(kind=kind_phys), dimension(ng06), public fracrefa
planck fraction mapping level : p = 473.4280 mb, t = 259.83 k
real(kind=kind_phys), dimension(ng14, msf14), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng02, msb02), public absb
the array absb(NG02,235) = kb(NG02,5,13:59) contains absorption coefs at the NG02=12 chosen g-values ...
real(kind=kind_phys), dimension(46, nbands) absice3
for iflagice = 3, absice3 are the ice water absorption coefficients used for fu parameterization. particle size 5 - 140 micron in increments of 3 microns. units = m2/g. hexagonal ice particle parameterization absorption units (abs coef/iwc):
real(kind=kind_phys), dimension(ng05, msf05), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng06), public cfc11adj
lower - co2, p = 706.2720 mb, t = 294.2 k upper - cfc11, cfc12 original cfc11 is multiplied by 1...
subroutine taugb12
Band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
real(kind=kind_phys), dimension(ng11), public fracrefb
planck fraction mapping level : p=0.353 mb, t = 262.11 k
This module sets up absorption coefficients for band 01: 10-250 cm-1 (low - h2o; high - h2o) ...
real(kind=kind_phys), dimension(ng05, maf05), public fracrefa
planck fraction mapping level : p = 473.42 mb, t = 259.83 k
real(kind=kind_phys), dimension(ng08, msf08), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng13, msa13), public absa
the array absa(NG13,585) = ka(NG13,9,5,13) contains absorption coefs at the NG13=4 g-intervals for a ...
integer, parameter ntbl
lookup table dimension
real(kind=kind_phys), dimension(ng02, msf02), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng15, maf15, mmn15), public ka_mn2
the array ka_mxx contains the absorption coefficient for a minor species at the NG15=2 chosen g-value...
real(kind=kind_phys), dimension(ng01), public fracrefa
planck fraction mapping level: p = 212.7250 mbar, t = 223.06 k
real(kind=kind_phys), dimension(ng07, mmc07), public kb_mco2
the array kb_mxxx contains absorption coefficient for a minor species at the NG07=12 chosen g-values ...
real(kind=kind_phys), dimension(ng16, mfr16), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
This module sets up absorption coefficients for band 08: 1080-1180 cm-1 (low - h2o; high - o3) ...
real(kind=kind_phys), dimension(ng04, maf04), public fracrefa
planck fraction mapping level: p=212.7250 mbar, t = 223.06 k
real(kind=kind_phys), dimension(ng05, msa05), public absa
the array absa(NG05,585) = ka(NG05,9,5,13) contains absorption coefs at the NG05=16 g-intervals for a...
real(kind=kind_phys), dimension(ng13, mfr13), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
This module sets up absorption coefficients for band 10: 1390-1480 cm-1 (low - h2o; high - h2o) ...
real(kind=kind_phys), dimension(ng09, msf09), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
real(kind=kind_phys), dimension(ng07, maf07), public fracrefa
planck fraction mapping level : p = 706.27 mb, t = 278.94 k
real(kind=kind_phys), dimension(ng08), public fracrefa
planck fraction mapping level : p=473.4280 mb, t = 259.83 k
real(kind=kind_phys), dimension(ng03, msa03), public absa
the array absa(NG03,585) = ka(NG03,9,5,13) contains absorption coefs at the NG03=16 g-intervals for a...
real(kind=kind_phys), dimension(ng10, msf10), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
subroutine taugb04
Band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
real(kind=kind_phys), dimension(ng06, mfr06), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng08, mmc08), public kb_mn2o
minor gas mapping level:upper - n2o, p = 8.716e-2 mb, t = 226.03 k
integer, save ilwcice
LW optical property for ice clouds (only ilwcliq>0) =0:not defined yet =1:input cip...
This module contains LW band parameters set up.
Define type construct for radiation fluxes at toa.
real(kind=kind_phys), dimension(ng01, mfr01), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng07, msf07), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
This module sets up absorption coefficients for band 13: 2080-2250 cm-1 (low - h2o, n2o; high - /)
real(kind=kind_phys), dimension(ng11, msf11), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
subroutine taugb07
Band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) (high key - o3; high minor - co2) ...
real(kind=kind_phys), dimension(ng13, maf13, mmo13), public ka_mco2
the array ka_mxxx contains the absorption coefficient for a minor species at the NG13=4 chosen g-valu...
real(kind=kind_phys), parameter con_avgd
avogadro constant ( )
integer, parameter nrates
num of ref rates of binary species
real(kind=kind_phys), dimension(ng16, msa16), public absa
the array absa(NG16,585) = ka(NG16,9,5,13) contains absorption coefs at the NG16=2 g-intervals for a ...
This module sets up absorption coefficients for band 04: 630-700 cm-1 (low - h2o, co2; high - co2...
real(kind=kind_phys), dimension(2, 5) absice1
for iflagice = 1, absice1 are the ice water absorption coefficients used for ebert and curry method ...
integer, save ilwcliq
LW optical property for liquid clouds =0:input cld opt depth, ignoring ilwcice setting =1:input c...
real(kind=kind_phys), dimension(ng10), public fracrefa
planck fraction mapping level : p = 212.7250, t = 223.06 k
subroutine, public rlwinit
This subroutine performs calculations necessary for the initialization of the longwave model...
subroutine taugb09
Band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) (high key - ch4; high minor - n2o) ...
real(kind=kind_phys), dimension(ng14, msb14), public absb
the array absb(NG14,235) = kb(NG14,5,13:59) contains absorption coefs at the NG14=2 chosen g-values f...
real(kind=kind_phys), dimension(ng12, msa12), public absa
the array absa(NG12,585) = ka(NG12,9,5,13) contains absorption coefs at the NG12=8 g-intervals for a ...
real(kind=kind_phys), dimension(ng08, mmc08), public ka_mn2o
minor gas mapping level:lower - n2o, p = 706.2720 mb, t= 278.94 k
subroutine taugb11
Band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) (high key - h2o; high minor - o2) ...
real(kind=kind_phys), dimension(ng07, msa07), public absa
the array absa(NG07,585) = ka(NG07,9,5,13) contains absorption coefs at the NG07=12 g-intervals for a...
subroutine taugb02
Band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
real(kind=kind_phys), parameter con_amo3
molecular wght of o3 ( )
This module sets up absorption coefficients for band 07: 980-1080 cm-1 (low - h2o, o3; high - o3)
real(kind=kind_phys), dimension(ng03, msf03), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
subroutine taugb03
Band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o); (high key - h2o,co2; high minor - n2o) ...
subroutine taugb14
Band 14: 2250-2380 cm-1 (low - co2; high - co2)
real(kind=kind_phys), dimension(ng16, msb16), public absb
the array absb(NG16,235) = kb(NG16,5,13:59) contains absorption coefs at the NG16=2 chosen g-values f...
subroutine rtrn
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
subroutine taugb05
Band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) (high key - o3,co2) ...
subroutine rtrnmc
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
real(kind=kind_phys), dimension(ng10, mfr10), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng16), public fracrefb
planck fraction mapping level : p=95.58350 mb, t = 215.70 k
real(kind=kind_phys), dimension(ng05, msb05), public absb
the array absb(NG05,1175) = kb(NG05,5,5,13:59) contains absorption coefs at the NG05=16 g-intervals f...
real(kind=kind_phys), dimension(ng11), public fracrefa
planck fraction mapping level : p=1053.63 mb, t= 294.2 k
subroutine rtrnmr
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
This module sets up absorption coefficients for band 16: 2600-3000 cm-1 (low - h2o, ch4; high - /)
integer, save isubclw
sub-column cloud approx flag in LW radiation
integer, save ivflip
vertical profile indexing flag
real(kind=kind_phys), dimension(ng02, mfr02), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng15, maf15), public fracrefa
planck fraction mapping level : p = 1053. mb, t = 294.2 k
real(kind=kind_phys), dimension(ng06, msf06), public selfref
the array selfref contains the coefficient of the water vapor self-continuum (including the energy te...
subroutine taugb06
Band 6: 820-980 cm-1 (low key - h2o; low minor - co2) (high key - none; high minor - cfc11...
This module contains cloud property coefficients.
integer, parameter maxgas
max num of absorbing gases
This module sets up absorption coefficients for band 03: 500-630 cm-1 (low - h2o, co2; high - h2o...
subroutine taugb01
band 1: 10-350 cm-1 (low key - h2o; low minor - n2); (high key - h2o; high minor - n2) ...
subroutine, public lwrad
This subroutine is the main LW radiation routine.
real(kind=kind_phys), dimension(ng13, maf13), public fracrefa
planck fraction mapping level : p=473.4280 mb, t = 259.83 k
integer, save iovrlw
cloud overlapping control flag for LW
real(kind=kind_phys), dimension(ng12, maf12), public fracrefa
planck fraction mapping level : p = 174.1640 mbar, t= 215.78 k
This module contains plank flux data.
real(kind=kind_phys), dimension(ng03, mfr03), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), dimension(ng11, mmo11), public kb_mo2
the array kb_mxx contains the absorption coefficient for a minor species at the NG11=8 chosen g-value...
integer, parameter nbands
num of total spectral bands
real(kind=kind_phys), dimension(ng03, maf03, mmn03), public ka_mn2o
the array ka_mxxx(NG03,9,19) contains the absorption coefficient for a minor species at the NG03=16 c...
integer, dimension(ngptlw) ngb
band indices for each g-point
real(kind=kind_phys), dimension(ng04, mfr04), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
real(kind=kind_phys), parameter con_amd
molecular wght of dry air ( )
real(kind=kind_phys), dimension(ng10, msb10), public absb
the array absb(NG10,235) = kb(NG10,5,13:59) contains absorption coefs at the NG10=6 chosen g-values f...