GFS Operational Physics Documentation  gsm/branches/DTC/phys-doc-all phys-doc-all R82971
radlw_main.f
Go to the documentation of this file.
1 
4 
5 !!!!! ============================================================== !!!!!
6 !!!!! lw-rrtm3 radiation package description !!!!!
7 !!!!! ============================================================== !!!!!
8 ! !
9 ! this package includes ncep's modifications of the rrtm-lw radiation !
10 ! code from aer inc. !
11 ! !
12 ! the lw-rrtm3 package includes these parts: !
13 ! !
14 ! 'radlw_rrtm3_param.f' !
15 ! 'radlw_rrtm3_datatb.f' !
16 ! 'radlw_rrtm3_main.f' !
17 ! !
18 ! the 'radlw_rrtm3_param.f' contains: !
19 ! !
20 ! 'module_radlw_parameters' -- band parameters set up !
21 ! !
22 ! the 'radlw_rrtm3_datatb.f' contains: !
23 ! !
24 ! 'module_radlw_avplank' -- plank flux data !
25 ! 'module_radlw_ref' -- reference temperature and pressure !
26 ! 'module_radlw_cldprlw' -- cloud property coefficients !
27 ! 'module_radlw_kgbnn' -- absorption coeffients for 16 !
28 ! bands, where nn = 01-16 !
29 ! !
30 ! the 'radlw_rrtm3_main.f' contains: !
31 ! !
32 ! 'module_radlw_main' -- main lw radiation transfer !
33 ! !
34 ! in the main module 'module_radlw_main' there are only two !
35 ! externally callable subroutines: !
36 ! !
37 ! !
38 ! 'lwrad' -- main lw radiation routine !
39 ! inputs: !
40 ! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, !
41 ! clouds,icseed,aerosols,sfemis,sfgtmp, !
42 ! npts, nlay, nlp1, lprnt, !
43 ! outputs: !
44 ! hlwc,topflx,sfcflx, !
45 !! optional outputs: !
46 ! HLW0,HLWB,FLXPRF) !
47 ! !
48 ! 'rlwinit' -- initialization routine !
49 ! inputs: !
50 ! ( me ) !
51 ! outputs: !
52 ! (none) !
53 ! !
54 ! all the lw radiation subprograms become contained subprograms !
55 ! in module 'module_radlw_main' and many of them are not directly !
56 ! accessable from places outside the module. !
57 ! !
58 ! derived data type constructs used: !
59 ! !
60 ! 1. radiation flux at toa: (from module 'module_radlw_parameters') !
61 ! topflw_type - derived data type for toa rad fluxes !
62 ! upfxc total sky upward flux at toa !
63 ! upfx0 clear sky upward flux at toa !
64 ! !
65 ! 2. radiation flux at sfc: (from module 'module_radlw_parameters') !
66 ! sfcflw_type - derived data type for sfc rad fluxes !
67 ! upfxc total sky upward flux at sfc !
68 ! upfx0 clear sky upward flux at sfc !
69 ! dnfxc total sky downward flux at sfc !
70 ! dnfx0 clear sky downward flux at sfc !
71 ! !
72 ! 3. radiation flux profiles(from module 'module_radlw_parameters') !
73 ! proflw_type - derived data type for rad vertical prof !
74 ! upfxc level upward flux for total sky !
75 ! dnfxc level downward flux for total sky !
76 ! upfx0 level upward flux for clear sky !
77 ! dnfx0 level downward flux for clear sky !
78 ! !
79 ! external modules referenced: !
80 ! !
81 ! 'module physparam' !
82 ! 'module physcons' !
83 ! 'mersenne_twister' !
84 ! !
85 ! compilation sequence is: !
86 ! !
87 ! 'radlw_rrtm3_param.f' !
88 ! 'radlw_rrtm3_datatb.f' !
89 ! 'radlw_rrtm3_main.f' !
90 ! !
91 ! and all should be put in front of routines that use lw modules !
92 ! !
93 !==========================================================================!
94 ! !
95 ! the original aer's program declarations: !
96 ! !
97 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
98 ! |
99 ! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). |
100 ! This software may be used, copied, or redistributed as long as it is |
101 ! not sold and this copyright notice is reproduced on each copy made. |
102 ! This model is provided as is without any express or implied warranties. |
103 ! (http://www.rtweb.aer.com/) |
104 ! |
105 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
106 ! !
107 ! ************************************************************************ !
108 ! !
109 ! rrtmg_lw !
110 ! !
111 ! !
112 ! a rapid radiative transfer model !
113 ! for the longwave region !
114 ! for application to general circulation models !
115 ! !
116 ! !
117 ! atmospheric and environmental research, inc. !
118 ! 131 hartwell avenue !
119 ! lexington, ma 02421 !
120 ! !
121 ! eli j. mlawer !
122 ! jennifer s. delamere !
123 ! michael j. iacono !
124 ! shepard a. clough !
125 ! !
126 ! !
127 ! email: miacono@aer.com !
128 ! email: emlawer@aer.com !
129 ! email: jdelamer@aer.com !
130 ! !
131 ! the authors wish to acknowledge the contributions of the !
132 ! following people: steven j. taubman, karen cady-pereira, !
133 ! patrick d. brown, ronald e. farren, luke chen, robert bergstrom. !
134 ! !
135 ! ************************************************************************ !
136 ! !
137 ! references: !
138 ! (rrtm_lw/rrtmg_lw): !
139 ! clough, s.A., m.w. shephard, e.j. mlawer, j.s. delamere, !
140 ! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: !
141 ! atmospheric radiative transfer modeling: a summary of the aer !
142 ! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. !
143 ! !
144 ! mlawer, e.j., s.j. taubman, p.d. brown, m.j. iacono, and s.a. !
145 ! clough: radiative transfer for inhomogeneous atmospheres: rrtm, !
146 ! a validated correlated-k model for the longwave. j. geophys. res., !
147 ! 102, 16663-16682, 1997. !
148 ! !
149 ! (mcica): !
150 ! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, !
151 ! approximation technique for computing radiative transfer in !
152 ! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, !
153 ! doi:10.1029/2002JD003322, 2003. !
154 ! !
155 ! ************************************************************************ !
156 ! !
157 ! aer's revision history: !
158 ! this version of rrtmg_lw has been modified from rrtm_lw to use a !
159 ! reduced set of g-points for application to gcms. !
160 ! !
161 ! -- original version (derived from rrtm_lw), reduction of g-points, !
162 ! other revisions for use with gcms. !
163 ! 1999: m. j. iacono, aer, inc. !
164 ! -- adapted for use with ncar/cam3. !
165 ! may 2004: m. j. iacono, aer, inc. !
166 ! -- revised to add mcica capability. !
167 ! nov 2005: m. j. iacono, aer, inc. !
168 ! -- conversion to f90 formatting for consistency with rrtmg_sw. !
169 ! feb 2007: m. j. iacono, aer, inc. !
170 ! -- modifications to formatting to use assumed-shape arrays. !
171 ! aug 2007: m. j. iacono, aer, inc. !
172 ! !
173 ! ************************************************************************ !
174 ! !
175 ! ncep modifications history log: !
176 ! !
177 ! nov 1999, ken campana -- received the original code from !
178 ! aer (1998 ncar ccm version), updated to link up with !
179 ! ncep mrf model !
180 ! jun 2000, ken campana -- added option to switch random and !
181 ! maximum/random cloud overlap !
182 ! 2001, shrinivas moorthi -- further updates for mrf model !
183 ! may 2001, yu-tai hou -- updated on trace gases and cloud !
184 ! property based on rrtm_v3.0 codes. !
185 ! dec 2001, yu-tai hou -- rewritten code into fortran 90 std !
186 ! set ncep radiation structure standard that contains !
187 ! three plug-in compatable fortran program files: !
188 ! 'radlw_param.f', 'radlw_datatb.f', 'radlw_main.f' !
189 ! fixed bugs in subprograms taugb14, taugb2, etc. added !
190 ! out-of-bounds protections. (a detailed note of !
191 ! up_to_date modifications/corrections by ncep was sent !
192 ! to aer in 2002) !
193 ! jun 2004, yu-tai hou -- added mike iacono's apr 2004 !
194 ! modification of variable diffusivity angles. !
195 ! apr 2005, yu-tai hou -- minor modifications on module !
196 ! structures include rain/snow effect (this version of !
197 ! code was given back to aer in jun 2006) !
198 ! mar 2007, yu-tai hou -- added aerosol effect for ncep !
199 ! models using the generallized aerosol optical property!
200 ! scheme for gfs model. !
201 ! apr 2007, yu-tai hou -- added spectral band heating as an !
202 ! optional output to support the 500 km gfs model's !
203 ! upper stratospheric radiation calculations. and !
204 ! restructure optional outputs for easy access by !
205 ! different models. !
206 ! oct 2008, yu-tai hou -- modified to include new features !
207 ! from aer's newer release v4.4-v4.7, including the !
208 ! mcica sub-grid cloud option. add rain/snow optical !
209 ! properties support to cloudy sky calculations. !
210 ! correct errors in mcica cloud optical properties for !
211 ! ebert & curry scheme (ilwcice=1) that needs band !
212 ! index conversion. simplified and unified sw and lw !
213 ! sub-column cloud subroutines into one module by using !
214 ! optional parameters. !
215 ! mar 2009, yu-tai hou -- replaced the original random number!
216 ! generator coming from the original code with ncep w3 !
217 ! library to simplify the program and moved sub-column !
218 ! cloud subroutines inside the main module. added !
219 ! option of user provided permutation seeds that could !
220 ! be randomly generated from forecast time stamp. !
221 ! oct 2009, yu-tai hou -- modified subrtines "cldprop" and !
222 ! "rlwinit" according updats from aer's rrtmg_lw v4.8. !
223 ! nov 2009, yu-tai hou -- modified subrtine "taumol" according
224 ! updats from aer's rrtmg_lw version 4.82. notice the !
225 ! cloud ice/liquid are assumed as in-cloud quantities, !
226 ! not as grid averaged quantities. !
227 ! jun 2010, yu-tai hou -- optimized code to improve efficiency
228 ! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's!
229 ! cloud-snow optical property scheme. !
230 ! nov 2012, yu-tai hou -- modified control parameters thru !
231 ! module 'physparam'. !
232 ! !
233 !!!!! ============================================================== !!!!!
234 !!!!! end descriptions !!!!!
235 !!!!! ============================================================== !!!!!
236 
237 
277 !========================================!
278  module module_radlw_main !
279 !........................................!
280 !
281  use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, &
282  & isubclw, icldflg, iovrlw, ivflip, &
283  & kind_phys
284  use physcons, only : con_g, con_cp, con_avgd, con_amd, &
285  & con_amw, con_amo3
286  use mersenne_twister, only : random_setseed, random_number, &
287  & random_stat
288 
290 !
291  use module_radlw_avplank, only : totplnk
292  use module_radlw_ref, only : preflog, tref, chi_mls
293 !
294  implicit none
295 !
296  private
297 !
298 ! ... version tag and last revision date
299  character(40), parameter :: &
300  & VTAGLW='NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 '
301 ! & VTAGLW='NCEP LW v5.0 Aug 2012 -RRTMG-LW v4.82 '
302 ! & VTAGLW='RRTMG-LW v4.82 Nov 2009 '
303 ! & VTAGLW='RRTMG-LW v4.8 Oct 2009 '
304 ! & VTAGLW='RRTMG-LW v4.71 Mar 2009 '
305 ! & VTAGLW='RRTMG-LW v4.4 Oct 2008 '
306 ! & VTAGLW='RRTM-LW v2.3g Mar 2007 '
307 ! & VTAGLW='RRTM-LW v2.3g Apr 2004 '
308 
309 ! --- constant values
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 ! pade approx constant
314  real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0
315  real (kind=kind_phys), parameter :: wtdiff = 0.5 ! weight for radiance to flux conversion
316  real (kind=kind_phys), parameter :: tblint = ntbl ! lookup table conversion factor
317  real (kind=kind_phys), parameter :: f_zero = 0.0
318  real (kind=kind_phys), parameter :: f_one = 1.0
319 
320 ! ... atomic weights for conversion from mass to volume mixing ratios
321  real (kind=kind_phys), parameter :: amdw = con_amd/con_amw
322  real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3
323 
324 ! ... band indices
325  integer, dimension(nbands) :: nspa, nspb
326 
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 /
329 
330 ! ... band wavenumber intervals
331 ! real (kind=kind_phys) :: wavenum1(nbands), wavenum2(nbands)
332 ! data wavenum1/ &
333 ! & 10., 350., 500., 630., 700., 820., 980., 1080., &
334 !err & 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2600. /
335 ! & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. /
336 ! data wavenum2/ &
337 ! & 350., 500., 630., 700., 820., 980., 1080., 1180., &
338 !err & 1390., 1480., 1800., 2080., 2250., 2390., 2600., 3250. /
339 ! & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250. /
340 ! real (kind=kind_phys) :: delwave(nbands)
341 ! data delwave / 340., 150., 130., 70., 120., 160., 100., 100., &
342 ! & 210., 90., 320., 280., 170., 130., 220., 650. /
343 
344 ! --- reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
345 ! and 1.80) as a function of total column water vapor. the function
346 ! has been defined to minimize flux and cooling rate errors in these bands
347 ! over a wide range of precipitable water values.
348  real (kind=kind_phys), dimension(nbands) :: a0, a1, a2
349 
350  data a0 / 1.66, 1.55, 1.58, 1.66, 1.54, 1.454, 1.89, 1.33, &
351  & 1.668, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 /
352  data a1 / 0.00, 0.25, 0.22, 0.00, 0.13, 0.446, -0.10, 0.40, &
353  & -0.006, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /
354  data a2 / 0.00, -12.0, -11.7, 0.00, -0.72,-0.243, 0.19,-0.062, &
355  & 0.414, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /
356 
357 !! --- logical flags for optional output fields
358 
359  logical :: lhlwb = .false.
360  logical :: lhlw0 = .false.
361  logical :: lflxprf= .false.
362 
363 ! --- those data will be set up only once by "rlwinit"
364 
365 ! ... fluxfac, heatfac are factors for fluxes (in w/m**2) and heating
366 ! rates (in k/day, or k/sec set by subroutine 'rlwinit')
367 ! semiss0 are default surface emissivity for each bands
368 
369  real (kind=kind_phys) :: fluxfac, heatfac, semiss0(nbands)
370  data semiss0(:) / nbands*1.0 /
371 
372  real (kind=kind_phys) :: tau_tbl(0:ntbl) !clr-sky opt dep (for cldy transfer)
373  real (kind=kind_phys) :: exp_tbl(0:ntbl) !transmittance lookup table
374  real (kind=kind_phys) :: tfn_tbl(0:ntbl) !tau transition function; i.e. the
375  !transition of planck func from mean lyr
376  !temp to lyr boundary temp as a func of
377  !opt dep. "linear in tau" method is used.
378 
379 ! --- the following variables are used for sub-column cloud scheme
380 
381  integer, parameter :: ipsdlw0 = ngptlw ! initial permutation seed
382 
383 ! --- public accessable subprograms
384 
385  public lwrad, rlwinit
386 
387 
388 ! ================
389  contains
390 ! ================
391 
453 ! --------------------------------
454  subroutine lwrad &
455  & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & ! --- inputs
456  & clouds,icseed,aerosols,sfemis,sfgtmp, &
457  & npts, nlay, nlp1, lprnt, &
458  & hlwc,topflx,sfcflx, & ! --- outputs
459  & hlw0,hlwb,flxprf & !! --- optional
460  & )
462 ! ==================== defination of variables ==================== !
463 ! !
464 ! input variables: !
465 ! plyr (npts,nlay) : layer mean pressures (mb) !
466 ! plvl (npts,nlp1) : interface pressures (mb) !
467 ! tlyr (npts,nlay) : layer mean temperature (k) !
468 ! tlvl (npts,nlp1) : interface temperatures (k) !
469 ! qlyr (npts,nlay) : layer specific humidity (gm/gm) *see inside !
470 ! olyr (npts,nlay) : layer ozone concentration (gm/gm) *see inside !
471 ! gasvmr(npts,nlay,:): atmospheric gases amount: !
472 ! (check module_radiation_gases for definition) !
473 ! gasvmr(:,:,1) - co2 volume mixing ratio !
474 ! gasvmr(:,:,2) - n2o volume mixing ratio !
475 ! gasvmr(:,:,3) - ch4 volume mixing ratio !
476 ! gasvmr(:,:,4) - o2 volume mixing ratio !
477 ! gasvmr(:,:,5) - co volume mixing ratio !
478 ! gasvmr(:,:,6) - cfc11 volume mixing ratio !
479 ! gasvmr(:,:,7) - cfc12 volume mixing ratio !
480 ! gasvmr(:,:,8) - cfc22 volume mixing ratio !
481 ! gasvmr(:,:,9) - ccl4 volume mixing ratio !
482 ! clouds(npts,nlay,:): layer cloud profiles: !
483 ! (check module_radiation_clouds for definition) !
484 ! --- for ilwcliq > 0 --- !
485 ! clouds(:,:,1) - layer total cloud fraction !
486 ! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) !
487 ! clouds(:,:,3) - mean eff radius for liq cloud (micron) !
488 ! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) !
489 ! clouds(:,:,5) - mean eff radius for ice cloud (micron) !
490 ! clouds(:,:,6) - layer rain drop water path (g/m**2) !
491 ! clouds(:,:,7) - mean eff radius for rain drop (micron) !
492 ! clouds(:,:,8) - layer snow flake water path (g/m**2) !
493 ! clouds(:,:,9) - mean eff radius for snow flake (micron) !
494 ! --- for ilwcliq = 0 --- !
495 ! clouds(:,:,1) - layer total cloud fraction !
496 ! clouds(:,:,2) - layer cloud optical depth !
497 ! clouds(:,:,3) - layer cloud single scattering albedo !
498 ! clouds(:,:,4) - layer cloud asymmetry factor !
499 ! icseed(npts) : auxiliary special cloud related array !
500 ! when module variable isubclw=2, it provides !
501 ! permutation seed for each column profile that !
502 ! are used for generating random numbers. !
503 ! when isubclw /=2, it will not be used. !
504 ! aerosols(npts,nlay,nbands,:) : aerosol optical properties !
505 ! (check module_radiation_aerosols for definition)!
506 ! (:,:,:,1) - optical depth !
507 ! (:,:,:,2) - single scattering albedo !
508 ! (:,:,:,3) - asymmetry parameter !
509 ! sfemis (npts) : surface emissivity !
510 ! sfgtmp (npts) : surface ground temperature (k) !
511 ! npts : total number of horizontal points !
512 ! nlay, nlp1 : total number of vertical layers, levels !
513 ! lprnt : cntl flag for diagnostic print out !
514 ! !
515 ! output variables: !
516 ! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) !
517 ! topflx(npts) : radiation fluxes at top, component: !
518 ! (check module_radlw_paramters for definition) !
519 ! upfxc - total sky upward flux at top (w/m2) !
520 ! upfx0 - clear sky upward flux at top (w/m2) !
521 ! sfcflx(npts) : radiation fluxes at sfc, component: !
522 ! (check module_radlw_paramters for definition) !
523 ! upfxc - total sky upward flux at sfc (w/m2) !
524 ! upfx0 - clear sky upward flux at sfc (w/m2) !
525 ! dnfxc - total sky downward flux at sfc (w/m2) !
526 ! dnfx0 - clear sky downward flux at sfc (w/m2) !
527 ! !
528 !! optional output variables: !
529 ! hlwb(npts,nlay,nbands): spectral band total sky heating rates !
530 ! hlw0 (npts,nlay): clear sky heating rate (k/day or k/sec) !
531 ! flxprf(npts,nlp1): level radiative fluxes (w/m2), components: !
532 ! (check module_radlw_paramters for definition) !
533 ! upfxc - total sky upward flux !
534 ! dnfxc - total sky dnward flux !
535 ! upfx0 - clear sky upward flux !
536 ! dnfx0 - clear sky dnward flux !
537 ! !
538 ! external module variables: (in physparam) !
539 ! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) !
540 ! =0: do not include rare gases !
541 ! >0: include all rare gases !
542 ! ilwcliq - control flag for liq-cloud optical properties !
543 ! =0: input cloud optical depth, ignor ilwcice !
544 ! =1: input cld liqp & reliq, hu & stamnes (1993) !
545 ! =2: not used !
546 ! ilwcice - control flag for ice-cloud optical properties !
547 ! *** if ilwcliq==0, ilwcice is ignored !
548 ! =1: input cld icep & reice, ebert & curry (1997) !
549 ! =2: input cld icep & reice, streamer (1996) !
550 ! =3: input cld icep & reice, fu (1998) !
551 ! isubclw - sub-column cloud approximation control flag !
552 ! =0: no sub-col cld treatment, use grid-mean cld quantities !
553 ! =1: mcica sub-col, prescribed seeds to get random numbers !
554 ! =2: mcica sub-col, providing array icseed for random numbers!
555 ! iovrlw - cloud overlapping control flag !
556 ! =0: random overlapping clouds !
557 ! =1: maximum/random overlapping clouds !
558 ! =2: maximum overlap cloud (used for isubclw>0 only) !
559 ! ivflip - control flag for vertical index direction !
560 ! =0: vertical index from toa to surface !
561 ! =1: vertical index from surface to toa !
562 ! !
563 ! module parameters, control variables: !
564 ! nbands - number of longwave spectral bands !
565 ! maxgas - maximum number of absorbing gaseous !
566 ! maxxsec - maximum number of cross-sections !
567 ! ngptlw - total number of g-point subintervals !
568 ! ng## - number of g-points in band (##=1-16) !
569 ! ngb(ngptlw) - band indices for each g-point !
570 ! bpade - pade approximation constant (1/0.278) !
571 ! nspa,nspb(nbands)- number of lower/upper ref atm's per band !
572 ! delwave(nbands) - longwave band width (wavenumbers) !
573 ! ipsdlw0 - permutation seed for mcica sub-col clds !
574 ! !
575 ! major local variables: !
576 ! pavel (nlay) - layer pressures (mb) !
577 ! delp (nlay) - layer pressure thickness (mb) !
578 ! tavel (nlay) - layer temperatures (k) !
579 ! tz (0:nlay) - level (interface) temperatures (k) !
580 ! semiss (nbands) - surface emissivity for each band !
581 ! wx (nlay,maxxsec) - cross-section molecules concentration !
582 ! coldry (nlay) - dry air column amount !
583 ! (1.e-20*molecules/cm**2) !
584 ! cldfrc (0:nlp1) - layer cloud fraction !
585 ! taucld (nbands,nlay) - layer cloud optical depth for each band !
586 ! cldfmc (ngptlw,nlay) - layer cloud fraction for each g-point !
587 ! tauaer (nbands,nlay) - aerosol optical depths !
588 ! fracs (ngptlw,nlay) - planck fractions !
589 ! tautot (ngptlw,nlay) - total optical depths (gaseous+aerosols) !
590 ! colamt (nlay,maxgas) - column amounts of absorbing gases !
591 ! 1-maxgas are for watervapor, carbon !
592 ! dioxide, ozone, nitrous oxide, methane, !
593 ! oxigen, carbon monoxide, respectively !
594 ! (molecules/cm**2) !
595 ! pwvcm - column precipitable water vapor (cm) !
596 ! secdiff(nbands) - variable diffusivity angle defined as !
597 ! an exponential function of the column !
598 ! water amount in bands 2-3 and 5-9. !
599 ! this reduces the bias of several w/m2 in !
600 ! downward surface flux in high water !
601 ! profiles caused by using the constant !
602 ! diffusivity angle of 1.66. (mji) !
603 ! facij (nlay) - indicator of interpolation factors !
604 ! =0/1: indicate lower/higher temp & height !
605 ! selffac(nlay) - scale factor for self-continuum, equals !
606 ! (w.v. density)/(atm density at 296K,1013 mb) !
607 ! selffrac(nlay) - factor for temp interpolation of ref !
608 ! self-continuum data !
609 ! indself(nlay) - index of the lower two appropriate ref !
610 ! temp for the self-continuum interpolation !
611 ! forfac (nlay) - scale factor for w.v. foreign-continuum !
612 ! forfrac(nlay) - factor for temp interpolation of ref !
613 ! w.v. foreign-continuum data !
614 ! indfor (nlay) - index of the lower two appropriate ref !
615 ! temp for the foreign-continuum interp !
616 ! laytrop - tropopause layer index at which switch is !
617 ! made from one conbination kew species to !
618 ! another. !
619 ! jp(nlay),jt(nlay),jt1(nlay) !
620 ! - lookup table indexes !
621 ! totuflux(0:nlay) - total-sky upward longwave flux (w/m2) !
622 ! totdflux(0:nlay) - total-sky downward longwave flux (w/m2) !
623 ! htr(nlay) - total-sky heating rate (k/day or k/sec) !
624 ! totuclfl(0:nlay) - clear-sky upward longwave flux (w/m2) !
625 ! totdclfl(0:nlay) - clear-sky downward longwave flux (w/m2) !
626 ! htrcl(nlay) - clear-sky heating rate (k/day or k/sec) !
627 ! fnet (0:nlay) - net longwave flux (w/m2) !
628 ! fnetc (0:nlay) - clear-sky net longwave flux (w/m2) !
629 ! !
630 ! !
631 ! ====================== end of definitions =================== !
632 
633 ! --- inputs:
634  integer, intent(in) :: npts, nlay, nlp1
635  integer, intent(in) :: icseed(npts)
636 
637  logical, intent(in) :: lprnt
638 
639  real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: plvl, &
640  & tlvl
641  real (kind=kind_phys), dimension(npts,nlay), intent(in) :: plyr, &
642  & tlyr, qlyr, olyr
643 
644  real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: gasvmr
645  real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: clouds
646 
647  real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, &
648  & sfgtmp
649 
650  real (kind=kind_phys), dimension(npts,nlay,nbands,3),intent(in):: &
651  & aerosols
652 
653 ! --- outputs:
654  real (kind=kind_phys), dimension(npts,nlay), intent(out) :: hlwc
655 
656  type(topflw_type), dimension(npts), intent(out) :: topflx
657  type(sfcflw_type), dimension(npts), intent(out) :: sfcflx
658 
659 !! --- optional outputs:
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
666 
667 ! --- locals:
668  real (kind=kind_phys), dimension(0:nlp1) :: cldfrc
669 
670  real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, &
671  & totuclfl, totdclfl, tz
672 
673  real (kind=kind_phys), dimension(nlay) :: htr, htrcl
674 
675  real (kind=kind_phys), dimension(nlay) :: pavel, tavel, delp, &
676  & clwp, ciwp, relw, reiw, cda1, cda2, cda3, cda4, &
677  & coldry, colbrd, h2ovmr, o3vmr, fac00, fac01, fac10, fac11, &
678  & selffac, selffrac, forfac, forfrac, minorfrac, scaleminor, &
679  & scaleminorn2, temcol
680 
681  real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay
682 
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, &
686  & cldfmc
687 
688  real (kind=kind_phys), dimension(nbands) :: semiss, secdiff
689 
690 ! --- column amount of absorbing gases:
691 ! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co
692  real (kind=kind_phys) :: colamt(nlay,maxgas)
693 
694 ! --- column cfc cross-section amounts:
695 ! (:,m) m = 1-ccl4, 2-cfc11, 3-cfc12, 4-cfc22
696  real (kind=kind_phys) :: wx(nlay,maxxsec)
697 
698 ! --- reference ratios of binary species parameter in lower atmosphere:
699 ! (:,m,:) m = 1-h2o/co2, 2-h2o/o3, 3-h2o/n2o, 4-h2o/ch4, 5-n2o/co2, 6-o3/co2
700  real (kind=kind_phys) :: rfrate(nlay,nrates,2)
701 
702  real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp
703 
704  integer, dimension(npts) :: ipseed
705  integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor
706  integer :: laytrop, iplon, i, j, k, k1
707  logical :: lcf1
708 
709 !
710 !===> ... begin here
711 !
712 
713 ! --- ... initialization
714 
715  lhlwb = present ( hlwb )
716  lhlw0 = present ( hlw0 )
717  lflxprf= present ( flxprf )
718 
719 
720  colamt(:,:) = f_zero
721 
724 
725  if ( isubclw == 1 ) then ! advance prescribed permutation seed
726  do i = 1, npts
727  ipseed(i) = ipsdlw0 + i
728  enddo
729  elseif ( isubclw == 2 ) then ! use input array of permutaion seeds
730  do i = 1, npts
731  ipseed(i) = icseed(i)
732  enddo
733  endif
734 
735 ! if ( lprnt ) then
736 ! print *,' In radlw, isubclw, ipsdlw0,ipseed =', &
737 ! & isubclw, ipsdlw0, ipseed
738 ! endif
739 
740 ! --- ... loop over horizontal npts profiles
741 
742  lab_do_iplon : do iplon = 1, npts
743 
745  if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0) then ! input surface emissivity
746  do j = 1, nbands
747  semiss(j) = sfemis(iplon)
748  enddo
749  else ! use default values
750  do j = 1, nbands
751  semiss(j) = semiss0(j)
752  enddo
753  endif
754 
755  stemp = sfgtmp(iplon) ! surface ground temp
756 
758 ! the vertical index of internal array is from surface to top
759 
760 ! --- ... molecular amounts are input or converted to volume mixing ratio
761 ! and later then converted to molecular amount (molec/cm2) by the
762 ! dry air column coldry (in molec/cm2) which is calculated from the
763 ! layer pressure thickness (in mb), based on the hydrostatic equation
764 ! --- ... and includes a correction to account for h2o in the layer.
765 
766  if (ivflip == 0) then ! input from toa to sfc
767 
768  tem1 = 100.0 * con_g
769  tem2 = 1.0e-20 * 1.0e3 * con_avgd
770  tz(0) = tlvl(iplon,nlp1)
771 
772  do k = 1, nlay
773  k1 = nlp1 - k
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)
778 
780 
781 !test use
782 ! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)*amdw) ! input mass mixing ratio
783 ! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)) ! input vol mixing ratio
784 ! o3vmr (k)= max(f_zero,olyr(iplon,k1)) ! input vol mixing ratio
785 !ncep model use
786  h2ovmr(k)= max(f_zero,qlyr(iplon,k1) &
787  & *amdw/(f_one-qlyr(iplon,k1))) ! input specific humidity
788  o3vmr(k)= max(f_zero,olyr(iplon,k1)*amdo3) ! input mass mixing ratio
789 
790 ! --- ... tem0 is the molecular weight of moist air
791  tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw
792  coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k)))
793  temcol(k) = 1.0e-12 * coldry(k)
794 
795  colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o
796  colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k1,1)) ! co2
797  colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3
798  enddo
799 
803 
804  if (ilwrgas > 0) then
805  do k = 1, nlay
806  k1 = nlp1 - k
807  colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,2)) ! n2o
808  colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,3)) ! ch4
809  colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k1,4)) ! o2
810  colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k1,5)) ! co
811 
812  wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k1,9) ) ! ccl4
813  wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k1,6) ) ! cf11
814  wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k1,7) ) ! cf12
815  wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k1,8) ) ! cf22
816  enddo
817  else
818  do k = 1, nlay
819  colamt(k,4) = f_zero ! n2o
820  colamt(k,5) = f_zero ! ch4
821  colamt(k,6) = f_zero ! o2
822  colamt(k,7) = f_zero ! co
823 
824  wx(k,1) = f_zero
825  wx(k,2) = f_zero
826  wx(k,3) = f_zero
827  wx(k,4) = f_zero
828  enddo
829  endif
830 
832 
833  do k = 1, nlay
834  k1 = nlp1 - k
835  do j = 1, nbands
836  tauaer(j,k) = aerosols(iplon,k1,j,1) &
837  & * (f_one - aerosols(iplon,k1,j,2))
838  enddo
839  enddo
840 
842  if (ilwcliq > 0) then ! use prognostic cloud method
843  do k = 1, nlay
844  k1 = nlp1 - k
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)
854  enddo
855  else ! use diagnostic cloud method
856  do k = 1, nlay
857  k1 = nlp1 - k
858  cldfrc(k)= clouds(iplon,k1,1)
859  cda1(k) = clouds(iplon,k1,2)
860  enddo
861  endif ! end if_ilwcliq
862 
863  cldfrc(0) = f_one ! padding value only
864  cldfrc(nlp1) = f_zero ! padding value only
865 
867 
868  tem1 = f_zero
869  tem2 = f_zero
870  do k = 1, nlay
871  tem1 = tem1 + coldry(k) + colamt(k,1)
872  tem2 = tem2 + colamt(k,1)
873  enddo
874 
875  tem0 = 10.0 * tem2 / (amdw * tem1 * con_g)
876  pwvcm = tem0 * plvl(iplon,nlp1)
877 
878  else ! input from sfc to toa
879 
880  tem1 = 100.0 * con_g
881  tem2 = 1.0e-20 * 1.0e3 * con_avgd
882  tz(0) = tlvl(iplon,1)
883 
884  do k = 1, nlay
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)
889 
890 ! --- ... set absorber amount
891 !test use
892 ! h2ovmr(k)= max(f_zero,qlyr(iplon,k)*amdw) ! input mass mixing ratio
893 ! h2ovmr(k)= max(f_zero,qlyr(iplon,k)) ! input vol mixing ratio
894 ! o3vmr (k)= max(f_zero,olyr(iplon,k)) ! input vol mixing ratio
895 !ncep model use
896  h2ovmr(k)= max(f_zero,qlyr(iplon,k) &
897  & *amdw/(f_one-qlyr(iplon,k))) ! input specific humidity
898  o3vmr(k)= max(f_zero,olyr(iplon,k)*amdo3) ! input mass mixing ratio
899 
900 ! --- ... tem0 is the molecular weight of moist air
901  tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw
902  coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k)))
903  temcol(k) = 1.0e-12 * coldry(k)
904 
905  colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o
906  colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k,1)) ! co2
907  colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3
908  enddo
909 
910 ! --- ... set up col amount for rare gases, convert from volume mixing ratio
911 ! to molec/cm2 based on coldry (scaled to 1.0e-20)
912 
913  if (ilwrgas > 0) then
914  do k = 1, nlay
915  colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k,2)) ! n2o
916  colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k,3)) ! ch4
917  colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k,4)) ! o2
918  colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k,5)) ! co
919 
920  wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k,9) ) ! ccl4
921  wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k,6) ) ! cf11
922  wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k,7) ) ! cf12
923  wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k,8) ) ! cf22
924  enddo
925  else
926  do k = 1, nlay
927  colamt(k,4) = f_zero ! n2o
928  colamt(k,5) = f_zero ! ch4
929  colamt(k,6) = f_zero ! o2
930  colamt(k,7) = f_zero ! co
931 
932  wx(k,1) = f_zero
933  wx(k,2) = f_zero
934  wx(k,3) = f_zero
935  wx(k,4) = f_zero
936  enddo
937  endif
938 
939 ! --- ... set aerosol optical properties
940 
941  do j = 1, nbands
942  do k = 1, nlay
943  tauaer(j,k) = aerosols(iplon,k,j,1) &
944  & * (f_one - aerosols(iplon,k,j,2))
945  enddo
946  enddo
947 
948  if (ilwcliq > 0) then ! use prognostic cloud method
949  do k = 1, nlay
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)
959  enddo
960  else ! use diagnostic cloud method
961  do k = 1, nlay
962  cldfrc(k)= clouds(iplon,k,1)
963  cda1(k) = clouds(iplon,k,2)
964  enddo
965  endif ! end if_ilwcliq
966 
967  cldfrc(0) = f_one ! padding value only
968  cldfrc(nlp1) = f_zero ! padding value only
969 
970 ! --- ... compute precipitable water vapor for diffusivity angle adjustments
971 
972  tem1 = f_zero
973  tem2 = f_zero
974  do k = 1, nlay
975  tem1 = tem1 + coldry(k) + colamt(k,1)
976  tem2 = tem2 + colamt(k,1)
977  enddo
978 
979  tem0 = 10.0 * tem2 / (amdw * tem1 * con_g)
980  pwvcm = tem0 * plvl(iplon,1)
981 
982  endif ! if_ivflip
983 
985 
986  do k = 1, nlay
987  summol = f_zero
988  do i = 2, maxgas
989  summol = summol + colamt(k,i)
990  enddo
991  colbrd(k) = coldry(k) - summol
992  enddo
993 
995 
996  tem1 = 1.80
997  tem2 = 1.50
998  do j = 1, nbands
999  if (j==1 .or. j==4 .or. j==10) then
1000  secdiff(j) = 1.66
1001  else
1002  secdiff(j) = min( tem1, max( tem2, &
1003  & a0(j)+a1(j)*exp(a2(j)*pwvcm) ))
1004  endif
1005  enddo
1006 
1007 ! if (lprnt) then
1008 ! print *,' coldry',coldry
1009 ! print *,' wx(*,1) ',(wx(k,1),k=1,NLAY)
1010 ! print *,' wx(*,2) ',(wx(k,2),k=1,NLAY)
1011 ! print *,' wx(*,3) ',(wx(k,3),k=1,NLAY)
1012 ! print *,' wx(*,4) ',(wx(k,4),k=1,NLAY)
1013 ! print *,' iplon ',iplon
1014 ! print *,' pavel ',pavel
1015 ! print *,' delp ',delp
1016 ! print *,' tavel ',tavel
1017 ! print *,' tz ',tz
1018 ! print *,' h2ovmr ',h2ovmr
1019 ! print *,' o3vmr ',o3vmr
1020 ! endif
1021 
1024 
1025  lcf1 = .false.
1026  lab_do_k0 : do k = 1, nlay
1027  if ( cldfrc(k) > eps ) then
1028  lcf1 = .true.
1029  exit lab_do_k0
1030  endif
1031  enddo lab_do_k0
1032 
1033  if ( lcf1 ) then
1034 
1035  call cldprop &
1036 ! --- inputs:
1037  & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, &
1038  & nlay, nlp1, ipseed(iplon), &
1039 ! --- outputs:
1040  & cldfmc, taucld &
1041  & )
1042 
1043  else
1044  cldfmc = f_zero
1045  taucld = f_zero
1046  endif
1047 
1048 ! if (lprnt) then
1049 ! print *,' after cldprop'
1050 ! print *,' clwp',clwp
1051 ! print *,' ciwp',ciwp
1052 ! print *,' relw',relw
1053 ! print *,' reiw',reiw
1054 ! print *,' taucl',cda1
1055 ! print *,' cldfrac',cldfrc
1056 ! endif
1057 
1060  call setcoef &
1061 ! --- inputs:
1062  & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, &
1063  & nlay, nlp1, &
1064 ! --- outputs:
1065  & laytrop,pklay,pklev,jp,jt,jt1, &
1066  & rfrate,fac00,fac01,fac10,fac11, &
1067  & selffac,selffrac,indself,forfac,forfrac,indfor, &
1068  & minorfrac,scaleminor,scaleminorn2,indminor &
1069  & )
1070 
1071 ! if (lprnt) then
1072 ! print *,'laytrop',laytrop
1073 ! print *,'colh2o',(colamt(k,1),k=1,NLAY)
1074 ! print *,'colco2',(colamt(k,2),k=1,NLAY)
1075 ! print *,'colo3', (colamt(k,3),k=1,NLAY)
1076 ! print *,'coln2o',(colamt(k,4),k=1,NLAY)
1077 ! print *,'colch4',(colamt(k,5),k=1,NLAY)
1078 ! print *,'fac00',fac00
1079 ! print *,'fac01',fac01
1080 ! print *,'fac10',fac10
1081 ! print *,'fac11',fac11
1082 ! print *,'jp',jp
1083 ! print *,'jt',jt
1084 ! print *,'jt1',jt1
1085 ! print *,'selffac',selffac
1086 ! print *,'selffrac',selffrac
1087 ! print *,'indself',indself
1088 ! print *,'forfac',forfac
1089 ! print *,'forfrac',forfrac
1090 ! print *,'indfor',indfor
1091 ! endif
1092 
1095 
1096  call taumol &
1097 ! --- inputs:
1098  & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, &
1099  & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, &
1100  & selffac,selffrac,indself,forfac,forfrac,indfor, &
1101  & minorfrac,scaleminor,scaleminorn2,indminor, &
1102  & nlay, &
1103 ! --- outputs:
1104  & fracs, tautot &
1105  & )
1106 
1107 ! if (lprnt) then
1108 ! print *,' after taumol'
1109 ! do k = 1, nlay
1110 ! write(6,121) k
1111 !121 format(' k =',i3,5x,'FRACS')
1112 ! write(6,122) (fracs(j,k),j=1,ngptlw)
1113 !122 format(10e14.7)
1114 ! write(6,123) k
1115 !123 format(' k =',i3,5x,'TAUTOT')
1116 ! write(6,122) (tautot(j,k),j=1,ngptlw)
1117 ! enddo
1118 ! endif
1119 
1129 
1130  if (isubclw <= 0) then
1131 
1132  if (iovrlw <= 0) then
1133 
1134  call rtrn &
1135 ! --- inputs:
1136  & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &
1137  & fracs,secdiff,nlay,nlp1, &
1138 ! --- outputs:
1139  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb &
1140  & )
1141 
1142  else
1143 
1144  call rtrnmr &
1145 ! --- inputs:
1146  & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &
1147  & fracs,secdiff,nlay,nlp1, &
1148 ! --- outputs:
1149  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb &
1150  & )
1151 
1152  endif ! end if_iovrlw_block
1153 
1154  else
1155 
1156  call rtrnmc &
1157 ! --- inputs:
1158  & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, &
1159  & fracs,secdiff,nlay,nlp1, &
1160 ! --- outputs:
1161  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb &
1162  & )
1163 
1164  endif ! end if_isubclw_block
1165 
1167 
1168  topflx(iplon)%upfxc = totuflux(nlay)
1169  topflx(iplon)%upfx0 = totuclfl(nlay)
1170 
1171  sfcflx(iplon)%upfxc = totuflux(0)
1172  sfcflx(iplon)%upfx0 = totuclfl(0)
1173  sfcflx(iplon)%dnfxc = totdflux(0)
1174  sfcflx(iplon)%dnfx0 = totdclfl(0)
1175 
1176  if (ivflip == 0) then ! output from toa to sfc
1177 
1178 !! --- ... optional fluxes
1179  if ( lflxprf ) then
1180  do k = 0, nlay
1181  k1 = nlp1 - k
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)
1186  enddo
1187  endif
1188 
1189  do k = 1, nlay
1190  k1 = nlp1 - k
1191  hlwc(iplon,k1) = htr(k)
1192  enddo
1193 
1194 !! --- ... optional clear sky heating rate
1195  if ( lhlw0 ) then
1196  do k = 1, nlay
1197  k1 = nlp1 - k
1198  hlw0(iplon,k1) = htrcl(k)
1199  enddo
1200  endif
1201 
1202 !! --- ... optional spectral band heating rate
1203  if ( lhlwb ) then
1204  do j = 1, nbands
1205  do k = 1, nlay
1206  k1 = nlp1 - k
1207  hlwb(iplon,k1,j) = htrb(k,j)
1208  enddo
1209  enddo
1210  endif
1211 
1212  else ! output from sfc to toa
1213 
1214 !! --- ... optional fluxes
1215  if ( lflxprf ) then
1216  do k = 0, nlay
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)
1221  enddo
1222  endif
1223 
1224  do k = 1, nlay
1225  hlwc(iplon,k) = htr(k)
1226  enddo
1227 
1228 !! --- ... optional clear sky heating rate
1229  if ( lhlw0 ) then
1230  do k = 1, nlay
1231  hlw0(iplon,k) = htrcl(k)
1232  enddo
1233  endif
1234 
1235 !! --- ... optional spectral band heating rate
1236  if ( lhlwb ) then
1237  do j = 1, nbands
1238  do k = 1, nlay
1239  hlwb(iplon,k,j) = htrb(k,j)
1240  enddo
1241  enddo
1242  endif
1243 
1244  endif ! if_ivflip
1245 
1246  enddo lab_do_iplon
1247 
1248 !...................................
1249  end subroutine lwrad
1250 !-----------------------------------
1252 
1253 
1254 
1260 !-----------------------------------
1261  subroutine rlwinit &
1262  & ( me ) ! --- inputs
1263 ! --- outputs: (none)
1264 
1265 ! =================== program usage description =================== !
1266 ! !
1267 ! purpose: initialize non-varying module variables, conversion factors,!
1268 ! and look-up tables. !
1269 ! !
1270 ! subprograms called: none !
1271 ! !
1272 ! ==================== defination of variables ==================== !
1273 ! !
1274 ! inputs: !
1275 ! me - print control for parallel process !
1276 ! !
1277 ! outputs: (none) !
1278 ! !
1279 ! external module variables: (in physparam) !
1280 ! ilwrate - heating rate unit selections !
1281 ! =1: output in k/day !
1282 ! =2: output in k/second !
1283 ! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) !
1284 ! =0: do not include rare gases !
1285 ! >0: include all rare gases !
1286 ! ilwcliq - liquid cloud optical properties contrl flag !
1287 ! =0: input cloud opt depth from diagnostic scheme !
1288 ! >0: input cwp,rew, and other cloud content parameters !
1289 ! isubclw - sub-column cloud approximation control flag !
1290 ! =0: no sub-col cld treatment, use grid-mean cld quantities !
1291 ! =1: mcica sub-col, prescribed seeds to get random numbers !
1292 ! =2: mcica sub-col, providing array icseed for random numbers!
1293 ! icldflg - cloud scheme control flag !
1294 ! =0: diagnostic scheme gives cloud tau, omiga, and g. !
1295 ! =1: prognostic scheme gives cloud liq/ice path, etc. !
1296 ! iovrlw - clouds vertical overlapping control flag !
1297 ! =0: random overlapping clouds !
1298 ! =1: maximum/random overlapping clouds !
1299 ! =2: maximum overlap cloud (isubcol>0 only) !
1300 ! !
1301 ! ******************************************************************* !
1302 ! original code description !
1303 ! !
1304 ! original version: michael j. iacono; july, 1998 !
1305 ! first revision for ncar ccm: september, 1998 !
1306 ! second revision for rrtm_v3.0: september, 2002 !
1307 ! !
1308 ! this subroutine performs calculations necessary for the initialization
1309 ! of the longwave model. lookup tables are computed for use in the lw !
1310 ! radiative transfer, and input absorption coefficient data for each !
1311 ! spectral band are reduced from 256 g-point intervals to 140. !
1312 ! !
1313 ! ******************************************************************* !
1314 ! !
1315 ! definitions: !
1316 ! arrays for 10000-point look-up tables: !
1317 ! tau_tbl - clear-sky optical depth (used in cloudy radiative transfer!
1318 ! exp_tbl - exponential lookup table for tansmittance !
1319 ! tfn_tbl - tau transition function; i.e. the transition of the Planck!
1320 ! function from that for the mean layer temperature to that !
1321 ! for the layer boundary temperature as a function of optical
1322 ! depth. the "linear in tau" method is used to make the table
1323 ! !
1324 ! ******************************************************************* !
1325 ! !
1326 ! ====================== end of description block ================= !
1327 
1328 ! --- inputs:
1329  integer, intent(in) :: me
1330 
1331 ! --- outputs: none
1332 
1333 ! --- locals:
1334  real (kind=kind_phys), parameter :: expeps = 1.e-20
1335 
1336  real (kind=kind_phys) :: tfn, pival, explimit
1337 
1338  integer :: i
1339 
1340 !
1341 !===> ... begin here
1342 !
1343  if ( iovrlw<0 .or. iovrlw>2 ) then
1344  print *,' *** Error in specification of cloud overlap flag', &
1345  & ' IOVRLW=',iovrlw,' in RLWINIT !!'
1346  stop
1347  elseif ( iovrlw==2 .and. isubclw==0 ) then
1348  if (me == 0) then
1349  print *,' *** IOVRLW=2 - maximum cloud overlap, is not yet', &
1350  & ' available for ISUBCLW=0 setting!!'
1351  print *,' The program uses maximum/random overlap', &
1352  & ' instead.'
1353  endif
1354 
1355  iovrlw = 1
1356  endif
1357 
1358  if (me == 0) then
1359  print *,' - Using AER Longwave Radiation, Version: ', vtaglw
1360 
1361  if (ilwrgas > 0) then
1362  print *,' --- Include rare gases N2O, CH4, O2, CFCs ', &
1363  & 'absorptions in LW'
1364  else
1365  print *,' --- Rare gases effect is NOT included in LW'
1366  endif
1367 
1368  if ( isubclw == 0 ) then
1369  print *,' --- Using standard grid average clouds, no ', &
1370  & 'sub-column clouds approximation applied'
1371  elseif ( isubclw == 1 ) then
1372  print *,' --- Using MCICA sub-colum clouds approximation ', &
1373  & 'with a prescribed sequence of permutaion seeds'
1374  elseif ( isubclw == 2 ) then
1375  print *,' --- Using MCICA sub-colum clouds approximation ', &
1376  & 'with provided input array of permutation seeds'
1377  else
1378  print *,' *** Error in specification of sub-column cloud ', &
1379  & ' control flag isubclw =',isubclw,' !!'
1380  stop
1381  endif
1382  endif
1383 
1384 ! --- ... check cloud flags for consistency
1385 
1386  if ((icldflg == 0 .and. ilwcliq /= 0) .or. &
1387  & (icldflg == 1 .and. ilwcliq == 0)) then
1388  print *,' *** Model cloud scheme inconsistent with LW', &
1389  & ' radiation cloud radiative property setup !!'
1390  stop
1391  endif
1392 
1393 ! --- ... setup default surface emissivity for each band here
1394 
1395  semiss0(:) = f_one
1396 
1397 ! --- ... setup constant factors for flux and heating rate
1398 ! the 1.0e-2 is to convert pressure from mb to N/m**2
1399 
1400  pival = 2.0 * asin(f_one)
1401  fluxfac = pival * 2.0d4
1402 ! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4
1403 
1404  if (ilwrate == 1) then
1405 ! heatfac = 8.4391
1406 ! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day)
1407  heatfac = con_g * 864.0 / con_cp ! (in k/day)
1408  else
1409  heatfac = con_g * 1.0e-2 / con_cp ! (in k/second)
1410  endif
1411 
1412 ! --- ... compute lookup tables for transmittance, tau transition
1413 ! function, and clear sky tau (for the cloudy sky radiative
1414 ! transfer). tau is computed as a function of the tau
1415 ! transition function, transmittance is calculated as a
1416 ! function of tau, and the tau transition function is
1417 ! calculated using the linear in tau formulation at values of
1418 ! tau above 0.01. tf is approximated as tau/6 for tau < 0.01.
1419 ! all tables are computed at intervals of 0.001. the inverse
1420 ! of the constant used in the pade approximation to the tau
1421 ! transition function is set to b.
1422 
1423  tau_tbl(0) = f_zero
1424  exp_tbl(0) = f_one
1425  tfn_tbl(0) = f_zero
1426 
1427  tau_tbl(ntbl) = 1.e10
1428  exp_tbl(ntbl) = expeps
1429  tfn_tbl(ntbl) = f_one
1430 
1431  explimit = aint( -log(tiny(exp_tbl(0))) )
1432 
1433  do i = 1, ntbl-1
1434 !org tfn = float(i) / float(ntbl)
1435 !org tau_tbl(i) = bpade * tfn / (f_one - tfn)
1436  tfn = real(i, kind_phys) / real(ntbl-i, kind_phys)
1437  tau_tbl(i) = bpade * tfn
1438  if (tau_tbl(i) >= explimit) then
1439  exp_tbl(i) = expeps
1440  else
1441  exp_tbl(i) = exp( -tau_tbl(i) )
1442  endif
1443 
1444  if (tau_tbl(i) < 0.06) then
1445  tfn_tbl(i) = tau_tbl(i) / 6.0
1446  else
1447  tfn_tbl(i) = f_one - 2.0*( (f_one / tau_tbl(i)) &
1448  & - ( exp_tbl(i) / (f_one - exp_tbl(i)) ) )
1449  endif
1450  enddo
1451 
1452 !...................................
1453  end subroutine rlwinit
1454 !-----------------------------------
1455 
1456 
1485 ! ----------------------------
1486  subroutine cldprop &
1487  & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs
1488  & nlay, nlp1, ipseed, &
1489  & cldfmc, taucld & ! --- outputs
1490  & )
1492 ! =================== program usage description =================== !
1493 ! !
1494 ! purpose: compute the cloud optical depth(s) for each cloudy layer !
1495 ! and g-point interval. !
1496 ! !
1497 ! subprograms called: none !
1498 ! !
1499 ! ==================== defination of variables ==================== !
1500 ! !
1501 ! inputs: -size- !
1502 ! cfrac - real, layer cloud fraction 0:nlp1 !
1503 ! ..... for ilwcliq > 0 (prognostic cloud sckeme) - - - !
1504 ! cliqp - real, layer in-cloud liq water path (g/m**2) nlay !
1505 ! reliq - real, mean eff radius for liq cloud (micron) nlay !
1506 ! cicep - real, layer in-cloud ice water path (g/m**2) nlay !
1507 ! reice - real, mean eff radius for ice cloud (micron) nlay !
1508 ! cdat1 - real, layer rain drop water path (g/m**2) nlay !
1509 ! cdat2 - real, effective radius for rain drop (microm) nlay !
1510 ! cdat3 - real, layer snow flake water path (g/m**2) nlay !
1511 ! cdat4 - real, effective radius for snow flakes (micron) nlay !
1512 ! ..... for ilwcliq = 0 (diagnostic cloud sckeme) - - - !
1513 ! cdat1 - real, input cloud optical depth nlay !
1514 ! cdat2 - real, layer cloud single scattering albedo nlay !
1515 ! cdat3 - real, layer cloud asymmetry factor nlay !
1516 ! cdat4 - real, optional use nlay !
1517 ! cliqp - not used nlay !
1518 ! reliq - not used nlay !
1519 ! cicep - not used nlay !
1520 ! reice - not used nlay !
1521 ! !
1522 ! nlay - integer, number of vertical layers 1 !
1523 ! nlp1 - integer, number of vertical levels 1 !
1524 ! ipseed- permutation seed for generating random numbers (isubclw>0) !
1525 ! !
1526 ! outputs: !
1527 ! cldfmc - real, cloud fraction for each sub-column ngptlw*nlay!
1528 ! taucld - real, cld opt depth for bands (non-mcica) nbands*nlay!
1529 ! !
1530 ! explanation of the method for each value of ilwcliq, and ilwcice. !
1531 ! set up in module "module_radlw_cntr_para" !
1532 ! !
1533 ! ilwcliq=0 : input cloud optical property (tau, ssa, asy). !
1534 ! (used for diagnostic cloud method) !
1535 ! ilwcliq>0 : input cloud liq/ice path and effective radius, also !
1536 ! require the user of 'ilwcice' to specify the method !
1537 ! used to compute aborption due to water/ice parts. !
1538 ! ................................................................... !
1539 ! !
1540 ! ilwcliq=1: the water droplet effective radius (microns) is input!
1541 ! and the opt depths due to water clouds are computed !
1542 ! as in hu and stamnes, j., clim., 6, 728-742, (1993). !
1543 ! the values for absorption coefficients appropriate for
1544 ! the spectral bands in rrtm have been obtained for a !
1545 ! range of effective radii by an averaging procedure !
1546 ! based on the work of j. pinto (private communication).
1547 ! linear interpolation is used to get the absorption !
1548 ! coefficients for the input effective radius. !
1549 ! !
1550 ! ilwcice=1: the cloud ice path (g/m2) and ice effective radius !
1551 ! (microns) are input and the optical depths due to ice!
1552 ! clouds are computed as in ebert and curry, jgr, 97, !
1553 ! 3831-3836 (1992). the spectral regions in this work !
1554 ! have been matched with the spectral bands in rrtm to !
1555 ! as great an extent as possible: !
1556 ! e&c 1 ib = 5 rrtm bands 9-16 !
1557 ! e&c 2 ib = 4 rrtm bands 6-8 !
1558 ! e&c 3 ib = 3 rrtm bands 3-5 !
1559 ! e&c 4 ib = 2 rrtm band 2 !
1560 ! e&c 5 ib = 1 rrtm band 1 !
1561 ! ilwcice=2: the cloud ice path (g/m2) and ice effective radius !
1562 ! (microns) are input and the optical depths due to ice!
1563 ! clouds are computed as in rt code, streamer v3.0 !
1564 ! (ref: key j., streamer user's guide, cooperative !
1565 ! institute for meteorological satellite studies, 2001,!
1566 ! 96 pp.) valid range of values for re are between 5.0 !
1567 ! and 131.0 micron. !
1568 ! ilwcice=3: the ice generalized effective size (dge) is input and!
1569 ! the optical properties, are calculated as in q. fu, !
1570 ! j. climate, (1998). q. fu provided high resolution !
1571 ! tales which were appropriately averaged for the bands!
1572 ! in rrtm_lw. linear interpolation is used to get the !
1573 ! coeff from the stored tables. valid range of values !
1574 ! for deg are between 5.0 and 140.0 micron. !
1575 ! !
1576 ! other cloud control module variables: !
1577 ! isubclw =0: standard cloud scheme, no sub-col cloud approximation !
1578 ! >0: mcica sub-col cloud scheme using ipseed as permutation!
1579 ! seed for generating rundom numbers !
1580 ! !
1581 ! ====================== end of description block ================= !
1582 !
1584 
1585 ! --- inputs:
1586  integer, intent(in) :: nlay, nlp1, ipseed
1587 
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
1591 
1592 ! --- outputs:
1593  real (kind=kind_phys), dimension(ngptlw,nlay),intent(out):: cldfmc
1594  real (kind=kind_phys), dimension(nbands,nlay),intent(out):: taucld
1595 
1596 ! --- locals:
1597  real (kind=kind_phys), dimension(nbands) :: tauliq, tauice
1598  real (kind=kind_phys), dimension(nlay) :: cldf
1599 
1600  real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, &
1601  & cldliq, refliq, cldice, refice
1602 
1603  logical :: lcloudy(ngptlw,nlay)
1604  integer :: ia, ib, ig, k, index
1605 
1606 !
1607 !===> ... begin here
1608 !
1609  do k = 1, nlay
1610  do ib = 1, nbands
1611  taucld(ib,k) = f_zero
1612  enddo
1613  enddo
1614 
1615  do k = 1, nlay
1616  do ig = 1, ngptlw
1617  cldfmc(ig,k) = f_zero
1618  enddo
1619  enddo
1620 
1627 
1628 ! --- ... compute cloud radiative properties for a cloudy column
1629 
1630  lab_if_ilwcliq : if (ilwcliq > 0) then
1631 
1632  lab_do_k : do k = 1, nlay
1633  lab_if_cld : if (cfrac(k) > cldmin) then
1634 
1635  tauran = absrain * cdat1(k) ! ncar formula
1636 !! tausnw = abssnow1 * cdat3(k) ! ncar formula
1637 ! --- if use fu's formula it needs to be normalized by snow density
1638 ! !not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2)
1639 ! use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2)
1640 ! factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size
1641 ! use newer factor value 1.0315
1642 ! 1/(0.9167*1.0315) = 1.05756
1643  if (cdat3(k)>f_zero .and. cdat4(k)>10.0_kind_phys) then
1644  tausnw = abssnow0*1.05756*cdat3(k)/cdat4(k) ! fu's formula
1645  else
1646  tausnw = f_zero
1647  endif
1648 
1649  cldliq = cliqp(k)
1650  cldice = cicep(k)
1651 ! refliq = max(2.5e0, min(60.0e0, reliq(k) ))
1652 ! refice = max(5.0e0, reice(k) )
1653  refliq = reliq(k)
1654  refice = reice(k)
1655 
1656 ! --- ... calculation of absorption coefficients due to water clouds.
1657 
1658  if ( cldliq <= f_zero ) then
1659  do ib = 1, nbands
1660  tauliq(ib) = f_zero
1661  enddo
1662  else
1663  if ( ilwcliq == 1 ) then
1664 
1665  factor = refliq - 1.5
1666  index = max( 1, min( 57, int( factor ) ))
1667  fint = factor - float(index)
1668 
1669  do ib = 1, nbands
1670  tauliq(ib) = max(f_zero, cldliq*(absliq1(index,ib) &
1671  & + fint*(absliq1(index+1,ib)-absliq1(index,ib)) ))
1672  enddo
1673  endif ! end if_ilwcliq_block
1674  endif ! end if_cldliq_block
1675 
1676 ! --- ... calculation of absorption coefficients due to ice clouds.
1677 
1678  if ( cldice <= f_zero ) then
1679  do ib = 1, nbands
1680  tauice(ib) = f_zero
1681  enddo
1682  else
1683 
1684 ! --- ... ebert and curry approach for all particle sizes though somewhat
1685 ! unjustified for large ice particles
1686 
1687  if ( ilwcice == 1 ) then
1688  refice = min(130.0, max(13.0, real(refice) ))
1689 
1690  do ib = 1, nbands
1691  ia = ipat(ib) ! eb_&_c band index for ice cloud coeff
1692  tauice(ib) = max(f_zero, cldice*(absice1(1,ia) &
1693  & + absice1(2,ia)/refice) )
1694  enddo
1695 
1696 ! --- ... streamer approach for ice effective radius between 5.0 and 131.0 microns
1697 ! and ebert and curry approach for ice eff radius greater than 131.0 microns.
1698 ! no smoothing between the transition of the two methods.
1699 
1700  elseif ( ilwcice == 2 ) then
1701 
1702  factor = (refice - 2.0) / 3.0
1703  index = max( 1, min( 42, int( factor ) ))
1704  fint = factor - float(index)
1705 
1706  do ib = 1, nbands
1707  tauice(ib) = max(f_zero, cldice*(absice2(index,ib) &
1708  & + fint*(absice2(index+1,ib) - absice2(index,ib)) ))
1709  enddo
1710 
1711 ! --- ... fu's approach for ice effective radius between 4.8 and 135 microns
1712 ! (generalized effective size from 5 to 140 microns)
1713 
1714  elseif ( ilwcice == 3 ) then
1715 
1716 ! dgeice = max(5.0, 1.5396*refice) ! v4.4 value
1717  dgeice = max(5.0, 1.0315*refice) ! v4.71 value
1718  factor = (dgeice - 2.0) / 3.0
1719  index = max( 1, min( 45, int( factor ) ))
1720  fint = factor - float(index)
1721 
1722  do ib = 1, nbands
1723  tauice(ib) = max(f_zero, cldice*(absice3(index,ib) &
1724  & + fint*(absice3(index+1,ib) - absice3(index,ib)) ))
1725  enddo
1726 
1727  endif ! end if_ilwcice_block
1728  endif ! end if_cldice_block
1729 
1730  do ib = 1, nbands
1731  taucld(ib,k) = tauice(ib) + tauliq(ib) + tauran + tausnw
1732  enddo
1733 
1734  endif lab_if_cld
1735  enddo lab_do_k
1736 
1737  else lab_if_ilwcliq
1738 
1739  do k = 1, nlay
1740  if (cfrac(k) > cldmin) then
1741  do ib = 1, nbands
1742  taucld(ib,k) = cdat1(k)
1743  enddo
1744  endif
1745  enddo
1746 
1747  endif lab_if_ilwcliq
1748 
1751 
1752  if ( isubclw > 0 ) then ! mcica sub-col clouds approx
1753  do k = 1, nlay
1754  if ( cfrac(k) < cldmin ) then
1755  cldf(k) = f_zero
1756  else
1757  cldf(k) = cfrac(k)
1758  endif
1759  enddo
1760 
1761 ! --- ... call sub-column cloud generator
1762 
1763  call mcica_subcol &
1764 ! --- inputs:
1765  & ( cldf, nlay, ipseed, &
1766 ! --- output:
1767  & lcloudy &
1768  & )
1769 
1770  do k = 1, nlay
1771  do ig = 1, ngptlw
1772  if ( lcloudy(ig,k) ) then
1773  cldfmc(ig,k) = f_one
1774  else
1775  cldfmc(ig,k) = f_zero
1776  endif
1777  enddo
1778  enddo
1779 
1780  endif ! end if_isubclw_block
1781 
1782  return
1783 ! ..................................
1784  end subroutine cldprop
1785 ! ----------------------------------
1787 
1793 ! ----------------------------------
1794  subroutine mcica_subcol &
1795  & ( cldf, nlay, ipseed, &! --- inputs
1796  & lcloudy & ! --- outputs
1797  & )
1799 ! ==================== defination of variables ==================== !
1800 ! !
1801 ! input variables: size !
1802 ! cldf - real, layer cloud fraction nlay !
1803 ! nlay - integer, number of model vertical layers 1 !
1804 ! ipseed - integer, permute seed for random num generator 1 !
1805 ! ** note : if the cloud generator is called multiple times, need !
1806 ! to permute the seed between each call; if between calls !
1807 ! for lw and sw, use values differ by the number of g-pts. !
1808 ! !
1809 ! output variables: !
1810 ! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay!
1811 ! !
1812 ! other control flags from module variables: !
1813 ! iovrlw : control flag for cloud overlapping method !
1814 ! =0:random; =1:maximum/random: =2:maximum !
1815 ! !
1816 ! ===================== end of definitions ==================== !
1817 
1818  implicit none
1819 
1820 ! --- inputs:
1821  integer, intent(in) :: nlay, ipseed
1822 
1823  real (kind=kind_phys), dimension(nlay), intent(in) :: cldf
1824 
1825 ! --- outputs:
1826  logical, dimension(ngptlw,nlay), intent(out) :: lcloudy
1827 
1828 ! --- locals:
1829  real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), &
1830  & rand2d(nlay*ngptlw), tem1
1831 
1832  type(random_stat) :: stat ! for thread safe random generator
1833 
1834  integer :: k, n, k1
1835 !
1836 !===> ... begin here
1837 !
1838 ! --- ... advance randum number generator by ipseed values
1839 
1840  call random_setseed &
1841 ! --- inputs:
1842  & ( ipseed, &
1843 ! --- outputs:
1844  & stat &
1845  & )
1846 
1847 ! --- ... sub-column set up according to overlapping assumption
1848 
1849  select case ( iovrlw )
1850 
1851  case( 0 ) ! random overlap, pick a random value at every level
1852 
1853  call random_number &
1854 ! --- inputs: ( none )
1855 ! --- outputs:
1856  & ( rand2d, stat )
1857 
1858  k1 = 0
1859  do n = 1, ngptlw
1860  do k = 1, nlay
1861  k1 = k1 + 1
1862  cdfunc(n,k) = rand2d(k1)
1863  enddo
1864  enddo
1865 
1866  case( 1 ) ! max-ran overlap
1867 
1868  call random_number &
1869 ! --- inputs: ( none )
1870 ! --- outputs:
1871  & ( rand2d, stat )
1872 
1873  k1 = 0
1874  do n = 1, ngptlw
1875  do k = 1, nlay
1876  k1 = k1 + 1
1877  cdfunc(n,k) = rand2d(k1)
1878  enddo
1879  enddo
1880 
1881 ! --- first pick a random number for bottom (or top) layer.
1882 ! then walk up the column: (aer's code)
1883 ! if layer below is cloudy, use the same rand num in the layer below
1884 ! if layer below is clear, use a new random number
1885 
1886 ! --- from bottom up
1887  do k = 2, nlay
1888  k1 = k - 1
1889  tem1 = f_one - cldf(k1)
1890 
1891  do n = 1, ngptlw
1892  if ( cdfunc(n,k1) > tem1 ) then
1893  cdfunc(n,k) = cdfunc(n,k1)
1894  else
1895  cdfunc(n,k) = cdfunc(n,k) * tem1
1896  endif
1897  enddo
1898  enddo
1899 
1900 ! --- or walk down the column: (if use original author's method)
1901 ! if layer above is cloudy, use the same rand num in the layer above
1902 ! if layer above is clear, use a new random number
1903 
1904 ! --- from top down
1905 ! do k = nlay-1, 1, -1
1906 ! k1 = k + 1
1907 ! tem1 = f_one - cldf(k1)
1908 
1909 ! do n = 1, ngptlw
1910 ! if ( cdfunc(n,k1) > tem1 ) then
1911 ! cdfunc(n,k) = cdfunc(n,k1)
1912 ! else
1913 ! cdfunc(n,k) = cdfunc(n,k) * tem1
1914 ! endif
1915 ! enddo
1916 ! enddo
1917 
1918  case( 2 ) ! maximum overlap, pick same random numebr at every level
1919 
1920  call random_number &
1921 ! --- inputs: ( none )
1922 ! --- outputs:
1923  & ( rand1d, stat )
1924 
1925  do n = 1, ngptlw
1926  tem1 = rand1d(n)
1927 
1928  do k = 1, nlay
1929  cdfunc(n,k) = tem1
1930  enddo
1931  enddo
1932 
1933  end select
1934 
1935 ! --- ... generate subcolumns for homogeneous clouds
1936 
1937  do k = 1, nlay
1938  tem1 = f_one - cldf(k)
1939 
1940  do n = 1, ngptlw
1941  lcloudy(n,k) = cdfunc(n,k) >= tem1
1942  enddo
1943  enddo
1944 
1945  return
1946 ! ..................................
1947  end subroutine mcica_subcol
1948 ! ----------------------------------
1949 
1989 ! ----------------------------------
1990  subroutine setcoef &
1991  & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & ! --- inputs:
1992  & nlay, nlp1, &
1993  & laytrop,pklay,pklev,jp,jt,jt1, & ! --- outputs:
1994  & rfrate,fac00,fac01,fac10,fac11, &
1995  & selffac,selffrac,indself,forfac,forfrac,indfor, &
1996  & minorfrac,scaleminor,scaleminorn2,indminor &
1997  & )
1999 ! =================== program usage description =================== !
2000 ! !
2001 ! purpose: compute various coefficients needed in radiative transfer !
2002 ! calculations. !
2003 ! !
2004 ! subprograms called: none !
2005 ! !
2006 ! ==================== defination of variables ==================== !
2007 ! !
2008 ! inputs: -size- !
2009 ! pavel - real, layer pressures (mb) nlay !
2010 ! tavel - real, layer temperatures (k) nlay !
2011 ! tz - real, level (interface) temperatures (k) 0:nlay !
2012 ! stemp - real, surface ground temperature (k) 1 !
2013 ! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay !
2014 ! colamt - real, column amounts of absorbing gases nlay*maxgas!
2015 ! 2nd indices range: 1-maxgas, for watervapor, !
2016 ! carbon dioxide, ozone, nitrous oxide, methane, !
2017 ! oxigen, carbon monoxide,etc. (molecules/cm**2) !
2018 ! coldry - real, dry air column amount nlay !
2019 ! colbrd - real, column amount of broadening gases nlay !
2020 ! nlay/nlp1 - integer, total number of vertical layers, levels 1 !
2021 ! !
2022 ! outputs: !
2023 ! laytrop - integer, tropopause layer index (unitless) 1 !
2024 ! pklay - real, integrated planck func at lay temp nbands*0:nlay!
2025 ! pklev - real, integrated planck func at lev temp nbands*0:nlay!
2026 ! jp - real, indices of lower reference pressure nlay !
2027 ! jt, jt1 - real, indices of lower reference temperatures nlay !
2028 ! rfrate - real, ref ratios of binary species param nlay*nrates*2!
2029 ! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2!
2030 ! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer !
2031 ! facij - real, factors multiply the reference ks, nlay !
2032 ! i,j=0/1 for lower/higher of the 2 appropriate !
2033 ! temperatures and altitudes. !
2034 ! selffac - real, scale factor for w. v. self-continuum nlay !
2035 ! equals (w. v. density)/(atmospheric density !
2036 ! at 296k and 1013 mb) !
2037 ! selffrac - real, factor for temperature interpolation of nlay !
2038 ! reference w. v. self-continuum data !
2039 ! indself - integer, index of lower ref temp for selffac nlay !
2040 ! forfac - real, scale factor for w. v. foreign-continuum nlay !
2041 ! forfrac - real, factor for temperature interpolation of nlay !
2042 ! reference w.v. foreign-continuum data !
2043 ! indfor - integer, index of lower ref temp for forfac nlay !
2044 ! minorfrac - real, factor for minor gases nlay !
2045 ! scaleminor,scaleminorn2 !
2046 ! - real, scale factors for minor gases nlay !
2047 ! indminor - integer, index of lower ref temp for minor gases nlay !
2048 ! !
2049 ! ====================== end of definitions =================== !
2050 
2051 ! --- inputs:
2052  integer, intent(in) :: nlay, nlp1
2053 
2054  real (kind=kind_phys), dimension(nlay,maxgas),intent(in):: colamt
2055  real (kind=kind_phys), dimension(0:nlay), intent(in):: tz
2056 
2057  real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, &
2058  & tavel, h2ovmr, coldry, colbrd
2059 
2060  real (kind=kind_phys), intent(in) :: stemp
2061 
2062 ! --- outputs:
2063  integer, dimension(nlay), intent(out) :: jp, jt, jt1, indself, &
2064  & indfor, indminor
2065 
2066  integer, intent(out) :: laytrop
2067 
2068  real (kind=kind_phys), dimension(nlay,nrates,2), intent(out) :: &
2069  & rfrate
2070  real (kind=kind_phys), dimension(nbands,0:nlay), intent(out) :: &
2071  & pklev, pklay
2072 
2073  real (kind=kind_phys), dimension(nlay), intent(out) :: &
2074  & fac00, fac01, fac10, fac11, selffac, selffrac, forfac, &
2075  & forfrac, minorfrac, scaleminor, scaleminorn2
2076 
2077 ! --- locals:
2078  real (kind=kind_phys) :: tlvlfr, tlyrfr, plog, fp, ft, ft1, &
2079  & tem1, tem2
2080 
2081  integer :: i, k, jp1, indlev, indlay
2082 !
2083 !===> ... begin here
2084 !
2085 ! --- ... calculate information needed by the radiative transfer routine
2086 ! that is specific to this atmosphere, especially some of the
2087 ! coefficients and indices needed to compute the optical depths
2088 ! by interpolating data from stored reference atmospheres.
2089 
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))
2094  do i = 1, nbands
2095  tem1 = totplnk(indlay+1,i) - totplnk(indlay,i)
2096  tem2 = totplnk(indlev+1,i) - totplnk(indlev,i)
2097  pklay(i,0) = delwave(i) * (totplnk(indlay,i) + tlyrfr*tem1)
2098  pklev(i,0) = delwave(i) * (totplnk(indlev,i) + tlvlfr*tem2)
2099  enddo
2100 
2101 ! --- ... begin layer loop
2102 ! calculate the integrated Planck functions for each band at the
2103 ! surface, level, and layer temperatures.
2104 
2105  laytrop = 0
2106 
2107  do k = 1, nlay
2108 
2109  indlay = min(180, max(1, int(tavel(k)-159.0) ))
2110  tlyrfr = tavel(k) - int(tavel(k))
2111 
2112  indlev = min(180, max(1, int(tz(k)-159.0) ))
2113  tlvlfr = tz(k) - int(tz(k))
2114 
2115 ! --- ... begin spectral band loop
2116 
2117  do i = 1, nbands
2118  pklay(i,k) = delwave(i) * (totplnk(indlay,i) + tlyrfr &
2119  & * (totplnk(indlay+1,i) - totplnk(indlay,i)) )
2120  pklev(i,k) = delwave(i) * (totplnk(indlev,i) + tlvlfr &
2121  & * (totplnk(indlev+1,i) - totplnk(indlev,i)) )
2122  enddo
2123 
2124 ! --- ... find the two reference pressures on either side of the
2125 ! layer pressure. store them in jp and jp1. store in fp the
2126 ! fraction of the difference (in ln(pressure)) between these
2127 ! two values that the layer pressure lies.
2128 
2129  plog = log(pavel(k))
2130  jp(k)= max(1, min(58, int(36.0 - 5.0*(plog+0.04)) ))
2131  jp1 = jp(k) + 1
2132 ! --- ... limit pressure extrapolation at the top
2133  fp = max(f_zero, min(f_one, 5.0*(preflog(jp(k))-plog) ))
2134 !org fp = 5.0 * (preflog(jp(k)) - plog)
2135 
2136 ! --- ... determine, for each reference pressure (jp and jp1), which
2137 ! reference temperature (these are different for each
2138 ! reference pressure) is nearest the layer temperature but does
2139 ! not exceed it. store these indices in jt and jt1, resp.
2140 ! store in ft (resp. ft1) the fraction of the way between jt
2141 ! (jt1) and the next highest reference temperature that the
2142 ! layer temperature falls.
2143 
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) ))
2148 ! --- ... restrict extrapolation ranges by limiting abs(det t) < 37.5 deg
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) ))
2151 !org ft = tem1 - float(jt (k) - 3)
2152 !org ft1 = tem2 - float(jt1(k) - 3)
2153 
2154 ! --- ... we have now isolated the layer ln pressure and temperature,
2155 ! between two reference pressures and two reference temperatures
2156 ! (for each reference pressure). we multiply the pressure
2157 ! fraction fp with the appropriate temperature fractions to get
2158 ! the factors that will be needed for the interpolation that yields
2159 ! the optical depths (performed in routines taugbn for band n)
2160 
2161  tem1 = f_one - fp
2162  fac10(k) = tem1 * ft
2163  fac00(k) = tem1 * (f_one - ft)
2164  fac11(k) = fp * ft1
2165  fac01(k) = fp * (f_one - ft1)
2166 
2167  forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k)))
2168  selffac(k) = h2ovmr(k) * forfac(k)
2169 
2170 ! --- ... set up factors needed to separately include the minor gases
2171 ! in the calculation of absorption coefficient
2172 
2173  scaleminor(k) = pavel(k) / tavel(k)
2174  scaleminorn2(k) = (pavel(k) / tavel(k)) &
2175  & * (colbrd(k)/(coldry(k) + colamt(k,1)))
2176  tem1 = (tavel(k) - 180.8) / 7.2
2177  indminor(k) = min(18, max(1, int(tem1)))
2178  minorfrac(k) = tem1 - float(indminor(k))
2179 
2180 ! --- ... if the pressure is less than ~100mb, perform a different
2181 ! set of species interpolations.
2182 
2183  if (plog > 4.56) then
2184 
2185  laytrop = laytrop + 1
2186 
2187  tem1 = (332.0 - tavel(k)) / 36.0
2188  indfor(k) = min(2, max(1, int(tem1)))
2189  forfrac(k) = tem1 - float(indfor(k))
2190 
2191 ! --- ... set up factors needed to separately include the water vapor
2192 ! self-continuum in the calculation of absorption coefficient.
2193 
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)
2197 
2198 ! --- ... setup reference ratio to be used in calculation of binary
2199 ! species parameter in lower atmosphere.
2200 
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)
2203 
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)
2206 
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)
2209 
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)
2212 
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)
2215 
2216  else
2217 
2218  tem1 = (tavel(k) - 188.0) / 36.0
2219  indfor(k) = 3
2220  forfrac(k) = tem1 - f_one
2221 
2222  indself(k) = 0
2223  selffrac(k) = f_zero
2224 
2225 ! --- ... setup reference ratio to be used in calculation of binary
2226 ! species parameter in upper atmosphere.
2227 
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)
2230 
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)
2233 
2234  endif
2235 
2236 ! --- ... rescale selffac and forfac for use in taumol
2237 
2238  selffac(k) = colamt(k,1) * selffac(k)
2239  forfac(k) = colamt(k,1) * forfac(k)
2240 
2241  enddo ! end do_k layer loop
2242 
2243  return
2244 ! ..................................
2245  end subroutine setcoef
2246 ! ----------------------------------
2247 
2248 
2283 ! ----------------------------------
2284  subroutine rtrn &
2285  & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & ! --- inputs
2286  & fracs,secdif, nlay,nlp1, &
2287  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs
2288  & )
2290 ! =================== program usage description =================== !
2291 ! !
2292 ! purpose: compute the upward/downward radiative fluxes, and heating !
2293 ! rates for both clear or cloudy atmosphere. clouds are assumed as !
2294 ! randomly overlaping in a vertical colum. !
2295 ! !
2296 ! subprograms called: none !
2297 ! !
2298 ! ==================== defination of variables ==================== !
2299 ! !
2300 ! inputs: -size- !
2301 ! semiss - real, lw surface emissivity nbands!
2302 ! delp - real, layer pressure thickness (mb) nlay !
2303 ! cldfrc - real, layer cloud fraction 0:nlp1 !
2304 ! taucld - real, layer cloud opt depth nbands,nlay!
2305 ! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay!
2306 ! pklay - real, integrated planck func at lay temp nbands*0:nlay!
2307 ! pklev - real, integrated planck func at lev temp nbands*0:nlay!
2308 ! fracs - real, planck fractions ngptlw,nlay!
2309 ! secdif - real, secant of diffusivity angle nbands!
2310 ! nlay - integer, number of vertical layers 1 !
2311 ! nlp1 - integer, number of vertical levels (interfaces) 1 !
2312 ! !
2313 ! outputs: !
2314 ! totuflux- real, total sky upward flux (w/m2) 0:nlay !
2315 ! totdflux- real, total sky downward flux (w/m2) 0:nlay !
2316 ! htr - real, total sky heating rate (k/sec or k/day) nlay !
2317 ! totuclfl- real, clear sky upward flux (w/m2) 0:nlay !
2318 ! totdclfl- real, clear sky downward flux (w/m2) 0:nlay !
2319 ! htrcl - real, clear sky heating rate (k/sec or k/day) nlay !
2320 ! htrb - real, spectral band lw heating rate (k/day) nlay*nbands!
2321 ! !
2322 ! module veriables: !
2323 ! ngb - integer, band index for each g-value ngptlw!
2324 ! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 !
2325 ! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 !
2326 ! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 !
2327 ! bpade - real, pade approx constant (1/0.278) 1 !
2328 ! wtdiff - real, weight for radiance to flux conversion 1 !
2329 ! ntbl - integer, dimension of look-up tables 1 !
2330 ! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl !
2331 ! exp_tbl - real, transmittance lookup table 0:ntbl !
2332 ! tfn_tbl - real, tau transition function 0:ntbl !
2333 ! !
2334 ! local variables: !
2335 ! itgas - integer, index for gases contribution look-up table 1 !
2336 ! ittot - integer, index for gases plus clouds look-up table 1 !
2337 ! reflct - real, surface reflectance 1 !
2338 ! atrgas - real, gaseous absorptivity 1 !
2339 ! atrtot - real, gaseous and cloud absorptivity 1 !
2340 ! odcld - real, cloud optical depth 1 !
2341 ! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay !
2342 ! odepth - real, optical depth of gaseous only 1 !
2343 ! odtot - real, optical depth of gas and cloud 1 !
2344 ! gasfac - real, gas-only pade factor, used for planck fn 1 !
2345 ! totfac - real, gas+cld pade factor, used for planck fn 1 !
2346 ! bbdgas - real, gas-only planck function for downward rt 1 !
2347 ! bbugas - real, gas-only planck function for upward rt 1 !
2348 ! bbdtot - real, gas and cloud planck function for downward rt 1 !
2349 ! bbutot - real, gas and cloud planck function for upward rt 1 !
2350 ! gassrcu- real, upwd source radiance due to gas only nlay!
2351 ! totsrcu- real, upwd source radiance due to gas+cld nlay!
2352 ! gassrcd- real, dnwd source radiance due to gas only 1 !
2353 ! totsrcd- real, dnwd source radiance due to gas+cld 1 !
2354 ! radtotu- real, spectrally summed total sky upwd radiance 1 !
2355 ! radclru- real, spectrally summed clear sky upwd radiance 1 !
2356 ! radtotd- real, spectrally summed total sky dnwd radiance 1 !
2357 ! radclrd- real, spectrally summed clear sky dnwd radiance 1 !
2358 ! toturad- real, total sky upward radiance by layer 0:nlay*nbands!
2359 ! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands!
2360 ! totdrad- real, total sky downward radiance by layer 0:nlay*nbands!
2361 ! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands!
2362 ! fnet - real, net longwave flux (w/m2) 0:nlay !
2363 ! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay !
2364 ! !
2365 ! !
2366 ! ******************************************************************* !
2367 ! original code description !
2368 ! !
2369 ! original version: e. j. mlawer, et al. rrtm_v3.0 !
2370 ! revision for gcms: michael j. iacono; october, 2002 !
2371 ! revision for f90: michael j. iacono; june, 2006 !
2372 ! !
2373 ! this program calculates the upward fluxes, downward fluxes, and !
2374 ! heating rates for an arbitrary clear or cloudy atmosphere. the input !
2375 ! to this program is the atmospheric profile, all Planck function !
2376 ! information, and the cloud fraction by layer. a variable diffusivity!
2377 ! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 !
2378 ! use a value for secdif that varies from 1.50 to 1.80 as a function !
2379 ! of the column water vapor, and other bands use a value of 1.66. the !
2380 ! gaussian weight appropriate to this angle (wtdiff=0.5) is applied !
2381 ! here. note that use of the emissivity angle for the flux integration!
2382 ! can cause errors of 1 to 4 W/m2 within cloudy layers. !
2383 ! clouds are treated with a random cloud overlap method. !
2384 ! !
2385 ! ******************************************************************* !
2386 ! ====================== end of description block ================= !
2387 
2388 ! --- inputs:
2389  integer, intent(in) :: nlay, nlp1
2390 
2391  real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc
2392  real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, &
2393  & secdif
2394  real (kind=kind_phys), dimension(nlay), intent(in) :: delp
2395 
2396  real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld
2397  real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, &
2398  & tautot
2399 
2400  real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: &
2401  & pklev, pklay
2402 
2403 ! --- outputs:
2404  real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl
2405 
2406  real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb
2407 
2408  real (kind=kind_phys), dimension(0:nlay), intent(out) :: &
2409  & totuflux, totdflux, totuclfl, totdclfl
2410 
2411 ! --- locals:
2412  real (kind=kind_phys), parameter :: rec_6 = 0.166667
2413 
2414  real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, &
2415  & clrdrad, toturad, totdrad
2416 
2417  real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, &
2418  & trngas, efclrfr, rfdelp
2419  real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc
2420 
2421  real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
2422  & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, &
2423  & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, &
2424  & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, &
2425  & clfr, trng, gasu
2426 
2427  integer :: ittot, itgas, ib, ig, k
2428 !
2429 !===> ... begin here
2430 !
2431  do ib = 1, nbands
2432  do k = 0, nlay
2433  toturad(k,ib) = f_zero
2434  totdrad(k,ib) = f_zero
2435  clrurad(k,ib) = f_zero
2436  clrdrad(k,ib) = f_zero
2437  enddo
2438  enddo
2439 
2440  do k = 0, nlay
2441  totuflux(k) = f_zero
2442  totdflux(k) = f_zero
2443  totuclfl(k) = f_zero
2444  totdclfl(k) = f_zero
2445  enddo
2446 
2447 ! --- ... loop over all g-points
2448 
2449  do ig = 1, ngptlw
2450  ib = ngb(ig)
2451 
2452  radtotd = f_zero
2453  radclrd = f_zero
2454 
2456 
2457  do k = nlay, 1, -1
2458 
2459 !!\n - clear sky, gases contribution
2460 
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
2466  else
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)
2473  endif
2474 
2475  plfrac = fracs(ig,k)
2476  blay = pklay(ib,k)
2477 
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
2484  trngas(k) = trng
2485 
2486 !!\n - total sky, gases+clouds contribution
2487 
2488  clfr = cldfrc(k)
2489  if (clfr >= eps) then
2490 !!\n - cloudy layer
2491 
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
2498  else
2499  tblind = odtot / (bpade + odtot)
2500  ittot = tblint*tblind + 0.5
2501  totfac = tfn_tbl(ittot)
2502  atrtot = f_one - exp_tbl(ittot)
2503  endif
2504 
2505  bbdtot = plfrac * (blay + dplnkd*totfac)
2506  bbutot = plfrac * (blay + dplnku*totfac)
2507  totsrcd= bbdtot * atrtot
2508  totsrcu(k)= bbutot * atrtot
2509 
2510 ! --- ... total sky radiance
2511  radtotd = radtotd*trng*efclrfr(k) + gassrcd &
2512  & + clfr*(totsrcd - gassrcd)
2513  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
2514 
2515 ! --- ... clear sky radiance
2516  radclrd = radclrd*trng + gassrcd
2517  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
2518 
2519  else
2520 ! --- ... clear layer
2521 
2522 ! --- ... total sky radiance
2523  radtotd = radtotd*trng + gassrcd
2524  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
2525 
2526 ! --- ... clear sky radiance
2527  radclrd = radclrd*trng + gassrcd
2528  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
2529 
2530  endif ! end if_clfr_block
2531 
2532  enddo ! end do_k_loop
2533 
2537 
2538 ! note: spectral and Lambertian reflection are identical for the
2539 ! diffusivity angle flux integration used here.
2540 
2541  reflct = f_one - semiss(ib)
2542  rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
2543 
2545  radtotu = rad0 + reflct*radtotd
2546  toturad(0,ib) = toturad(0,ib) + radtotu
2547 
2549  radclru = rad0 + reflct*radclrd
2550  clrurad(0,ib) = clrurad(0,ib) + radclru
2551 
2553 
2554  do k = 1, nlay
2555  clfr = cldfrc(k)
2556  trng = trngas(k)
2557  gasu = gassrcu(k)
2558 
2559  if (clfr >= eps) then
2560 ! --- ... cloudy layer
2561 
2562 ! --- ... total sky radiance
2563  radtotu = radtotu*trng*efclrfr(k) + gasu &
2564  & + clfr*(totsrcu(k) - gasu)
2565  toturad(k,ib) = toturad(k,ib) + radtotu
2566 
2567 ! --- ... clear sky radiance
2568  radclru = radclru*trng + gasu
2569  clrurad(k,ib) = clrurad(k,ib) + radclru
2570 
2571  else
2572 ! --- ... clear layer
2573 
2574 ! --- ... total sky radiance
2575  radtotu = radtotu*trng + gasu
2576  toturad(k,ib) = toturad(k,ib) + radtotu
2577 
2578 ! --- ... clear sky radiance
2579  radclru = radclru*trng + gasu
2580  clrurad(k,ib) = clrurad(k,ib) + radclru
2581 
2582  endif ! end if_clfr_block
2583 
2584  enddo ! end do_k_loop
2585 
2586  enddo ! end do_ig_loop
2587 
2590 
2591  flxfac = wtdiff * fluxfac
2592 
2593  do k = 0, nlay
2594  do ib = 1, nbands
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)
2599  enddo
2600 
2601  totuflux(k) = totuflux(k) * flxfac
2602  totdflux(k) = totdflux(k) * flxfac
2603  totuclfl(k) = totuclfl(k) * flxfac
2604  totdclfl(k) = totdclfl(k) * flxfac
2605  enddo
2606 
2607 ! --- ... calculate net fluxes and heating rates
2608  fnet(0) = totuflux(0) - totdflux(0)
2609 
2610  do k = 1, nlay
2611  rfdelp(k) = heatfac / delp(k)
2612  fnet(k) = totuflux(k) - totdflux(k)
2613  htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
2614  enddo
2615 
2616 !! --- ... optional clear sky heating rates
2617  if ( lhlw0 ) then
2618  fnetc(0) = totuclfl(0) - totdclfl(0)
2619 
2620  do k = 1, nlay
2621  fnetc(k) = totuclfl(k) - totdclfl(k)
2622  htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
2623  enddo
2624  endif
2625 
2626 !! --- ... optional spectral band heating rates
2627  if ( lhlwb ) then
2628  do ib = 1, nbands
2629  fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
2630 
2631  do k = 1, nlay
2632  fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
2633  htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
2634  enddo
2635  enddo
2636  endif
2637 
2638 ! ..................................
2639  end subroutine rtrn
2640 ! ----------------------------------
2641 
2642 
2666 ! ----------------------------------
2667  subroutine rtrnmr &
2668  & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &! --- inputs
2669  & fracs,secdif, nlay,nlp1, &
2670  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs:
2671  & )
2673 ! =================== program usage description =================== !
2674 ! !
2675 ! purpose: compute the upward/downward radiative fluxes, and heating !
2676 ! rates for both clear or cloudy atmosphere. clouds are assumed as in !
2677 ! maximum-randomly overlaping in a vertical colum. !
2678 ! !
2679 ! subprograms called: none !
2680 ! !
2681 ! ==================== defination of variables ==================== !
2682 ! !
2683 ! inputs: -size- !
2684 ! semiss - real, lw surface emissivity nbands!
2685 ! delp - real, layer pressure thickness (mb) nlay !
2686 ! cldfrc - real, layer cloud fraction 0:nlp1 !
2687 ! taucld - real, layer cloud opt depth nbands,nlay!
2688 ! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay!
2689 ! pklay - real, integrated planck func at lay temp nbands*0:nlay!
2690 ! pklev - real, integrated planck func at lev temp nbands*0:nlay!
2691 ! fracs - real, planck fractions ngptlw,nlay!
2692 ! secdif - real, secant of diffusivity angle nbands!
2693 ! nlay - integer, number of vertical layers 1 !
2694 ! nlp1 - integer, number of vertical levels (interfaces) 1 !
2695 ! !
2696 ! outputs: !
2697 ! totuflux- real, total sky upward flux (w/m2) 0:nlay !
2698 ! totdflux- real, total sky downward flux (w/m2) 0:nlay !
2699 ! htr - real, total sky heating rate (k/sec or k/day) nlay !
2700 ! totuclfl- real, clear sky upward flux (w/m2) 0:nlay !
2701 ! totdclfl- real, clear sky downward flux (w/m2) 0:nlay !
2702 ! htrcl - real, clear sky heating rate (k/sec or k/day) nlay !
2703 ! htrb - real, spectral band lw heating rate (k/day) nlay*nbands!
2704 ! !
2705 ! module veriables: !
2706 ! ngb - integer, band index for each g-value ngptlw!
2707 ! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 !
2708 ! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 !
2709 ! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 !
2710 ! bpade - real, pade approx constant (1/0.278) 1 !
2711 ! wtdiff - real, weight for radiance to flux conversion 1 !
2712 ! ntbl - integer, dimension of look-up tables 1 !
2713 ! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl !
2714 ! exp_tbl - real, transmittance lookup table 0:ntbl !
2715 ! tfn_tbl - real, tau transition function 0:ntbl !
2716 ! !
2717 ! local variables: !
2718 ! itgas - integer, index for gases contribution look-up table 1 !
2719 ! ittot - integer, index for gases plus clouds look-up table 1 !
2720 ! reflct - real, surface reflectance 1 !
2721 ! atrgas - real, gaseous absorptivity 1 !
2722 ! atrtot - real, gaseous and cloud absorptivity 1 !
2723 ! odcld - real, cloud optical depth 1 !
2724 ! odepth - real, optical depth of gaseous only 1 !
2725 ! odtot - real, optical depth of gas and cloud 1 !
2726 ! gasfac - real, gas-only pade factor, used for planck fn 1 !
2727 ! totfac - real, gas+cld pade factor, used for planck fn 1 !
2728 ! bbdgas - real, gas-only planck function for downward rt 1 !
2729 ! bbugas - real, gas-only planck function for upward rt 1 !
2730 ! bbdtot - real, gas and cloud planck function for downward rt 1 !
2731 ! bbutot - real, gas and cloud planck function for upward rt 1 !
2732 ! gassrcu- real, upwd source radiance due to gas only nlay!
2733 ! totsrcu- real, upwd source radiance due to gas + cld nlay!
2734 ! gassrcd- real, dnwd source radiance due to gas only 1 !
2735 ! totsrcd- real, dnwd source radiance due to gas + cld 1 !
2736 ! radtotu- real, spectrally summed total sky upwd radiance 1 !
2737 ! radclru- real, spectrally summed clear sky upwd radiance 1 !
2738 ! radtotd- real, spectrally summed total sky dnwd radiance 1 !
2739 ! radclrd- real, spectrally summed clear sky dnwd radiance 1 !
2740 ! toturad- real, total sky upward radiance by layer 0:nlay*nbands!
2741 ! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands!
2742 ! totdrad- real, total sky downward radiance by layer 0:nlay*nbands!
2743 ! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands!
2744 ! fnet - real, net longwave flux (w/m2) 0:nlay !
2745 ! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay !
2746 ! !
2747 ! !
2748 ! ******************************************************************* !
2749 ! original code description !
2750 ! !
2751 ! original version: e. j. mlawer, et al. rrtm_v3.0 !
2752 ! revision for gcms: michael j. iacono; october, 2002 !
2753 ! revision for f90: michael j. iacono; june, 2006 !
2754 ! !
2755 ! this program calculates the upward fluxes, downward fluxes, and !
2756 ! heating rates for an arbitrary clear or cloudy atmosphere. the input !
2757 ! to this program is the atmospheric profile, all Planck function !
2758 ! information, and the cloud fraction by layer. a variable diffusivity!
2759 ! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 !
2760 ! use a value for secdif that varies from 1.50 to 1.80 as a function !
2761 ! of the column water vapor, and other bands use a value of 1.66. the !
2762 ! gaussian weight appropriate to this angle (wtdiff=0.5) is applied !
2763 ! here. note that use of the emissivity angle for the flux integration!
2764 ! can cause errors of 1 to 4 W/m2 within cloudy layers. !
2765 ! clouds are treated with a maximum-random cloud overlap method. !
2766 ! !
2767 ! ******************************************************************* !
2768 ! ====================== end of description block ================= !
2769 
2770 ! --- inputs:
2771  integer, intent(in) :: nlay, nlp1
2772 
2773  real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc
2774  real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, &
2775  & secdif
2776  real (kind=kind_phys), dimension(nlay), intent(in) :: delp
2777 
2778  real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld
2779  real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, &
2780  & tautot
2781 
2782  real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: &
2783  & pklev, pklay
2784 
2785 ! --- outputs:
2786  real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl
2787 
2788  real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb
2789 
2790  real (kind=kind_phys), dimension(0:nlay), intent(out) :: &
2791  & totuflux, totdflux, totuclfl, totdclfl
2792 
2793 ! --- locals:
2794  real (kind=kind_phys), parameter :: rec_6 = 0.166667
2795 
2796  real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, &
2797  & clrdrad, toturad, totdrad
2798 
2799  real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, &
2800  & trngas, trntot, rfdelp
2801  real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc
2802 
2803  real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
2804  & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, &
2805  & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, &
2806  & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, rad, &
2807  & totradd, clrradd, totradu, clrradu, fmax, fmin, rat1, rat2,&
2808  & radmod, clfr, trng, trnt, gasu, totu
2809 
2810  integer :: ittot, itgas, ib, ig, k
2811 
2812 ! dimensions for cloud overlap adjustment
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
2817 
2818  logical :: lstcldu(nlay), lstcldd(nlay)
2819 !
2820 !===> ... begin here
2821 !
2822  do k = 1, nlp1
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
2829  enddo
2830 
2831  lstcldu(1) = cldfrc(1) > eps
2832  rat1 = f_zero
2833  rat2 = f_zero
2834 
2835  do k = 1, nlay-1
2836 
2837  lstcldu(k+1) = cldfrc(k+1)>eps .and. cldfrc(k)<=eps
2838 
2839  if (cldfrc(k) > eps) then
2840 
2842 
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)) &
2847  & / (f_one - cldfrc(k))
2848  endif
2849  facclr2u(k) = f_zero
2850  faccld2u(k) = f_zero
2851  else
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)) &
2858  & / (cldfrc(k-1) - cldfrc(k))
2859  else
2860  facclr1u(k+1) = rat2
2861  endif
2862  endif
2863 
2864  if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero) then
2865  rat1 = f_one
2866  rat2 = f_zero
2867  else
2868  rat1 = f_zero
2869  rat2 = f_zero
2870  endif
2871  else
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
2876  else
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
2881  else
2882  faccld1u(k+1) = (cldfrc(k) - cldfrc(k+1)) &
2883  & / (cldfrc(k) - fmin)
2884  endif
2885  endif
2886 
2887  if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero) then
2888  rat1 = f_zero
2889  rat2 = f_one
2890  else
2891  rat1 = f_zero
2892  rat2 = f_zero
2893  endif
2894  endif
2895 
2896  faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrc(k-1)
2897  faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k) &
2898  & * (f_one - cldfrc(k-1))
2899  endif
2900 
2901  enddo
2902 
2903  do k = 0, nlay
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
2910  enddo
2911 
2912  lstcldd(nlay) = cldfrc(nlay) > eps
2913  rat1 = f_zero
2914  rat2 = f_zero
2915 
2916  do k = nlay, 2, -1
2917 
2918  lstcldd(k-1) = cldfrc(k-1) > eps .and. cldfrc(k)<=eps
2919 
2920  if (cldfrc(k) > eps) then
2921 
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)) &
2926  & / (f_one - cldfrc(k))
2927  endif
2928 
2929  facclr2d(k) = f_zero
2930  faccld2d(k) = f_zero
2931  else
2932  fmax = max(cldfrc(k), cldfrc(k+1))
2933 
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)) &
2939  & / (cldfrc(k+1) - cldfrc(k))
2940  else
2941  facclr1d(k-1) = rat2
2942  endif
2943  endif
2944 
2945  if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero) then
2946  rat1 = f_one
2947  rat2 = f_zero
2948  else
2949  rat1 = f_zero
2950  rat2 = f_zero
2951  endif
2952  else
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
2957  else
2958  fmin = min(cldfrc(k), cldfrc(k+1))
2959 
2960  if (cldfrc(k-1) <= fmin) then
2961  faccld1d(k-1) = rat1
2962  faccld2d(k-1) = (fmin - cldfrc(k-1)) / fmin
2963  else
2964  faccld1d(k-1) = (cldfrc(k) - cldfrc(k-1)) &
2965  & / (cldfrc(k) - fmin)
2966  endif
2967  endif
2968 
2969  if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero) then
2970  rat1 = f_zero
2971  rat2 = f_one
2972  else
2973  rat1 = f_zero
2974  rat2 = f_zero
2975  endif
2976  endif
2977 
2978  faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrc(k+1)
2979  faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k) &
2980  & * (f_one - cldfrc(k+1))
2981  endif
2982 
2983  enddo
2984 
2986 
2987  do ib = 1, nbands
2988  do k = 0, nlay
2989  toturad(k,ib) = f_zero
2990  totdrad(k,ib) = f_zero
2991  clrurad(k,ib) = f_zero
2992  clrdrad(k,ib) = f_zero
2993  enddo
2994  enddo
2995 
2996  do k = 0, nlay
2997  totuflux(k) = f_zero
2998  totdflux(k) = f_zero
2999  totuclfl(k) = f_zero
3000  totdclfl(k) = f_zero
3001  enddo
3002 
3003 ! --- ... loop over all g-points
3004 
3005  do ig = 1, ngptlw
3006  ib = ngb(ig)
3007 
3008  radtotd = f_zero
3009  radclrd = f_zero
3010 
3012 
3013  do k = nlay, 1, -1
3014 
3015 ! --- ... clear sky, gases contribution
3016 
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
3022  else
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)
3029  endif
3030 
3031  plfrac = fracs(ig,k)
3032  blay = pklay(ib,k)
3033 
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
3040  trngas(k) = trng
3041 
3042 ! --- ... total sky, gases+clouds contribution
3043 
3044  clfr = cldfrc(k)
3045  if (lstcldd(k)) then
3046  totradd = clfr * radtotd
3047  clrradd = radtotd - totradd
3048  rad = f_zero
3049  endif
3050 
3051  if (clfr >= eps) then
3053 
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
3060  else
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
3066  endif
3067 
3068  bbdtot = plfrac * (blay + dplnkd*totfac)
3069  bbutot = plfrac * (blay + dplnku*totfac)
3070  totsrcd = bbdtot * atrtot
3071  totsrcu(k)= bbutot * atrtot
3072  trntot(k) = trnt
3073 
3074  totradd = totradd*trnt + clfr*totsrcd
3075  clrradd = clrradd*trng + (f_one - clfr)*gassrcd
3076 
3078  radtotd = totradd + clrradd
3079  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3080 
3082  radclrd = radclrd*trng + gassrcd
3083  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3084 
3085  radmod = rad*(facclr1d(k-1)*trng + faccld1d(k-1)*trnt) &
3086  & - faccmb1d(k-1)*gassrcd + faccmb2d(k-1)*totsrcd
3087 
3088  rad = -radmod + facclr2d(k-1)*(clrradd + radmod) &
3089  & - faccld2d(k-1)*(totradd - radmod)
3090  totradd = totradd + rad
3091  clrradd = clrradd - rad
3092 
3093  else
3094 ! --- ... clear layer
3095 
3096 ! --- ... total sky radiance
3097  radtotd = radtotd*trng + gassrcd
3098  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3099 
3100 ! --- ... clear sky radiance
3101  radclrd = radclrd*trng + gassrcd
3102  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3103 
3104  endif ! end if_clfr_block
3105 
3106  enddo ! end do_k_loop
3107 
3111 
3112 ! note: spectral and Lambertian reflection are identical for the
3113 ! diffusivity angle flux integration used here.
3114 
3115  reflct = f_one - semiss(ib)
3116  rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
3117 
3119  radtotu = rad0 + reflct*radtotd
3120  toturad(0,ib) = toturad(0,ib) + radtotu
3121 
3123  radclru = rad0 + reflct*radclrd
3124  clrurad(0,ib) = clrurad(0,ib) + radclru
3125 
3127 
3128  do k = 1, nlay
3129 
3130  clfr = cldfrc(k)
3131  trng = trngas(k)
3132  gasu = gassrcu(k)
3133 
3134  if (lstcldu(k)) then
3135  totradu = clfr * radtotu
3136  clrradu = radtotu - totradu
3137  rad = f_zero
3138  endif
3139 
3140  if (clfr >= eps) then
3142 
3143  trnt = trntot(k)
3144  totu = totsrcu(k)
3145  totradu = totradu*trnt + clfr*totu
3146  clrradu = clrradu*trng + (f_one - clfr)*gasu
3147 
3149  radtotu = totradu + clrradu
3150  toturad(k,ib) = toturad(k,ib) + radtotu
3151 
3153  radclru = radclru*trng + gasu
3154  clrurad(k,ib) = clrurad(k,ib) + radclru
3155 
3156  radmod = rad*(facclr1u(k+1)*trng + faccld1u(k+1)*trnt) &
3157  & - faccmb1u(k+1)*gasu + faccmb2u(k+1)*totu
3158  rad = -radmod + facclr2u(k+1)*(clrradu + radmod) &
3159  & - faccld2u(k+1)*(totradu - radmod)
3160  totradu = totradu + rad
3161  clrradu = clrradu - rad
3162 
3163  else
3164 ! --- ... clear layer
3165 
3166 ! --- ... total sky radiance
3167  radtotu = radtotu*trng + gasu
3168  toturad(k,ib) = toturad(k,ib) + radtotu
3169 
3170 ! --- ... clear sky radiance
3171  radclru = radclru*trng + gasu
3172  clrurad(k,ib) = clrurad(k,ib) + radclru
3173 
3174  endif ! end if_clfr_block
3175 
3176  enddo ! end do_k_loop
3177 
3178  enddo ! end do_ig_loop
3179 
3182 
3183  flxfac = wtdiff * fluxfac
3184 
3185  do k = 0, nlay
3186  do ib = 1, nbands
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)
3191  enddo
3192 
3193  totuflux(k) = totuflux(k) * flxfac
3194  totdflux(k) = totdflux(k) * flxfac
3195  totuclfl(k) = totuclfl(k) * flxfac
3196  totdclfl(k) = totdclfl(k) * flxfac
3197  enddo
3198 
3199 ! --- ... calculate net fluxes and heating rates
3200  fnet(0) = totuflux(0) - totdflux(0)
3201 
3202  do k = 1, nlay
3203  rfdelp(k) = heatfac / delp(k)
3204  fnet(k) = totuflux(k) - totdflux(k)
3205  htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3206  enddo
3207 
3208 !! --- ... optional clear sky heating rates
3209  if ( lhlw0 ) then
3210  fnetc(0) = totuclfl(0) - totdclfl(0)
3211 
3212  do k = 1, nlay
3213  fnetc(k) = totuclfl(k) - totdclfl(k)
3214  htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
3215  enddo
3216  endif
3217 
3218 !! --- ... optional spectral band heating rates
3219  if ( lhlwb ) then
3220  do ib = 1, nbands
3221  fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
3222 
3223  do k = 1, nlay
3224  fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
3225  htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3226  enddo
3227  enddo
3228  endif
3229 
3230 ! .................................
3231  end subroutine rtrnmr
3232 ! ---------------------------------
3234 
3235 
3259 ! ---------------------------------
3260  subroutine rtrnmc &
3261  & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & ! --- inputs:
3262  & fracs,secdif, nlay,nlp1, &
3263  & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs:
3264  & )
3266 ! =================== program usage description =================== !
3267 ! !
3268 ! purpose: compute the upward/downward radiative fluxes, and heating !
3269 ! rates for both clear or cloudy atmosphere. clouds are treated with !
3270 ! the mcica stochastic approach. !
3271 ! !
3272 ! subprograms called: none !
3273 ! !
3274 ! ==================== defination of variables ==================== !
3275 ! !
3276 ! inputs: -size- !
3277 ! semiss - real, lw surface emissivity nbands!
3278 ! delp - real, layer pressure thickness (mb) nlay !
3279 ! cldfmc - real, layer cloud fraction (sub-column) ngptlw*nlay!
3280 ! taucld - real, layer cloud opt depth nbands*nlay!
3281 ! tautot - real, total optical depth (gas+aerosols) ngptlw*nlay!
3282 ! pklay - real, integrated planck func at lay temp nbands*0:nlay!
3283 ! pklev - real, integrated planck func at lev temp nbands*0:nlay!
3284 ! fracs - real, planck fractions ngptlw*nlay!
3285 ! secdif - real, secant of diffusivity angle nbands!
3286 ! nlay - integer, number of vertical layers 1 !
3287 ! nlp1 - integer, number of vertical levels (interfaces) 1 !
3288 ! !
3289 ! outputs: !
3290 ! totuflux- real, total sky upward flux (w/m2) 0:nlay !
3291 ! totdflux- real, total sky downward flux (w/m2) 0:nlay !
3292 ! htr - real, total sky heating rate (k/sec or k/day) nlay !
3293 ! totuclfl- real, clear sky upward flux (w/m2) 0:nlay !
3294 ! totdclfl- real, clear sky downward flux (w/m2) 0:nlay !
3295 ! htrcl - real, clear sky heating rate (k/sec or k/day) nlay !
3296 ! htrb - real, spectral band lw heating rate (k/day) nlay*nbands!
3297 ! !
3298 ! module veriables: !
3299 ! ngb - integer, band index for each g-value ngptlw!
3300 ! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 !
3301 ! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 !
3302 ! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 !
3303 ! bpade - real, pade approx constant (1/0.278) 1 !
3304 ! wtdiff - real, weight for radiance to flux conversion 1 !
3305 ! ntbl - integer, dimension of look-up tables 1 !
3306 ! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl !
3307 ! exp_tbl - real, transmittance lookup table 0:ntbl !
3308 ! tfn_tbl - real, tau transition function 0:ntbl !
3309 ! !
3310 ! local variables: !
3311 ! itgas - integer, index for gases contribution look-up table 1 !
3312 ! ittot - integer, index for gases plus clouds look-up table 1 !
3313 ! reflct - real, surface reflectance 1 !
3314 ! atrgas - real, gaseous absorptivity 1 !
3315 ! atrtot - real, gaseous and cloud absorptivity 1 !
3316 ! odcld - real, cloud optical depth 1 !
3317 ! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay!
3318 ! odepth - real, optical depth of gaseous only 1 !
3319 ! odtot - real, optical depth of gas and cloud 1 !
3320 ! gasfac - real, gas-only pade factor, used for planck function 1 !
3321 ! totfac - real, gas and cloud pade factor, used for planck fn 1 !
3322 ! bbdgas - real, gas-only planck function for downward rt 1 !
3323 ! bbugas - real, gas-only planck function for upward rt 1 !
3324 ! bbdtot - real, gas and cloud planck function for downward rt 1 !
3325 ! bbutot - real, gas and cloud planck function for upward rt 1 !
3326 ! gassrcu- real, upwd source radiance due to gas nlay!
3327 ! totsrcu- real, upwd source radiance due to gas+cld nlay!
3328 ! gassrcd- real, dnwd source radiance due to gas 1 !
3329 ! totsrcd- real, dnwd source radiance due to gas+cld 1 !
3330 ! radtotu- real, spectrally summed total sky upwd radiance 1 !
3331 ! radclru- real, spectrally summed clear sky upwd radiance 1 !
3332 ! radtotd- real, spectrally summed total sky dnwd radiance 1 !
3333 ! radclrd- real, spectrally summed clear sky dnwd radiance 1 !
3334 ! toturad- real, total sky upward radiance by layer 0:nlay*nbands!
3335 ! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands!
3336 ! totdrad- real, total sky downward radiance by layer 0:nlay*nbands!
3337 ! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands!
3338 ! fnet - real, net longwave flux (w/m2) 0:nlay !
3339 ! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay !
3340 ! !
3341 ! !
3342 ! ******************************************************************* !
3343 ! original code description !
3344 ! !
3345 ! original version: e. j. mlawer, et al. rrtm_v3.0 !
3346 ! revision for gcms: michael j. iacono; october, 2002 !
3347 ! revision for f90: michael j. iacono; june, 2006 !
3348 ! !
3349 ! this program calculates the upward fluxes, downward fluxes, and !
3350 ! heating rates for an arbitrary clear or cloudy atmosphere. the input !
3351 ! to this program is the atmospheric profile, all Planck function !
3352 ! information, and the cloud fraction by layer. a variable diffusivity!
3353 ! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 !
3354 ! use a value for secdif that varies from 1.50 to 1.80 as a function !
3355 ! of the column water vapor, and other bands use a value of 1.66. the !
3356 ! gaussian weight appropriate to this angle (wtdiff=0.5) is applied !
3357 ! here. note that use of the emissivity angle for the flux integration!
3358 ! can cause errors of 1 to 4 W/m2 within cloudy layers. !
3359 ! clouds are treated with the mcica stochastic approach and !
3360 ! maximum-random cloud overlap. !
3361 ! !
3362 ! ******************************************************************* !
3363 ! ====================== end of description block ================= !
3364 
3365 ! --- inputs:
3366  integer, intent(in) :: nlay, nlp1
3367 
3368  real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, &
3369  & secdif
3370  real (kind=kind_phys), dimension(nlay), intent(in) :: delp
3371 
3372  real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld
3373  real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, &
3374  & tautot, cldfmc
3375 
3376  real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: &
3377  & pklev, pklay
3378 
3379 ! --- outputs:
3380  real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl
3381 
3382  real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb
3383 
3384  real (kind=kind_phys), dimension(0:nlay), intent(out) :: &
3385  & totuflux, totdflux, totuclfl, totdclfl
3386 
3387 ! --- locals:
3388  real (kind=kind_phys), parameter :: rec_6 = 0.166667
3389 
3390  real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, &
3391  & clrdrad, toturad, totdrad
3392 
3393  real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, &
3394  & trngas, efclrfr, rfdelp
3395  real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc
3396 
3397  real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, &
3398  & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, &
3399  & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, &
3400  & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, &
3401  & clfm, trng, gasu
3402 
3403  integer :: ittot, itgas, ib, ig, k
3404 !
3405 !===> ... begin here
3406 !
3407  do ib = 1, nbands
3408  do k = 0, nlay
3409  toturad(k,ib) = f_zero
3410  totdrad(k,ib) = f_zero
3411  clrurad(k,ib) = f_zero
3412  clrdrad(k,ib) = f_zero
3413  enddo
3414  enddo
3415 
3416  do k = 0, nlay
3417  totuflux(k) = f_zero
3418  totdflux(k) = f_zero
3419  totuclfl(k) = f_zero
3420  totdclfl(k) = f_zero
3421  enddo
3422 
3423 ! --- ... loop over all g-points
3424 
3425  do ig = 1, ngptlw
3426  ib = ngb(ig)
3427 
3428  radtotd = f_zero
3429  radclrd = f_zero
3430 
3437 
3438  do k = nlay, 1, -1
3439 
3440 ! --- ... clear sky, gases contribution
3441 
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
3447  else
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)
3454  endif
3455 
3456  plfrac = fracs(ig,k)
3457  blay = pklay(ib,k)
3458 
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
3465  trngas(k) = trng
3466 
3467 ! --- ... total sky, gases+clouds contribution
3468 
3469  clfm = cldfmc(ig,k)
3470  if (clfm >= eps) then
3471 ! --- ... cloudy layer
3472 
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
3479  else
3480  tblind = odtot / (bpade + odtot)
3481  ittot = tblint*tblind + 0.5
3482  totfac = tfn_tbl(ittot)
3483  atrtot = f_one - exp_tbl(ittot)
3484  endif
3485 
3486  bbdtot = plfrac * (blay + dplnkd*totfac)
3487  bbutot = plfrac * (blay + dplnku*totfac)
3488  totsrcd= bbdtot * atrtot
3489  totsrcu(k)= bbutot * atrtot
3490 
3491 ! --- ... total sky radiance
3492  radtotd = radtotd*trng*efclrfr(k) + gassrcd &
3493  & + clfm*(totsrcd - gassrcd)
3494  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3495 
3496 ! --- ... clear sky radiance
3497  radclrd = radclrd*trng + gassrcd
3498  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3499 
3500  else
3501 ! --- ... clear layer
3502 
3503 ! --- ... total sky radiance
3504  radtotd = radtotd*trng + gassrcd
3505  totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd
3506 
3507 ! --- ... clear sky radiance
3508  radclrd = radclrd*trng + gassrcd
3509  clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd
3510 
3511  endif ! end if_clfm_block
3512 
3513  enddo ! end do_k_loop
3514 
3518 
3519 ! note: spectral and Lambertian reflection are identical for the
3520 ! diffusivity angle flux integration used here.
3521 
3522  reflct = f_one - semiss(ib)
3523  rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0)
3524 
3526  radtotu = rad0 + reflct*radtotd
3527  toturad(0,ib) = toturad(0,ib) + radtotu
3528 
3530  radclru = rad0 + reflct*radclrd
3531  clrurad(0,ib) = clrurad(0,ib) + radclru
3532 
3536 
3537 ! toturad holds summed radiance for total sky stream
3538 ! clrurad holds summed radiance for clear sky stream
3539 
3540  do k = 1, nlay
3541  clfm = cldfmc(ig,k)
3542  trng = trngas(k)
3543  gasu = gassrcu(k)
3544 
3545  if (clfm > eps) then
3546 ! --- ... cloudy layer
3547 
3548 ! --- ... total sky radiance
3549  radtotu = radtotu*trng*efclrfr(k) + gasu &
3550  & + clfm*(totsrcu(k) - gasu)
3551  toturad(k,ib) = toturad(k,ib) + radtotu
3552 
3553 ! --- ... clear sky radiance
3554  radclru = radclru*trng + gasu
3555  clrurad(k,ib) = clrurad(k,ib) + radclru
3556 
3557  else
3558 ! --- ... clear layer
3559 
3560 ! --- ... total sky radiance
3561  radtotu = radtotu*trng + gasu
3562  toturad(k,ib) = toturad(k,ib) + radtotu
3563 
3564 ! --- ... clear sky radiance
3565  radclru = radclru*trng + gasu
3566  clrurad(k,ib) = clrurad(k,ib) + radclru
3567 
3568  endif ! end if_clfm_block
3569 
3570  enddo ! end do_k_loop
3571 
3572  enddo ! end do_ig_loop
3573 
3576 
3577  flxfac = wtdiff * fluxfac
3578 
3579  do k = 0, nlay
3580  do ib = 1, nbands
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)
3585  enddo
3586 
3587  totuflux(k) = totuflux(k) * flxfac
3588  totdflux(k) = totdflux(k) * flxfac
3589  totuclfl(k) = totuclfl(k) * flxfac
3590  totdclfl(k) = totdclfl(k) * flxfac
3591  enddo
3592 
3593 ! --- ... calculate net fluxes and heating rates
3594  fnet(0) = totuflux(0) - totdflux(0)
3595 
3596  do k = 1, nlay
3597  rfdelp(k) = heatfac / delp(k)
3598  fnet(k) = totuflux(k) - totdflux(k)
3599  htr(k) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3600  enddo
3601 
3602 !! --- ... optional clear sky heating rates
3603  if ( lhlw0 ) then
3604  fnetc(0) = totuclfl(0) - totdclfl(0)
3605 
3606  do k = 1, nlay
3607  fnetc(k) = totuclfl(k) - totdclfl(k)
3608  htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k)
3609  enddo
3610  endif
3611 
3612 !! --- ... optional spectral band heating rates
3613  if ( lhlwb ) then
3614  do ib = 1, nbands
3615  fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac
3616 
3617  do k = 1, nlay
3618  fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac
3619  htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k)
3620  enddo
3621  enddo
3622  endif
3623 
3624 ! ..................................
3625  end subroutine rtrnmc
3626 ! ----------------------------------
3628 
3673 ! ----------------------------------
3674  subroutine taumol &
3675  & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs
3676  & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, &
3677  & selffac,selffrac,indself,forfac,forfrac,indfor, &
3678  & minorfrac,scaleminor,scaleminorn2,indminor, &
3679  & nlay, &
3680  & fracs, tautot & ! --- outputs
3681  & )
3683 ! ************ original subprogram description *************** !
3684 ! !
3685 ! optical depths developed for the !
3686 ! !
3687 ! rapid radiative transfer model (rrtm) !
3688 ! !
3689 ! atmospheric and environmental research, inc. !
3690 ! 131 hartwell avenue !
3691 ! lexington, ma 02421 !
3692 ! !
3693 ! eli j. mlawer !
3694 ! jennifer delamere !
3695 ! steven j. taubman !
3696 ! shepard a. clough !
3697 ! !
3698 ! email: mlawer@aer.com !
3699 ! email: jdelamer@aer.com !
3700 ! !
3701 ! the authors wish to acknowledge the contributions of the !
3702 ! following people: karen cady-pereira, patrick d. brown, !
3703 ! michael j. iacono, ronald e. farren, luke chen, !
3704 ! robert bergstrom. !
3705 ! !
3706 ! revision for g-point reduction: michael j. iacono; aer, inc. !
3707 ! !
3708 ! taumol !
3709 ! !
3710 ! this file contains the subroutines taugbn (where n goes from !
3711 ! 1 to 16). taugbn calculates the optical depths and planck !
3712 ! fractions per g-value and layer for band n. !
3713 ! !
3714 ! ******************************************************************* !
3715 ! ================== program usage description ================== !
3716 ! !
3717 ! call taumol !
3718 ! inputs: !
3719 ! ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, !
3720 ! rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, !
3721 ! selffac,selffrac,indself,forfac,forfrac,indfor, !
3722 ! minorfrac,scaleminor,scaleminorn2,indminor, !
3723 ! nlay, !
3724 ! outputs: !
3725 ! fracs, tautot ) !
3726 ! !
3727 ! subprograms called: taugb## (## = 01 -16) !
3728 ! !
3729 ! !
3730 ! ==================== defination of variables ==================== !
3731 ! !
3732 ! inputs: size !
3733 ! laytrop - integer, tropopause layer index (unitless) 1 !
3734 ! layer at which switch is made for key species !
3735 ! pavel - real, layer pressures (mb) nlay !
3736 ! coldry - real, column amount for dry air (mol/cm2) nlay !
3737 ! colamt - real, column amounts of h2o, co2, o3, n2o, ch4, !
3738 ! o2, co (mol/cm**2) nlay*maxgas!
3739 ! colbrd - real, column amount of broadening gases nlay !
3740 ! wx - real, cross-section amounts(mol/cm2) nlay*maxxsec!
3741 ! tauaer - real, aerosol optical depth nbands*nlay !
3742 ! rfrate - real, reference ratios of binary species parameter !
3743 ! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2!
3744 ! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer !
3745 ! nlay*nrates*2!
3746 ! facij - real, factors multiply the reference ks, i,j of 0/1 !
3747 ! for lower/higher of the 2 appropriate temperatures !
3748 ! and altitudes nlay !
3749 ! jp - real, index of lower reference pressure nlay !
3750 ! jt, jt1 - real, indices of lower reference temperatures nlay !
3751 ! for pressure levels jp and jp+1, respectively !
3752 ! selffac - real, scale factor for water vapor self-continuum !
3753 ! equals (water vapor density)/(atmospheric density !
3754 ! at 296k and 1013 mb) nlay !
3755 ! selffrac - real, factor for temperature interpolation of !
3756 ! reference water vapor self-continuum data nlay !
3757 ! indself - integer, index of lower reference temperature for !
3758 ! the self-continuum interpolation nlay !
3759 ! forfac - real, scale factor for w. v. foreign-continuum nlay !
3760 ! forfrac - real, factor for temperature interpolation of !
3761 ! reference w.v. foreign-continuum data nlay !
3762 ! indfor - integer, index of lower reference temperature for !
3763 ! the foreign-continuum interpolation nlay !
3764 ! minorfrac - real, factor for minor gases nlay !
3765 ! scaleminor,scaleminorn2 !
3766 ! - real, scale factors for minor gases nlay !
3767 ! indminor - integer, index of lower reference temperature for !
3768 ! minor gases nlay !
3769 ! nlay - integer, total number of layers 1 !
3770 ! !
3771 ! outputs: !
3772 ! fracs - real, planck fractions ngptlw,nlay!
3773 ! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay!
3774 ! !
3775 ! internal variables: !
3776 ! ng## - integer, number of g-values in band ## (##=01-16) 1 !
3777 ! nspa - integer, for lower atmosphere, the number of ref !
3778 ! atmos, each has different relative amounts of the !
3779 ! key species for the band nbands!
3780 ! nspb - integer, same but for upper atmosphere nbands!
3781 ! absa - real, k-values for lower ref atmospheres (no w.v. !
3782 ! self-continuum) (cm**2/molecule) nspa(##)*5*13*ng##!
3783 ! absb - real, k-values for high ref atmospheres (all sources) !
3784 ! (cm**2/molecule) nspb(##)*5*13:59*ng##!
3785 ! ka_m'mgas'- real, k-values for low ref atmospheres minor species !
3786 ! (cm**2/molecule) mmn##*ng##!
3787 ! kb_m'mgas'- real, k-values for high ref atmospheres minor species !
3788 ! (cm**2/molecule) mmn##*ng##!
3789 ! selfref - real, k-values for w.v. self-continuum for ref atmos !
3790 ! used below laytrop (cm**2/mol) 10*ng##!
3791 ! forref - real, k-values for w.v. foreign-continuum for ref atmos
3792 ! used below/above laytrop (cm**2/mol) 4*ng##!
3793 ! !
3794 ! ****************************************************************** !
3795 
3796 ! --- inputs:
3797  integer, intent(in) :: nlay, laytrop
3798 
3799  integer, dimension(nlay), intent(in) :: jp, jt, jt1, indself, &
3800  & indfor, indminor
3801 
3802  real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, &
3803  & coldry, colbrd, fac00, fac01, fac10, fac11, selffac, &
3804  & selffrac, forfac, forfrac, minorfrac, scaleminor, &
3805  & scaleminorn2
3806 
3807  real (kind=kind_phys), dimension(nlay,maxgas), intent(in):: colamt
3808  real (kind=kind_phys), dimension(nlay,maxxsec),intent(in):: wx
3809 
3810  real (kind=kind_phys), dimension(nbands,nlay), intent(in):: tauaer
3811 
3812  real (kind=kind_phys), dimension(nlay,nrates,2), intent(in) :: &
3813  & rfrate
3814 
3815 ! --- outputs:
3816  real (kind=kind_phys), dimension(ngptlw,nlay), intent(out) :: &
3817  & fracs, tautot
3818 
3819 ! --- locals
3820  real (kind=kind_phys), dimension(ngptlw,nlay) :: taug
3821 
3822  integer :: ib, ig, k
3823 !
3824 !===> ... begin here
3825 !
3826  call taugb01
3827  call taugb02
3828  call taugb03
3829  call taugb04
3830  call taugb05
3831  call taugb06
3832  call taugb07
3833  call taugb08
3834  call taugb09
3835  call taugb10
3836  call taugb11
3837  call taugb12
3838  call taugb13
3839  call taugb14
3840  call taugb15
3841  call taugb16
3842 
3843 ! --- combine gaseous and aerosol optical depths
3844 
3845  do ig = 1, ngptlw
3846  ib = ngb(ig)
3847 
3848  do k = 1, nlay
3849  tautot(ig,k) = taug(ig,k) + tauaer(ib,k)
3850  enddo
3851  enddo
3852 
3853 ! =================
3854  contains
3855 ! =================
3856 
3859 ! ----------------------------------
3860  subroutine taugb01
3861 ! ..................................
3862 
3863 ! ------------------------------------------------------------------ !
3864 ! written by eli j. mlawer, atmospheric & environmental research. !
3865 ! revised by michael j. iacono, atmospheric & environmental research. !
3866 ! !
3867 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) !
3868 ! (high key - h2o; high minor - n2) !
3869 ! !
3870 ! compute the optical depth by interpolating in ln(pressure) and !
3871 ! temperature. below laytrop, the water vapor self-continuum and !
3872 ! foreign continuum is interpolated (in temperature) separately. !
3873 ! ------------------------------------------------------------------ !
3874 
3875  use module_radlw_kgb01
3876 
3877 ! --- locals:
3878  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
3879  & indm, indmp, ig
3880 
3881  real (kind=kind_phys) :: pp, corradj, scalen2, tauself, taufor, &
3882  & taun2
3883 !
3884 !===> ... begin here
3885 !
3886 ! --- minor gas mapping levels:
3887 ! lower - n2, p = 142.5490 mbar, t = 215.70 k
3888 ! upper - n2, p = 142.5490 mbar, t = 215.70 k
3889 
3890 ! --- ... lower atmosphere loop
3891 
3892  do k = 1, laytrop
3893  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(1) + 1
3894  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(1) + 1
3895  inds = indself(k)
3896  indf = indfor(k)
3897  indm = indminor(k)
3898 
3899  ind0p = ind0 + 1
3900  ind1p = ind1 + 1
3901  indsp = inds + 1
3902  indfp = indf + 1
3903  indmp = indm + 1
3904 
3905  pp = pavel(k)
3906  scalen2 = colbrd(k) * scaleminorn2(k)
3907  if (pp < 250.0) then
3908  corradj = f_one - 0.15 * (250.0-pp) / 154.4
3909  else
3910  corradj = f_one
3911  endif
3912 
3913  do ig = 1, ng01
3914  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
3915  & * (selfref(ig,indsp) - selfref(ig,inds)))
3916  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
3917  & * (forref(ig,indfp) - forref(ig,indf)))
3918  taun2 = scalen2 * (ka_mn2(ig,indm) + minorfrac(k) &
3919  & * (ka_mn2(ig,indmp) - ka_mn2(ig,indm)))
3920 
3921  taug(ig,k) = corradj * (colamt(k,1) &
3922  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
3923  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
3924  & + tauself + taufor + taun2)
3925 
3926  fracs(ig,k) = fracrefa(ig)
3927  enddo
3928  enddo
3929 
3930 ! --- ... upper atmosphere loop
3931 
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
3935  indf = indfor(k)
3936  indm = indminor(k)
3937 
3938  ind0p = ind0 + 1
3939  ind1p = ind1 + 1
3940  indfp = indf + 1
3941  indmp = indm + 1
3942 
3943  scalen2 = colbrd(k) * scaleminorn2(k)
3944  corradj = f_one - 0.15 * (pavel(k) / 95.6)
3945 
3946  do ig = 1, ng01
3947  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
3948  & * (forref(ig,indfp) - forref(ig,indf)))
3949  taun2 = scalen2 * (kb_mn2(ig,indm) + minorfrac(k) &
3950  & * (kb_mn2(ig,indmp) - kb_mn2(ig,indm)))
3951 
3952  taug(ig,k) = corradj * (colamt(k,1) &
3953  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
3954  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
3955  & + taufor + taun2)
3956 
3957  fracs(ig,k) = fracrefb(ig)
3958  enddo
3959  enddo
3960 
3961 ! ..................................
3962  end subroutine taugb01
3963 ! ----------------------------------
3964 
3966 ! ----------------------------------
3967  subroutine taugb02
3968 ! ..................................
3969 
3970 ! ------------------------------------------------------------------ !
3971 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) !
3972 ! ------------------------------------------------------------------ !
3973 
3974  use module_radlw_kgb02
3975 
3976 ! --- locals:
3977  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
3978  & ig
3979 
3980  real (kind=kind_phys) :: corradj, tauself, taufor
3981 !
3982 !===> ... begin here
3983 !
3984 ! --- ... lower atmosphere loop
3985 
3986  do k = 1, laytrop
3987  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(2) + 1
3988  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(2) + 1
3989  inds = indself(k)
3990  indf = indfor(k)
3991 
3992  ind0p = ind0 + 1
3993  ind1p = ind1 + 1
3994  indsp = inds + 1
3995  indfp = indf + 1
3996 
3997  corradj = f_one - 0.05 * (pavel(k) - 100.0) / 900.0
3998 
3999  do ig = 1, ng02
4000  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
4001  & * (selfref(ig,indsp) - selfref(ig,inds)))
4002  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4003  & * (forref(ig,indfp) - forref(ig,indf)))
4004 
4005  taug(ns02+ig,k) = corradj * (colamt(k,1) &
4006  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
4007  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
4008  & + tauself + taufor)
4009 
4010  fracs(ns02+ig,k) = fracrefa(ig)
4011  enddo
4012  enddo
4013 
4014 ! --- ... upper atmosphere loop
4015 
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
4019  indf = indfor(k)
4020 
4021  ind0p = ind0 + 1
4022  ind1p = ind1 + 1
4023  indfp = indf + 1
4024 
4025  do ig = 1, ng02
4026  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4027  & * (forref(ig,indfp) - forref(ig,indf)))
4028 
4029  taug(ns02+ig,k) = colamt(k,1) &
4030  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
4031  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
4032  & + taufor
4033 
4034  fracs(ns02+ig,k) = fracrefb(ig)
4035  enddo
4036  enddo
4037 
4038 ! ..................................
4039  end subroutine taugb02
4040 ! ----------------------------------
4041 
4044 ! ----------------------------------
4045  subroutine taugb03
4046 ! ..................................
4047 
4048 ! ------------------------------------------------------------------ !
4049 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) !
4050 ! (high key - h2o,co2; high minor - n2o) !
4051 ! ------------------------------------------------------------------ !
4052 
4053  use module_radlw_kgb03
4054 
4055 ! --- locals:
4056  integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
4057  & id000, id010, id100, id110, id200, id210, jmn2o, jmn2op, &
4058  & id001, id011, id101, id111, id201, id211, jpl, jplp, &
4059  & ig, js, js1
4060 
4061  real (kind=kind_phys) :: absn2o, ratn2o, adjfac, adjcoln2o, &
4062  & speccomb, specparm, specmult, fs, &
4063  & speccomb1, specparm1, specmult1, fs1, &
4064  & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, &
4065  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
4066  & refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b, &
4067  & fac000, fac100, fac200, fac010, fac110, fac210, &
4068  & fac001, fac101, fac201, fac011, fac111, fac211, &
4069  & tau_major, tau_major1, tauself, taufor, n2om1, n2om2, &
4070  & p, p4, fk0, fk1, fk2
4071 !
4072 !===> ... begin here
4073 !
4074 ! --- ... minor gas mapping levels:
4075 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
4076 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
4077 
4078  refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) ! P = 212.725 mb
4079  refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb
4080  refrat_m_a = chi_mls(1,3)/chi_mls(2,3) ! P = 706.270 mb
4081  refrat_m_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb
4082 
4083 ! --- ... lower atmosphere loop
4084 
4085  do k = 1, laytrop
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
4092 
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
4099 
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)
4105 
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)
4111 
4112  inds = indself(k)
4113  indf = indfor(k)
4114  indm = indminor(k)
4115  indsp = inds + 1
4116  indfp = indf + 1
4117  indmp = indm + 1
4118  jmn2op= jmn2o+ 1
4119  jplp = jpl + 1
4120 
4121 ! --- ... in atmospheres where the amount of n2O is too great to be considered
4122 ! a minor species, adjust the column amount of n2O by an empirical factor
4123 ! to obtain the proper contribution.
4124 
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
4130  else
4131  adjcoln2o = colamt(k,4)
4132  endif
4133 
4134  if (specparm < 0.125) then
4135  p = fs - f_one
4136  p4 = p**4
4137  fk0 = p4
4138  fk1 = f_one - p - 2.0*p4
4139  fk2 = p + p4
4140  id000 = ind0
4141  id010 = ind0 + 9
4142  id100 = ind0 + 1
4143  id110 = ind0 +10
4144  id200 = ind0 + 2
4145  id210 = ind0 +11
4146  else if (specparm > 0.875) then
4147  p = -fs
4148  p4 = p**4
4149  fk0 = p4
4150  fk1 = f_one - p - 2.0*p4
4151  fk2 = p + p4
4152  id000 = ind0 + 1
4153  id010 = ind0 +10
4154  id100 = ind0
4155  id110 = ind0 + 9
4156  id200 = ind0 - 1
4157  id210 = ind0 + 8
4158  else
4159  fk0 = f_one - fs
4160  fk1 = fs
4161  fk2 = f_zero
4162  id000 = ind0
4163  id010 = ind0 + 9
4164  id100 = ind0 + 1
4165  id110 = ind0 +10
4166  id200 = ind0
4167  id210 = ind0
4168  endif
4169 
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)
4176 
4177  if (specparm1 < 0.125) then
4178  p = fs1 - f_one
4179  p4 = p**4
4180  fk0 = p4
4181  fk1 = f_one - p - 2.0*p4
4182  fk2 = p + p4
4183  id001 = ind1
4184  id011 = ind1 + 9
4185  id101 = ind1 + 1
4186  id111 = ind1 +10
4187  id201 = ind1 + 2
4188  id211 = ind1 +11
4189  elseif (specparm1 > 0.875) then
4190  p = -fs1
4191  p4 = p**4
4192  fk0 = p4
4193  fk1 = f_one - p - 2.0*p4
4194  fk2 = p + p4
4195  id001 = ind1 + 1
4196  id011 = ind1 +10
4197  id101 = ind1
4198  id111 = ind1 + 9
4199  id201 = ind1 - 1
4200  id211 = ind1 + 8
4201  else
4202  fk0 = f_one - fs1
4203  fk1 = fs1
4204  fk2 = f_zero
4205  id001 = ind1
4206  id011 = ind1 + 9
4207  id101 = ind1 + 1
4208  id111 = ind1 +10
4209  id201 = ind1
4210  id211 = ind1
4211  endif
4212 
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)
4219 
4220  do ig = 1, ng03
4221  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
4222  & * (selfref(ig,indsp) - selfref(ig,inds)))
4223  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4224  & * (forref(ig,indfp) - forref(ig,indf)))
4225  n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o &
4226  & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm))
4227  n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o &
4228  & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp))
4229  absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1)
4230 
4231  tau_major = speccomb &
4232  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
4233  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
4234  & + fac200*absa(ig,id200) + fac210*absa(ig,id210))
4235 
4236  tau_major1 = speccomb1 &
4237  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
4238  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
4239  & + fac201*absa(ig,id201) + fac211*absa(ig,id211))
4240 
4241  taug(ns03+ig,k) = tau_major + tau_major1 &
4242  & + tauself + taufor + adjcoln2o*absn2o
4243 
4244  fracs(ns03+ig,k) = fracrefa(ig,jpl) + fpl &
4245  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
4246  enddo ! end do_k_loop
4247  enddo ! end do_ig_loop
4248 
4249 ! --- ... upper atmosphere loop
4250 
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
4258 
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
4265 
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)
4271 
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)
4277 
4278  indf = indfor(k)
4279  indm = indminor(k)
4280  indfp = indf + 1
4281  indmp = indm + 1
4282  jmn2op= jmn2o+ 1
4283  jplp = jpl + 1
4284 
4285  id000 = ind0
4286  id010 = ind0 + 5
4287  id100 = ind0 + 1
4288  id110 = ind0 + 6
4289  id001 = ind1
4290  id011 = ind1 + 5
4291  id101 = ind1 + 1
4292  id111 = ind1 + 6
4293 
4294 ! --- ... in atmospheres where the amount of n2o is too great to be considered
4295 ! a minor species, adjust the column amount of N2O by an empirical factor
4296 ! to obtain the proper contribution.
4297 
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
4303  else
4304  adjcoln2o = colamt(k,4)
4305  endif
4306 
4307  fk0 = f_one - fs
4308  fk1 = fs
4309  fac000 = fk0*fac00(k)
4310  fac010 = fk0*fac10(k)
4311  fac100 = fk1*fac00(k)
4312  fac110 = fk1*fac10(k)
4313 
4314  fk0 = f_one - fs1
4315  fk1 = fs1
4316  fac001 = fk0*fac01(k)
4317  fac011 = fk0*fac11(k)
4318  fac101 = fk1*fac01(k)
4319  fac111 = fk1*fac11(k)
4320 
4321  do ig = 1, ng03
4322  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4323  & * (forref(ig,indfp) - forref(ig,indf)))
4324  n2om1 = kb_mn2o(ig,jmn2o,indm) + fmn2o &
4325  & * (kb_mn2o(ig,jmn2op,indm) - kb_mn2o(ig,jmn2o,indm))
4326  n2om2 = kb_mn2o(ig,jmn2o,indmp) + fmn2o &
4327  & * (kb_mn2o(ig,jmn2op,indmp) - kb_mn2o(ig,jmn2o,indmp))
4328  absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1)
4329 
4330  tau_major = speccomb &
4331  & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) &
4332  & + fac100*absb(ig,id100) + fac110*absb(ig,id110))
4333 
4334  tau_major1 = speccomb1 &
4335  & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) &
4336  & + fac101*absb(ig,id101) + fac111*absb(ig,id111))
4337 
4338  taug(ns03+ig,k) = tau_major + tau_major1 &
4339  & + taufor + adjcoln2o*absn2o
4340 
4341  fracs(ns03+ig,k) = fracrefb(ig,jpl) + fpl &
4342  & * (fracrefb(ig,jplp) - fracrefb(ig,jpl))
4343  enddo
4344  enddo
4345 
4346 ! ..................................
4347  end subroutine taugb03
4348 ! ----------------------------------
4349 
4351 ! ----------------------------------
4352  subroutine taugb04
4353 ! ..................................
4354 
4355 ! ------------------------------------------------------------------ !
4356 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) !
4357 ! ------------------------------------------------------------------ !
4358 
4359  use module_radlw_kgb04
4360 
4361 ! --- locals:
4362  integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, &
4363  & id000, id010, id100, id110, id200, id210, ig, js, js1, &
4364  & id001, id011, id101, id111, id201, id211
4365 
4366  real (kind=kind_phys) :: tauself, taufor, p, p4, fk0, fk1, fk2, &
4367  & speccomb, specparm, specmult, fs, &
4368  & speccomb1, specparm1, specmult1, fs1, &
4369  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
4370  & fac000, fac100, fac200, fac010, fac110, fac210, &
4371  & fac001, fac101, fac201, fac011, fac111, fac211, &
4372  & refrat_planck_a, refrat_planck_b, tau_major, tau_major1
4373 !
4374 !===> ... begin here
4375 !
4376  refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) ! P = 142.5940 mb
4377  refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) ! P = 95.58350 mb
4378 
4379 ! --- ... lower atmosphere loop
4380 
4381  do k = 1, laytrop
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
4388 
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
4395 
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)
4401 
4402  inds = indself(k)
4403  indf = indfor(k)
4404  indsp = inds + 1
4405  indfp = indf + 1
4406  jplp = jpl + 1
4407 
4408  if (specparm < 0.125) then
4409  p = fs - f_one
4410  p4 = p**4
4411  fk0 = p4
4412  fk1 = f_one - p - 2.0*p4
4413  fk2 = p + p4
4414  id000 = ind0
4415  id010 = ind0 + 9
4416  id100 = ind0 + 1
4417  id110 = ind0 +10
4418  id200 = ind0 + 2
4419  id210 = ind0 +11
4420  elseif (specparm > 0.875) then
4421  p = -fs
4422  p4 = p**4
4423  fk0 = p4
4424  fk1 = f_one - p - 2.0*p4
4425  fk2 = p + p4
4426  id000 = ind0 + 1
4427  id010 = ind0 +10
4428  id100 = ind0
4429  id110 = ind0 + 9
4430  id200 = ind0 - 1
4431  id210 = ind0 + 8
4432  else
4433  fk0 = f_one - fs
4434  fk1 = fs
4435  fk2 = f_zero
4436  id000 = ind0
4437  id010 = ind0 + 9
4438  id100 = ind0 + 1
4439  id110 = ind0 +10
4440  id200 = ind0
4441  id210 = ind0
4442  endif
4443 
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)
4450 
4451  if (specparm1 < 0.125) then
4452  p = fs1 - f_one
4453  p4 = p**4
4454  fk0 = p4
4455  fk1 = f_one - p - 2.0*p4
4456  fk2 = p + p4
4457  id001 = ind1
4458  id011 = ind1 + 9
4459  id101 = ind1 + 1
4460  id111 = ind1 +10
4461  id201 = ind1 + 2
4462  id211 = ind1 +11
4463  elseif (specparm1 > 0.875) then
4464  p = -fs1
4465  p4 = p**4
4466  fk0 = p4
4467  fk1 = f_one - p - 2.0*p4
4468  fk2 = p + p4
4469  id001 = ind1 + 1
4470  id011 = ind1 +10
4471  id101 = ind1
4472  id111 = ind1 + 9
4473  id201 = ind1 - 1
4474  id211 = ind1 + 8
4475  else
4476  fk0 = f_one - fs1
4477  fk1 = fs1
4478  fk2 = f_zero
4479  id001 = ind1
4480  id011 = ind1 + 9
4481  id101 = ind1 + 1
4482  id111 = ind1 +10
4483  id201 = ind1
4484  id211 = ind1
4485  endif
4486 
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)
4493 
4494  do ig = 1, ng04
4495  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
4496  & * (selfref(ig,indsp) - selfref(ig,inds)))
4497  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4498  & * (forref(ig,indfp) - forref(ig,indf)))
4499 
4500  tau_major = speccomb &
4501  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
4502  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
4503  & + fac200*absa(ig,id200) + fac210*absa(ig,id210))
4504 
4505  tau_major1 = speccomb1 &
4506  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
4507  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
4508  & + fac201*absa(ig,id201) + fac211*absa(ig,id211))
4509 
4510  taug(ns04+ig,k) = tau_major + tau_major1 + tauself + taufor
4511 
4512  fracs(ns04+ig,k) = fracrefa(ig,jpl) + fpl &
4513  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
4514  enddo ! end do_k_loop
4515  enddo ! end do_ig_loop
4516 
4517 ! --- ... upper atmosphere loop
4518 
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
4526 
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
4533 
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)
4539  jplp = jpl + 1
4540 
4541  id000 = ind0
4542  id010 = ind0 + 5
4543  id100 = ind0 + 1
4544  id110 = ind0 + 6
4545  id001 = ind1
4546  id011 = ind1 + 5
4547  id101 = ind1 + 1
4548  id111 = ind1 + 6
4549 
4550  fk0 = f_one - fs
4551  fk1 = fs
4552  fac000 = fk0*fac00(k)
4553  fac010 = fk0*fac10(k)
4554  fac100 = fk1*fac00(k)
4555  fac110 = fk1*fac10(k)
4556 
4557  fk0 = f_one - fs1
4558  fk1 = fs1
4559  fac001 = fk0*fac01(k)
4560  fac011 = fk0*fac11(k)
4561  fac101 = fk1*fac01(k)
4562  fac111 = fk1*fac11(k)
4563 
4564  do ig = 1, ng04
4565  tau_major = speccomb &
4566  & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) &
4567  & + fac100*absb(ig,id100) + fac110*absb(ig,id110))
4568  tau_major1 = speccomb1 &
4569  & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) &
4570  & + fac101*absb(ig,id101) + fac111*absb(ig,id111))
4571 
4572  taug(ns04+ig,k) = tau_major + tau_major1
4573 
4574  fracs(ns04+ig,k) = fracrefb(ig,jpl) + fpl &
4575  & * (fracrefb(ig,jplp) - fracrefb(ig,jpl))
4576  enddo
4577 
4578 ! --- ... empirical modification to code to improve stratospheric cooling rates
4579 ! for co2. revised to apply weighting for g-point reduction in this band.
4580 
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
4588  enddo
4589 
4590 ! ..................................
4591  end subroutine taugb04
4592 ! ----------------------------------
4593 
4596 ! ----------------------------------
4597  subroutine taugb05
4598 ! ..................................
4599 
4600 ! ------------------------------------------------------------------ !
4601 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) !
4602 ! (high key - o3,co2) !
4603 ! ------------------------------------------------------------------ !
4604 
4605  use module_radlw_kgb05
4606 
4607 ! --- locals:
4608  integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
4609  & id000, id010, id100, id110, id200, id210, jmo3, jmo3p, &
4610  & id001, id011, id101, id111, id201, id211, jpl, jplp, &
4611  & ig, js, js1
4612 
4613  real (kind=kind_phys) :: tauself, taufor, o3m1, o3m2, abso3, &
4614  & speccomb, specparm, specmult, fs, &
4615  & speccomb1, specparm1, specmult1, fs1, &
4616  & speccomb_mo3, specparm_mo3, specmult_mo3, fmo3, &
4617  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
4618  & refrat_planck_a, refrat_planck_b, refrat_m_a, &
4619  & fac000, fac100, fac200, fac010, fac110, fac210, &
4620  & fac001, fac101, fac201, fac011, fac111, fac211, &
4621  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21
4622 !
4623 !===> ... begin here
4624 !
4625 ! --- ... minor gas mapping level :
4626 ! lower - o3, p = 317.34 mbar, t = 240.77 k
4627 ! lower - ccl4
4628 
4629 ! --- ... calculate reference ratio to be used in calculation of Planck
4630 ! fraction in lower/upper atmosphere.
4631 
4632  refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) ! P = 473.420 mb
4633  refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) ! P = 0.2369 mb
4634  refrat_m_a = chi_mls(1,7)/chi_mls(2,7) ! P = 317.348 mb
4635 
4636 ! --- ... lower atmosphere loop
4637 
4638  do k = 1, laytrop
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
4645 
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
4652 
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)
4658 
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)
4664 
4665  inds = indself(k)
4666  indf = indfor(k)
4667  indm = indminor(k)
4668  indsp = inds + 1
4669  indfp = indf + 1
4670  indmp = indm + 1
4671  jplp = jpl + 1
4672  jmo3p = jmo3 + 1
4673 
4674  if (specparm < 0.125 .and. specparm1 < 0.125) then
4675  p0 = fs - f_one
4676  p40 = p0**4
4677  fk00 = p40
4678  fk10 = f_one - p0 - 2.0*p40
4679  fk20 = p0 + p40
4680 
4681  p1 = fs1 - f_one
4682  p41 = p1**4
4683  fk01 = p41
4684  fk11 = f_one - p1 - 2.0*p41
4685  fk21 = p1 + p41
4686 
4687  id000 = ind0
4688  id010 = ind0 + 9
4689  id100 = ind0 + 1
4690  id110 = ind0 +10
4691  id200 = ind0 + 2
4692  id210 = ind0 +11
4693 
4694  id001 = ind1
4695  id011 = ind1 + 9
4696  id101 = ind1 + 1
4697  id111 = ind1 +10
4698  id201 = ind1 + 2
4699  id211 = ind1 +11
4700  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
4701  p0 = -fs
4702  p40 = p0**4
4703  fk00 = p40
4704  fk10 = f_one - p0 - 2.0*p40
4705  fk20 = p0 + p40
4706 
4707  p1 = -fs1
4708  p41 = p1**4
4709  fk01 = p41
4710  fk11 = f_one - p1 - 2.0*p41
4711  fk21 = p1 + p41
4712 
4713  id000 = ind0 + 1
4714  id010 = ind0 +10
4715  id100 = ind0
4716  id110 = ind0 + 9
4717  id200 = ind0 - 1
4718  id210 = ind0 + 8
4719 
4720  id001 = ind1 + 1
4721  id011 = ind1 +10
4722  id101 = ind1
4723  id111 = ind1 + 9
4724  id201 = ind1 - 1
4725  id211 = ind1 + 8
4726  else
4727  fk00 = f_one - fs
4728  fk10 = fs
4729  fk20 = f_zero
4730 
4731  fk01 = f_one - fs1
4732  fk11 = fs1
4733  fk21 = f_zero
4734 
4735  id000 = ind0
4736  id010 = ind0 + 9
4737  id100 = ind0 + 1
4738  id110 = ind0 +10
4739  id200 = ind0
4740  id210 = ind0
4741 
4742  id001 = ind1
4743  id011 = ind1 + 9
4744  id101 = ind1 + 1
4745  id111 = ind1 +10
4746  id201 = ind1
4747  id211 = ind1
4748  endif
4749 
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)
4756 
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)
4763 
4764  do ig = 1, ng05
4765  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
4766  & * (selfref(ig,indsp) - selfref(ig,inds)))
4767  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4768  & * (forref(ig,indfp) - forref(ig,indf)))
4769  o3m1 = ka_mo3(ig,jmo3,indm) + fmo3 &
4770  & * (ka_mo3(ig,jmo3p,indm) - ka_mo3(ig,jmo3,indm))
4771  o3m2 = ka_mo3(ig,jmo3,indmp) + fmo3 &
4772  & * (ka_mo3(ig,jmo3p,indmp) - ka_mo3(ig,jmo3,indmp))
4773  abso3 = o3m1 + minorfrac(k)*(o3m2 - o3m1)
4774 
4775  taug(ns05+ig,k) = speccomb &
4776  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
4777  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
4778  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
4779  & + speccomb1 &
4780  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
4781  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
4782  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
4783  & + tauself + taufor+abso3*colamt(k,3)+wx(k,1)*ccl4(ig)
4784 
4785  fracs(ns05+ig,k) = fracrefa(ig,jpl) + fpl &
4786  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
4787  enddo
4788  enddo
4789 
4790 ! --- ... upper atmosphere loop
4791 
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
4799 
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
4806 
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)
4812  jplp= jpl + 1
4813 
4814  id000 = ind0
4815  id010 = ind0 + 5
4816  id100 = ind0 + 1
4817  id110 = ind0 + 6
4818  id001 = ind1
4819  id011 = ind1 + 5
4820  id101 = ind1 + 1
4821  id111 = ind1 + 6
4822 
4823  fk00 = f_one - fs
4824  fk10 = fs
4825 
4826  fk01 = f_one - fs1
4827  fk11 = fs1
4828 
4829  fac000 = fk00 * fac00(k)
4830  fac010 = fk00 * fac10(k)
4831  fac100 = fk10 * fac00(k)
4832  fac110 = fk10 * fac10(k)
4833 
4834  fac001 = fk01 * fac01(k)
4835  fac011 = fk01 * fac11(k)
4836  fac101 = fk11 * fac01(k)
4837  fac111 = fk11 * fac11(k)
4838 
4839  do ig = 1, ng05
4840  taug(ns05+ig,k) = speccomb &
4841  & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) &
4842  & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) &
4843  & + speccomb1 &
4844  & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) &
4845  & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) &
4846  & + wx(k,1) * ccl4(ig)
4847 
4848  fracs(ns05+ig,k) = fracrefb(ig,jpl) + fpl &
4849  & * (fracrefb(ig,jplp) - fracrefb(ig,jpl))
4850  enddo
4851  enddo
4852 
4853 ! ..................................
4854  end subroutine taugb05
4855 ! ----------------------------------
4856 
4859 ! ----------------------------------
4860  subroutine taugb06
4861 ! ..................................
4862 
4863 ! ------------------------------------------------------------------ !
4864 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) !
4865 ! (high key - none; high minor - cfc11, cfc12)
4866 ! ------------------------------------------------------------------ !
4867 
4868  use module_radlw_kgb06
4869 
4870 ! --- locals:
4871  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
4872  & indm, indmp, ig
4873 
4874  real (kind=kind_phys) :: ratco2, adjfac, adjcolco2, tauself, &
4875  & taufor, absco2, temp
4876 !
4877 !===> ... begin here
4878 !
4879 ! --- ... minor gas mapping level:
4880 ! lower - co2, p = 706.2720 mb, t = 294.2 k
4881 ! upper - cfc11, cfc12
4882 
4883 ! --- ... lower atmosphere loop
4884 
4885  do k = 1, laytrop
4886  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(6) + 1
4887  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(6) + 1
4888 
4889  inds = indself(k)
4890  indf = indfor(k)
4891  indm = indminor(k)
4892  indsp = inds + 1
4893  indfp = indf + 1
4894  indmp = indm + 1
4895  ind0p = ind0 + 1
4896  ind1p = ind1 + 1
4897 
4898 ! --- ... in atmospheres where the amount of co2 is too great to be considered
4899 ! a minor species, adjust the column amount of co2 by an empirical factor
4900 ! to obtain the proper contribution.
4901 
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
4907  else
4908  adjcolco2 = colamt(k,2)
4909  endif
4910 
4911  do ig = 1, ng06
4912  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
4913  & * (selfref(ig,indsp) - selfref(ig,inds)))
4914  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
4915  & * (forref(ig,indfp) - forref(ig,indf)))
4916  absco2 = ka_mco2(ig,indm) + minorfrac(k) &
4917  & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm))
4918 
4919  taug(ns06+ig,k) = colamt(k,1) &
4920  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
4921  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
4922  & + tauself + taufor + adjcolco2*absco2 &
4923  & + wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig)
4924 
4925  fracs(ns06+ig,k) = fracrefa(ig)
4926  enddo
4927  enddo
4928 
4929 ! --- ... upper atmosphere loop
4930 ! nothing important goes on above laytrop in this band.
4931 
4932  do k = laytrop+1, nlay
4933  do ig = 1, ng06
4934  taug(ns06+ig,k) = wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig)
4935 
4936  fracs(ns06+ig,k) = fracrefa(ig)
4937  enddo
4938  enddo
4939 
4940 ! ..................................
4941  end subroutine taugb06
4942 ! ----------------------------------
4943 
4946 ! ----------------------------------
4947  subroutine taugb07
4948 ! ..................................
4949 
4950 ! ------------------------------------------------------------------ !
4951 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) !
4952 ! (high key - o3; high minor - co2) !
4953 ! ------------------------------------------------------------------ !
4954 
4955  use module_radlw_kgb07
4956 
4957 ! --- locals:
4958  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
4959  & id000, id010, id100, id110, id200, id210, indm, indmp, &
4960  & id001, id011, id101, id111, id201, id211, jmco2, jmco2p, &
4961  & jpl, jplp, ig, js, js1
4962 
4963  real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, &
4964  & speccomb, specparm, specmult, fs, &
4965  & speccomb1, specparm1, specmult1, fs1, &
4966  & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, &
4967  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
4968  & refrat_planck_a, refrat_m_a, ratco2, adjfac, adjcolco2, &
4969  & fac000, fac100, fac200, fac010, fac110, fac210, &
4970  & fac001, fac101, fac201, fac011, fac111, fac211, &
4971  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp
4972 !
4973 !===> ... begin here
4974 !
4975 ! --- ... minor gas mapping level :
4976 ! lower - co2, p = 706.2620 mbar, t= 278.94 k
4977 ! upper - co2, p = 12.9350 mbar, t = 234.01 k
4978 
4979 ! --- ... calculate reference ratio to be used in calculation of Planck
4980 ! fraction in lower atmosphere.
4981 
4982  refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2620 mb
4983  refrat_m_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2720 mb
4984 
4985 ! --- ... lower atmosphere loop
4986 
4987  do k = 1, laytrop
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
4994 
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
5001 
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)
5007 
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)
5013 
5014  inds = indself(k)
5015  indf = indfor(k)
5016  indm = indminor(k)
5017  indsp = inds + 1
5018  indfp = indf + 1
5019  indmp = indm + 1
5020  jplp = jpl + 1
5021  jmco2p= jmco2+ 1
5022  ind0p = ind0 + 1
5023  ind1p = ind1 + 1
5024 
5025 ! --- ... in atmospheres where the amount of CO2 is too great to be considered
5026 ! a minor species, adjust the column amount of CO2 by an empirical factor
5027 ! to obtain the proper contribution.
5028 
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
5034  else
5035  adjcolco2 = colamt(k,2)
5036  endif
5037 
5038  if (specparm < 0.125 .and. specparm1 < 0.125) then
5039  p0 = fs - f_one
5040  p40 = p0**4
5041  fk00 = p40
5042  fk10 = f_one - p0 - 2.0*p40
5043  fk20 = p0 + p40
5044 
5045  p1 = fs1 - f_one
5046  p41 = p1**4
5047  fk01 = p41
5048  fk11 = f_one - p1 - 2.0*p41
5049  fk21 = p1 + p41
5050 
5051  id000 = ind0
5052  id010 = ind0 + 9
5053  id100 = ind0 + 1
5054  id110 = ind0 +10
5055  id200 = ind0 + 2
5056  id210 = ind0 +11
5057 
5058  id001 = ind1
5059  id011 = ind1 + 9
5060  id101 = ind1 + 1
5061  id111 = ind1 +10
5062  id201 = ind1 + 2
5063  id211 = ind1 +11
5064  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
5065  p0 = -fs
5066  p40 = p0**4
5067  fk00 = p40
5068  fk10 = f_one - p0 - 2.0*p40
5069  fk20 = p0 + p40
5070 
5071  p1 = -fs1
5072  p41 = p1**4
5073  fk01 = p41
5074  fk11 = f_one - p1 - 2.0*p41
5075  fk21 = p1 + p41
5076 
5077  id000 = ind0 + 1
5078  id010 = ind0 +10
5079  id100 = ind0
5080  id110 = ind0 + 9
5081  id200 = ind0 - 1
5082  id210 = ind0 + 8
5083 
5084  id001 = ind1 + 1
5085  id011 = ind1 +10
5086  id101 = ind1
5087  id111 = ind1 + 9
5088  id201 = ind1 - 1
5089  id211 = ind1 + 8
5090  else
5091  fk00 = f_one - fs
5092  fk10 = fs
5093  fk20 = f_zero
5094 
5095  fk01 = f_one - fs1
5096  fk11 = fs1
5097  fk21 = f_zero
5098 
5099  id000 = ind0
5100  id010 = ind0 + 9
5101  id100 = ind0 + 1
5102  id110 = ind0 +10
5103  id200 = ind0
5104  id210 = ind0
5105 
5106  id001 = ind1
5107  id011 = ind1 + 9
5108  id101 = ind1 + 1
5109  id111 = ind1 +10
5110  id201 = ind1
5111  id211 = ind1
5112  endif
5113 
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)
5120 
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)
5127 
5128  do ig = 1, ng07
5129  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
5130  & * (selfref(ig,indsp) - selfref(ig,inds)))
5131  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5132  & * (forref(ig,indfp) - forref(ig,indf)))
5133  co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 &
5134  & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm))
5135  co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 &
5136  & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp))
5137  absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1)
5138 
5139  taug(ns07+ig,k) = speccomb &
5140  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
5141  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
5142  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
5143  & + speccomb1 &
5144  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
5145  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
5146  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
5147  & + tauself + taufor + adjcolco2*absco2
5148 
5149  fracs(ns07+ig,k) = fracrefa(ig,jpl) + fpl &
5150  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
5151  enddo
5152  enddo
5153 
5154 ! --- ... upper atmosphere loop
5155 
5156 ! --- ... in atmospheres where the amount of co2 is too great to be considered
5157 ! a minor species, adjust the column amount of co2 by an empirical factor
5158 ! to obtain the proper contribution.
5159 
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
5166  else
5167  adjcolco2 = colamt(k,2)
5168  endif
5169 
5170  ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(7) + 1
5171  ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(7) + 1
5172 
5173  indm = indminor(k)
5174  indmp = indm + 1
5175  ind0p = ind0 + 1
5176  ind1p = ind1 + 1
5177 
5178  do ig = 1, ng07
5179  absco2 = kb_mco2(ig,indm) + minorfrac(k) &
5180  & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm))
5181 
5182  taug(ns07+ig,k) = colamt(k,3) &
5183  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
5184  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
5185  & + adjcolco2 * absco2
5186 
5187  fracs(ns07+ig,k) = fracrefb(ig)
5188  enddo
5189 
5190 ! --- ... empirical modification to code to improve stratospheric cooling rates
5191 ! for o3. revised to apply weighting for g-point reduction in this band.
5192 
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
5199  enddo
5200 
5201 ! ..................................
5202  end subroutine taugb07
5203 ! ----------------------------------
5204 
5207 ! ----------------------------------
5208  subroutine taugb08
5209 ! ..................................
5210 
5211 ! ------------------------------------------------------------------ !
5212 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) !
5213 ! (high key - o3; high minor - co2, n2o) !
5214 ! ------------------------------------------------------------------ !
5215 
5216  use module_radlw_kgb08
5217 
5218 ! --- locals:
5219  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5220  & indm, indmp, ig
5221 
5222  real (kind=kind_phys) :: tauself, taufor, absco2, abso3, absn2o, &
5223  & ratco2, adjfac, adjcolco2, temp
5224 !
5225 !===> ... begin here
5226 !
5227 ! --- ... minor gas mapping level:
5228 ! lower - co2, p = 1053.63 mb, t = 294.2 k
5229 ! lower - o3, p = 317.348 mb, t = 240.77 k
5230 ! lower - n2o, p = 706.2720 mb, t= 278.94 k
5231 ! lower - cfc12,cfc11
5232 ! upper - co2, p = 35.1632 mb, t = 223.28 k
5233 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k
5234 
5235 ! --- ... lower atmosphere loop
5236 
5237  do k = 1, laytrop
5238  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(8) + 1
5239  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(8) + 1
5240 
5241  inds = indself(k)
5242  indf = indfor(k)
5243  indm = indminor(k)
5244  ind0p = ind0 + 1
5245  ind1p = ind1 + 1
5246  indsp = inds + 1
5247  indfp = indf + 1
5248  indmp = indm + 1
5249 
5250 ! --- ... in atmospheres where the amount of co2 is too great to be considered
5251 ! a minor species, adjust the column amount of co2 by an empirical factor
5252 ! to obtain the proper contribution.
5253 
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
5259  else
5260  adjcolco2 = colamt(k,2)
5261  endif
5262 
5263  do ig = 1, ng08
5264  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
5265  & * (selfref(ig,indsp) - selfref(ig,inds)))
5266  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5267  & * (forref(ig,indfp) - forref(ig,indf)))
5268  absco2 = (ka_mco2(ig,indm) + minorfrac(k) &
5269  & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm)))
5270  abso3 = (ka_mo3(ig,indm) + minorfrac(k) &
5271  & * (ka_mo3(ig,indmp) - ka_mo3(ig,indm)))
5272  absn2o = (ka_mn2o(ig,indm) + minorfrac(k) &
5273  & * (ka_mn2o(ig,indmp) - ka_mn2o(ig,indm)))
5274 
5275  taug(ns08+ig,k) = colamt(k,1) &
5276  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
5277  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
5278  & + tauself+taufor + adjcolco2*absco2 &
5279  & + colamt(k,3)*abso3 + colamt(k,4)*absn2o &
5280  & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig)
5281 
5282  fracs(ns08+ig,k) = fracrefa(ig)
5283  enddo
5284  enddo
5285 
5286 ! --- ... upper atmosphere loop
5287 
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
5291 
5292  indm = indminor(k)
5293  ind0p = ind0 + 1
5294  ind1p = ind1 + 1
5295  indmp = indm + 1
5296 
5297 ! --- ... in atmospheres where the amount of co2 is too great to be considered
5298 ! a minor species, adjust the column amount of co2 by an empirical factor
5299 ! to obtain the proper contribution.
5300 
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
5306  else
5307  adjcolco2 = colamt(k,2)
5308  endif
5309 
5310  do ig = 1, ng08
5311  absco2 = (kb_mco2(ig,indm) + minorfrac(k) &
5312  & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm)))
5313  absn2o = (kb_mn2o(ig,indm) + minorfrac(k) &
5314  & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm)))
5315 
5316  taug(ns08+ig,k) = colamt(k,3) &
5317  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
5318  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
5319  & + adjcolco2*absco2 + colamt(k,4)*absn2o &
5320  & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig)
5321 
5322  fracs(ns08+ig,k) = fracrefb(ig)
5323  enddo
5324  enddo
5325 
5326 ! ..................................
5327  end subroutine taugb08
5328 ! ----------------------------------
5329 
5332 ! ----------------------------------
5333  subroutine taugb09
5334 ! ..................................
5335 
5336 ! ------------------------------------------------------------------ !
5337 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) !
5338 ! (high key - ch4; high minor - n2o) !
5339 ! ------------------------------------------------------------------ !
5340 
5341  use module_radlw_kgb09
5342 
5343 ! --- locals:
5344  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5345  & id000, id010, id100, id110, id200, id210, indm, indmp, &
5346  & id001, id011, id101, id111, id201, id211, jmn2o, jmn2op, &
5347  & jpl, jplp, ig, js, js1
5348 
5349  real (kind=kind_phys) :: tauself, taufor, n2om1, n2om2, absn2o, &
5350  & speccomb, specparm, specmult, fs, &
5351  & speccomb1, specparm1, specmult1, fs1, &
5352  & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, &
5353  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
5354  & refrat_planck_a, refrat_m_a, ratn2o, adjfac, adjcoln2o, &
5355  & fac000, fac100, fac200, fac010, fac110, fac210, &
5356  & fac001, fac101, fac201, fac011, fac111, fac211, &
5357  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp
5358 !
5359 !===> ... begin here
5360 !
5361 ! --- ... minor gas mapping level :
5362 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
5363 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
5364 
5365 ! --- ... calculate reference ratio to be used in calculation of Planck
5366 ! fraction in lower/upper atmosphere.
5367 
5368  refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) ! P = 212 mb
5369  refrat_m_a = chi_mls(1,3)/chi_mls(6,3) ! P = 706.272 mb
5370 
5371 ! --- ... lower atmosphere loop
5372 
5373  do k = 1, laytrop
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
5380 
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
5387 
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)
5393 
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)
5399 
5400  inds = indself(k)
5401  indf = indfor(k)
5402  indm = indminor(k)
5403  indsp = inds + 1
5404  indfp = indf + 1
5405  indmp = indm + 1
5406  jplp = jpl + 1
5407  jmn2op= jmn2o+ 1
5408 
5409 ! --- ... in atmospheres where the amount of n2o is too great to be considered
5410 ! a minor species, adjust the column amount of n2o by an empirical factor
5411 ! to obtain the proper contribution.
5412 
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
5418  else
5419  adjcoln2o = colamt(k,4)
5420  endif
5421 
5422  if (specparm < 0.125 .and. specparm1 < 0.125) then
5423  p0 = fs - f_one
5424  p40 = p0**4
5425  fk00 = p40
5426  fk10 = f_one - p0 - 2.0*p40
5427  fk20 = p0 + p40
5428 
5429  p1 = fs1 - f_one
5430  p41 = p1**4
5431  fk01 = p41
5432  fk11 = f_one - p1 - 2.0*p41
5433  fk21 = p1 + p41
5434 
5435  id000 = ind0
5436  id010 = ind0 + 9
5437  id100 = ind0 + 1
5438  id110 = ind0 +10
5439  id200 = ind0 + 2
5440  id210 = ind0 +11
5441 
5442  id001 = ind1
5443  id011 = ind1 + 9
5444  id101 = ind1 + 1
5445  id111 = ind1 +10
5446  id201 = ind1 + 2
5447  id211 = ind1 +11
5448 
5449  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
5450  p0 = -fs
5451  p40 = p0**4
5452  fk00 = p40
5453  fk10 = f_one - p0 - 2.0*p40
5454  fk20 = p0 + p40
5455 
5456  p1 = -fs1
5457  p41 = p1**4
5458  fk01 = p41
5459  fk11 = f_one - p1 - 2.0*p41
5460  fk21 = p1 + p41
5461 
5462  id000 = ind0 + 1
5463  id010 = ind0 +10
5464  id100 = ind0
5465  id110 = ind0 + 9
5466  id200 = ind0 - 1
5467  id210 = ind0 + 8
5468 
5469  id001 = ind1 + 1
5470  id011 = ind1 +10
5471  id101 = ind1
5472  id111 = ind1 + 9
5473  id201 = ind1 - 1
5474  id211 = ind1 + 8
5475  else
5476  fk00 = f_one - fs
5477  fk10 = fs
5478  fk20 = f_zero
5479 
5480  fk01 = f_one - fs1
5481  fk11 = fs1
5482  fk21 = f_zero
5483 
5484  id000 = ind0
5485  id010 = ind0 + 9
5486  id100 = ind0 + 1
5487  id110 = ind0 +10
5488  id200 = ind0
5489  id210 = ind0
5490 
5491  id001 = ind1
5492  id011 = ind1 + 9
5493  id101 = ind1 + 1
5494  id111 = ind1 +10
5495  id201 = ind1
5496  id211 = ind1
5497  endif
5498 
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)
5505 
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)
5512 
5513  do ig = 1, ng09
5514  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
5515  & * (selfref(ig,indsp) - selfref(ig,inds)))
5516  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5517  & * (forref(ig,indfp) - forref(ig,indf)))
5518  n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o &
5519  & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm))
5520  n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o &
5521  & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp))
5522  absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1)
5523 
5524  taug(ns09+ig,k) = speccomb &
5525  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
5526  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
5527  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
5528  & + speccomb1 &
5529  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
5530  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
5531  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
5532  & + tauself + taufor + adjcoln2o*absn2o
5533 
5534  fracs(ns09+ig,k) = fracrefa(ig,jpl) + fpl &
5535  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
5536  enddo
5537  enddo
5538 
5539 ! --- ... upper atmosphere loop
5540 
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
5544 
5545  indm = indminor(k)
5546  ind0p = ind0 + 1
5547  ind1p = ind1 + 1
5548  indmp = indm + 1
5549 
5550 ! --- ... in atmospheres where the amount of n2o is too great to be considered
5551 ! a minor species, adjust the column amount of n2o by an empirical factor
5552 ! to obtain the proper contribution.
5553 
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
5559  else
5560  adjcoln2o = colamt(k,4)
5561  endif
5562 
5563  do ig = 1, ng09
5564  absn2o = kb_mn2o(ig,indm) + minorfrac(k) &
5565  & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm))
5566 
5567  taug(ns09+ig,k) = colamt(k,5) &
5568  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
5569  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
5570  & + adjcoln2o*absn2o
5571 
5572  fracs(ns09+ig,k) = fracrefb(ig)
5573  enddo
5574  enddo
5575 
5576 ! ..................................
5577  end subroutine taugb09
5578 ! ----------------------------------
5579 
5581 ! ----------------------------------
5582  subroutine taugb10
5583 ! ..................................
5584 
5585 ! ------------------------------------------------------------------ !
5586 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) !
5587 ! ------------------------------------------------------------------ !
5588 
5589  use module_radlw_kgb10
5590 
5591 ! --- locals:
5592  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5593  & ig
5594 
5595  real (kind=kind_phys) :: tauself, taufor
5596 !
5597 !===> ... begin here
5598 !
5599 ! --- ... lower atmosphere loop
5600 
5601  do k = 1, laytrop
5602  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(10) + 1
5603  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(10) + 1
5604 
5605  inds = indself(k)
5606  indf = indfor(k)
5607  ind0p = ind0 + 1
5608  ind1p = ind1 + 1
5609  indsp = inds + 1
5610  indfp = indf + 1
5611 
5612  do ig = 1, ng10
5613  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
5614  & * (selfref(ig,indsp) - selfref(ig,inds)))
5615  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5616  & * (forref(ig,indfp) - forref(ig,indf)))
5617 
5618  taug(ns10+ig,k) = colamt(k,1) &
5619  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
5620  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
5621  & + tauself + taufor
5622 
5623  fracs(ns10+ig,k) = fracrefa(ig)
5624  enddo
5625  enddo
5626 
5627 ! --- ... upper atmosphere loop
5628 
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
5632 
5633  indf = indfor(k)
5634  ind0p = ind0 + 1
5635  ind1p = ind1 + 1
5636  indfp = indf + 1
5637 
5638  do ig = 1, ng10
5639  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5640  & * (forref(ig,indfp) - forref(ig,indf)))
5641 
5642  taug(ns10+ig,k) = colamt(k,1) &
5643  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
5644  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
5645  & + taufor
5646 
5647  fracs(ns10+ig,k) = fracrefb(ig)
5648  enddo
5649  enddo
5650 
5651 ! ..................................
5652  end subroutine taugb10
5653 ! ----------------------------------
5654 
5657 ! ----------------------------------
5658  subroutine taugb11
5659 ! ..................................
5660 
5661 ! ------------------------------------------------------------------ !
5662 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) !
5663 ! (high key - h2o; high minor - o2) !
5664 ! ------------------------------------------------------------------ !
5665 
5666  use module_radlw_kgb11
5667 
5668 ! --- locals:
5669  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
5670  & indm, indmp, ig
5671 
5672  real (kind=kind_phys) :: scaleo2, tauself, taufor, tauo2
5673 !
5674 !===> ... begin here
5675 !
5676 ! --- ... minor gas mapping level :
5677 ! lower - o2, p = 706.2720 mbar, t = 278.94 k
5678 ! upper - o2, p = 4.758820 mbarm t = 250.85 k
5679 
5680 ! --- ... lower atmosphere loop
5681 
5682  do k = 1, laytrop
5683  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(11) + 1
5684  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(11) + 1
5685 
5686  inds = indself(k)
5687  indf = indfor(k)
5688  indm = indminor(k)
5689  ind0p = ind0 + 1
5690  ind1p = ind1 + 1
5691  indsp = inds + 1
5692  indfp = indf + 1
5693  indmp = indm + 1
5694 
5695  scaleo2 = colamt(k,6) * scaleminor(k)
5696 
5697  do ig = 1, ng11
5698  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
5699  & * (selfref(ig,indsp) - selfref(ig,inds)))
5700  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5701  & * (forref(ig,indfp) - forref(ig,indf)))
5702  tauo2 = scaleo2 * (ka_mo2(ig,indm) + minorfrac(k) &
5703  & * (ka_mo2(ig,indmp) - ka_mo2(ig,indm)))
5704 
5705  taug(ns11+ig,k) = colamt(k,1) &
5706  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
5707  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
5708  & + tauself + taufor + tauo2
5709 
5710  fracs(ns11+ig,k) = fracrefa(ig)
5711  enddo
5712  enddo
5713 
5714 ! --- ... upper atmosphere loop
5715 
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
5719 
5720  indf = indfor(k)
5721  indm = indminor(k)
5722  ind0p = ind0 + 1
5723  ind1p = ind1 + 1
5724  indfp = indf + 1
5725  indmp = indm + 1
5726 
5727  scaleo2 = colamt(k,6) * scaleminor(k)
5728 
5729  do ig = 1, ng11
5730  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5731  & * (forref(ig,indfp) - forref(ig,indf)))
5732  tauo2 = scaleo2 * (kb_mo2(ig,indm) + minorfrac(k) &
5733  & * (kb_mo2(ig,indmp) - kb_mo2(ig,indm)))
5734 
5735  taug(ns11+ig,k) = colamt(k,1) &
5736  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
5737  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) &
5738  & + taufor + tauo2
5739 
5740  fracs(ns11+ig,k) = fracrefb(ig)
5741  enddo
5742  enddo
5743 
5744 ! ..................................
5745  end subroutine taugb11
5746 ! ----------------------------------
5747 
5749 ! ----------------------------------
5750  subroutine taugb12
5751 ! ..................................
5752 
5753 ! ------------------------------------------------------------------ !
5754 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) !
5755 ! ------------------------------------------------------------------ !
5756 
5757  use module_radlw_kgb12
5758 
5759 ! --- locals:
5760  integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, &
5761  & id000, id010, id100, id110, id200, id210, ig, js, js1, &
5762  & id001, id011, id101, id111, id201, id211
5763 
5764  real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, &
5765  & speccomb, specparm, specmult, fs, &
5766  & speccomb1, specparm1, specmult1, fs1, &
5767  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
5768  & fac000, fac100, fac200, fac010, fac110, fac210, &
5769  & fac001, fac101, fac201, fac011, fac111, fac211, &
5770  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21
5771 !
5772 !===> ... begin here
5773 !
5774 ! --- ... calculate reference ratio to be used in calculation of Planck
5775 ! fraction in lower/upper atmosphere.
5776 
5777  refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) ! P = 174.164 mb
5778 
5779 ! --- ... lower atmosphere loop
5780 
5781  do k = 1, laytrop
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
5788 
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
5795 
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)
5802 
5803  inds = indself(k)
5804  indf = indfor(k)
5805  indsp = inds + 1
5806  indfp = indf + 1
5807  jplp = jpl + 1
5808 
5809  if (specparm < 0.125 .and. specparm1 < 0.125) then
5810  p0 = fs - f_one
5811  p40 = p0**4
5812  fk00 = p40
5813  fk10 = f_one - p0 - 2.0*p40
5814  fk20 = p0 + p40
5815 
5816  p1 = fs1 - f_one
5817  p41 = p1**4
5818  fk01 = p41
5819  fk11 = f_one - p1 - 2.0*p41
5820  fk21 = p1 + p41
5821 
5822  id000 = ind0
5823  id010 = ind0 + 9
5824  id100 = ind0 + 1
5825  id110 = ind0 +10
5826  id200 = ind0 + 2
5827  id210 = ind0 +11
5828 
5829  id001 = ind1
5830  id011 = ind1 + 9
5831  id101 = ind1 + 1
5832  id111 = ind1 +10
5833  id201 = ind1 + 2
5834  id211 = ind1 +11
5835  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
5836  p0 = -fs
5837  p40 = p0**4
5838  fk00 = p40
5839  fk10 = f_one - p0 - 2.0*p40
5840  fk20 = p0 + p40
5841 
5842  p1 = -fs1
5843  p41 = p1**4
5844  fk01 = p41
5845  fk11 = f_one - p1 - 2.0*p41
5846  fk21 = p1 + p41
5847 
5848  id000 = ind0 + 1
5849  id010 = ind0 +10
5850  id100 = ind0
5851  id110 = ind0 + 9
5852  id200 = ind0 - 1
5853  id210 = ind0 + 8
5854 
5855  id001 = ind1 + 1
5856  id011 = ind1 +10
5857  id101 = ind1
5858  id111 = ind1 + 9
5859  id201 = ind1 - 1
5860  id211 = ind1 + 8
5861  else
5862  fk00 = f_one - fs
5863  fk10 = fs
5864  fk20 = f_zero
5865 
5866  fk01 = f_one - fs1
5867  fk11 = fs1
5868  fk21 = f_zero
5869 
5870  id000 = ind0
5871  id010 = ind0 + 9
5872  id100 = ind0 + 1
5873  id110 = ind0 +10
5874  id200 = ind0
5875  id210 = ind0
5876 
5877  id001 = ind1
5878  id011 = ind1 + 9
5879  id101 = ind1 + 1
5880  id111 = ind1 +10
5881  id201 = ind1
5882  id211 = ind1
5883  endif
5884 
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)
5891 
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)
5898 
5899  do ig = 1, ng12
5900  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
5901  & * (selfref(ig,indsp) - selfref(ig,inds)))
5902  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
5903  & * (forref(ig,indfp) - forref(ig,indf)))
5904 
5905  taug(ns12+ig,k) = speccomb &
5906  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
5907  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
5908  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
5909  & + speccomb1 &
5910  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
5911  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
5912  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
5913  & + tauself + taufor
5914 
5915  fracs(ns12+ig,k) = fracrefa(ig,jpl) + fpl &
5916  & *(fracrefa(ig,jplp) - fracrefa(ig,jpl))
5917  enddo
5918  enddo
5919 
5920 ! --- ... upper atmosphere loop
5921 
5922  do k = laytrop+1, nlay
5923  do ig = 1, ng12
5924  taug(ns12+ig,k) = f_zero
5925  fracs(ns12+ig,k) = f_zero
5926  enddo
5927  enddo
5928 
5929 ! ..................................
5930  end subroutine taugb12
5931 ! ----------------------------------
5932 
5934 ! ----------------------------------
5935  subroutine taugb13
5936 ! ..................................
5937 
5938 ! ------------------------------------------------------------------ !
5939 ! band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) !
5940 ! ------------------------------------------------------------------ !
5941 
5942  use module_radlw_kgb13
5943 
5944 ! --- locals:
5945  integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
5946  & id000, id010, id100, id110, id200, id210, jmco2, jpl, &
5947  & id001, id011, id101, id111, id201, id211, jmco2p, jplp, &
5948  & jmco, jmcop, ig, js, js1
5949 
5950  real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, &
5951  & speccomb, specparm, specmult, fs, &
5952  & speccomb1, specparm1, specmult1, fs1, &
5953  & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, &
5954  & speccomb_mco, specparm_mco, specmult_mco, fmco, &
5955  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
5956  & refrat_planck_a, refrat_m_a, refrat_m_a3, ratco2, &
5957  & adjfac, adjcolco2, com1, com2, absco, abso3, &
5958  & fac000, fac100, fac200, fac010, fac110, fac210, &
5959  & fac001, fac101, fac201, fac011, fac111, fac211, &
5960  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp
5961 !
5962 !===> ... begin here
5963 !
5964 ! --- ... minor gas mapping levels :
5965 ! lower - co2, p = 1053.63 mb, t = 294.2 k
5966 ! lower - co, p = 706 mb, t = 278.94 k
5967 ! upper - o3, p = 95.5835 mb, t = 215.7 k
5968 
5969 ! --- ... calculate reference ratio to be used in calculation of Planck
5970 ! fraction in lower/upper atmosphere.
5971 
5972  refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) ! P = 473.420 mb (Level 5)
5973  refrat_m_a = chi_mls(1,1)/chi_mls(4,1) ! P = 1053. (Level 1)
5974  refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) ! P = 706. (Level 3)
5975 
5976 ! --- ... lower atmosphere loop
5977 
5978  do k = 1, laytrop
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
5985 
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
5992 
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)
5998 
5999 ! --- ... in atmospheres where the amount of co2 is too great to be considered
6000 ! a minor species, adjust the column amount of co2 by an empirical factor
6001 ! to obtain the proper contribution.
6002 
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)
6008 
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)
6014 
6015  inds = indself(k)
6016  indf = indfor(k)
6017  indm = indminor(k)
6018  indsp = inds + 1
6019  indfp = indf + 1
6020  indmp = indm + 1
6021  jplp = jpl + 1
6022  jmco2p= jmco2+ 1
6023  jmcop = jmco + 1
6024 
6025 ! --- ... in atmospheres where the amount of co2 is too great to be considered
6026 ! a minor species, adjust the column amount of co2 by an empirical factor
6027 ! to obtain the proper contribution.
6028 
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
6034  else
6035  adjcolco2 = colamt(k,2)
6036  endif
6037 
6038  if (specparm < 0.125 .and. specparm1 < 0.125) then
6039  p0 = fs - f_one
6040  p40 = p0**4
6041  fk00 = p40
6042  fk10 = f_one - p0 - 2.0*p40
6043  fk20 = p0 + p40
6044 
6045  p1 = fs1 - f_one
6046  p41 = p1**4
6047  fk01 = p41
6048  fk11 = f_one - p1 - 2.0*p41
6049  fk21 = p1 + p41
6050 
6051  id000 = ind0
6052  id010 = ind0 + 9
6053  id100 = ind0 + 1
6054  id110 = ind0 +10
6055  id200 = ind0 + 2
6056  id210 = ind0 +11
6057 
6058  id001 = ind1
6059  id011 = ind1 + 9
6060  id101 = ind1 + 1
6061  id111 = ind1 +10
6062  id201 = ind1 + 2
6063  id211 = ind1 +11
6064  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
6065  p0 = -fs
6066  p40 = p0**4
6067  fk00 = p40
6068  fk10 = f_one - p0 - 2.0*p40
6069  fk20 = p0 + p40
6070 
6071  p1 = -fs1
6072  p41 = p1**4
6073  fk01 = p41
6074  fk11 = f_one - p1 - 2.0*p41
6075  fk21 = p1 + p41
6076 
6077  id000 = ind0 + 1
6078  id010 = ind0 +10
6079  id100 = ind0
6080  id110 = ind0 + 9
6081  id200 = ind0 - 1
6082  id210 = ind0 + 8
6083 
6084  id001 = ind1 + 1
6085  id011 = ind1 +10
6086  id101 = ind1
6087  id111 = ind1 + 9
6088  id201 = ind1 - 1
6089  id211 = ind1 + 8
6090  else
6091  fk00 = f_one - fs
6092  fk10 = fs
6093  fk20 = f_zero
6094 
6095  fk01 = f_one - fs1
6096  fk11 = fs1
6097  fk21 = f_zero
6098 
6099  id000 = ind0
6100  id010 = ind0 + 9
6101  id100 = ind0 + 1
6102  id110 = ind0 +10
6103  id200 = ind0
6104  id210 = ind0
6105 
6106  id001 = ind1
6107  id011 = ind1 + 9
6108  id101 = ind1 + 1
6109  id111 = ind1 +10
6110  id201 = ind1
6111  id211 = ind1
6112  endif
6113 
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)
6120 
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)
6127 
6128  do ig = 1, ng13
6129  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
6130  & * (selfref(ig,indsp) - selfref(ig,inds)))
6131  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
6132  & * (forref(ig,indfp) - forref(ig,indf)))
6133  co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 &
6134  & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm))
6135  co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 &
6136  & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp))
6137  absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1)
6138  com1 = ka_mco(ig,jmco,indm) + fmco &
6139  & * (ka_mco(ig,jmcop,indm) - ka_mco(ig,jmco,indm))
6140  com2 = ka_mco(ig,jmco,indmp) + fmco &
6141  & * (ka_mco(ig,jmcop,indmp) - ka_mco(ig,jmco,indmp))
6142  absco = com1 + minorfrac(k) * (com2 - com1)
6143 
6144  taug(ns13+ig,k) = speccomb &
6145  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
6146  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
6147  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
6148  & + speccomb1 &
6149  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
6150  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
6151  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
6152  & + tauself + taufor + adjcolco2*absco2 &
6153  & + colamt(k,7)*absco
6154 
6155  fracs(ns13+ig,k) = fracrefa(ig,jpl) + fpl &
6156  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
6157  enddo
6158  enddo
6159 
6160 ! --- ... upper atmosphere loop
6161 
6162  do k = laytrop+1, nlay
6163  indm = indminor(k)
6164  indmp = indm + 1
6165 
6166  do ig = 1, ng13
6167  abso3 = kb_mo3(ig,indm) + minorfrac(k) &
6168  & * (kb_mo3(ig,indmp) - kb_mo3(ig,indm))
6169 
6170  taug(ns13+ig,k) = colamt(k,3)*abso3
6171 
6172  fracs(ns13+ig,k) = fracrefb(ig)
6173  enddo
6174  enddo
6175 
6176 ! ..................................
6177  end subroutine taugb13
6178 ! ----------------------------------
6179 
6181 ! ----------------------------------
6182  subroutine taugb14
6183 ! ..................................
6184 
6185 ! ------------------------------------------------------------------ !
6186 ! band 14: 2250-2380 cm-1 (low - co2; high - co2) !
6187 ! ------------------------------------------------------------------ !
6188 
6189  use module_radlw_kgb14
6190 
6191 ! --- locals:
6192  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
6193  & ig
6194 
6195  real (kind=kind_phys) :: tauself, taufor
6196 !
6197 !===> ... begin here
6198 !
6199 ! --- ... lower atmosphere loop
6200 
6201  do k = 1, laytrop
6202  ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(14) + 1
6203  ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(14) + 1
6204 
6205  inds = indself(k)
6206  indf = indfor(k)
6207  ind0p = ind0 + 1
6208  ind1p = ind1 + 1
6209  indsp = inds + 1
6210  indfp = indf + 1
6211 
6212  do ig = 1, ng14
6213  tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) &
6214  & * (selfref(ig,indsp) - selfref(ig,inds)))
6215  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
6216  & * (forref(ig,indfp) - forref(ig,indf)))
6217 
6218  taug(ns14+ig,k) = colamt(k,2) &
6219  & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) &
6220  & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) &
6221  & + tauself + taufor
6222 
6223  fracs(ns14+ig,k) = fracrefa(ig)
6224  enddo
6225  enddo
6226 
6227 ! --- ... upper atmosphere loop
6228 
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
6232 
6233  ind0p = ind0 + 1
6234  ind1p = ind1 + 1
6235 
6236  do ig = 1, ng14
6237  taug(ns14+ig,k) = colamt(k,2) &
6238  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
6239  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p))
6240 
6241  fracs(ns14+ig,k) = fracrefb(ig)
6242  enddo
6243  enddo
6244 
6245 ! ..................................
6246  end subroutine taugb14
6247 ! ----------------------------------
6248 
6251 ! ----------------------------------
6252  subroutine taugb15
6253 ! ..................................
6254 
6255 ! ------------------------------------------------------------------ !
6256 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) !
6257 ! (high - nothing) !
6258 ! ------------------------------------------------------------------ !
6259 
6260  use module_radlw_kgb15
6261 
6262 ! --- locals:
6263  integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, &
6264  & id000, id010, id100, id110, id200, id210, jpl, jplp, &
6265  & id001, id011, id101, id111, id201, id211, jmn2, jmn2p, &
6266  & ig, js, js1
6267 
6268  real (kind=kind_phys) :: scalen2, tauself, taufor, &
6269  & speccomb, specparm, specmult, fs, &
6270  & speccomb1, specparm1, specmult1, fs1, &
6271  & speccomb_mn2, specparm_mn2, specmult_mn2, fmn2, &
6272  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
6273  & refrat_planck_a, refrat_m_a, n2m1, n2m2, taun2, &
6274  & fac000, fac100, fac200, fac010, fac110, fac210, &
6275  & fac001, fac101, fac201, fac011, fac111, fac211, &
6276  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21
6277 !
6278 !===> ... begin here
6279 !
6280 ! --- ... minor gas mapping level :
6281 ! lower - nitrogen continuum, P = 1053., T = 294.
6282 
6283 ! --- ... calculate reference ratio to be used in calculation of Planck
6284 ! fraction in lower atmosphere.
6285 
6286  refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb (Level 1)
6287  refrat_m_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb
6288 
6289 ! --- ... lower atmosphere loop
6290 
6291  do k = 1, laytrop
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
6298 
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
6305 
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)
6311 
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)
6317 
6318  scalen2 = colbrd(k) * scaleminor(k)
6319 
6320  inds = indself(k)
6321  indf = indfor(k)
6322  indm = indminor(k)
6323  indsp = inds + 1
6324  indfp = indf + 1
6325  indmp = indm + 1
6326  jplp = jpl + 1
6327  jmn2p = jmn2 + 1
6328 
6329 
6330  if (specparm < 0.125 .and. specparm1 < 0.125) then
6331  p0 = fs - f_one
6332  p40 = p0**4
6333  fk00 = p40
6334  fk10 = f_one - p0 - 2.0*p40
6335  fk20 = p0 + p40
6336 
6337  p1 = fs1 - f_one
6338  p41 = p1**4
6339  fk01 = p41
6340  fk11 = f_one - p1 - 2.0*p41
6341  fk21 = p1 + p41
6342 
6343  id000 = ind0
6344  id010 = ind0 + 9
6345  id100 = ind0 + 1
6346  id110 = ind0 +10
6347  id200 = ind0 + 2
6348  id210 = ind0 +11
6349 
6350  id001 = ind1
6351  id011 = ind1 + 9
6352  id101 = ind1 + 1
6353  id111 = ind1 +10
6354  id201 = ind1 + 2
6355  id211 = ind1 +11
6356  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
6357  p0 = -fs
6358  p40 = p0**4
6359  fk00 = p40
6360  fk10 = f_one - p0 - 2.0*p40
6361  fk20 = p0 + p40
6362 
6363  p1 = -fs1
6364  p41 = p1**4
6365  fk01 = p41
6366  fk11 = f_one - p1 - 2.0*p41
6367  fk21 = p1 + p41
6368 
6369  id000 = ind0 + 1
6370  id010 = ind0 +10
6371  id100 = ind0
6372  id110 = ind0 + 9
6373  id200 = ind0 - 1
6374  id210 = ind0 + 8
6375 
6376  id001 = ind1 + 1
6377  id011 = ind1 +10
6378  id101 = ind1
6379  id111 = ind1 + 9
6380  id201 = ind1 - 1
6381  id211 = ind1 + 8
6382  else
6383  fk00 = f_one - fs
6384  fk10 = fs
6385  fk20 = f_zero
6386 
6387  fk01 = f_one - fs1
6388  fk11 = fs1
6389  fk21 = f_zero
6390 
6391  id000 = ind0
6392  id010 = ind0 + 9
6393  id100 = ind0 + 1
6394  id110 = ind0 +10
6395  id200 = ind0
6396  id210 = ind0
6397 
6398  id001 = ind1
6399  id011 = ind1 + 9
6400  id101 = ind1 + 1
6401  id111 = ind1 +10
6402  id201 = ind1
6403  id211 = ind1
6404  endif
6405 
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)
6412 
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)
6419 
6420  do ig = 1, ng15
6421  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
6422  & * (selfref(ig,indsp) - selfref(ig,inds)))
6423  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
6424  & * (forref(ig,indfp) - forref(ig,indf)))
6425  n2m1 = ka_mn2(ig,jmn2,indm) + fmn2 &
6426  & * (ka_mn2(ig,jmn2p,indm) - ka_mn2(ig,jmn2,indm))
6427  n2m2 = ka_mn2(ig,jmn2,indmp) + fmn2 &
6428  & * (ka_mn2(ig,jmn2p,indmp) - ka_mn2(ig,jmn2,indmp))
6429  taun2 = scalen2 * (n2m1 + minorfrac(k) * (n2m2 - n2m1))
6430 
6431  taug(ns15+ig,k) = speccomb &
6432  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
6433  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
6434  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
6435  & + speccomb1 &
6436  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
6437  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
6438  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
6439  & + tauself + taufor + taun2
6440 
6441  fracs(ns15+ig,k) = fracrefa(ig,jpl) + fpl &
6442  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
6443  enddo
6444  enddo
6445 
6446 ! --- ... upper atmosphere loop
6447 
6448  do k = laytrop+1, nlay
6449  do ig = 1, ng15
6450  taug(ns15+ig,k) = f_zero
6451 
6452  fracs(ns15+ig,k) = f_zero
6453  enddo
6454  enddo
6455 
6456 ! ..................................
6457  end subroutine taugb15
6458 ! ----------------------------------
6459 
6461 ! ----------------------------------
6462  subroutine taugb16
6463 ! ..................................
6464 
6465 ! ------------------------------------------------------------------ !
6466 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) !
6467 ! ------------------------------------------------------------------ !
6468 
6469  use module_radlw_kgb16
6470 
6471 ! --- locals:
6472  integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, &
6473  & id000, id010, id100, id110, id200, id210, jpl, jplp, &
6474  & id001, id011, id101, id111, id201, id211, ig, js, js1
6475 
6476  real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, &
6477  & speccomb, specparm, specmult, fs, &
6478  & speccomb1, specparm1, specmult1, fs1, &
6479  & speccomb_planck,specparm_planck,specmult_planck,fpl, &
6480  & fac000, fac100, fac200, fac010, fac110, fac210, &
6481  & fac001, fac101, fac201, fac011, fac111, fac211, &
6482  & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21
6483 !
6484 !===> ... begin here
6485 !
6486 ! --- ... calculate reference ratio to be used in calculation of Planck
6487 ! fraction in lower atmosphere.
6488 
6489  refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) ! P = 387. mb (Level 6)
6490 
6491 ! --- ... lower atmosphere loop
6492 
6493  do k = 1, laytrop
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
6500 
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
6507 
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)
6513 
6514  inds = indself(k)
6515  indf = indfor(k)
6516  indsp = inds + 1
6517  indfp = indf + 1
6518  jplp = jpl + 1
6519 
6520  if (specparm < 0.125 .and. specparm1 < 0.125) then
6521  p0 = fs - f_one
6522  p40 = p0**4
6523  fk00 = p40
6524  fk10 = f_one - p0 - 2.0*p40
6525  fk20 = p0 + p40
6526 
6527  p1 = fs1 - f_one
6528  p41 = p1**4
6529  fk01 = p41
6530  fk11 = f_one - p1 - 2.0*p41
6531  fk21 = p1 + p41
6532 
6533  id000 = ind0
6534  id010 = ind0 + 9
6535  id100 = ind0 + 1
6536  id110 = ind0 +10
6537  id200 = ind0 + 2
6538  id210 = ind0 +11
6539 
6540  id001 = ind1
6541  id011 = ind1 + 9
6542  id101 = ind1 + 1
6543  id111 = ind1 +10
6544  id201 = ind1 + 2
6545  id211 = ind1 +11
6546  elseif (specparm > 0.875 .and. specparm1 > 0.875) then
6547  p0 = -fs
6548  p40 = p0**4
6549  fk00 = p40
6550  fk10 = f_one - p0 - 2.0*p40
6551  fk20 = p0 + p40
6552 
6553  p1 = -fs1
6554  p41 = p1**4
6555  fk01 = p41
6556  fk11 = f_one - p1 - 2.0*p41
6557  fk21 = p1 + p41
6558 
6559  id000 = ind0 + 1
6560  id010 = ind0 +10
6561  id100 = ind0
6562  id110 = ind0 + 9
6563  id200 = ind0 - 1
6564  id210 = ind0 + 8
6565 
6566  id001 = ind1 + 1
6567  id011 = ind1 +10
6568  id101 = ind1
6569  id111 = ind1 + 9
6570  id201 = ind1 - 1
6571  id211 = ind1 + 8
6572  else
6573  fk00 = f_one - fs
6574  fk10 = fs
6575  fk20 = f_zero
6576 
6577  fk01 = f_one - fs1
6578  fk11 = fs1
6579  fk21 = f_zero
6580 
6581  id000 = ind0
6582  id010 = ind0 + 9
6583  id100 = ind0 + 1
6584  id110 = ind0 +10
6585  id200 = ind0
6586  id210 = ind0
6587 
6588  id001 = ind1
6589  id011 = ind1 + 9
6590  id101 = ind1 + 1
6591  id111 = ind1 +10
6592  id201 = ind1
6593  id211 = ind1
6594  endif
6595 
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)
6602 
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)
6609 
6610  do ig = 1, ng16
6611  tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) &
6612  & * (selfref(ig,indsp) - selfref(ig,inds)))
6613  taufor = forfac(k) * (forref(ig,indf) + forfrac(k) &
6614  & * (forref(ig,indfp) - forref(ig,indf)))
6615 
6616  taug(ns16+ig,k) = speccomb &
6617  & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) &
6618  & + fac100*absa(ig,id100) + fac110*absa(ig,id110) &
6619  & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) &
6620  & + speccomb1 &
6621  & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) &
6622  & + fac101*absa(ig,id101) + fac111*absa(ig,id111) &
6623  & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) &
6624  & + tauself + taufor
6625 
6626  fracs(ns16+ig,k) = fracrefa(ig,jpl) + fpl &
6627  & * (fracrefa(ig,jplp) - fracrefa(ig,jpl))
6628  enddo
6629  enddo
6630 
6631 ! --- ... upper atmosphere loop
6632 
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
6636 
6637  ind0p = ind0 + 1
6638  ind1p = ind1 + 1
6639 
6640  do ig = 1, ng16
6641  taug(ns16+ig,k) = colamt(k,5) &
6642  & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) &
6643  & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p))
6644 
6645  fracs(ns16+ig,k) = fracrefb(ig)
6646  enddo
6647  enddo
6648 
6649 ! ..................................
6650  end subroutine taugb16
6651 ! ----------------------------------
6652 
6653 ! ..................................
6654  end subroutine taumol
6655 !-----------------------------------
6656 
6657 
6658 !
6659 !........................................!
6660  end module module_radlw_main !
6661 !========================================!
6662 
6663 !! @}
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
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
Definition: radlw_param.f:113
Define type construct for radiation fluxes at surface.
Definition: radlw_param.f:84
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 ( )
Definition: physcons.f:138
subroutine cldprop(cfrac, cliqp, reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, nlay, nlp1, ipseed, cldfmc, taucld )
This subroutine computes the cloud optical depth(s) for each cloudy layer and g-point interval...
Definition: radlw_main.f:1491
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)
Definition: radlw_main.f:5583
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...
subroutine rtrn(semiss, delp, cldfrc, taucld, tautot, pklay, pklev, fracs, secdif, nlay, nlp1, totuflux, totdflux, htr, totuclfl, totdclfl, htrcl, htrb )
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
Definition: radlw_main.f:2289
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 ( )
Definition: physcons.f:59
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...
Definition: radlw_datatb.f:966
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.
Definition: physparam.f:104
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)
Definition: radlw_main.f:6253
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
Definition: radlw_param.f:119
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...
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)
Definition: radlw_main.f:6463
real(kind=kind_phys), parameter absrain
absrain is the rain drop absorption coefficient .
Definition: radlw_datatb.f:945
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.
Definition: radlw_param.f:97
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)
Definition: radlw_datatb.f:939
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)
Definition: radlw_main.f:5936
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 =0:use diagnostic cloud scheme for cloud cover and mean ...
Definition: physparam.f:241
subroutine taumol(laytrop, pavel, coldry, colamt, colbrd, wx, tauaer, rfrate, fac00, fac01, fac10, fac11, jp, jt, jt1, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, nlay, fracs, tautot )
This subroutine contains optical depths developed for the rapid radiative transfer model...
Definition: radlw_main.f:3682
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
Definition: radlw_datatb.f:948
real(kind=kind_phys), dimension(ng08, mmc08), public kb_mco2
minor gas mapping level:upper - co2, p = 35.1632 mb, t = 223.28 k
subroutine rtrnmc(semiss, delp, cldfmc, taucld, tautot, pklay, pklev, fracs, secdif, nlay, nlp1, totuflux, totdflux, htr, totuclfl, totdclfl, htrcl, htrb )
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
Definition: radlw_main.f:3265
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 minor gases effect control flag (CH4,N2O,O2,and some CFCs): =0: minor gases' effects are not inc...
Definition: physparam.f:109
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.
Definition: radlw_datatb.f:750
subroutine taugb08
Band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) (high key - o3; high minor - co2...
Definition: radlw_main.f:5209
real(kind=kind_phys), dimension(nplnk, nbands), public totplnk
plank flux data
Definition: radlw_datatb.f:78
real(kind=kind_phys), parameter con_cp
spec heat air at p ( )
Definition: physcons.f:80
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 ...
subroutine mcica_subcol(cldf, nlay, ipseed, lcloudy )
This suroutine computes sub-colum cloud profile flag array.
Definition: radlw_main.f:1798
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)
Definition: radlw_main.f:5751
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
Definition: radlw_param.f:115
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)
Definition: radlw_main.f:4353
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
subroutine rtrnmr(semiss, delp, cldfrc, taucld, tautot, pklay, pklev, fracs, secdif, nlay, nlp1, totuflux, totdflux, htr, totuclfl, totdclfl, htrcl, htrb )
This subroutine computes the upward/downward radiative fluxes, and heating rates for both clear or cl...
Definition: radlw_main.f:2672
integer, save ilwcice
LW optical property scheme for ice clouds (only ilwcliq>0) =1:optical property scheme based on Eber...
Definition: physparam.f:124
This module contains LW band parameters set up.
Definition: radlw_param.f:64
Define type construct for radiation fluxes at toa.
Definition: radlw_param.f:75
real(kind=kind_phys), dimension(ng01, mfr01), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
subroutine, public lwrad(plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, clouds, icseed, aerosols, sfemis, sfgtmp, npts, nlay, nlp1, lprnt, hlwc, topflx, sfcflx, HLW0, HLWB, FLXPRF )
This subroutine is the main LW radiation routine.
Definition: radlw_main.f:461
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, public rlwinit(me)
This subroutine performs calculations necessary for the initialization of the longwave model...
Definition: radlw_main.f:1263
subroutine taugb07
Band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) (high key - o3; high minor - co2) ...
Definition: radlw_main.f:4948
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 ( )
Definition: physcons.f:131
integer, parameter nrates
num of ref rates of binary species
Definition: radlw_param.f:121
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 scheme for liquid clouds =0:input cloud optical properties directly, not computed within =1:input cwp,rew, use Hu and Stamnes(1993) method.
Definition: physparam.f:115
real(kind=kind_phys), dimension(ng10), public fracrefa
planck fraction mapping level : p = 212.7250, t = 223.06 k
subroutine taugb09
Band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) (high key - ch4; high minor - n2o) ...
Definition: radlw_main.f:5334
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) ...
Definition: radlw_main.f:5659
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)
Definition: radlw_main.f:3968
real(kind=kind_phys), parameter con_amo3
molecular wght of o3 ( )
Definition: physcons.f:140
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) ...
Definition: radlw_main.f:4046
subroutine taugb14
Band 14: 2250-2380 cm-1 (low - co2; high - co2)
Definition: radlw_main.f:6183
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 taugb05
Band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) (high key - o3,co2) ...
Definition: radlw_main.f:4598
real(kind=kind_phys), dimension(ng10, mfr10), public forref
the array forref contains the coefficient of the water vapor foreign-continuum (including the energy ...
subroutine setcoef(pavel, tavel, tz, stemp, h2ovmr, colamt, coldry, colbrd, nlay, nlp1, laytrop, pklay, pklev, jp, jt, jt1, rfrate, fac00, fac01, fac10, fac11, selffac, selffrac, indself, forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor )
This subroutine computes various coefficients needed in radiative transfer calculations.
Definition: radlw_main.f:1998
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
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 =0:no McICA approximation in LW radiation =1:use McI...
Definition: physparam.f:301
integer, save ivflip
vertical profile indexing flag
Definition: physparam.f:289
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...
Definition: radlw_main.f:4861
This module contains cloud property coefficients.
Definition: radlw_datatb.f:928
integer, parameter maxgas
max num of absorbing gases
Definition: radlw_param.f:117
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) ...
Definition: radlw_main.f:3861
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 =0:use random cloud overlapping method =1:use maximum-rando...
Definition: physparam.f:256
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.
Definition: radlw_datatb.f:67
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
Definition: radlw_param.f:111
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
Definition: radlw_param.f:142
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 ( )
Definition: physcons.f:136
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...