Line data Source code
1 : ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_init.f90,v $
2 : ! author: $Author: mike $
3 : ! revision: $Revision: 1.2 $
4 : ! created: $Date: 2007/08/22 19:20:03 $
5 : !
6 : module rrtmg_lw_init
7 :
8 : ! --------------------------------------------------------------------------
9 : ! | |
10 : ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). |
11 : ! | This software may be used, copied, or redistributed as long as it is |
12 : ! | not sold and this copyright notice is reproduced on each copy made. |
13 : ! | This model is provided as is without any express or implied warranties. |
14 : ! | (http://www.rtweb.aer.com/) |
15 : ! | |
16 : ! --------------------------------------------------------------------------
17 :
18 : use shr_kind_mod, only: r8 => shr_kind_r8
19 :
20 : ! use parkind, only : jpim, jprb
21 : use rrlw_wvn
22 : use rrtmg_lw_setcoef, only: lwatmref, lwavplank
23 :
24 : implicit none
25 :
26 : contains
27 :
28 : ! **************************************************************************
29 1024 : subroutine rrtmg_lw_ini
30 : ! **************************************************************************
31 : !
32 : ! Original version: Michael J. Iacono; July, 1998
33 : ! First revision for NCAR CCM: September, 1998
34 : ! Second revision for RRTM_V3.0: September, 2002
35 : !
36 : ! This subroutine performs calculations necessary for the initialization
37 : ! of the longwave model. Lookup tables are computed for use in the LW
38 : ! radiative transfer, and input absorption coefficient data for each
39 : ! spectral band are reduced from 256 g-point intervals to 140.
40 : ! **************************************************************************
41 :
42 : use parrrtm, only : mg, nbndlw, ngptlw
43 : use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
44 :
45 : ! ------- Local -------
46 :
47 : integer :: itr, ibnd, igc, ig, ind, ipr
48 : integer :: igcsm, iprsm
49 :
50 : real(kind=r8) :: wtsum, wtsm(mg) !
51 : real(kind=r8) :: tfn !
52 :
53 : ! ------- Definitions -------
54 : ! Arrays for 10000-point look-up tables:
55 : ! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
56 : ! EXP_TBL Exponential lookup table for ransmittance
57 : ! TFN_TBL Tau transition function; i.e. the transition of the Planck
58 : ! function from that for the mean layer temperature to that for
59 : ! the layer boundary temperature as a function of optical depth.
60 : ! The "linear in tau" method is used to make the table.
61 : ! PADE Pade approximation constant (= 0.278)
62 : ! BPADE Inverse of the Pade approximation constant
63 : !
64 :
65 : ! Initialize model data
66 1024 : call lwdatinit
67 1024 : call lwcmbdat ! g-point interval reduction data
68 1024 : call lwatmref ! reference MLS profile
69 1024 : call lwavplank ! Planck function
70 1024 : call lw_kgb01 ! molecular absorption coefficients
71 1024 : call lw_kgb02
72 1024 : call lw_kgb03
73 1024 : call lw_kgb04
74 1024 : call lw_kgb05
75 1024 : call lw_kgb06
76 1024 : call lw_kgb07
77 1024 : call lw_kgb08
78 1024 : call lw_kgb09
79 1024 : call lw_kgb10
80 1024 : call lw_kgb11
81 1024 : call lw_kgb12
82 1024 : call lw_kgb13
83 1024 : call lw_kgb14
84 1024 : call lw_kgb15
85 1024 : call lw_kgb16
86 :
87 : ! Compute lookup tables for transmittance, tau transition function,
88 : ! and clear sky tau (for the cloudy sky radiative transfer). Tau is
89 : ! computed as a function of the tau transition function, transmittance
90 : ! is calculated as a function of tau, and the tau transition function
91 : ! is calculated using the linear in tau formulation at values of tau
92 : ! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables
93 : ! are computed at intervals of 0.001. The inverse of the constant used
94 : ! in the Pade approximation to the tau transition function is set to b.
95 :
96 1024 : tau_tbl(0) = 0.0_r8
97 1024 : tau_tbl(ntbl) = 1.e10_r8
98 1024 : exp_tbl(0) = 1.0_r8
99 1024 : exp_tbl(ntbl) = 0.0_r8
100 1024 : tfn_tbl(0) = 0.0_r8
101 1024 : tfn_tbl(ntbl) = 1.0_r8
102 1024 : bpade = 1.0_r8 / pade
103 10240000 : do itr = 1, ntbl-1
104 10238976 : tfn = float(itr) / float(ntbl)
105 10238976 : tau_tbl(itr) = bpade * tfn / (1._r8 - tfn)
106 10238976 : exp_tbl(itr) = exp(-tau_tbl(itr))
107 10240000 : if (tau_tbl(itr) .lt. 0.06_r8) then
108 167936 : tfn_tbl(itr) = tau_tbl(itr)/6._r8
109 : else
110 10071040 : tfn_tbl(itr) = 1._r8-2._r8*((1._r8/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
111 : endif
112 : enddo
113 :
114 : ! Perform g-point reduction from 16 per band (256 total points) to
115 : ! a band dependant number (140 total points) for all absorption
116 : ! coefficient input data and Planck fraction input data.
117 : ! Compute relative weighting for new g-point combinations.
118 :
119 1024 : igcsm = 0
120 17408 : do ibnd = 1,nbndlw
121 16384 : iprsm = 0
122 17408 : if (ngc(ibnd).lt.mg) then
123 124928 : do igc = 1,ngc(ibnd)
124 110592 : igcsm = igcsm + 1
125 110592 : wtsum = 0._r8
126 339968 : do ipr = 1, ngn(igcsm)
127 229376 : iprsm = iprsm + 1
128 339968 : wtsum = wtsum + wt(iprsm)
129 : enddo
130 124928 : wtsm(igc) = wtsum
131 : enddo
132 243712 : do ig = 1, ng(ibnd)
133 229376 : ind = (ibnd-1)*mg + ig
134 243712 : rwgt(ind) = wt(ig)/wtsm(ngm(ind))
135 : enddo
136 : else
137 34816 : do ig = 1, ng(ibnd)
138 32768 : igcsm = igcsm + 1
139 32768 : ind = (ibnd-1)*mg + ig
140 34816 : rwgt(ind) = 1.0_r8
141 : enddo
142 : endif
143 : enddo
144 :
145 : ! Reduce g-points for absorption coefficient data in each LW spectral band.
146 :
147 1024 : call cmbgb1
148 1024 : call cmbgb2
149 1024 : call cmbgb3
150 1024 : call cmbgb4
151 1024 : call cmbgb5
152 1024 : call cmbgb6
153 1024 : call cmbgb7
154 1024 : call cmbgb8
155 1024 : call cmbgb9
156 1024 : call cmbgb10
157 1024 : call cmbgb11
158 1024 : call cmbgb12
159 1024 : call cmbgb13
160 1024 : call cmbgb14
161 1024 : call cmbgb15
162 1024 : call cmbgb16
163 :
164 1024 : end subroutine rrtmg_lw_ini
165 :
166 : !***************************************************************************
167 1024 : subroutine lwdatinit
168 : !***************************************************************************
169 :
170 : ! --------- Modules ----------
171 :
172 : use parrrtm, only : maxxsec, maxinpx
173 : use rrlw_con, only: heatfac, grav, planck, boltz, &
174 : clight, avogad, alosmt, gascon, radcn1, radcn2
175 : use shr_const_mod, only: shr_const_avogad
176 : use physconst, only: cday, gravit, cpair
177 :
178 : save
179 :
180 : ! Longwave spectral band limits (wavenumbers)
181 : wavenum1(:) = (/ 10._r8, 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, &
182 : 980._r8,1080._r8,1180._r8,1390._r8,1480._r8,1800._r8, &
183 1024 : 2080._r8,2250._r8,2390._r8,2600._r8/)
184 : wavenum2(:) = (/350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, &
185 : 1080._r8,1180._r8,1390._r8,1480._r8,1800._r8,2080._r8, &
186 1024 : 2250._r8,2390._r8,2600._r8,3250._r8/)
187 : delwave(:) = (/340._r8, 150._r8, 130._r8, 70._r8, 120._r8, 160._r8, &
188 : 100._r8, 100._r8, 210._r8, 90._r8, 320._r8, 280._r8, &
189 1024 : 170._r8, 130._r8, 220._r8, 650._r8/)
190 :
191 : ! Spectral band information
192 1024 : ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
193 1024 : nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
194 1024 : nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
195 :
196 : ! Use constants set in CAM for consistency
197 1024 : grav = gravit
198 1024 : avogad = shr_const_avogad * 1.e-3_r8
199 :
200 : ! Heatfac is the factor by which one must multiply delta-flux/
201 : ! delta-pressure, with flux in w/m-2 and pressure in mbar, to get
202 : ! the heating rate in units of degrees/day. It is equal to
203 : ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
204 : ! = (9.8066)(86400)(1e-5)/(1.004)
205 : ! heatfac = 8.4391_r8
206 :
207 : ! Modified values for consistency with CAM:
208 : ! = (9.80616)(86400)(1e-5)/(1.00464)
209 : ! heatfac = 8.43339130434_r8
210 :
211 : ! Calculate heatfac directly from CAM constants:
212 1024 : heatfac = grav * cday * 1.e-5_r8 / (cpair * 1.e-3_r8)
213 :
214 : ! nxmol - number of cross-sections input by user
215 : ! ixindx(i) - index of cross-section molecule corresponding to Ith
216 : ! cross-section specified by user
217 : ! = 0 -- not allowed in rrtm
218 : ! = 1 -- ccl4
219 : ! = 2 -- cfc11
220 : ! = 3 -- cfc12
221 : ! = 4 -- cfc22
222 1024 : nxmol = 4
223 1024 : ixindx(1) = 1
224 1024 : ixindx(2) = 2
225 1024 : ixindx(3) = 3
226 1024 : ixindx(4) = 4
227 35840 : ixindx(5:maxinpx) = 0
228 :
229 : ! Constants from NIST 01/11/2002
230 :
231 : ! grav = 9.8066_r8
232 1024 : planck = 6.62606876e-27_r8
233 1024 : boltz = 1.3806503e-16_r8
234 1024 : clight = 2.99792458e+10_r8
235 : ! avogad = 6.02214199e+23_r8
236 1024 : alosmt = 2.6867775e+19_r8
237 1024 : gascon = 8.31447200e+07_r8
238 1024 : radcn1 = 1.191042722e-12_r8
239 1024 : radcn2 = 1.4387752_r8
240 :
241 : !
242 : ! units are generally cgs
243 : !
244 : ! The first and second radiation constants are taken from NIST.
245 : ! They were previously obtained from the relations:
246 : ! radcn1 = 2.*planck*clight*clight*1.e-07
247 : ! radcn2 = planck*clight/boltz
248 :
249 1024 : end subroutine lwdatinit
250 :
251 : !***************************************************************************
252 1024 : subroutine lwcmbdat
253 : !***************************************************************************
254 :
255 : save
256 :
257 : ! ------- Definitions -------
258 : ! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
259 : ! This mapping from 256 to 140 points has been carefully selected to
260 : ! minimize the effect on the resulting fluxes and cooling rates, and
261 : ! caution should be used if the mapping is modified. The full 256
262 : ! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
263 : ! ngptlw The total number of new g-points
264 : ! ngc The number of new g-points in each band
265 : ! ngs The cumulative sum of new g-points for each band
266 : ! ngm The index of each new g-point relative to the original
267 : ! 16 g-points for each band.
268 : ! ngn The number of original g-points that are combined to make
269 : ! each new g-point in each band.
270 : ! ngb The band index for each new g-point.
271 : ! wt RRTM weights for 16 g-points.
272 :
273 : ! ------- Data statements -------
274 1024 : ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
275 1024 : ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
276 : ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1
277 : 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2
278 : 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3
279 : 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4
280 : 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5
281 : 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6
282 : 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7
283 : 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8
284 : 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9
285 : 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10
286 : 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11
287 : 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12
288 : 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13
289 : 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14
290 : 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15
291 1024 : 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16
292 : ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1
293 : 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2
294 : 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3
295 : 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4
296 : 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5
297 : 2,2,2,2,2,2,2,2, & ! band 6
298 : 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7
299 : 2,2,2,2,2,2,2,2, & ! band 8
300 : 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9
301 : 2,2,2,2,4,4, & ! band 10
302 : 1,1,2,2,2,2,3,3, & ! band 11
303 : 1,1,1,1,2,2,4,4, & ! band 12
304 : 3,3,4,6, & ! band 13
305 : 8,8, & ! band 14
306 : 8,8, & ! band 15
307 1024 : 4,12/) ! band 16
308 : ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1
309 : 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2
310 : 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3
311 : 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4
312 : 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5
313 : 6,6,6,6,6,6,6,6, & ! band 6
314 : 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7
315 : 8,8,8,8,8,8,8,8, & ! band 8
316 : 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9
317 : 10,10,10,10,10,10, & ! band 10
318 : 11,11,11,11,11,11,11,11, & ! band 11
319 : 12,12,12,12,12,12,12,12, & ! band 12
320 : 13,13,13,13, & ! band 13
321 : 14,14, & ! band 14
322 : 15,15, & ! band 15
323 1024 : 16,16/) ! band 16
324 : wt(:) = (/ 0.1527534276_r8, 0.1491729617_r8, 0.1420961469_r8, &
325 : 0.1316886544_r8, 0.1181945205_r8, 0.1019300893_r8, &
326 : 0.0832767040_r8, 0.0626720116_r8, 0.0424925000_r8, &
327 : 0.0046269894_r8, 0.0038279891_r8, 0.0030260086_r8, &
328 : 0.0022199750_r8, 0.0014140010_r8, 0.0005330000_r8, &
329 1024 : 0.0000750000_r8/)
330 :
331 1024 : end subroutine lwcmbdat
332 :
333 : !***************************************************************************
334 1024 : subroutine cmbgb1
335 : !***************************************************************************
336 : !
337 : ! Original version: MJIacono; July 1998
338 : ! Revision for GCMs: MJIacono; September 1998
339 : ! Revision for RRTMG: MJIacono, September 2002
340 : ! Revision for F90 reformatting: MJIacono, June 2006
341 : !
342 : ! The subroutines CMBGB1->CMBGB16 input the absorption coefficient
343 : ! data for each band, which are defined for 16 g-points and 16 spectral
344 : ! bands. The data are combined with appropriate weighting following the
345 : ! g-point mapping arrays specified in RRTMINIT. Plank fraction data
346 : ! in arrays FRACREFA and FRACREFB are combined without weighting. All
347 : ! g-point reduced data are put into new arrays for use in RRTM.
348 : !
349 : ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
350 : ! (high key - h2o; high minor - n2)
351 : ! note: previous versions of rrtm band 1:
352 : ! 10-250 cm-1 (low - h2o; high - h2o)
353 : !***************************************************************************
354 :
355 : use parrrtm, only : mg, nbndlw, ngptlw, ng1
356 : use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
357 : selfrefo, forrefo, &
358 : fracrefa, fracrefb, ka, kb, ka_mn2, kb_mn2, &
359 : selfref, forref
360 :
361 : ! ------- Local -------
362 : integer :: jt, jp, igc, ipr, iprsm
363 : real(kind=r8) :: sumk, sumk1, sumk2, sumf1, sumf2
364 :
365 :
366 6144 : do jt = 1,5
367 71680 : do jp = 1,13
368 66560 : iprsm = 0
369 737280 : do igc = 1,ngc(1)
370 665600 : sumk = 0.
371 1730560 : do ipr = 1, ngn(igc)
372 1064960 : iprsm = iprsm + 1
373 1730560 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
374 : enddo
375 732160 : ka(jt,jp,igc) = sumk
376 : enddo
377 : enddo
378 246784 : do jp = 13,59
379 240640 : iprsm = 0
380 2652160 : do igc = 1,ngc(1)
381 2406400 : sumk = 0.
382 6256640 : do ipr = 1, ngn(igc)
383 3850240 : iprsm = iprsm + 1
384 6256640 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
385 : enddo
386 2647040 : kb(jt,jp,igc) = sumk
387 : enddo
388 : enddo
389 : enddo
390 :
391 11264 : do jt = 1,10
392 10240 : iprsm = 0
393 113664 : do igc = 1,ngc(1)
394 102400 : sumk = 0.
395 266240 : do ipr = 1, ngn(igc)
396 163840 : iprsm = iprsm + 1
397 266240 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
398 : enddo
399 112640 : selfref(jt,igc) = sumk
400 : enddo
401 : enddo
402 :
403 5120 : do jt = 1,4
404 4096 : iprsm = 0
405 46080 : do igc = 1,ngc(1)
406 40960 : sumk = 0.
407 106496 : do ipr = 1, ngn(igc)
408 65536 : iprsm = iprsm + 1
409 106496 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
410 : enddo
411 45056 : forref(jt,igc) = sumk
412 : enddo
413 : enddo
414 :
415 20480 : do jt = 1,19
416 19456 : iprsm = 0
417 215040 : do igc = 1,ngc(1)
418 194560 : sumk1 = 0.
419 194560 : sumk2 = 0.
420 505856 : do ipr = 1, ngn(igc)
421 311296 : iprsm = iprsm + 1
422 311296 : sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
423 505856 : sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
424 : enddo
425 194560 : ka_mn2(jt,igc) = sumk1
426 214016 : kb_mn2(jt,igc) = sumk2
427 : enddo
428 : enddo
429 :
430 1024 : iprsm = 0
431 11264 : do igc = 1,ngc(1)
432 10240 : sumf1 = 0.
433 10240 : sumf2 = 0.
434 26624 : do ipr = 1, ngn(igc)
435 16384 : iprsm = iprsm + 1
436 16384 : sumf1= sumf1+ fracrefao(iprsm)
437 26624 : sumf2= sumf2+ fracrefbo(iprsm)
438 : enddo
439 10240 : fracrefa(igc) = sumf1
440 11264 : fracrefb(igc) = sumf2
441 : enddo
442 :
443 1024 : end subroutine cmbgb1
444 :
445 : !***************************************************************************
446 1024 : subroutine cmbgb2
447 : !***************************************************************************
448 : !
449 : ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
450 : !
451 : ! note: previous version of rrtm band 2:
452 : ! 250 - 500 cm-1 (low - h2o; high - h2o)
453 : !***************************************************************************
454 :
455 : use parrrtm, only : mg, nbndlw, ngptlw, ng2
456 : use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
457 : fracrefa, fracrefb, ka, kb, selfref, forref
458 :
459 : ! ------- Local -------
460 : integer :: jt, jp, igc, ipr, iprsm
461 : real(kind=r8) :: sumk, sumf1, sumf2
462 :
463 :
464 6144 : do jt = 1,5
465 71680 : do jp = 1,13
466 66560 : iprsm = 0
467 870400 : do igc = 1,ngc(2)
468 798720 : sumk = 0.
469 1863680 : do ipr = 1, ngn(ngs(1)+igc)
470 1064960 : iprsm = iprsm + 1
471 1863680 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
472 : enddo
473 865280 : ka(jt,jp,igc) = sumk
474 : enddo
475 : enddo
476 246784 : do jp = 13,59
477 240640 : iprsm = 0
478 3133440 : do igc = 1,ngc(2)
479 2887680 : sumk = 0.
480 6737920 : do ipr = 1, ngn(ngs(1)+igc)
481 3850240 : iprsm = iprsm + 1
482 6737920 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
483 : enddo
484 3128320 : kb(jt,jp,igc) = sumk
485 : enddo
486 : enddo
487 : enddo
488 :
489 11264 : do jt = 1,10
490 10240 : iprsm = 0
491 134144 : do igc = 1,ngc(2)
492 122880 : sumk = 0.
493 286720 : do ipr = 1, ngn(ngs(1)+igc)
494 163840 : iprsm = iprsm + 1
495 286720 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
496 : enddo
497 133120 : selfref(jt,igc) = sumk
498 : enddo
499 : enddo
500 :
501 5120 : do jt = 1,4
502 4096 : iprsm = 0
503 54272 : do igc = 1,ngc(2)
504 49152 : sumk = 0.
505 114688 : do ipr = 1, ngn(ngs(1)+igc)
506 65536 : iprsm = iprsm + 1
507 114688 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
508 : enddo
509 53248 : forref(jt,igc) = sumk
510 : enddo
511 : enddo
512 :
513 1024 : iprsm = 0
514 13312 : do igc = 1,ngc(2)
515 12288 : sumf1 = 0.
516 12288 : sumf2 = 0.
517 28672 : do ipr = 1, ngn(ngs(1)+igc)
518 16384 : iprsm = iprsm + 1
519 16384 : sumf1= sumf1+ fracrefao(iprsm)
520 28672 : sumf2= sumf2+ fracrefbo(iprsm)
521 : enddo
522 12288 : fracrefa(igc) = sumf1
523 13312 : fracrefb(igc) = sumf2
524 : enddo
525 :
526 1024 : end subroutine cmbgb2
527 :
528 : !***************************************************************************
529 1024 : subroutine cmbgb3
530 : !***************************************************************************
531 : !
532 : ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
533 : ! (high key - h2o,co2; high minor - n2o)
534 : !
535 : ! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
536 : !***************************************************************************
537 :
538 : use parrrtm, only : mg, nbndlw, ngptlw, ng3
539 : use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
540 : selfrefo, forrefo, &
541 : fracrefa, fracrefb, ka, kb, ka_mn2o, kb_mn2o, &
542 : selfref, forref
543 :
544 : ! ------- Local -------
545 : integer :: jn, jt, jp, igc, ipr, iprsm
546 : real(kind=r8) :: sumk, sumf
547 :
548 :
549 10240 : do jn = 1,9
550 56320 : do jt = 1,5
551 654336 : do jp = 1,13
552 599040 : iprsm = 0
553 10229760 : do igc = 1,ngc(3)
554 9584640 : sumk = 0.
555 19169280 : do ipr = 1, ngn(ngs(2)+igc)
556 9584640 : iprsm = iprsm + 1
557 19169280 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
558 : enddo
559 10183680 : ka(jn,jt,jp,igc) = sumk
560 : enddo
561 : enddo
562 : enddo
563 : enddo
564 6144 : do jn = 1,5
565 31744 : do jt = 1,5
566 1233920 : do jp = 13,59
567 1203200 : iprsm = 0
568 20480000 : do igc = 1,ngc(3)
569 19251200 : sumk = 0.
570 38502400 : do ipr = 1, ngn(ngs(2)+igc)
571 19251200 : iprsm = iprsm + 1
572 38502400 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
573 : enddo
574 20454400 : kb(jn,jt,jp,igc) = sumk
575 : enddo
576 : enddo
577 : enddo
578 : enddo
579 :
580 10240 : do jn = 1,9
581 185344 : do jt = 1,19
582 175104 : iprsm = 0
583 2985984 : do igc = 1,ngc(3)
584 2801664 : sumk = 0.
585 5603328 : do ipr = 1, ngn(ngs(2)+igc)
586 2801664 : iprsm = iprsm + 1
587 5603328 : sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
588 : enddo
589 2976768 : ka_mn2o(jn,jt,igc) = sumk
590 : enddo
591 : enddo
592 : enddo
593 :
594 6144 : do jn = 1,5
595 103424 : do jt = 1,19
596 97280 : iprsm = 0
597 1658880 : do igc = 1,ngc(3)
598 1556480 : sumk = 0.
599 3112960 : do ipr = 1, ngn(ngs(2)+igc)
600 1556480 : iprsm = iprsm + 1
601 3112960 : sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
602 : enddo
603 1653760 : kb_mn2o(jn,jt,igc) = sumk
604 : enddo
605 : enddo
606 : enddo
607 :
608 11264 : do jt = 1,10
609 10240 : iprsm = 0
610 175104 : do igc = 1,ngc(3)
611 163840 : sumk = 0.
612 327680 : do ipr = 1, ngn(ngs(2)+igc)
613 163840 : iprsm = iprsm + 1
614 327680 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
615 : enddo
616 174080 : selfref(jt,igc) = sumk
617 : enddo
618 : enddo
619 :
620 5120 : do jt = 1,4
621 4096 : iprsm = 0
622 70656 : do igc = 1,ngc(3)
623 65536 : sumk = 0.
624 131072 : do ipr = 1, ngn(ngs(2)+igc)
625 65536 : iprsm = iprsm + 1
626 131072 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
627 : enddo
628 69632 : forref(jt,igc) = sumk
629 : enddo
630 : enddo
631 :
632 10240 : do jp = 1,9
633 9216 : iprsm = 0
634 157696 : do igc = 1,ngc(3)
635 147456 : sumf = 0.
636 294912 : do ipr = 1, ngn(ngs(2)+igc)
637 147456 : iprsm = iprsm + 1
638 294912 : sumf = sumf + fracrefao(iprsm,jp)
639 : enddo
640 156672 : fracrefa(igc,jp) = sumf
641 : enddo
642 : enddo
643 :
644 6144 : do jp = 1,5
645 5120 : iprsm = 0
646 88064 : do igc = 1,ngc(3)
647 81920 : sumf = 0.
648 163840 : do ipr = 1, ngn(ngs(2)+igc)
649 81920 : iprsm = iprsm + 1
650 163840 : sumf = sumf + fracrefbo(iprsm,jp)
651 : enddo
652 87040 : fracrefb(igc,jp) = sumf
653 : enddo
654 : enddo
655 :
656 1024 : end subroutine cmbgb3
657 :
658 : !***************************************************************************
659 1024 : subroutine cmbgb4
660 : !***************************************************************************
661 : !
662 : ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
663 : !
664 : ! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
665 : !***************************************************************************
666 :
667 : use parrrtm, only : mg, nbndlw, ngptlw, ng4
668 : use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
669 : fracrefa, fracrefb, ka, kb, selfref, forref
670 :
671 : ! ------- Local -------
672 : integer :: jn, jt, jp, igc, ipr, iprsm
673 : real(kind=r8) :: sumk, sumf
674 :
675 :
676 10240 : do jn = 1,9
677 56320 : do jt = 1,5
678 654336 : do jp = 1,13
679 599040 : iprsm = 0
680 9031680 : do igc = 1,ngc(4)
681 8386560 : sumk = 0.
682 17971200 : do ipr = 1, ngn(ngs(3)+igc)
683 9584640 : iprsm = iprsm + 1
684 17971200 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
685 : enddo
686 8985600 : ka(jn,jt,jp,igc) = sumk
687 : enddo
688 : enddo
689 : enddo
690 : enddo
691 6144 : do jn = 1,5
692 31744 : do jt = 1,5
693 1233920 : do jp = 13,59
694 1203200 : iprsm = 0
695 18073600 : do igc = 1,ngc(4)
696 16844800 : sumk = 0.
697 36096000 : do ipr = 1, ngn(ngs(3)+igc)
698 19251200 : iprsm = iprsm + 1
699 36096000 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
700 : enddo
701 18048000 : kb(jn,jt,jp,igc) = sumk
702 : enddo
703 : enddo
704 : enddo
705 : enddo
706 :
707 11264 : do jt = 1,10
708 10240 : iprsm = 0
709 154624 : do igc = 1,ngc(4)
710 143360 : sumk = 0.
711 307200 : do ipr = 1, ngn(ngs(3)+igc)
712 163840 : iprsm = iprsm + 1
713 307200 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
714 : enddo
715 153600 : selfref(jt,igc) = sumk
716 : enddo
717 : enddo
718 :
719 5120 : do jt = 1,4
720 4096 : iprsm = 0
721 62464 : do igc = 1,ngc(4)
722 57344 : sumk = 0.
723 122880 : do ipr = 1, ngn(ngs(3)+igc)
724 65536 : iprsm = iprsm + 1
725 122880 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
726 : enddo
727 61440 : forref(jt,igc) = sumk
728 : enddo
729 : enddo
730 :
731 10240 : do jp = 1,9
732 9216 : iprsm = 0
733 139264 : do igc = 1,ngc(4)
734 129024 : sumf = 0.
735 276480 : do ipr = 1, ngn(ngs(3)+igc)
736 147456 : iprsm = iprsm + 1
737 276480 : sumf = sumf + fracrefao(iprsm,jp)
738 : enddo
739 138240 : fracrefa(igc,jp) = sumf
740 : enddo
741 : enddo
742 :
743 6144 : do jp = 1,5
744 5120 : iprsm = 0
745 77824 : do igc = 1,ngc(4)
746 71680 : sumf = 0.
747 153600 : do ipr = 1, ngn(ngs(3)+igc)
748 81920 : iprsm = iprsm + 1
749 153600 : sumf = sumf + fracrefbo(iprsm,jp)
750 : enddo
751 76800 : fracrefb(igc,jp) = sumf
752 : enddo
753 : enddo
754 :
755 1024 : end subroutine cmbgb4
756 :
757 : !***************************************************************************
758 1024 : subroutine cmbgb5
759 : !***************************************************************************
760 : !
761 : ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
762 : ! (high key - o3,co2)
763 : !
764 : ! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
765 : !***************************************************************************
766 :
767 : use parrrtm, only : mg, nbndlw, ngptlw, ng5
768 : use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
769 : selfrefo, forrefo, &
770 : fracrefa, fracrefb, ka, kb, ka_mo3, ccl4, &
771 : selfref, forref
772 :
773 : ! ------- Local -------
774 : integer :: jn, jt, jp, igc, ipr, iprsm
775 : real(kind=r8) :: sumk, sumf
776 :
777 :
778 10240 : do jn = 1,9
779 56320 : do jt = 1,5
780 654336 : do jp = 1,13
781 599040 : iprsm = 0
782 10229760 : do igc = 1,ngc(5)
783 9584640 : sumk = 0.
784 19169280 : do ipr = 1, ngn(ngs(4)+igc)
785 9584640 : iprsm = iprsm + 1
786 19169280 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
787 : enddo
788 10183680 : ka(jn,jt,jp,igc) = sumk
789 : enddo
790 : enddo
791 : enddo
792 : enddo
793 6144 : do jn = 1,5
794 31744 : do jt = 1,5
795 1233920 : do jp = 13,59
796 1203200 : iprsm = 0
797 20480000 : do igc = 1,ngc(5)
798 19251200 : sumk = 0.
799 38502400 : do ipr = 1, ngn(ngs(4)+igc)
800 19251200 : iprsm = iprsm + 1
801 38502400 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
802 : enddo
803 20454400 : kb(jn,jt,jp,igc) = sumk
804 : enddo
805 : enddo
806 : enddo
807 : enddo
808 :
809 10240 : do jn = 1,9
810 185344 : do jt = 1,19
811 175104 : iprsm = 0
812 2985984 : do igc = 1,ngc(5)
813 2801664 : sumk = 0.
814 5603328 : do ipr = 1, ngn(ngs(4)+igc)
815 2801664 : iprsm = iprsm + 1
816 5603328 : sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
817 : enddo
818 2976768 : ka_mo3(jn,jt,igc) = sumk
819 : enddo
820 : enddo
821 : enddo
822 :
823 11264 : do jt = 1,10
824 10240 : iprsm = 0
825 175104 : do igc = 1,ngc(5)
826 163840 : sumk = 0.
827 327680 : do ipr = 1, ngn(ngs(4)+igc)
828 163840 : iprsm = iprsm + 1
829 327680 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
830 : enddo
831 174080 : selfref(jt,igc) = sumk
832 : enddo
833 : enddo
834 :
835 5120 : do jt = 1,4
836 4096 : iprsm = 0
837 70656 : do igc = 1,ngc(5)
838 65536 : sumk = 0.
839 131072 : do ipr = 1, ngn(ngs(4)+igc)
840 65536 : iprsm = iprsm + 1
841 131072 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
842 : enddo
843 69632 : forref(jt,igc) = sumk
844 : enddo
845 : enddo
846 :
847 10240 : do jp = 1,9
848 9216 : iprsm = 0
849 157696 : do igc = 1,ngc(5)
850 147456 : sumf = 0.
851 294912 : do ipr = 1, ngn(ngs(4)+igc)
852 147456 : iprsm = iprsm + 1
853 294912 : sumf = sumf + fracrefao(iprsm,jp)
854 : enddo
855 156672 : fracrefa(igc,jp) = sumf
856 : enddo
857 : enddo
858 :
859 6144 : do jp = 1,5
860 5120 : iprsm = 0
861 88064 : do igc = 1,ngc(5)
862 81920 : sumf = 0.
863 163840 : do ipr = 1, ngn(ngs(4)+igc)
864 81920 : iprsm = iprsm + 1
865 163840 : sumf = sumf + fracrefbo(iprsm,jp)
866 : enddo
867 87040 : fracrefb(igc,jp) = sumf
868 : enddo
869 : enddo
870 :
871 1024 : iprsm = 0
872 17408 : do igc = 1,ngc(5)
873 16384 : sumk = 0.
874 32768 : do ipr = 1, ngn(ngs(4)+igc)
875 16384 : iprsm = iprsm + 1
876 32768 : sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
877 : enddo
878 17408 : ccl4(igc) = sumk
879 : enddo
880 :
881 1024 : end subroutine cmbgb5
882 :
883 : !***************************************************************************
884 1024 : subroutine cmbgb6
885 : !***************************************************************************
886 : !
887 : ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
888 : ! (high key - nothing; high minor - cfc11, cfc12)
889 : !
890 : ! old band 6: 820-980 cm-1 (low - h2o; high - nothing)
891 : !***************************************************************************
892 :
893 : use parrrtm, only : mg, nbndlw, ngptlw, ng6
894 : use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
895 : selfrefo, forrefo, &
896 : fracrefa, ka, ka_mco2, cfc11adj, cfc12, &
897 : selfref, forref
898 :
899 : ! ------- Local -------
900 : integer :: jt, jp, igc, ipr, iprsm
901 : real(kind=r8) :: sumk, sumf, sumk1, sumk2
902 :
903 :
904 6144 : do jt = 1,5
905 72704 : do jp = 1,13
906 66560 : iprsm = 0
907 604160 : do igc = 1,ngc(6)
908 532480 : sumk = 0.
909 1597440 : do ipr = 1, ngn(ngs(5)+igc)
910 1064960 : iprsm = iprsm + 1
911 1597440 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
912 : enddo
913 599040 : ka(jt,jp,igc) = sumk
914 : enddo
915 : enddo
916 : enddo
917 :
918 20480 : do jt = 1,19
919 19456 : iprsm = 0
920 176128 : do igc = 1,ngc(6)
921 155648 : sumk = 0.
922 466944 : do ipr = 1, ngn(ngs(5)+igc)
923 311296 : iprsm = iprsm + 1
924 466944 : sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
925 : enddo
926 175104 : ka_mco2(jt,igc) = sumk
927 : enddo
928 : enddo
929 :
930 11264 : do jt = 1,10
931 10240 : iprsm = 0
932 93184 : do igc = 1,ngc(6)
933 81920 : sumk = 0.
934 245760 : do ipr = 1, ngn(ngs(5)+igc)
935 163840 : iprsm = iprsm + 1
936 245760 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
937 : enddo
938 92160 : selfref(jt,igc) = sumk
939 : enddo
940 : enddo
941 :
942 5120 : do jt = 1,4
943 4096 : iprsm = 0
944 37888 : do igc = 1,ngc(6)
945 32768 : sumk = 0.
946 98304 : do ipr = 1, ngn(ngs(5)+igc)
947 65536 : iprsm = iprsm + 1
948 98304 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
949 : enddo
950 36864 : forref(jt,igc) = sumk
951 : enddo
952 : enddo
953 :
954 1024 : iprsm = 0
955 9216 : do igc = 1,ngc(6)
956 8192 : sumf = 0.
957 8192 : sumk1= 0.
958 8192 : sumk2= 0.
959 24576 : do ipr = 1, ngn(ngs(5)+igc)
960 16384 : iprsm = iprsm + 1
961 16384 : sumf = sumf + fracrefao(iprsm)
962 16384 : sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
963 24576 : sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
964 : enddo
965 8192 : fracrefa(igc) = sumf
966 8192 : cfc11adj(igc) = sumk1
967 9216 : cfc12(igc) = sumk2
968 : enddo
969 :
970 1024 : end subroutine cmbgb6
971 :
972 : !***************************************************************************
973 1024 : subroutine cmbgb7
974 : !***************************************************************************
975 : !
976 : ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
977 : ! (high key - o3; high minor - co2)
978 : !
979 : ! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
980 : !***************************************************************************
981 :
982 : use parrrtm, only : mg, nbndlw, ngptlw, ng7
983 : use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
984 : selfrefo, forrefo, &
985 : fracrefa, fracrefb, ka, kb, ka_mco2, kb_mco2, &
986 : selfref, forref
987 :
988 : ! ------- Local -------
989 : integer :: jn, jt, jp, igc, ipr, iprsm
990 : real(kind=r8) :: sumk, sumf
991 :
992 :
993 10240 : do jn = 1,9
994 56320 : do jt = 1,5
995 654336 : do jp = 1,13
996 599040 : iprsm = 0
997 7833600 : do igc = 1,ngc(7)
998 7188480 : sumk = 0.
999 16773120 : do ipr = 1, ngn(ngs(6)+igc)
1000 9584640 : iprsm = iprsm + 1
1001 16773120 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
1002 : enddo
1003 7787520 : ka(jn,jt,jp,igc) = sumk
1004 : enddo
1005 : enddo
1006 : enddo
1007 : enddo
1008 6144 : do jt = 1,5
1009 246784 : do jp = 13,59
1010 240640 : iprsm = 0
1011 3133440 : do igc = 1,ngc(7)
1012 2887680 : sumk = 0.
1013 6737920 : do ipr = 1, ngn(ngs(6)+igc)
1014 3850240 : iprsm = iprsm + 1
1015 6737920 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
1016 : enddo
1017 3128320 : kb(jt,jp,igc) = sumk
1018 : enddo
1019 : enddo
1020 : enddo
1021 :
1022 10240 : do jn = 1,9
1023 185344 : do jt = 1,19
1024 175104 : iprsm = 0
1025 2285568 : do igc = 1,ngc(7)
1026 2101248 : sumk = 0.
1027 4902912 : do ipr = 1, ngn(ngs(6)+igc)
1028 2801664 : iprsm = iprsm + 1
1029 4902912 : sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
1030 : enddo
1031 2276352 : ka_mco2(jn,jt,igc) = sumk
1032 : enddo
1033 : enddo
1034 : enddo
1035 :
1036 20480 : do jt = 1,19
1037 19456 : iprsm = 0
1038 253952 : do igc = 1,ngc(7)
1039 233472 : sumk = 0.
1040 544768 : do ipr = 1, ngn(ngs(6)+igc)
1041 311296 : iprsm = iprsm + 1
1042 544768 : sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
1043 : enddo
1044 252928 : kb_mco2(jt,igc) = sumk
1045 : enddo
1046 : enddo
1047 :
1048 11264 : do jt = 1,10
1049 10240 : iprsm = 0
1050 134144 : do igc = 1,ngc(7)
1051 122880 : sumk = 0.
1052 286720 : do ipr = 1, ngn(ngs(6)+igc)
1053 163840 : iprsm = iprsm + 1
1054 286720 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
1055 : enddo
1056 133120 : selfref(jt,igc) = sumk
1057 : enddo
1058 : enddo
1059 :
1060 5120 : do jt = 1,4
1061 4096 : iprsm = 0
1062 54272 : do igc = 1,ngc(7)
1063 49152 : sumk = 0.
1064 114688 : do ipr = 1, ngn(ngs(6)+igc)
1065 65536 : iprsm = iprsm + 1
1066 114688 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
1067 : enddo
1068 53248 : forref(jt,igc) = sumk
1069 : enddo
1070 : enddo
1071 :
1072 10240 : do jp = 1,9
1073 9216 : iprsm = 0
1074 120832 : do igc = 1,ngc(7)
1075 110592 : sumf = 0.
1076 258048 : do ipr = 1, ngn(ngs(6)+igc)
1077 147456 : iprsm = iprsm + 1
1078 258048 : sumf = sumf + fracrefao(iprsm,jp)
1079 : enddo
1080 119808 : fracrefa(igc,jp) = sumf
1081 : enddo
1082 : enddo
1083 :
1084 1024 : iprsm = 0
1085 13312 : do igc = 1,ngc(7)
1086 12288 : sumf = 0.
1087 28672 : do ipr = 1, ngn(ngs(6)+igc)
1088 16384 : iprsm = iprsm + 1
1089 28672 : sumf = sumf + fracrefbo(iprsm)
1090 : enddo
1091 13312 : fracrefb(igc) = sumf
1092 : enddo
1093 :
1094 1024 : end subroutine cmbgb7
1095 :
1096 : !***************************************************************************
1097 1024 : subroutine cmbgb8
1098 : !***************************************************************************
1099 : !
1100 : ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
1101 : ! (high key - o3; high minor - co2, n2o)
1102 : !
1103 : ! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
1104 : !***************************************************************************
1105 :
1106 : use parrrtm, only : mg, nbndlw, ngptlw, ng8
1107 : use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
1108 : kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
1109 : cfc12o, cfc22adjo, &
1110 : fracrefa, fracrefb, ka, ka_mco2, ka_mn2o, &
1111 : ka_mo3, kb, kb_mco2, kb_mn2o, selfref, forref, &
1112 : cfc12, cfc22adj
1113 :
1114 : ! ------- Local -------
1115 : integer :: jt, jp, igc, ipr, iprsm
1116 : real(kind=r8) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
1117 :
1118 :
1119 6144 : do jt = 1,5
1120 72704 : do jp = 1,13
1121 66560 : iprsm = 0
1122 604160 : do igc = 1,ngc(8)
1123 532480 : sumk = 0.
1124 1597440 : do ipr = 1, ngn(ngs(7)+igc)
1125 1064960 : iprsm = iprsm + 1
1126 1597440 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
1127 : enddo
1128 599040 : ka(jt,jp,igc) = sumk
1129 : enddo
1130 : enddo
1131 : enddo
1132 6144 : do jt = 1,5
1133 246784 : do jp = 13,59
1134 240640 : iprsm = 0
1135 2170880 : do igc = 1,ngc(8)
1136 1925120 : sumk = 0.
1137 5775360 : do ipr = 1, ngn(ngs(7)+igc)
1138 3850240 : iprsm = iprsm + 1
1139 5775360 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
1140 : enddo
1141 2165760 : kb(jt,jp,igc) = sumk
1142 : enddo
1143 : enddo
1144 : enddo
1145 :
1146 11264 : do jt = 1,10
1147 10240 : iprsm = 0
1148 93184 : do igc = 1,ngc(8)
1149 81920 : sumk = 0.
1150 245760 : do ipr = 1, ngn(ngs(7)+igc)
1151 163840 : iprsm = iprsm + 1
1152 245760 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
1153 : enddo
1154 92160 : selfref(jt,igc) = sumk
1155 : enddo
1156 : enddo
1157 :
1158 5120 : do jt = 1,4
1159 4096 : iprsm = 0
1160 37888 : do igc = 1,ngc(8)
1161 32768 : sumk = 0.
1162 98304 : do ipr = 1, ngn(ngs(7)+igc)
1163 65536 : iprsm = iprsm + 1
1164 98304 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
1165 : enddo
1166 36864 : forref(jt,igc) = sumk
1167 : enddo
1168 : enddo
1169 :
1170 20480 : do jt = 1,19
1171 19456 : iprsm = 0
1172 176128 : do igc = 1,ngc(8)
1173 155648 : sumk1 = 0.
1174 155648 : sumk2 = 0.
1175 155648 : sumk3 = 0.
1176 155648 : sumk4 = 0.
1177 155648 : sumk5 = 0.
1178 466944 : do ipr = 1, ngn(ngs(7)+igc)
1179 311296 : iprsm = iprsm + 1
1180 311296 : sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
1181 311296 : sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
1182 311296 : sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
1183 311296 : sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
1184 466944 : sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
1185 : enddo
1186 155648 : ka_mco2(jt,igc) = sumk1
1187 155648 : kb_mco2(jt,igc) = sumk2
1188 155648 : ka_mo3(jt,igc) = sumk3
1189 155648 : ka_mn2o(jt,igc) = sumk4
1190 175104 : kb_mn2o(jt,igc) = sumk5
1191 : enddo
1192 : enddo
1193 :
1194 1024 : iprsm = 0
1195 9216 : do igc = 1,ngc(8)
1196 8192 : sumf1= 0.
1197 8192 : sumf2= 0.
1198 8192 : sumk1= 0.
1199 8192 : sumk2= 0.
1200 24576 : do ipr = 1, ngn(ngs(7)+igc)
1201 16384 : iprsm = iprsm + 1
1202 16384 : sumf1= sumf1+ fracrefao(iprsm)
1203 16384 : sumf2= sumf2+ fracrefbo(iprsm)
1204 16384 : sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
1205 24576 : sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
1206 : enddo
1207 8192 : fracrefa(igc) = sumf1
1208 8192 : fracrefb(igc) = sumf2
1209 8192 : cfc12(igc) = sumk1
1210 9216 : cfc22adj(igc) = sumk2
1211 : enddo
1212 :
1213 1024 : end subroutine cmbgb8
1214 :
1215 : !***************************************************************************
1216 1024 : subroutine cmbgb9
1217 : !***************************************************************************
1218 : !
1219 : ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
1220 : ! (high key - ch4; high minor - n2o)!
1221 :
1222 : ! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
1223 : !***************************************************************************
1224 :
1225 : use parrrtm, only : mg, nbndlw, ngptlw, ng9
1226 : use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, &
1227 : kbo, kbo_mn2o, selfrefo, forrefo, &
1228 : fracrefa, fracrefb, ka, ka_mn2o, &
1229 : kb, kb_mn2o, selfref, forref
1230 :
1231 : ! ------- Local -------
1232 : integer :: jn, jt, jp, igc, ipr, iprsm
1233 : real(kind=r8) :: sumk, sumf
1234 :
1235 :
1236 10240 : do jn = 1,9
1237 56320 : do jt = 1,5
1238 654336 : do jp = 1,13
1239 599040 : iprsm = 0
1240 7833600 : do igc = 1,ngc(9)
1241 7188480 : sumk = 0.
1242 16773120 : do ipr = 1, ngn(ngs(8)+igc)
1243 9584640 : iprsm = iprsm + 1
1244 16773120 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
1245 : enddo
1246 7787520 : ka(jn,jt,jp,igc) = sumk
1247 : enddo
1248 : enddo
1249 : enddo
1250 : enddo
1251 :
1252 6144 : do jt = 1,5
1253 246784 : do jp = 13,59
1254 240640 : iprsm = 0
1255 3133440 : do igc = 1,ngc(9)
1256 2887680 : sumk = 0.
1257 6737920 : do ipr = 1, ngn(ngs(8)+igc)
1258 3850240 : iprsm = iprsm + 1
1259 6737920 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
1260 : enddo
1261 3128320 : kb(jt,jp,igc) = sumk
1262 : enddo
1263 : enddo
1264 : enddo
1265 :
1266 10240 : do jn = 1,9
1267 185344 : do jt = 1,19
1268 175104 : iprsm = 0
1269 2285568 : do igc = 1,ngc(9)
1270 2101248 : sumk = 0.
1271 4902912 : do ipr = 1, ngn(ngs(8)+igc)
1272 2801664 : iprsm = iprsm + 1
1273 4902912 : sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
1274 : enddo
1275 2276352 : ka_mn2o(jn,jt,igc) = sumk
1276 : enddo
1277 : enddo
1278 : enddo
1279 :
1280 20480 : do jt = 1,19
1281 19456 : iprsm = 0
1282 253952 : do igc = 1,ngc(9)
1283 233472 : sumk = 0.
1284 544768 : do ipr = 1, ngn(ngs(8)+igc)
1285 311296 : iprsm = iprsm + 1
1286 544768 : sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
1287 : enddo
1288 252928 : kb_mn2o(jt,igc) = sumk
1289 : enddo
1290 : enddo
1291 :
1292 11264 : do jt = 1,10
1293 10240 : iprsm = 0
1294 134144 : do igc = 1,ngc(9)
1295 122880 : sumk = 0.
1296 286720 : do ipr = 1, ngn(ngs(8)+igc)
1297 163840 : iprsm = iprsm + 1
1298 286720 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
1299 : enddo
1300 133120 : selfref(jt,igc) = sumk
1301 : enddo
1302 : enddo
1303 :
1304 5120 : do jt = 1,4
1305 4096 : iprsm = 0
1306 54272 : do igc = 1,ngc(9)
1307 49152 : sumk = 0.
1308 114688 : do ipr = 1, ngn(ngs(8)+igc)
1309 65536 : iprsm = iprsm + 1
1310 114688 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
1311 : enddo
1312 53248 : forref(jt,igc) = sumk
1313 : enddo
1314 : enddo
1315 :
1316 10240 : do jp = 1,9
1317 9216 : iprsm = 0
1318 120832 : do igc = 1,ngc(9)
1319 110592 : sumf = 0.
1320 258048 : do ipr = 1, ngn(ngs(8)+igc)
1321 147456 : iprsm = iprsm + 1
1322 258048 : sumf = sumf + fracrefao(iprsm,jp)
1323 : enddo
1324 119808 : fracrefa(igc,jp) = sumf
1325 : enddo
1326 : enddo
1327 :
1328 1024 : iprsm = 0
1329 13312 : do igc = 1,ngc(9)
1330 12288 : sumf = 0.
1331 28672 : do ipr = 1, ngn(ngs(8)+igc)
1332 16384 : iprsm = iprsm + 1
1333 28672 : sumf = sumf + fracrefbo(iprsm)
1334 : enddo
1335 13312 : fracrefb(igc) = sumf
1336 : enddo
1337 :
1338 1024 : end subroutine cmbgb9
1339 :
1340 : !***************************************************************************
1341 1024 : subroutine cmbgb10
1342 : !***************************************************************************
1343 : !
1344 : ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
1345 : !
1346 : ! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
1347 : !***************************************************************************
1348 :
1349 : use parrrtm, only : mg, nbndlw, ngptlw, ng10
1350 : use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, &
1351 : selfrefo, forrefo, &
1352 : fracrefa, fracrefb, ka, kb, &
1353 : selfref, forref
1354 :
1355 : ! ------- Local -------
1356 : integer :: jt, jp, igc, ipr, iprsm
1357 : real(kind=r8) :: sumk, sumf1, sumf2
1358 :
1359 :
1360 6144 : do jt = 1,5
1361 72704 : do jp = 1,13
1362 66560 : iprsm = 0
1363 471040 : do igc = 1,ngc(10)
1364 399360 : sumk = 0.
1365 1464320 : do ipr = 1, ngn(ngs(9)+igc)
1366 1064960 : iprsm = iprsm + 1
1367 1464320 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
1368 : enddo
1369 465920 : ka(jt,jp,igc) = sumk
1370 : enddo
1371 : enddo
1372 : enddo
1373 :
1374 6144 : do jt = 1,5
1375 246784 : do jp = 13,59
1376 240640 : iprsm = 0
1377 1689600 : do igc = 1,ngc(10)
1378 1443840 : sumk = 0.
1379 5294080 : do ipr = 1, ngn(ngs(9)+igc)
1380 3850240 : iprsm = iprsm + 1
1381 5294080 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
1382 : enddo
1383 1684480 : kb(jt,jp,igc) = sumk
1384 : enddo
1385 : enddo
1386 : enddo
1387 :
1388 11264 : do jt = 1,10
1389 10240 : iprsm = 0
1390 72704 : do igc = 1,ngc(10)
1391 61440 : sumk = 0.
1392 225280 : do ipr = 1, ngn(ngs(9)+igc)
1393 163840 : iprsm = iprsm + 1
1394 225280 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
1395 : enddo
1396 71680 : selfref(jt,igc) = sumk
1397 : enddo
1398 : enddo
1399 :
1400 5120 : do jt = 1,4
1401 4096 : iprsm = 0
1402 29696 : do igc = 1,ngc(10)
1403 24576 : sumk = 0.
1404 90112 : do ipr = 1, ngn(ngs(9)+igc)
1405 65536 : iprsm = iprsm + 1
1406 90112 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
1407 : enddo
1408 28672 : forref(jt,igc) = sumk
1409 : enddo
1410 : enddo
1411 :
1412 1024 : iprsm = 0
1413 7168 : do igc = 1,ngc(10)
1414 6144 : sumf1= 0.
1415 6144 : sumf2= 0.
1416 22528 : do ipr = 1, ngn(ngs(9)+igc)
1417 16384 : iprsm = iprsm + 1
1418 16384 : sumf1= sumf1+ fracrefao(iprsm)
1419 22528 : sumf2= sumf2+ fracrefbo(iprsm)
1420 : enddo
1421 6144 : fracrefa(igc) = sumf1
1422 7168 : fracrefb(igc) = sumf2
1423 : enddo
1424 :
1425 1024 : end subroutine cmbgb10
1426 :
1427 : !***************************************************************************
1428 1024 : subroutine cmbgb11
1429 : !***************************************************************************
1430 : !
1431 : ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
1432 : ! (high key - h2o; high minor - o2)
1433 : !
1434 : ! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
1435 : ! (high key - h2o; high minor - o2)
1436 : !***************************************************************************
1437 :
1438 : use parrrtm, only : mg, nbndlw, ngptlw, ng11
1439 : use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, &
1440 : kbo, kbo_mo2, selfrefo, forrefo, &
1441 : fracrefa, fracrefb, ka, ka_mo2, &
1442 : kb, kb_mo2, selfref, forref
1443 :
1444 : ! ------- Local -------
1445 : integer :: jt, jp, igc, ipr, iprsm
1446 : real(kind=r8) :: sumk, sumk1, sumk2, sumf1, sumf2
1447 :
1448 :
1449 6144 : do jt = 1,5
1450 72704 : do jp = 1,13
1451 66560 : iprsm = 0
1452 604160 : do igc = 1,ngc(11)
1453 532480 : sumk = 0.
1454 1597440 : do ipr = 1, ngn(ngs(10)+igc)
1455 1064960 : iprsm = iprsm + 1
1456 1597440 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
1457 : enddo
1458 599040 : ka(jt,jp,igc) = sumk
1459 : enddo
1460 : enddo
1461 : enddo
1462 6144 : do jt = 1,5
1463 246784 : do jp = 13,59
1464 240640 : iprsm = 0
1465 2170880 : do igc = 1,ngc(11)
1466 1925120 : sumk = 0.
1467 5775360 : do ipr = 1, ngn(ngs(10)+igc)
1468 3850240 : iprsm = iprsm + 1
1469 5775360 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
1470 : enddo
1471 2165760 : kb(jt,jp,igc) = sumk
1472 : enddo
1473 : enddo
1474 : enddo
1475 :
1476 20480 : do jt = 1,19
1477 19456 : iprsm = 0
1478 176128 : do igc = 1,ngc(11)
1479 155648 : sumk1 = 0.
1480 155648 : sumk2 = 0.
1481 466944 : do ipr = 1, ngn(ngs(10)+igc)
1482 311296 : iprsm = iprsm + 1
1483 311296 : sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
1484 466944 : sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
1485 : enddo
1486 155648 : ka_mo2(jt,igc) = sumk1
1487 175104 : kb_mo2(jt,igc) = sumk2
1488 : enddo
1489 : enddo
1490 :
1491 11264 : do jt = 1,10
1492 10240 : iprsm = 0
1493 93184 : do igc = 1,ngc(11)
1494 81920 : sumk = 0.
1495 245760 : do ipr = 1, ngn(ngs(10)+igc)
1496 163840 : iprsm = iprsm + 1
1497 245760 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
1498 : enddo
1499 92160 : selfref(jt,igc) = sumk
1500 : enddo
1501 : enddo
1502 :
1503 5120 : do jt = 1,4
1504 4096 : iprsm = 0
1505 37888 : do igc = 1,ngc(11)
1506 32768 : sumk = 0.
1507 98304 : do ipr = 1, ngn(ngs(10)+igc)
1508 65536 : iprsm = iprsm + 1
1509 98304 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
1510 : enddo
1511 36864 : forref(jt,igc) = sumk
1512 : enddo
1513 : enddo
1514 :
1515 1024 : iprsm = 0
1516 9216 : do igc = 1,ngc(11)
1517 8192 : sumf1= 0.
1518 8192 : sumf2= 0.
1519 24576 : do ipr = 1, ngn(ngs(10)+igc)
1520 16384 : iprsm = iprsm + 1
1521 16384 : sumf1= sumf1+ fracrefao(iprsm)
1522 24576 : sumf2= sumf2+ fracrefbo(iprsm)
1523 : enddo
1524 8192 : fracrefa(igc) = sumf1
1525 9216 : fracrefb(igc) = sumf2
1526 : enddo
1527 :
1528 1024 : end subroutine cmbgb11
1529 :
1530 : !***************************************************************************
1531 1024 : subroutine cmbgb12
1532 : !***************************************************************************
1533 : !
1534 : ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1535 : !
1536 : ! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1537 : !***************************************************************************
1538 :
1539 : use parrrtm, only : mg, nbndlw, ngptlw, ng12
1540 : use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, &
1541 : fracrefa, ka, selfref, forref
1542 :
1543 : ! ------- Local -------
1544 : integer :: jn, jt, jp, igc, ipr, iprsm
1545 : real(kind=r8) :: sumk, sumf
1546 :
1547 :
1548 10240 : do jn = 1,9
1549 56320 : do jt = 1,5
1550 654336 : do jp = 1,13
1551 599040 : iprsm = 0
1552 5437440 : do igc = 1,ngc(12)
1553 4792320 : sumk = 0.
1554 14376960 : do ipr = 1, ngn(ngs(11)+igc)
1555 9584640 : iprsm = iprsm + 1
1556 14376960 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
1557 : enddo
1558 5391360 : ka(jn,jt,jp,igc) = sumk
1559 : enddo
1560 : enddo
1561 : enddo
1562 : enddo
1563 :
1564 11264 : do jt = 1,10
1565 10240 : iprsm = 0
1566 93184 : do igc = 1,ngc(12)
1567 81920 : sumk = 0.
1568 245760 : do ipr = 1, ngn(ngs(11)+igc)
1569 163840 : iprsm = iprsm + 1
1570 245760 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
1571 : enddo
1572 92160 : selfref(jt,igc) = sumk
1573 : enddo
1574 : enddo
1575 :
1576 5120 : do jt = 1,4
1577 4096 : iprsm = 0
1578 37888 : do igc = 1,ngc(12)
1579 32768 : sumk = 0.
1580 98304 : do ipr = 1, ngn(ngs(11)+igc)
1581 65536 : iprsm = iprsm + 1
1582 98304 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
1583 : enddo
1584 36864 : forref(jt,igc) = sumk
1585 : enddo
1586 : enddo
1587 :
1588 10240 : do jp = 1,9
1589 9216 : iprsm = 0
1590 83968 : do igc = 1,ngc(12)
1591 73728 : sumf = 0.
1592 221184 : do ipr = 1, ngn(ngs(11)+igc)
1593 147456 : iprsm = iprsm + 1
1594 221184 : sumf = sumf + fracrefao(iprsm,jp)
1595 : enddo
1596 82944 : fracrefa(igc,jp) = sumf
1597 : enddo
1598 : enddo
1599 :
1600 1024 : end subroutine cmbgb12
1601 :
1602 : !***************************************************************************
1603 1024 : subroutine cmbgb13
1604 : !***************************************************************************
1605 : !
1606 : ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
1607 : !
1608 : ! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1609 : !***************************************************************************
1610 :
1611 : use parrrtm, only : mg, nbndlw, ngptlw, ng13
1612 : use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
1613 : kbo_mo3, selfrefo, forrefo, &
1614 : fracrefa, fracrefb, ka, ka_mco2, ka_mco, &
1615 : kb_mo3, selfref, forref
1616 :
1617 : ! ------- Local -------
1618 : integer :: jn, jt, jp, igc, ipr, iprsm
1619 : real(kind=r8) :: sumk, sumk1, sumk2, sumf
1620 :
1621 :
1622 10240 : do jn = 1,9
1623 56320 : do jt = 1,5
1624 654336 : do jp = 1,13
1625 599040 : iprsm = 0
1626 3041280 : do igc = 1,ngc(13)
1627 2396160 : sumk = 0.
1628 11980800 : do ipr = 1, ngn(ngs(12)+igc)
1629 9584640 : iprsm = iprsm + 1
1630 11980800 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1631 : enddo
1632 2995200 : ka(jn,jt,jp,igc) = sumk
1633 : enddo
1634 : enddo
1635 : enddo
1636 : enddo
1637 :
1638 10240 : do jn = 1,9
1639 185344 : do jt = 1,19
1640 175104 : iprsm = 0
1641 884736 : do igc = 1,ngc(13)
1642 700416 : sumk1 = 0.
1643 700416 : sumk2 = 0.
1644 3502080 : do ipr = 1, ngn(ngs(12)+igc)
1645 2801664 : iprsm = iprsm + 1
1646 2801664 : sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
1647 3502080 : sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
1648 : enddo
1649 700416 : ka_mco2(jn,jt,igc) = sumk1
1650 875520 : ka_mco(jn,jt,igc) = sumk2
1651 : enddo
1652 : enddo
1653 : enddo
1654 :
1655 20480 : do jt = 1,19
1656 19456 : iprsm = 0
1657 98304 : do igc = 1,ngc(13)
1658 77824 : sumk = 0.
1659 389120 : do ipr = 1, ngn(ngs(12)+igc)
1660 311296 : iprsm = iprsm + 1
1661 389120 : sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
1662 : enddo
1663 97280 : kb_mo3(jt,igc) = sumk
1664 : enddo
1665 : enddo
1666 :
1667 11264 : do jt = 1,10
1668 10240 : iprsm = 0
1669 52224 : do igc = 1,ngc(13)
1670 40960 : sumk = 0.
1671 204800 : do ipr = 1, ngn(ngs(12)+igc)
1672 163840 : iprsm = iprsm + 1
1673 204800 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
1674 : enddo
1675 51200 : selfref(jt,igc) = sumk
1676 : enddo
1677 : enddo
1678 :
1679 5120 : do jt = 1,4
1680 4096 : iprsm = 0
1681 21504 : do igc = 1,ngc(13)
1682 16384 : sumk = 0.
1683 81920 : do ipr = 1, ngn(ngs(12)+igc)
1684 65536 : iprsm = iprsm + 1
1685 81920 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
1686 : enddo
1687 20480 : forref(jt,igc) = sumk
1688 : enddo
1689 : enddo
1690 :
1691 1024 : iprsm = 0
1692 5120 : do igc = 1,ngc(13)
1693 4096 : sumf = 0.
1694 20480 : do ipr = 1, ngn(ngs(12)+igc)
1695 16384 : iprsm = iprsm + 1
1696 20480 : sumf = sumf + fracrefbo(iprsm)
1697 : enddo
1698 5120 : fracrefb(igc) = sumf
1699 : enddo
1700 :
1701 10240 : do jp = 1,9
1702 9216 : iprsm = 0
1703 47104 : do igc = 1,ngc(13)
1704 36864 : sumf = 0.
1705 184320 : do ipr = 1, ngn(ngs(12)+igc)
1706 147456 : iprsm = iprsm + 1
1707 184320 : sumf = sumf + fracrefao(iprsm,jp)
1708 : enddo
1709 46080 : fracrefa(igc,jp) = sumf
1710 : enddo
1711 : enddo
1712 :
1713 1024 : end subroutine cmbgb13
1714 :
1715 : !***************************************************************************
1716 1024 : subroutine cmbgb14
1717 : !***************************************************************************
1718 : !
1719 : ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1720 : !
1721 : ! old band 14: 2250-2380 cm-1 (low - co2; high - co2)
1722 : !***************************************************************************
1723 :
1724 : use parrrtm, only : mg, nbndlw, ngptlw, ng14
1725 : use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, &
1726 : selfrefo, forrefo, &
1727 : fracrefa, fracrefb, ka, kb, &
1728 : selfref, forref
1729 :
1730 : ! ------- Local -------
1731 : integer :: jt, jp, igc, ipr, iprsm
1732 : real(kind=r8) :: sumk, sumf1, sumf2
1733 :
1734 :
1735 6144 : do jt = 1,5
1736 72704 : do jp = 1,13
1737 66560 : iprsm = 0
1738 204800 : do igc = 1,ngc(14)
1739 133120 : sumk = 0.
1740 1198080 : do ipr = 1, ngn(ngs(13)+igc)
1741 1064960 : iprsm = iprsm + 1
1742 1198080 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
1743 : enddo
1744 199680 : ka(jt,jp,igc) = sumk
1745 : enddo
1746 : enddo
1747 : enddo
1748 :
1749 6144 : do jt = 1,5
1750 246784 : do jp = 13,59
1751 240640 : iprsm = 0
1752 727040 : do igc = 1,ngc(14)
1753 481280 : sumk = 0.
1754 4331520 : do ipr = 1, ngn(ngs(13)+igc)
1755 3850240 : iprsm = iprsm + 1
1756 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
1757 : enddo
1758 721920 : kb(jt,jp,igc) = sumk
1759 : enddo
1760 : enddo
1761 : enddo
1762 :
1763 11264 : do jt = 1,10
1764 10240 : iprsm = 0
1765 31744 : do igc = 1,ngc(14)
1766 20480 : sumk = 0.
1767 184320 : do ipr = 1, ngn(ngs(13)+igc)
1768 163840 : iprsm = iprsm + 1
1769 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
1770 : enddo
1771 30720 : selfref(jt,igc) = sumk
1772 : enddo
1773 : enddo
1774 :
1775 5120 : do jt = 1,4
1776 4096 : iprsm = 0
1777 13312 : do igc = 1,ngc(14)
1778 8192 : sumk = 0.
1779 73728 : do ipr = 1, ngn(ngs(13)+igc)
1780 65536 : iprsm = iprsm + 1
1781 73728 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
1782 : enddo
1783 12288 : forref(jt,igc) = sumk
1784 : enddo
1785 : enddo
1786 :
1787 1024 : iprsm = 0
1788 3072 : do igc = 1,ngc(14)
1789 2048 : sumf1= 0.
1790 2048 : sumf2= 0.
1791 18432 : do ipr = 1, ngn(ngs(13)+igc)
1792 16384 : iprsm = iprsm + 1
1793 16384 : sumf1= sumf1+ fracrefao(iprsm)
1794 18432 : sumf2= sumf2+ fracrefbo(iprsm)
1795 : enddo
1796 2048 : fracrefa(igc) = sumf1
1797 3072 : fracrefb(igc) = sumf2
1798 : enddo
1799 :
1800 1024 : end subroutine cmbgb14
1801 :
1802 : !***************************************************************************
1803 1024 : subroutine cmbgb15
1804 : !***************************************************************************
1805 : !
1806 : ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
1807 : ! (high - nothing)
1808 : !
1809 : ! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1810 : !***************************************************************************
1811 :
1812 : use parrrtm, only : mg, nbndlw, ngptlw, ng15
1813 : use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
1814 : fracrefa, ka, ka_mn2, selfref, forref
1815 :
1816 : ! ------- Local -------
1817 : integer :: jn, jt, jp, igc, ipr, iprsm
1818 : real(kind=r8) :: sumk, sumf
1819 :
1820 :
1821 10240 : do jn = 1,9
1822 56320 : do jt = 1,5
1823 654336 : do jp = 1,13
1824 599040 : iprsm = 0
1825 1843200 : do igc = 1,ngc(15)
1826 1198080 : sumk = 0.
1827 10782720 : do ipr = 1, ngn(ngs(14)+igc)
1828 9584640 : iprsm = iprsm + 1
1829 10782720 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
1830 : enddo
1831 1797120 : ka(jn,jt,jp,igc) = sumk
1832 : enddo
1833 : enddo
1834 : enddo
1835 : enddo
1836 :
1837 10240 : do jn = 1,9
1838 185344 : do jt = 1,19
1839 175104 : iprsm = 0
1840 534528 : do igc = 1,ngc(15)
1841 350208 : sumk = 0.
1842 3151872 : do ipr = 1, ngn(ngs(14)+igc)
1843 2801664 : iprsm = iprsm + 1
1844 3151872 : sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
1845 : enddo
1846 525312 : ka_mn2(jn,jt,igc) = sumk
1847 : enddo
1848 : enddo
1849 : enddo
1850 :
1851 11264 : do jt = 1,10
1852 10240 : iprsm = 0
1853 31744 : do igc = 1,ngc(15)
1854 20480 : sumk = 0.
1855 184320 : do ipr = 1, ngn(ngs(14)+igc)
1856 163840 : iprsm = iprsm + 1
1857 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
1858 : enddo
1859 30720 : selfref(jt,igc) = sumk
1860 : enddo
1861 : enddo
1862 :
1863 5120 : do jt = 1,4
1864 4096 : iprsm = 0
1865 13312 : do igc = 1,ngc(15)
1866 8192 : sumk = 0.
1867 73728 : do ipr = 1, ngn(ngs(14)+igc)
1868 65536 : iprsm = iprsm + 1
1869 73728 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
1870 : enddo
1871 12288 : forref(jt,igc) = sumk
1872 : enddo
1873 : enddo
1874 :
1875 10240 : do jp = 1,9
1876 9216 : iprsm = 0
1877 28672 : do igc = 1,ngc(15)
1878 18432 : sumf = 0.
1879 165888 : do ipr = 1, ngn(ngs(14)+igc)
1880 147456 : iprsm = iprsm + 1
1881 165888 : sumf = sumf + fracrefao(iprsm,jp)
1882 : enddo
1883 27648 : fracrefa(igc,jp) = sumf
1884 : enddo
1885 : enddo
1886 :
1887 1024 : end subroutine cmbgb15
1888 :
1889 : !***************************************************************************
1890 1024 : subroutine cmbgb16
1891 : !***************************************************************************
1892 : !
1893 : ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
1894 : !
1895 : ! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1896 : !***************************************************************************
1897 :
1898 : use parrrtm, only : mg, nbndlw, ngptlw, ng16
1899 : use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
1900 : fracrefa, fracrefb, ka, kb, selfref, forref
1901 :
1902 : ! ------- Local -------
1903 : integer :: jn, jt, jp, igc, ipr, iprsm
1904 : real(kind=r8) :: sumk, sumf
1905 :
1906 :
1907 10240 : do jn = 1,9
1908 56320 : do jt = 1,5
1909 654336 : do jp = 1,13
1910 599040 : iprsm = 0
1911 1843200 : do igc = 1,ngc(16)
1912 1198080 : sumk = 0.
1913 10782720 : do ipr = 1, ngn(ngs(15)+igc)
1914 9584640 : iprsm = iprsm + 1
1915 10782720 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
1916 : enddo
1917 1797120 : ka(jn,jt,jp,igc) = sumk
1918 : enddo
1919 : enddo
1920 : enddo
1921 : enddo
1922 :
1923 6144 : do jt = 1,5
1924 246784 : do jp = 13,59
1925 240640 : iprsm = 0
1926 727040 : do igc = 1,ngc(16)
1927 481280 : sumk = 0.
1928 4331520 : do ipr = 1, ngn(ngs(15)+igc)
1929 3850240 : iprsm = iprsm + 1
1930 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
1931 : enddo
1932 721920 : kb(jt,jp,igc) = sumk
1933 : enddo
1934 : enddo
1935 : enddo
1936 :
1937 11264 : do jt = 1,10
1938 10240 : iprsm = 0
1939 31744 : do igc = 1,ngc(16)
1940 20480 : sumk = 0.
1941 184320 : do ipr = 1, ngn(ngs(15)+igc)
1942 163840 : iprsm = iprsm + 1
1943 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
1944 : enddo
1945 30720 : selfref(jt,igc) = sumk
1946 : enddo
1947 : enddo
1948 :
1949 5120 : do jt = 1,4
1950 4096 : iprsm = 0
1951 13312 : do igc = 1,ngc(16)
1952 8192 : sumk = 0.
1953 73728 : do ipr = 1, ngn(ngs(15)+igc)
1954 65536 : iprsm = iprsm + 1
1955 73728 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
1956 : enddo
1957 12288 : forref(jt,igc) = sumk
1958 : enddo
1959 : enddo
1960 :
1961 1024 : iprsm = 0
1962 3072 : do igc = 1,ngc(16)
1963 2048 : sumf = 0.
1964 18432 : do ipr = 1, ngn(ngs(15)+igc)
1965 16384 : iprsm = iprsm + 1
1966 18432 : sumf = sumf + fracrefbo(iprsm)
1967 : enddo
1968 3072 : fracrefb(igc) = sumf
1969 : enddo
1970 :
1971 10240 : do jp = 1,9
1972 9216 : iprsm = 0
1973 28672 : do igc = 1,ngc(16)
1974 18432 : sumf = 0.
1975 165888 : do ipr = 1, ngn(ngs(15)+igc)
1976 147456 : iprsm = iprsm + 1
1977 165888 : sumf = sumf + fracrefao(iprsm,jp)
1978 : enddo
1979 27648 : fracrefa(igc,jp) = sumf
1980 : enddo
1981 : enddo
1982 :
1983 1024 : end subroutine cmbgb16
1984 :
1985 : !***************************************************************************
1986 :
1987 : end module rrtmg_lw_init
1988 :
|
