Line data Source code
1 : ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_rtrnmc.f90,v $
2 : ! author: $Author: mike $
3 : ! revision: $Revision: 1.3 $
4 : ! created: $Date: 2008/04/24 16:17:28 $
5 : !
6 : module rrtmg_lw_rtrnmc
7 :
8 : ! --------------------------------------------------------------------------
9 : ! | |
10 : ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). |
11 : ! | This software may be used, copied, or redistributed as long as it is |
12 : ! | not sold and this copyright notice is reproduced on each copy made. |
13 : ! | This model is provided as is without any express or implied warranties. |
14 : ! | (http://www.rtweb.aer.com/) |
15 : ! | |
16 : ! --------------------------------------------------------------------------
17 :
18 : ! --------- Modules ----------
19 :
20 : use shr_kind_mod, only: r8 => shr_kind_r8
21 :
22 : use parrrtm, only: mg, nbndlw, ngptlw
23 : use rrlw_con, only: fluxfac, heatfac
24 : use rrlw_wvn, only: delwave, ngb, ngs
25 : use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
26 :
27 : implicit none
28 :
29 : contains
30 :
31 : !-----------------------------------------------------------------------------
32 972000 : subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, &
33 486000 : cldfmc, taucmc, planklay, planklev, plankbnd, &
34 486000 : pwvcm, fracs, taut, &
35 486000 : totuflux, totdflux, fnet, htr, &
36 486000 : totuclfl, totdclfl, fnetc, htrc, totufluxs, totdfluxs )
37 : !-----------------------------------------------------------------------------
38 : !
39 : ! Original version: E. J. Mlawer, et al. RRTM_V3.0
40 : ! Revision for GCMs: Michael J. Iacono; October, 2002
41 : ! Revision for F90: Michael J. Iacono; June, 2006
42 : !
43 : ! This program calculates the upward fluxes, downward fluxes, and
44 : ! heating rates for an arbitrary clear or cloudy atmosphere. The input
45 : ! to this program is the atmospheric profile, all Planck function
46 : ! information, and the cloud fraction by layer. A variable diffusivity
47 : ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9
48 : ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
49 : ! the column water vapor, and other bands use a value of 1.66. The Gaussian
50 : ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that
51 : ! use of the emissivity angle for the flux integration can cause errors of
52 : ! 1 to 4 W/m2 within cloudy layers.
53 : ! Clouds are treated with the McICA stochastic approach and maximum-random
54 : ! cloud overlap.
55 : !***************************************************************************
56 :
57 : ! ------- Declarations -------
58 :
59 : ! ----- Input -----
60 : integer, intent(in) :: nlayers ! total number of layers
61 : integer, intent(in) :: istart ! beginning band of calculation
62 : integer, intent(in) :: iend ! ending band of calculation
63 : integer, intent(in) :: iout ! output option flag
64 :
65 : ! Atmosphere
66 : real(kind=r8), intent(in) :: pz(0:nlayers) ! level (interface) pressures (hPa, mb)
67 : ! Dimensions: (0:nlayers)
68 : real(kind=r8), intent(in) :: pwvcm ! precipitable water vapor (cm)
69 : real(kind=r8), intent(in) :: semiss(nbndlw) ! lw surface emissivity
70 : ! Dimensions: (nbndlw)
71 : real(kind=r8), intent(in) :: planklay(nlayers,nbndlw) !
72 : ! Dimensions: (nlayers,nbndlw)
73 : real(kind=r8), intent(in) :: planklev(0:nlayers,nbndlw) !
74 : ! Dimensions: (0:nlayers,nbndlw)
75 : real(kind=r8), intent(in) :: plankbnd(nbndlw) !
76 : ! Dimensions: (nbndlw)
77 : real(kind=r8), intent(in) :: fracs(nlayers,ngptlw) !
78 : ! Dimensions: (nlayers,ngptw)
79 : real(kind=r8), intent(in) :: taut(nlayers,ngptlw) ! gaseous + aerosol optical depths
80 : ! Dimensions: (nlayers,ngptlw)
81 :
82 : ! Clouds
83 : real(kind=r8), intent(in) :: cldfmc(ngptlw,nlayers) ! layer cloud fraction [mcica]
84 : ! Dimensions: (ngptlw,nlayers)
85 : real(kind=r8), intent(in) :: taucmc(ngptlw,nlayers) ! layer cloud optical depth [mcica]
86 : ! Dimensions: (ngptlw,nlayers)
87 :
88 : ! ----- Output -----
89 : real(kind=r8), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2)
90 : ! Dimensions: (0:nlayers)
91 : real(kind=r8), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2)
92 : ! Dimensions: (0:nlayers)
93 : real(kind=r8), intent(out) :: fnet(0:) ! net longwave flux (w/m2)
94 : ! Dimensions: (0:nlayers)
95 : real(kind=r8), intent(out) :: htr(0:) ! longwave heating rate (k/day)
96 : ! Dimensions: (0:nlayers)
97 : real(kind=r8), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2)
98 : ! Dimensions: (0:nlayers)
99 : real(kind=r8), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2)
100 : ! Dimensions: (0:nlayers)
101 : real(kind=r8), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2)
102 : ! Dimensions: (0:nlayers)
103 : real(kind=r8), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day)
104 : ! Dimensions: (0:nlayers)
105 : real(kind=r8), intent(out) :: totufluxs(:,0:) ! upward longwave flux spectral (w/m2)
106 : ! Dimensions: (nbndlw, 0:nlayers)
107 : real(kind=r8), intent(out) :: totdfluxs(:,0:) ! downward longwave flux spectral (w/m2)
108 : ! Dimensions: (nbndlw, 0:nlayers)
109 :
110 : ! ----- Local -----
111 : ! Declarations for radiative transfer
112 972000 : real(kind=r8) :: abscld(nlayers,ngptlw)
113 972000 : real(kind=r8) :: atot(nlayers)
114 972000 : real(kind=r8) :: atrans(nlayers)
115 972000 : real(kind=r8) :: bbugas(nlayers)
116 972000 : real(kind=r8) :: bbutot(nlayers)
117 972000 : real(kind=r8) :: clrurad(0:nlayers)
118 972000 : real(kind=r8) :: clrdrad(0:nlayers)
119 972000 : real(kind=r8) :: efclfrac(nlayers,ngptlw)
120 972000 : real(kind=r8) :: uflux(0:nlayers)
121 972000 : real(kind=r8) :: dflux(0:nlayers)
122 972000 : real(kind=r8) :: urad(0:nlayers)
123 972000 : real(kind=r8) :: drad(0:nlayers)
124 972000 : real(kind=r8) :: uclfl(0:nlayers)
125 972000 : real(kind=r8) :: dclfl(0:nlayers)
126 972000 : real(kind=r8) :: odcld(nlayers,ngptlw)
127 :
128 :
129 : real(kind=r8) :: secdiff(nbndlw) ! secant of diffusivity angle
130 : real(kind=r8) :: a0(nbndlw),a1(nbndlw),a2(nbndlw) ! diffusivity angle adjustment coefficients
131 : real(kind=r8) :: wtdiff, rec_6
132 : real(kind=r8) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
133 : real(kind=r8) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
134 : real(kind=r8) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
135 : real(kind=r8) :: rad0, reflect, radlu, radclru
136 :
137 972000 : integer :: icldlyr(nlayers) ! flag for cloud in layer
138 : integer :: ibnd, ib, iband, lay, lev, l, ig ! loop indices
139 : integer :: igc ! g-point interval counter
140 : integer :: iclddn ! flag for cloud in down path
141 : integer :: ittot, itgas, itr ! lookup table indices
142 :
143 : ! ------- Definitions -------
144 : ! input
145 : ! nlayers ! number of model layers
146 : ! ngptlw ! total number of g-point subintervals
147 : ! nbndlw ! number of longwave spectral bands
148 : ! secdiff ! diffusivity angle
149 : ! wtdiff ! weight for radiance to flux conversion
150 : ! pavel ! layer pressures (mb)
151 : ! pz ! level (interface) pressures (mb)
152 : ! tavel ! layer temperatures (k)
153 : ! tz ! level (interface) temperatures(mb)
154 : ! tbound ! surface temperature (k)
155 : ! cldfrac ! layer cloud fraction
156 : ! taucloud ! layer cloud optical depth
157 : ! itr ! integer look-up table index
158 : ! icldlyr ! flag for cloudy layers
159 : ! iclddn ! flag for cloud in column at any layer
160 : ! semiss ! surface emissivities for each band
161 : ! reflect ! surface reflectance
162 : ! bpade ! 1/(pade constant)
163 : ! tau_tbl ! clear sky optical depth look-up table
164 : ! exp_tbl ! exponential look-up table for transmittance
165 : ! tfn_tbl ! tau transition function look-up table
166 :
167 : ! local
168 : ! atrans ! gaseous absorptivity
169 : ! abscld ! cloud absorptivity
170 : ! atot ! combined gaseous and cloud absorptivity
171 : ! odclr ! clear sky (gaseous) optical depth
172 : ! odcld ! cloud optical depth
173 : ! odtot ! optical depth of gas and cloud
174 : ! tfacgas ! gas-only pade factor, used for planck fn
175 : ! tfactot ! gas and cloud pade factor, used for planck fn
176 : ! bbdgas ! gas-only planck function for downward rt
177 : ! bbugas ! gas-only planck function for upward rt
178 : ! bbdtot ! gas and cloud planck function for downward rt
179 : ! bbutot ! gas and cloud planck function for upward calc.
180 : ! gassrc ! source radiance due to gas only
181 : ! efclfrac ! effective cloud fraction
182 : ! radlu ! spectrally summed upward radiance
183 : ! radclru ! spectrally summed clear sky upward radiance
184 : ! urad ! upward radiance by layer
185 : ! clrurad ! clear sky upward radiance by layer
186 : ! radld ! spectrally summed downward radiance
187 : ! radclrd ! spectrally summed clear sky downward radiance
188 : ! drad ! downward radiance by layer
189 : ! clrdrad ! clear sky downward radiance by layer
190 :
191 : ! output
192 : ! totuflux ! upward longwave flux (w/m2)
193 : ! totdflux ! downward longwave flux (w/m2)
194 : ! fnet ! net longwave flux (w/m2)
195 : ! htr ! longwave heating rate (k/day)
196 : ! totuclfl ! clear sky upward longwave flux (w/m2)
197 : ! totdclfl ! clear sky downward longwave flux (w/m2)
198 : ! fnetc ! clear sky net longwave flux (w/m2)
199 : ! htrc ! clear sky longwave heating rate (k/day)
200 :
201 :
202 : ! This secant and weight corresponds to the standard diffusivity
203 : ! angle. This initial value is redefined below for some bands.
204 : data wtdiff /0.5_r8/
205 : data rec_6 /0.166667_r8/
206 :
207 : ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
208 : ! and 1.80) as a function of total column water vapor. The function
209 : ! has been defined to minimize flux and cooling rate errors in these bands
210 : ! over a wide range of precipitable water values.
211 : data a0 / 1.66_r8, 1.55_r8, 1.58_r8, 1.66_r8, &
212 : 1.54_r8, 1.454_r8, 1.89_r8, 1.33_r8, &
213 : 1.668_r8, 1.66_r8, 1.66_r8, 1.66_r8, &
214 : 1.66_r8, 1.66_r8, 1.66_r8, 1.66_r8 /
215 : data a1 / 0.00_r8, 0.25_r8, 0.22_r8, 0.00_r8, &
216 : 0.13_r8, 0.446_r8, -0.10_r8, 0.40_r8, &
217 : -0.006_r8, 0.00_r8, 0.00_r8, 0.00_r8, &
218 : 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 /
219 : data a2 / 0.00_r8, -12.0_r8, -11.7_r8, 0.00_r8, &
220 : -0.72_r8,-0.243_r8, 0.19_r8,-0.062_r8, &
221 : 0.414_r8, 0.00_r8, 0.00_r8, 0.00_r8, &
222 : 0.00_r8, 0.00_r8, 0.00_r8, 0.00_r8 /
223 :
224 8262000 : do ibnd = 1,nbndlw
225 8262000 : if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
226 4374000 : secdiff(ibnd) = 1.66_r8
227 : else
228 3402000 : secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm)
229 3402000 : if (secdiff(ibnd) .gt. 1.80_r8) secdiff(ibnd) = 1.80_r8
230 3402000 : if (secdiff(ibnd) .lt. 1.50_r8) secdiff(ibnd) = 1.50_r8
231 : endif
232 : enddo
233 :
234 486000 : urad(0) = 0.0_r8
235 486000 : drad(0) = 0.0_r8
236 486000 : totuflux(0) = 0.0_r8
237 486000 : totdflux(0) = 0.0_r8
238 486000 : clrurad(0) = 0.0_r8
239 486000 : clrdrad(0) = 0.0_r8
240 486000 : totuclfl(0) = 0.0_r8
241 486000 : totdclfl(0) = 0.0_r8
242 :
243 45684000 : do lay = 1, nlayers
244 45198000 : urad(lay) = 0.0_r8
245 45198000 : drad(lay) = 0.0_r8
246 45198000 : totuflux(lay) = 0.0_r8
247 45198000 : totdflux(lay) = 0.0_r8
248 45198000 : clrurad(lay) = 0.0_r8
249 45198000 : clrdrad(lay) = 0.0_r8
250 45198000 : totuclfl(lay) = 0.0_r8
251 45198000 : totdclfl(lay) = 0.0_r8
252 45684000 : icldlyr(lay) = 0
253 : enddo
254 : ! Change to band loop?
255 68526000 : do ig = 1, ngptlw
256 6396246000 : do lay = 1, nlayers
257 6395760000 : if (cldfmc(ig,lay) .eq. 1._r8) then
258 485811632 : ib = ngb(ig)
259 485811632 : odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay)
260 485811632 : transcld = exp(-odcld(lay,ig))
261 485811632 : abscld(lay,ig) = 1._r8 - transcld
262 485811632 : efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay)
263 485811632 : icldlyr(lay) = 1
264 : else
265 5841908368 : odcld(lay,ig) = 0.0_r8
266 5841908368 : abscld(lay,ig) = 0.0_r8
267 5841908368 : efclfrac(lay,ig) = 0.0_r8
268 : endif
269 : enddo
270 :
271 : enddo
272 :
273 486000 : igc = 1
274 : ! Loop over frequency bands.
275 8262000 : do iband = istart, iend
276 :
277 : ! Reinitialize g-point counter for each band if output for each band is requested.
278 7776000 : if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1
279 :
280 : ! Loop over g-channels.
281 : 1000 continue
282 :
283 : ! Radiative transfer starts here.
284 68040000 : radld = 0._r8
285 68040000 : radclrd = 0._r8
286 68040000 : iclddn = 0
287 :
288 : ! Downward radiative transfer loop.
289 :
290 6395760000 : do lev = nlayers, 1, -1
291 6327720000 : plfrac = fracs(lev,igc)
292 6327720000 : blay = planklay(lev,iband)
293 6327720000 : dplankup = planklev(lev,iband) - blay
294 6327720000 : dplankdn = planklev(lev-1,iband) - blay
295 6327720000 : odepth = secdiff(iband) * taut(lev,igc)
296 6327720000 : if (odepth .lt. 0.0_r8) odepth = 0.0_r8
297 : ! Cloudy layer
298 6327720000 : if (icldlyr(lev).eq.1) then
299 872068680 : iclddn = 1
300 872068680 : odtot = odepth + odcld(lev,igc)
301 872068680 : if (odtot .lt. 0.06_r8) then
302 171749977 : atrans(lev) = odepth - 0.5_r8*odepth*odepth
303 171749977 : odepth_rec = rec_6*odepth
304 171749977 : gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
305 :
306 171749977 : atot(lev) = odtot - 0.5_r8*odtot*odtot
307 171749977 : odtot_rec = rec_6*odtot
308 171749977 : bbdtot = plfrac * (blay+dplankdn*odtot_rec)
309 171749977 : bbd = plfrac*(blay+dplankdn*odepth_rec)
310 : radld = radld - radld * (atrans(lev) + &
311 : efclfrac(lev,igc) * (1. - atrans(lev))) + &
312 : gassrc + cldfmc(igc,lev) * &
313 171749977 : (bbdtot * atot(lev) - gassrc)
314 171749977 : drad(lev-1) = drad(lev-1) + radld
315 :
316 171749977 : bbugas(lev) = plfrac * (blay+dplankup*odepth_rec)
317 171749977 : bbutot(lev) = plfrac * (blay+dplankup*odtot_rec)
318 :
319 700318703 : elseif (odepth .le. 0.06_r8) then
320 68576597 : atrans(lev) = odepth - 0.5_r8*odepth*odepth
321 68576597 : odepth_rec = rec_6*odepth
322 68576597 : gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
323 :
324 68576597 : odtot = odepth + odcld(lev,igc)
325 68576597 : tblind = odtot/(bpade+odtot)
326 68576597 : ittot = tblint*tblind + 0.5_r8
327 68576597 : tfactot = tfn_tbl(ittot)
328 68576597 : bbdtot = plfrac * (blay + tfactot*dplankdn)
329 68576597 : bbd = plfrac*(blay+dplankdn*odepth_rec)
330 68576597 : atot(lev) = 1. - exp_tbl(ittot)
331 :
332 : radld = radld - radld * (atrans(lev) + &
333 : efclfrac(lev,igc) * (1._r8 - atrans(lev))) + &
334 : gassrc + cldfmc(igc,lev) * &
335 68576597 : (bbdtot * atot(lev) - gassrc)
336 68576597 : drad(lev-1) = drad(lev-1) + radld
337 :
338 68576597 : bbugas(lev) = plfrac * (blay + dplankup*odepth_rec)
339 68576597 : bbutot(lev) = plfrac * (blay + tfactot * dplankup)
340 :
341 : else
342 :
343 631742106 : tblind = odepth/(bpade+odepth)
344 631742106 : itgas = tblint*tblind+0.5_r8
345 631742106 : odepth = tau_tbl(itgas)
346 631742106 : atrans(lev) = 1._r8 - exp_tbl(itgas)
347 631742106 : tfacgas = tfn_tbl(itgas)
348 631742106 : gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
349 :
350 631742106 : odtot = odepth + odcld(lev,igc)
351 631742106 : tblind = odtot/(bpade+odtot)
352 631742106 : ittot = tblint*tblind + 0.5_r8
353 631742106 : tfactot = tfn_tbl(ittot)
354 631742106 : bbdtot = plfrac * (blay + tfactot*dplankdn)
355 631742106 : bbd = plfrac*(blay+tfacgas*dplankdn)
356 631742106 : atot(lev) = 1._r8 - exp_tbl(ittot)
357 :
358 : radld = radld - radld * (atrans(lev) + &
359 : efclfrac(lev,igc) * (1._r8 - atrans(lev))) + &
360 : gassrc + cldfmc(igc,lev) * &
361 631742106 : (bbdtot * atot(lev) - gassrc)
362 631742106 : drad(lev-1) = drad(lev-1) + radld
363 631742106 : bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
364 631742106 : bbutot(lev) = plfrac * (blay + tfactot * dplankup)
365 : endif
366 : ! Clear layer
367 : else
368 5455651320 : if (odepth .le. 0.06_r8) then
369 3077789662 : atrans(lev) = odepth-0.5_r8*odepth*odepth
370 3077789662 : odepth = rec_6*odepth
371 3077789662 : bbd = plfrac*(blay+dplankdn*odepth)
372 3077789662 : bbugas(lev) = plfrac*(blay+dplankup*odepth)
373 : else
374 2377861658 : tblind = odepth/(bpade+odepth)
375 2377861658 : itr = tblint*tblind+0.5_r8
376 2377861658 : transc = exp_tbl(itr)
377 2377861658 : atrans(lev) = 1._r8-transc
378 2377861658 : tausfac = tfn_tbl(itr)
379 2377861658 : bbd = plfrac*(blay+tausfac*dplankdn)
380 2377861658 : bbugas(lev) = plfrac * (blay + tausfac * dplankup)
381 : endif
382 5455651320 : radld = radld + (bbd-radld)*atrans(lev)
383 5455651320 : drad(lev-1) = drad(lev-1) + radld
384 : endif
385 : ! Set clear sky stream to total sky stream as long as layers
386 : ! remain clear. Streams diverge when a cloud is reached (iclddn=1),
387 : ! and clear sky stream must be computed separately from that point.
388 6395760000 : if (iclddn.eq.1) then
389 1729017360 : radclrd = radclrd + (bbd-radclrd) * atrans(lev)
390 1729017360 : clrdrad(lev-1) = clrdrad(lev-1) + radclrd
391 : else
392 4598702640 : radclrd = radld
393 4598702640 : clrdrad(lev-1) = drad(lev-1)
394 : endif
395 : enddo
396 :
397 : ! Spectral emissivity & reflectance
398 : ! Include the contribution of spectrally varying longwave emissivity
399 : ! and reflection from the surface to the upward radiative transfer.
400 : ! Note: Spectral and Lambertian reflection are identical for the
401 : ! diffusivity angle flux integration used here.
402 :
403 68040000 : rad0 = fracs(1,igc) * plankbnd(iband)
404 : ! Add in specular reflection of surface downward radiance.
405 68040000 : reflect = 1._r8 - semiss(iband)
406 68040000 : radlu = rad0 + reflect * radld
407 68040000 : radclru = rad0 + reflect * radclrd
408 :
409 :
410 : ! Upward radiative transfer loop.
411 68040000 : urad(0) = urad(0) + radlu
412 68040000 : clrurad(0) = clrurad(0) + radclru
413 :
414 6395760000 : do lev = 1, nlayers
415 : ! Cloudy layer
416 6327720000 : if (icldlyr(lev) .eq. 1) then
417 872068680 : gassrc = bbugas(lev) * atrans(lev)
418 : radlu = radlu - radlu * (atrans(lev) + &
419 : efclfrac(lev,igc) * (1._r8 - atrans(lev))) + &
420 : gassrc + cldfmc(igc,lev) * &
421 872068680 : (bbutot(lev) * atot(lev) - gassrc)
422 872068680 : urad(lev) = urad(lev) + radlu
423 : ! Clear layer
424 : else
425 5455651320 : radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
426 5455651320 : urad(lev) = urad(lev) + radlu
427 : endif
428 : ! Set clear sky stream to total sky stream as long as all layers
429 : ! are clear (iclddn=0). Streams must be calculated separately at
430 : ! all layers when a cloud is present (ICLDDN=1), because surface
431 : ! reflectance is different for each stream.
432 6395760000 : if (iclddn.eq.1) then
433 5121312840 : radclru = radclru + (bbugas(lev)-radclru)*atrans(lev)
434 5121312840 : clrurad(lev) = clrurad(lev) + radclru
435 : else
436 1206407160 : radclru = radlu
437 1206407160 : clrurad(lev) = urad(lev)
438 : endif
439 : enddo
440 :
441 : ! Increment g-point counter
442 68040000 : igc = igc + 1
443 : ! Return to continue radiative transfer for all g-channels in present band
444 68040000 : if (igc .le. ngs(iband)) go to 1000
445 :
446 : ! Process longwave output from band for total and clear streams.
447 : ! Calculate upward, downward, and net flux.
448 738720000 : do lev = nlayers, 0, -1
449 730944000 : uflux(lev) = urad(lev)*wtdiff
450 730944000 : dflux(lev) = drad(lev)*wtdiff
451 730944000 : urad(lev) = 0.0_r8
452 730944000 : drad(lev) = 0.0_r8
453 730944000 : uclfl(lev) = clrurad(lev)*wtdiff
454 730944000 : dclfl(lev) = clrdrad(lev)*wtdiff
455 730944000 : clrurad(lev) = 0.0_r8
456 738720000 : clrdrad(lev) = 0.0_r8
457 : enddo
458 :
459 739206000 : do lev = nlayers, 0, -1
460 730944000 : totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband)
461 730944000 : totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband)
462 730944000 : totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband)
463 730944000 : totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband)
464 730944000 : totufluxs(iband,lev) = uflux(lev) * delwave(iband)
465 738720000 : totdfluxs(iband,lev) = dflux(lev) * delwave(iband)
466 : enddo
467 : ! End spectral band loop
468 : enddo
469 :
470 : ! Calculate fluxes at surface
471 486000 : totuflux(0) = totuflux(0) * fluxfac
472 486000 : totdflux(0) = totdflux(0) * fluxfac
473 8262000 : totufluxs(:,0) = totufluxs(:,0) * fluxfac
474 8262000 : totdfluxs(:,0) = totdfluxs(:,0) * fluxfac
475 486000 : fnet(0) = totuflux(0) - totdflux(0)
476 486000 : totuclfl(0) = totuclfl(0) * fluxfac
477 486000 : totdclfl(0) = totdclfl(0) * fluxfac
478 486000 : fnetc(0) = totuclfl(0) - totdclfl(0)
479 :
480 : ! Calculate fluxes at model levels
481 45684000 : do lev = 1, nlayers
482 45198000 : totuflux(lev) = totuflux(lev) * fluxfac
483 45198000 : totdflux(lev) = totdflux(lev) * fluxfac
484 768366000 : totufluxs(:,lev) = totufluxs(:,lev) * fluxfac
485 768366000 : totdfluxs(:,lev) = totdfluxs(:,lev) * fluxfac
486 45198000 : fnet(lev) = totuflux(lev) - totdflux(lev)
487 45198000 : totuclfl(lev) = totuclfl(lev) * fluxfac
488 45198000 : totdclfl(lev) = totdclfl(lev) * fluxfac
489 45198000 : fnetc(lev) = totuclfl(lev) - totdclfl(lev)
490 45198000 : l = lev - 1
491 :
492 : ! Calculate heating rates at model layers
493 45198000 : htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev))
494 45684000 : htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev))
495 : enddo
496 :
497 : ! Set heating rate to zero in top layer
498 486000 : htr(nlayers) = 0.0_r8
499 486000 : htrc(nlayers) = 0.0_r8
500 :
501 486000 : end subroutine rtrnmc
502 :
503 : end module rrtmg_lw_rtrnmc
504 :
|
