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 1536 : 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 1536 : call lwdatinit
67 1536 : call lwcmbdat ! g-point interval reduction data
68 1536 : call lwatmref ! reference MLS profile
69 1536 : call lwavplank ! Planck function
70 1536 : call lw_kgb01 ! molecular absorption coefficients
71 1536 : call lw_kgb02
72 1536 : call lw_kgb03
73 1536 : call lw_kgb04
74 1536 : call lw_kgb05
75 1536 : call lw_kgb06
76 1536 : call lw_kgb07
77 1536 : call lw_kgb08
78 1536 : call lw_kgb09
79 1536 : call lw_kgb10
80 1536 : call lw_kgb11
81 1536 : call lw_kgb12
82 1536 : call lw_kgb13
83 1536 : call lw_kgb14
84 1536 : call lw_kgb15
85 1536 : 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 1536 : tau_tbl(0) = 0.0_r8
97 1536 : tau_tbl(ntbl) = 1.e10_r8
98 1536 : exp_tbl(0) = 1.0_r8
99 1536 : exp_tbl(ntbl) = 0.0_r8
100 1536 : tfn_tbl(0) = 0.0_r8
101 1536 : tfn_tbl(ntbl) = 1.0_r8
102 1536 : bpade = 1.0_r8 / pade
103 15360000 : do itr = 1, ntbl-1
104 15358464 : tfn = float(itr) / float(ntbl)
105 15358464 : tau_tbl(itr) = bpade * tfn / (1._r8 - tfn)
106 15358464 : exp_tbl(itr) = exp(-tau_tbl(itr))
107 15360000 : if (tau_tbl(itr) .lt. 0.06_r8) then
108 251904 : tfn_tbl(itr) = tau_tbl(itr)/6._r8
109 : else
110 15106560 : 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 : igcsm = 0
120 26112 : do ibnd = 1,nbndlw
121 24576 : iprsm = 0
122 26112 : if (ngc(ibnd).lt.mg) then
123 187392 : do igc = 1,ngc(ibnd)
124 165888 : igcsm = igcsm + 1
125 165888 : wtsum = 0._r8
126 509952 : do ipr = 1, ngn(igcsm)
127 344064 : iprsm = iprsm + 1
128 509952 : wtsum = wtsum + wt(iprsm)
129 : enddo
130 187392 : wtsm(igc) = wtsum
131 : enddo
132 365568 : do ig = 1, ng(ibnd)
133 344064 : ind = (ibnd-1)*mg + ig
134 365568 : rwgt(ind) = wt(ig)/wtsm(ngm(ind))
135 : enddo
136 : else
137 52224 : do ig = 1, ng(ibnd)
138 49152 : igcsm = igcsm + 1
139 49152 : ind = (ibnd-1)*mg + ig
140 52224 : 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 1536 : call cmbgb1
148 1536 : call cmbgb2
149 1536 : call cmbgb3
150 1536 : call cmbgb4
151 1536 : call cmbgb5
152 1536 : call cmbgb6
153 1536 : call cmbgb7
154 1536 : call cmbgb8
155 1536 : call cmbgb9
156 1536 : call cmbgb10
157 1536 : call cmbgb11
158 1536 : call cmbgb12
159 1536 : call cmbgb13
160 1536 : call cmbgb14
161 1536 : call cmbgb15
162 1536 : call cmbgb16
163 :
164 1536 : end subroutine rrtmg_lw_ini
165 :
166 : !***************************************************************************
167 1536 : 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 1536 : 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 1536 : 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 1536 : 170._r8, 130._r8, 220._r8, 650._r8/)
190 :
191 : ! Spectral band information
192 1536 : ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
193 1536 : nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
194 1536 : 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 1536 : grav = gravit
198 1536 : 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 1536 : 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 1536 : nxmol = 4
223 1536 : ixindx(1) = 1
224 1536 : ixindx(2) = 2
225 1536 : ixindx(3) = 3
226 1536 : ixindx(4) = 4
227 53760 : ixindx(5:maxinpx) = 0
228 :
229 : ! Constants from NIST 01/11/2002
230 :
231 : ! grav = 9.8066_r8
232 1536 : planck = 6.62606876e-27_r8
233 1536 : boltz = 1.3806503e-16_r8
234 1536 : clight = 2.99792458e+10_r8
235 : ! avogad = 6.02214199e+23_r8
236 1536 : alosmt = 2.6867775e+19_r8
237 1536 : gascon = 8.31447200e+07_r8
238 1536 : radcn1 = 1.191042722e-12_r8
239 1536 : 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 1536 : end subroutine lwdatinit
250 :
251 : !***************************************************************************
252 1536 : 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 1536 : ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
275 1536 : 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 1536 : 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 1536 : 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 1536 : 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 1536 : 0.0000750000_r8/)
330 :
331 1536 : end subroutine lwcmbdat
332 :
333 : !***************************************************************************
334 1536 : 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 9216 : do jt = 1,5
367 107520 : do jp = 1,13
368 99840 : iprsm = 0
369 1105920 : do igc = 1,ngc(1)
370 998400 : sumk = 0.
371 2595840 : do ipr = 1, ngn(igc)
372 1597440 : iprsm = iprsm + 1
373 2595840 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
374 : enddo
375 1098240 : ka(jt,jp,igc) = sumk
376 : enddo
377 : enddo
378 370176 : do jp = 13,59
379 360960 : iprsm = 0
380 3978240 : do igc = 1,ngc(1)
381 3609600 : sumk = 0.
382 9384960 : do ipr = 1, ngn(igc)
383 5775360 : iprsm = iprsm + 1
384 9384960 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
385 : enddo
386 3970560 : kb(jt,jp,igc) = sumk
387 : enddo
388 : enddo
389 : enddo
390 :
391 16896 : do jt = 1,10
392 15360 : iprsm = 0
393 170496 : do igc = 1,ngc(1)
394 153600 : sumk = 0.
395 399360 : do ipr = 1, ngn(igc)
396 245760 : iprsm = iprsm + 1
397 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
398 : enddo
399 168960 : selfref(jt,igc) = sumk
400 : enddo
401 : enddo
402 :
403 7680 : do jt = 1,4
404 6144 : iprsm = 0
405 69120 : do igc = 1,ngc(1)
406 61440 : sumk = 0.
407 159744 : do ipr = 1, ngn(igc)
408 98304 : iprsm = iprsm + 1
409 159744 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
410 : enddo
411 67584 : forref(jt,igc) = sumk
412 : enddo
413 : enddo
414 :
415 30720 : do jt = 1,19
416 29184 : iprsm = 0
417 322560 : do igc = 1,ngc(1)
418 291840 : sumk1 = 0.
419 291840 : sumk2 = 0.
420 758784 : do ipr = 1, ngn(igc)
421 466944 : iprsm = iprsm + 1
422 466944 : sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
423 758784 : sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
424 : enddo
425 291840 : ka_mn2(jt,igc) = sumk1
426 321024 : kb_mn2(jt,igc) = sumk2
427 : enddo
428 : enddo
429 :
430 1536 : iprsm = 0
431 16896 : do igc = 1,ngc(1)
432 15360 : sumf1 = 0.
433 15360 : sumf2 = 0.
434 39936 : do ipr = 1, ngn(igc)
435 24576 : iprsm = iprsm + 1
436 24576 : sumf1= sumf1+ fracrefao(iprsm)
437 39936 : sumf2= sumf2+ fracrefbo(iprsm)
438 : enddo
439 15360 : fracrefa(igc) = sumf1
440 16896 : fracrefb(igc) = sumf2
441 : enddo
442 :
443 1536 : end subroutine cmbgb1
444 :
445 : !***************************************************************************
446 1536 : 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 9216 : do jt = 1,5
465 107520 : do jp = 1,13
466 99840 : iprsm = 0
467 1305600 : do igc = 1,ngc(2)
468 1198080 : sumk = 0.
469 2795520 : do ipr = 1, ngn(ngs(1)+igc)
470 1597440 : iprsm = iprsm + 1
471 2795520 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
472 : enddo
473 1297920 : ka(jt,jp,igc) = sumk
474 : enddo
475 : enddo
476 370176 : do jp = 13,59
477 360960 : iprsm = 0
478 4700160 : do igc = 1,ngc(2)
479 4331520 : sumk = 0.
480 10106880 : do ipr = 1, ngn(ngs(1)+igc)
481 5775360 : iprsm = iprsm + 1
482 10106880 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
483 : enddo
484 4692480 : kb(jt,jp,igc) = sumk
485 : enddo
486 : enddo
487 : enddo
488 :
489 16896 : do jt = 1,10
490 15360 : iprsm = 0
491 201216 : do igc = 1,ngc(2)
492 184320 : sumk = 0.
493 430080 : do ipr = 1, ngn(ngs(1)+igc)
494 245760 : iprsm = iprsm + 1
495 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
496 : enddo
497 199680 : selfref(jt,igc) = sumk
498 : enddo
499 : enddo
500 :
501 7680 : do jt = 1,4
502 6144 : iprsm = 0
503 81408 : do igc = 1,ngc(2)
504 73728 : sumk = 0.
505 172032 : do ipr = 1, ngn(ngs(1)+igc)
506 98304 : iprsm = iprsm + 1
507 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
508 : enddo
509 79872 : forref(jt,igc) = sumk
510 : enddo
511 : enddo
512 :
513 1536 : iprsm = 0
514 19968 : do igc = 1,ngc(2)
515 18432 : sumf1 = 0.
516 18432 : sumf2 = 0.
517 43008 : do ipr = 1, ngn(ngs(1)+igc)
518 24576 : iprsm = iprsm + 1
519 24576 : sumf1= sumf1+ fracrefao(iprsm)
520 43008 : sumf2= sumf2+ fracrefbo(iprsm)
521 : enddo
522 18432 : fracrefa(igc) = sumf1
523 19968 : fracrefb(igc) = sumf2
524 : enddo
525 :
526 1536 : end subroutine cmbgb2
527 :
528 : !***************************************************************************
529 1536 : 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 15360 : do jn = 1,9
550 84480 : do jt = 1,5
551 981504 : do jp = 1,13
552 898560 : iprsm = 0
553 15344640 : do igc = 1,ngc(3)
554 14376960 : sumk = 0.
555 28753920 : do ipr = 1, ngn(ngs(2)+igc)
556 14376960 : iprsm = iprsm + 1
557 28753920 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
558 : enddo
559 15275520 : ka(jn,jt,jp,igc) = sumk
560 : enddo
561 : enddo
562 : enddo
563 : enddo
564 9216 : do jn = 1,5
565 47616 : do jt = 1,5
566 1850880 : do jp = 13,59
567 1804800 : iprsm = 0
568 30720000 : do igc = 1,ngc(3)
569 28876800 : sumk = 0.
570 57753600 : do ipr = 1, ngn(ngs(2)+igc)
571 28876800 : iprsm = iprsm + 1
572 57753600 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
573 : enddo
574 30681600 : kb(jn,jt,jp,igc) = sumk
575 : enddo
576 : enddo
577 : enddo
578 : enddo
579 :
580 15360 : do jn = 1,9
581 278016 : do jt = 1,19
582 262656 : iprsm = 0
583 4478976 : do igc = 1,ngc(3)
584 4202496 : sumk = 0.
585 8404992 : do ipr = 1, ngn(ngs(2)+igc)
586 4202496 : iprsm = iprsm + 1
587 8404992 : sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
588 : enddo
589 4465152 : ka_mn2o(jn,jt,igc) = sumk
590 : enddo
591 : enddo
592 : enddo
593 :
594 9216 : do jn = 1,5
595 155136 : do jt = 1,19
596 145920 : iprsm = 0
597 2488320 : do igc = 1,ngc(3)
598 2334720 : sumk = 0.
599 4669440 : do ipr = 1, ngn(ngs(2)+igc)
600 2334720 : iprsm = iprsm + 1
601 4669440 : sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
602 : enddo
603 2480640 : kb_mn2o(jn,jt,igc) = sumk
604 : enddo
605 : enddo
606 : enddo
607 :
608 16896 : do jt = 1,10
609 15360 : iprsm = 0
610 262656 : do igc = 1,ngc(3)
611 245760 : sumk = 0.
612 491520 : do ipr = 1, ngn(ngs(2)+igc)
613 245760 : iprsm = iprsm + 1
614 491520 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
615 : enddo
616 261120 : selfref(jt,igc) = sumk
617 : enddo
618 : enddo
619 :
620 7680 : do jt = 1,4
621 6144 : iprsm = 0
622 105984 : do igc = 1,ngc(3)
623 98304 : sumk = 0.
624 196608 : do ipr = 1, ngn(ngs(2)+igc)
625 98304 : iprsm = iprsm + 1
626 196608 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
627 : enddo
628 104448 : forref(jt,igc) = sumk
629 : enddo
630 : enddo
631 :
632 15360 : do jp = 1,9
633 13824 : iprsm = 0
634 236544 : do igc = 1,ngc(3)
635 221184 : sumf = 0.
636 442368 : do ipr = 1, ngn(ngs(2)+igc)
637 221184 : iprsm = iprsm + 1
638 442368 : sumf = sumf + fracrefao(iprsm,jp)
639 : enddo
640 235008 : fracrefa(igc,jp) = sumf
641 : enddo
642 : enddo
643 :
644 9216 : do jp = 1,5
645 7680 : iprsm = 0
646 132096 : do igc = 1,ngc(3)
647 122880 : sumf = 0.
648 245760 : do ipr = 1, ngn(ngs(2)+igc)
649 122880 : iprsm = iprsm + 1
650 245760 : sumf = sumf + fracrefbo(iprsm,jp)
651 : enddo
652 130560 : fracrefb(igc,jp) = sumf
653 : enddo
654 : enddo
655 :
656 1536 : end subroutine cmbgb3
657 :
658 : !***************************************************************************
659 1536 : 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 15360 : do jn = 1,9
677 84480 : do jt = 1,5
678 981504 : do jp = 1,13
679 898560 : iprsm = 0
680 13547520 : do igc = 1,ngc(4)
681 12579840 : sumk = 0.
682 26956800 : do ipr = 1, ngn(ngs(3)+igc)
683 14376960 : iprsm = iprsm + 1
684 26956800 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
685 : enddo
686 13478400 : ka(jn,jt,jp,igc) = sumk
687 : enddo
688 : enddo
689 : enddo
690 : enddo
691 9216 : do jn = 1,5
692 47616 : do jt = 1,5
693 1850880 : do jp = 13,59
694 1804800 : iprsm = 0
695 27110400 : do igc = 1,ngc(4)
696 25267200 : sumk = 0.
697 54144000 : do ipr = 1, ngn(ngs(3)+igc)
698 28876800 : iprsm = iprsm + 1
699 54144000 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
700 : enddo
701 27072000 : kb(jn,jt,jp,igc) = sumk
702 : enddo
703 : enddo
704 : enddo
705 : enddo
706 :
707 16896 : do jt = 1,10
708 15360 : iprsm = 0
709 231936 : do igc = 1,ngc(4)
710 215040 : sumk = 0.
711 460800 : do ipr = 1, ngn(ngs(3)+igc)
712 245760 : iprsm = iprsm + 1
713 460800 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
714 : enddo
715 230400 : selfref(jt,igc) = sumk
716 : enddo
717 : enddo
718 :
719 7680 : do jt = 1,4
720 6144 : iprsm = 0
721 93696 : do igc = 1,ngc(4)
722 86016 : sumk = 0.
723 184320 : do ipr = 1, ngn(ngs(3)+igc)
724 98304 : iprsm = iprsm + 1
725 184320 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
726 : enddo
727 92160 : forref(jt,igc) = sumk
728 : enddo
729 : enddo
730 :
731 15360 : do jp = 1,9
732 13824 : iprsm = 0
733 208896 : do igc = 1,ngc(4)
734 193536 : sumf = 0.
735 414720 : do ipr = 1, ngn(ngs(3)+igc)
736 221184 : iprsm = iprsm + 1
737 414720 : sumf = sumf + fracrefao(iprsm,jp)
738 : enddo
739 207360 : fracrefa(igc,jp) = sumf
740 : enddo
741 : enddo
742 :
743 9216 : do jp = 1,5
744 7680 : iprsm = 0
745 116736 : do igc = 1,ngc(4)
746 107520 : sumf = 0.
747 230400 : do ipr = 1, ngn(ngs(3)+igc)
748 122880 : iprsm = iprsm + 1
749 230400 : sumf = sumf + fracrefbo(iprsm,jp)
750 : enddo
751 115200 : fracrefb(igc,jp) = sumf
752 : enddo
753 : enddo
754 :
755 1536 : end subroutine cmbgb4
756 :
757 : !***************************************************************************
758 1536 : 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 15360 : do jn = 1,9
779 84480 : do jt = 1,5
780 981504 : do jp = 1,13
781 898560 : iprsm = 0
782 15344640 : do igc = 1,ngc(5)
783 14376960 : sumk = 0.
784 28753920 : do ipr = 1, ngn(ngs(4)+igc)
785 14376960 : iprsm = iprsm + 1
786 28753920 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
787 : enddo
788 15275520 : ka(jn,jt,jp,igc) = sumk
789 : enddo
790 : enddo
791 : enddo
792 : enddo
793 9216 : do jn = 1,5
794 47616 : do jt = 1,5
795 1850880 : do jp = 13,59
796 1804800 : iprsm = 0
797 30720000 : do igc = 1,ngc(5)
798 28876800 : sumk = 0.
799 57753600 : do ipr = 1, ngn(ngs(4)+igc)
800 28876800 : iprsm = iprsm + 1
801 57753600 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
802 : enddo
803 30681600 : kb(jn,jt,jp,igc) = sumk
804 : enddo
805 : enddo
806 : enddo
807 : enddo
808 :
809 15360 : do jn = 1,9
810 278016 : do jt = 1,19
811 262656 : iprsm = 0
812 4478976 : do igc = 1,ngc(5)
813 4202496 : sumk = 0.
814 8404992 : do ipr = 1, ngn(ngs(4)+igc)
815 4202496 : iprsm = iprsm + 1
816 8404992 : sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
817 : enddo
818 4465152 : ka_mo3(jn,jt,igc) = sumk
819 : enddo
820 : enddo
821 : enddo
822 :
823 16896 : do jt = 1,10
824 15360 : iprsm = 0
825 262656 : do igc = 1,ngc(5)
826 245760 : sumk = 0.
827 491520 : do ipr = 1, ngn(ngs(4)+igc)
828 245760 : iprsm = iprsm + 1
829 491520 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
830 : enddo
831 261120 : selfref(jt,igc) = sumk
832 : enddo
833 : enddo
834 :
835 7680 : do jt = 1,4
836 6144 : iprsm = 0
837 105984 : do igc = 1,ngc(5)
838 98304 : sumk = 0.
839 196608 : do ipr = 1, ngn(ngs(4)+igc)
840 98304 : iprsm = iprsm + 1
841 196608 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
842 : enddo
843 104448 : forref(jt,igc) = sumk
844 : enddo
845 : enddo
846 :
847 15360 : do jp = 1,9
848 13824 : iprsm = 0
849 236544 : do igc = 1,ngc(5)
850 221184 : sumf = 0.
851 442368 : do ipr = 1, ngn(ngs(4)+igc)
852 221184 : iprsm = iprsm + 1
853 442368 : sumf = sumf + fracrefao(iprsm,jp)
854 : enddo
855 235008 : fracrefa(igc,jp) = sumf
856 : enddo
857 : enddo
858 :
859 9216 : do jp = 1,5
860 7680 : iprsm = 0
861 132096 : do igc = 1,ngc(5)
862 122880 : sumf = 0.
863 245760 : do ipr = 1, ngn(ngs(4)+igc)
864 122880 : iprsm = iprsm + 1
865 245760 : sumf = sumf + fracrefbo(iprsm,jp)
866 : enddo
867 130560 : fracrefb(igc,jp) = sumf
868 : enddo
869 : enddo
870 :
871 1536 : iprsm = 0
872 26112 : do igc = 1,ngc(5)
873 24576 : sumk = 0.
874 49152 : do ipr = 1, ngn(ngs(4)+igc)
875 24576 : iprsm = iprsm + 1
876 49152 : sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
877 : enddo
878 26112 : ccl4(igc) = sumk
879 : enddo
880 :
881 1536 : end subroutine cmbgb5
882 :
883 : !***************************************************************************
884 1536 : 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 9216 : do jt = 1,5
905 109056 : do jp = 1,13
906 99840 : iprsm = 0
907 906240 : do igc = 1,ngc(6)
908 798720 : sumk = 0.
909 2396160 : do ipr = 1, ngn(ngs(5)+igc)
910 1597440 : iprsm = iprsm + 1
911 2396160 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
912 : enddo
913 898560 : ka(jt,jp,igc) = sumk
914 : enddo
915 : enddo
916 : enddo
917 :
918 30720 : do jt = 1,19
919 29184 : iprsm = 0
920 264192 : do igc = 1,ngc(6)
921 233472 : sumk = 0.
922 700416 : do ipr = 1, ngn(ngs(5)+igc)
923 466944 : iprsm = iprsm + 1
924 700416 : sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
925 : enddo
926 262656 : ka_mco2(jt,igc) = sumk
927 : enddo
928 : enddo
929 :
930 16896 : do jt = 1,10
931 15360 : iprsm = 0
932 139776 : do igc = 1,ngc(6)
933 122880 : sumk = 0.
934 368640 : do ipr = 1, ngn(ngs(5)+igc)
935 245760 : iprsm = iprsm + 1
936 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
937 : enddo
938 138240 : selfref(jt,igc) = sumk
939 : enddo
940 : enddo
941 :
942 7680 : do jt = 1,4
943 6144 : iprsm = 0
944 56832 : do igc = 1,ngc(6)
945 49152 : sumk = 0.
946 147456 : do ipr = 1, ngn(ngs(5)+igc)
947 98304 : iprsm = iprsm + 1
948 147456 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
949 : enddo
950 55296 : forref(jt,igc) = sumk
951 : enddo
952 : enddo
953 :
954 1536 : iprsm = 0
955 13824 : do igc = 1,ngc(6)
956 12288 : sumf = 0.
957 12288 : sumk1= 0.
958 12288 : sumk2= 0.
959 36864 : do ipr = 1, ngn(ngs(5)+igc)
960 24576 : iprsm = iprsm + 1
961 24576 : sumf = sumf + fracrefao(iprsm)
962 24576 : sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
963 36864 : sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
964 : enddo
965 12288 : fracrefa(igc) = sumf
966 12288 : cfc11adj(igc) = sumk1
967 13824 : cfc12(igc) = sumk2
968 : enddo
969 :
970 1536 : end subroutine cmbgb6
971 :
972 : !***************************************************************************
973 1536 : 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 15360 : do jn = 1,9
994 84480 : do jt = 1,5
995 981504 : do jp = 1,13
996 898560 : iprsm = 0
997 11750400 : do igc = 1,ngc(7)
998 10782720 : sumk = 0.
999 25159680 : do ipr = 1, ngn(ngs(6)+igc)
1000 14376960 : iprsm = iprsm + 1
1001 25159680 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
1002 : enddo
1003 11681280 : ka(jn,jt,jp,igc) = sumk
1004 : enddo
1005 : enddo
1006 : enddo
1007 : enddo
1008 9216 : do jt = 1,5
1009 370176 : do jp = 13,59
1010 360960 : iprsm = 0
1011 4700160 : do igc = 1,ngc(7)
1012 4331520 : sumk = 0.
1013 10106880 : do ipr = 1, ngn(ngs(6)+igc)
1014 5775360 : iprsm = iprsm + 1
1015 10106880 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
1016 : enddo
1017 4692480 : kb(jt,jp,igc) = sumk
1018 : enddo
1019 : enddo
1020 : enddo
1021 :
1022 15360 : do jn = 1,9
1023 278016 : do jt = 1,19
1024 262656 : iprsm = 0
1025 3428352 : do igc = 1,ngc(7)
1026 3151872 : sumk = 0.
1027 7354368 : do ipr = 1, ngn(ngs(6)+igc)
1028 4202496 : iprsm = iprsm + 1
1029 7354368 : sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
1030 : enddo
1031 3414528 : ka_mco2(jn,jt,igc) = sumk
1032 : enddo
1033 : enddo
1034 : enddo
1035 :
1036 30720 : do jt = 1,19
1037 29184 : iprsm = 0
1038 380928 : do igc = 1,ngc(7)
1039 350208 : sumk = 0.
1040 817152 : do ipr = 1, ngn(ngs(6)+igc)
1041 466944 : iprsm = iprsm + 1
1042 817152 : sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
1043 : enddo
1044 379392 : kb_mco2(jt,igc) = sumk
1045 : enddo
1046 : enddo
1047 :
1048 16896 : do jt = 1,10
1049 15360 : iprsm = 0
1050 201216 : do igc = 1,ngc(7)
1051 184320 : sumk = 0.
1052 430080 : do ipr = 1, ngn(ngs(6)+igc)
1053 245760 : iprsm = iprsm + 1
1054 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
1055 : enddo
1056 199680 : selfref(jt,igc) = sumk
1057 : enddo
1058 : enddo
1059 :
1060 7680 : do jt = 1,4
1061 6144 : iprsm = 0
1062 81408 : do igc = 1,ngc(7)
1063 73728 : sumk = 0.
1064 172032 : do ipr = 1, ngn(ngs(6)+igc)
1065 98304 : iprsm = iprsm + 1
1066 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
1067 : enddo
1068 79872 : forref(jt,igc) = sumk
1069 : enddo
1070 : enddo
1071 :
1072 15360 : do jp = 1,9
1073 13824 : iprsm = 0
1074 181248 : do igc = 1,ngc(7)
1075 165888 : sumf = 0.
1076 387072 : do ipr = 1, ngn(ngs(6)+igc)
1077 221184 : iprsm = iprsm + 1
1078 387072 : sumf = sumf + fracrefao(iprsm,jp)
1079 : enddo
1080 179712 : fracrefa(igc,jp) = sumf
1081 : enddo
1082 : enddo
1083 :
1084 1536 : iprsm = 0
1085 19968 : do igc = 1,ngc(7)
1086 18432 : sumf = 0.
1087 43008 : do ipr = 1, ngn(ngs(6)+igc)
1088 24576 : iprsm = iprsm + 1
1089 43008 : sumf = sumf + fracrefbo(iprsm)
1090 : enddo
1091 19968 : fracrefb(igc) = sumf
1092 : enddo
1093 :
1094 1536 : end subroutine cmbgb7
1095 :
1096 : !***************************************************************************
1097 1536 : 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 9216 : do jt = 1,5
1120 109056 : do jp = 1,13
1121 99840 : iprsm = 0
1122 906240 : do igc = 1,ngc(8)
1123 798720 : sumk = 0.
1124 2396160 : do ipr = 1, ngn(ngs(7)+igc)
1125 1597440 : iprsm = iprsm + 1
1126 2396160 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
1127 : enddo
1128 898560 : ka(jt,jp,igc) = sumk
1129 : enddo
1130 : enddo
1131 : enddo
1132 9216 : do jt = 1,5
1133 370176 : do jp = 13,59
1134 360960 : iprsm = 0
1135 3256320 : do igc = 1,ngc(8)
1136 2887680 : sumk = 0.
1137 8663040 : do ipr = 1, ngn(ngs(7)+igc)
1138 5775360 : iprsm = iprsm + 1
1139 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
1140 : enddo
1141 3248640 : kb(jt,jp,igc) = sumk
1142 : enddo
1143 : enddo
1144 : enddo
1145 :
1146 16896 : do jt = 1,10
1147 15360 : iprsm = 0
1148 139776 : do igc = 1,ngc(8)
1149 122880 : sumk = 0.
1150 368640 : do ipr = 1, ngn(ngs(7)+igc)
1151 245760 : iprsm = iprsm + 1
1152 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
1153 : enddo
1154 138240 : selfref(jt,igc) = sumk
1155 : enddo
1156 : enddo
1157 :
1158 7680 : do jt = 1,4
1159 6144 : iprsm = 0
1160 56832 : do igc = 1,ngc(8)
1161 49152 : sumk = 0.
1162 147456 : do ipr = 1, ngn(ngs(7)+igc)
1163 98304 : iprsm = iprsm + 1
1164 147456 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
1165 : enddo
1166 55296 : forref(jt,igc) = sumk
1167 : enddo
1168 : enddo
1169 :
1170 30720 : do jt = 1,19
1171 29184 : iprsm = 0
1172 264192 : do igc = 1,ngc(8)
1173 233472 : sumk1 = 0.
1174 233472 : sumk2 = 0.
1175 233472 : sumk3 = 0.
1176 233472 : sumk4 = 0.
1177 233472 : sumk5 = 0.
1178 700416 : do ipr = 1, ngn(ngs(7)+igc)
1179 466944 : iprsm = iprsm + 1
1180 466944 : sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
1181 466944 : sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
1182 466944 : sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
1183 466944 : sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
1184 700416 : sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
1185 : enddo
1186 233472 : ka_mco2(jt,igc) = sumk1
1187 233472 : kb_mco2(jt,igc) = sumk2
1188 233472 : ka_mo3(jt,igc) = sumk3
1189 233472 : ka_mn2o(jt,igc) = sumk4
1190 262656 : kb_mn2o(jt,igc) = sumk5
1191 : enddo
1192 : enddo
1193 :
1194 1536 : iprsm = 0
1195 13824 : do igc = 1,ngc(8)
1196 12288 : sumf1= 0.
1197 12288 : sumf2= 0.
1198 12288 : sumk1= 0.
1199 12288 : sumk2= 0.
1200 36864 : do ipr = 1, ngn(ngs(7)+igc)
1201 24576 : iprsm = iprsm + 1
1202 24576 : sumf1= sumf1+ fracrefao(iprsm)
1203 24576 : sumf2= sumf2+ fracrefbo(iprsm)
1204 24576 : sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
1205 36864 : sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
1206 : enddo
1207 12288 : fracrefa(igc) = sumf1
1208 12288 : fracrefb(igc) = sumf2
1209 12288 : cfc12(igc) = sumk1
1210 13824 : cfc22adj(igc) = sumk2
1211 : enddo
1212 :
1213 1536 : end subroutine cmbgb8
1214 :
1215 : !***************************************************************************
1216 1536 : 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 15360 : do jn = 1,9
1237 84480 : do jt = 1,5
1238 981504 : do jp = 1,13
1239 898560 : iprsm = 0
1240 11750400 : do igc = 1,ngc(9)
1241 10782720 : sumk = 0.
1242 25159680 : do ipr = 1, ngn(ngs(8)+igc)
1243 14376960 : iprsm = iprsm + 1
1244 25159680 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
1245 : enddo
1246 11681280 : ka(jn,jt,jp,igc) = sumk
1247 : enddo
1248 : enddo
1249 : enddo
1250 : enddo
1251 :
1252 9216 : do jt = 1,5
1253 370176 : do jp = 13,59
1254 360960 : iprsm = 0
1255 4700160 : do igc = 1,ngc(9)
1256 4331520 : sumk = 0.
1257 10106880 : do ipr = 1, ngn(ngs(8)+igc)
1258 5775360 : iprsm = iprsm + 1
1259 10106880 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
1260 : enddo
1261 4692480 : kb(jt,jp,igc) = sumk
1262 : enddo
1263 : enddo
1264 : enddo
1265 :
1266 15360 : do jn = 1,9
1267 278016 : do jt = 1,19
1268 262656 : iprsm = 0
1269 3428352 : do igc = 1,ngc(9)
1270 3151872 : sumk = 0.
1271 7354368 : do ipr = 1, ngn(ngs(8)+igc)
1272 4202496 : iprsm = iprsm + 1
1273 7354368 : sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
1274 : enddo
1275 3414528 : ka_mn2o(jn,jt,igc) = sumk
1276 : enddo
1277 : enddo
1278 : enddo
1279 :
1280 30720 : do jt = 1,19
1281 29184 : iprsm = 0
1282 380928 : do igc = 1,ngc(9)
1283 350208 : sumk = 0.
1284 817152 : do ipr = 1, ngn(ngs(8)+igc)
1285 466944 : iprsm = iprsm + 1
1286 817152 : sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
1287 : enddo
1288 379392 : kb_mn2o(jt,igc) = sumk
1289 : enddo
1290 : enddo
1291 :
1292 16896 : do jt = 1,10
1293 15360 : iprsm = 0
1294 201216 : do igc = 1,ngc(9)
1295 184320 : sumk = 0.
1296 430080 : do ipr = 1, ngn(ngs(8)+igc)
1297 245760 : iprsm = iprsm + 1
1298 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
1299 : enddo
1300 199680 : selfref(jt,igc) = sumk
1301 : enddo
1302 : enddo
1303 :
1304 7680 : do jt = 1,4
1305 6144 : iprsm = 0
1306 81408 : do igc = 1,ngc(9)
1307 73728 : sumk = 0.
1308 172032 : do ipr = 1, ngn(ngs(8)+igc)
1309 98304 : iprsm = iprsm + 1
1310 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
1311 : enddo
1312 79872 : forref(jt,igc) = sumk
1313 : enddo
1314 : enddo
1315 :
1316 15360 : do jp = 1,9
1317 13824 : iprsm = 0
1318 181248 : do igc = 1,ngc(9)
1319 165888 : sumf = 0.
1320 387072 : do ipr = 1, ngn(ngs(8)+igc)
1321 221184 : iprsm = iprsm + 1
1322 387072 : sumf = sumf + fracrefao(iprsm,jp)
1323 : enddo
1324 179712 : fracrefa(igc,jp) = sumf
1325 : enddo
1326 : enddo
1327 :
1328 1536 : iprsm = 0
1329 19968 : do igc = 1,ngc(9)
1330 18432 : sumf = 0.
1331 43008 : do ipr = 1, ngn(ngs(8)+igc)
1332 24576 : iprsm = iprsm + 1
1333 43008 : sumf = sumf + fracrefbo(iprsm)
1334 : enddo
1335 19968 : fracrefb(igc) = sumf
1336 : enddo
1337 :
1338 1536 : end subroutine cmbgb9
1339 :
1340 : !***************************************************************************
1341 1536 : 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 9216 : do jt = 1,5
1361 109056 : do jp = 1,13
1362 99840 : iprsm = 0
1363 706560 : do igc = 1,ngc(10)
1364 599040 : sumk = 0.
1365 2196480 : do ipr = 1, ngn(ngs(9)+igc)
1366 1597440 : iprsm = iprsm + 1
1367 2196480 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
1368 : enddo
1369 698880 : ka(jt,jp,igc) = sumk
1370 : enddo
1371 : enddo
1372 : enddo
1373 :
1374 9216 : do jt = 1,5
1375 370176 : do jp = 13,59
1376 360960 : iprsm = 0
1377 2534400 : do igc = 1,ngc(10)
1378 2165760 : sumk = 0.
1379 7941120 : do ipr = 1, ngn(ngs(9)+igc)
1380 5775360 : iprsm = iprsm + 1
1381 7941120 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
1382 : enddo
1383 2526720 : kb(jt,jp,igc) = sumk
1384 : enddo
1385 : enddo
1386 : enddo
1387 :
1388 16896 : do jt = 1,10
1389 15360 : iprsm = 0
1390 109056 : do igc = 1,ngc(10)
1391 92160 : sumk = 0.
1392 337920 : do ipr = 1, ngn(ngs(9)+igc)
1393 245760 : iprsm = iprsm + 1
1394 337920 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
1395 : enddo
1396 107520 : selfref(jt,igc) = sumk
1397 : enddo
1398 : enddo
1399 :
1400 7680 : do jt = 1,4
1401 6144 : iprsm = 0
1402 44544 : do igc = 1,ngc(10)
1403 36864 : sumk = 0.
1404 135168 : do ipr = 1, ngn(ngs(9)+igc)
1405 98304 : iprsm = iprsm + 1
1406 135168 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
1407 : enddo
1408 43008 : forref(jt,igc) = sumk
1409 : enddo
1410 : enddo
1411 :
1412 1536 : iprsm = 0
1413 10752 : do igc = 1,ngc(10)
1414 9216 : sumf1= 0.
1415 9216 : sumf2= 0.
1416 33792 : do ipr = 1, ngn(ngs(9)+igc)
1417 24576 : iprsm = iprsm + 1
1418 24576 : sumf1= sumf1+ fracrefao(iprsm)
1419 33792 : sumf2= sumf2+ fracrefbo(iprsm)
1420 : enddo
1421 9216 : fracrefa(igc) = sumf1
1422 10752 : fracrefb(igc) = sumf2
1423 : enddo
1424 :
1425 1536 : end subroutine cmbgb10
1426 :
1427 : !***************************************************************************
1428 1536 : 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 9216 : do jt = 1,5
1450 109056 : do jp = 1,13
1451 99840 : iprsm = 0
1452 906240 : do igc = 1,ngc(11)
1453 798720 : sumk = 0.
1454 2396160 : do ipr = 1, ngn(ngs(10)+igc)
1455 1597440 : iprsm = iprsm + 1
1456 2396160 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
1457 : enddo
1458 898560 : ka(jt,jp,igc) = sumk
1459 : enddo
1460 : enddo
1461 : enddo
1462 9216 : do jt = 1,5
1463 370176 : do jp = 13,59
1464 360960 : iprsm = 0
1465 3256320 : do igc = 1,ngc(11)
1466 2887680 : sumk = 0.
1467 8663040 : do ipr = 1, ngn(ngs(10)+igc)
1468 5775360 : iprsm = iprsm + 1
1469 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
1470 : enddo
1471 3248640 : kb(jt,jp,igc) = sumk
1472 : enddo
1473 : enddo
1474 : enddo
1475 :
1476 30720 : do jt = 1,19
1477 29184 : iprsm = 0
1478 264192 : do igc = 1,ngc(11)
1479 233472 : sumk1 = 0.
1480 233472 : sumk2 = 0.
1481 700416 : do ipr = 1, ngn(ngs(10)+igc)
1482 466944 : iprsm = iprsm + 1
1483 466944 : sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
1484 700416 : sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
1485 : enddo
1486 233472 : ka_mo2(jt,igc) = sumk1
1487 262656 : kb_mo2(jt,igc) = sumk2
1488 : enddo
1489 : enddo
1490 :
1491 16896 : do jt = 1,10
1492 15360 : iprsm = 0
1493 139776 : do igc = 1,ngc(11)
1494 122880 : sumk = 0.
1495 368640 : do ipr = 1, ngn(ngs(10)+igc)
1496 245760 : iprsm = iprsm + 1
1497 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
1498 : enddo
1499 138240 : selfref(jt,igc) = sumk
1500 : enddo
1501 : enddo
1502 :
1503 7680 : do jt = 1,4
1504 6144 : iprsm = 0
1505 56832 : do igc = 1,ngc(11)
1506 49152 : sumk = 0.
1507 147456 : do ipr = 1, ngn(ngs(10)+igc)
1508 98304 : iprsm = iprsm + 1
1509 147456 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
1510 : enddo
1511 55296 : forref(jt,igc) = sumk
1512 : enddo
1513 : enddo
1514 :
1515 1536 : iprsm = 0
1516 13824 : do igc = 1,ngc(11)
1517 12288 : sumf1= 0.
1518 12288 : sumf2= 0.
1519 36864 : do ipr = 1, ngn(ngs(10)+igc)
1520 24576 : iprsm = iprsm + 1
1521 24576 : sumf1= sumf1+ fracrefao(iprsm)
1522 36864 : sumf2= sumf2+ fracrefbo(iprsm)
1523 : enddo
1524 12288 : fracrefa(igc) = sumf1
1525 13824 : fracrefb(igc) = sumf2
1526 : enddo
1527 :
1528 1536 : end subroutine cmbgb11
1529 :
1530 : !***************************************************************************
1531 1536 : 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 15360 : do jn = 1,9
1549 84480 : do jt = 1,5
1550 981504 : do jp = 1,13
1551 898560 : iprsm = 0
1552 8156160 : do igc = 1,ngc(12)
1553 7188480 : sumk = 0.
1554 21565440 : do ipr = 1, ngn(ngs(11)+igc)
1555 14376960 : iprsm = iprsm + 1
1556 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
1557 : enddo
1558 8087040 : ka(jn,jt,jp,igc) = sumk
1559 : enddo
1560 : enddo
1561 : enddo
1562 : enddo
1563 :
1564 16896 : do jt = 1,10
1565 15360 : iprsm = 0
1566 139776 : do igc = 1,ngc(12)
1567 122880 : sumk = 0.
1568 368640 : do ipr = 1, ngn(ngs(11)+igc)
1569 245760 : iprsm = iprsm + 1
1570 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
1571 : enddo
1572 138240 : selfref(jt,igc) = sumk
1573 : enddo
1574 : enddo
1575 :
1576 7680 : do jt = 1,4
1577 6144 : iprsm = 0
1578 56832 : do igc = 1,ngc(12)
1579 49152 : sumk = 0.
1580 147456 : do ipr = 1, ngn(ngs(11)+igc)
1581 98304 : iprsm = iprsm + 1
1582 147456 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
1583 : enddo
1584 55296 : forref(jt,igc) = sumk
1585 : enddo
1586 : enddo
1587 :
1588 15360 : do jp = 1,9
1589 13824 : iprsm = 0
1590 125952 : do igc = 1,ngc(12)
1591 110592 : sumf = 0.
1592 331776 : do ipr = 1, ngn(ngs(11)+igc)
1593 221184 : iprsm = iprsm + 1
1594 331776 : sumf = sumf + fracrefao(iprsm,jp)
1595 : enddo
1596 124416 : fracrefa(igc,jp) = sumf
1597 : enddo
1598 : enddo
1599 :
1600 1536 : end subroutine cmbgb12
1601 :
1602 : !***************************************************************************
1603 1536 : 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 15360 : do jn = 1,9
1623 84480 : do jt = 1,5
1624 981504 : do jp = 1,13
1625 898560 : iprsm = 0
1626 4561920 : do igc = 1,ngc(13)
1627 3594240 : sumk = 0.
1628 17971200 : do ipr = 1, ngn(ngs(12)+igc)
1629 14376960 : iprsm = iprsm + 1
1630 17971200 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1631 : enddo
1632 4492800 : ka(jn,jt,jp,igc) = sumk
1633 : enddo
1634 : enddo
1635 : enddo
1636 : enddo
1637 :
1638 15360 : do jn = 1,9
1639 278016 : do jt = 1,19
1640 262656 : iprsm = 0
1641 1327104 : do igc = 1,ngc(13)
1642 1050624 : sumk1 = 0.
1643 1050624 : sumk2 = 0.
1644 5253120 : do ipr = 1, ngn(ngs(12)+igc)
1645 4202496 : iprsm = iprsm + 1
1646 4202496 : sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
1647 5253120 : sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
1648 : enddo
1649 1050624 : ka_mco2(jn,jt,igc) = sumk1
1650 1313280 : ka_mco(jn,jt,igc) = sumk2
1651 : enddo
1652 : enddo
1653 : enddo
1654 :
1655 30720 : do jt = 1,19
1656 29184 : iprsm = 0
1657 147456 : do igc = 1,ngc(13)
1658 116736 : sumk = 0.
1659 583680 : do ipr = 1, ngn(ngs(12)+igc)
1660 466944 : iprsm = iprsm + 1
1661 583680 : sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
1662 : enddo
1663 145920 : kb_mo3(jt,igc) = sumk
1664 : enddo
1665 : enddo
1666 :
1667 16896 : do jt = 1,10
1668 15360 : iprsm = 0
1669 78336 : do igc = 1,ngc(13)
1670 61440 : sumk = 0.
1671 307200 : do ipr = 1, ngn(ngs(12)+igc)
1672 245760 : iprsm = iprsm + 1
1673 307200 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
1674 : enddo
1675 76800 : selfref(jt,igc) = sumk
1676 : enddo
1677 : enddo
1678 :
1679 7680 : do jt = 1,4
1680 6144 : iprsm = 0
1681 32256 : do igc = 1,ngc(13)
1682 24576 : sumk = 0.
1683 122880 : do ipr = 1, ngn(ngs(12)+igc)
1684 98304 : iprsm = iprsm + 1
1685 122880 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
1686 : enddo
1687 30720 : forref(jt,igc) = sumk
1688 : enddo
1689 : enddo
1690 :
1691 1536 : iprsm = 0
1692 7680 : do igc = 1,ngc(13)
1693 6144 : sumf = 0.
1694 30720 : do ipr = 1, ngn(ngs(12)+igc)
1695 24576 : iprsm = iprsm + 1
1696 30720 : sumf = sumf + fracrefbo(iprsm)
1697 : enddo
1698 7680 : fracrefb(igc) = sumf
1699 : enddo
1700 :
1701 15360 : do jp = 1,9
1702 : iprsm = 0
1703 70656 : do igc = 1,ngc(13)
1704 55296 : sumf = 0.
1705 276480 : do ipr = 1, ngn(ngs(12)+igc)
1706 221184 : iprsm = iprsm + 1
1707 276480 : sumf = sumf + fracrefao(iprsm,jp)
1708 : enddo
1709 69120 : fracrefa(igc,jp) = sumf
1710 : enddo
1711 : enddo
1712 :
1713 1536 : end subroutine cmbgb13
1714 :
1715 : !***************************************************************************
1716 1536 : 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 9216 : do jt = 1,5
1736 109056 : do jp = 1,13
1737 99840 : iprsm = 0
1738 307200 : do igc = 1,ngc(14)
1739 199680 : sumk = 0.
1740 1797120 : do ipr = 1, ngn(ngs(13)+igc)
1741 1597440 : iprsm = iprsm + 1
1742 1797120 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
1743 : enddo
1744 299520 : ka(jt,jp,igc) = sumk
1745 : enddo
1746 : enddo
1747 : enddo
1748 :
1749 9216 : do jt = 1,5
1750 370176 : do jp = 13,59
1751 360960 : iprsm = 0
1752 1090560 : do igc = 1,ngc(14)
1753 721920 : sumk = 0.
1754 6497280 : do ipr = 1, ngn(ngs(13)+igc)
1755 5775360 : iprsm = iprsm + 1
1756 6497280 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
1757 : enddo
1758 1082880 : kb(jt,jp,igc) = sumk
1759 : enddo
1760 : enddo
1761 : enddo
1762 :
1763 16896 : do jt = 1,10
1764 15360 : iprsm = 0
1765 47616 : do igc = 1,ngc(14)
1766 30720 : sumk = 0.
1767 276480 : do ipr = 1, ngn(ngs(13)+igc)
1768 245760 : iprsm = iprsm + 1
1769 276480 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
1770 : enddo
1771 46080 : selfref(jt,igc) = sumk
1772 : enddo
1773 : enddo
1774 :
1775 7680 : do jt = 1,4
1776 6144 : iprsm = 0
1777 19968 : do igc = 1,ngc(14)
1778 12288 : sumk = 0.
1779 110592 : do ipr = 1, ngn(ngs(13)+igc)
1780 98304 : iprsm = iprsm + 1
1781 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
1782 : enddo
1783 18432 : forref(jt,igc) = sumk
1784 : enddo
1785 : enddo
1786 :
1787 1536 : iprsm = 0
1788 4608 : do igc = 1,ngc(14)
1789 3072 : sumf1= 0.
1790 3072 : sumf2= 0.
1791 27648 : do ipr = 1, ngn(ngs(13)+igc)
1792 24576 : iprsm = iprsm + 1
1793 24576 : sumf1= sumf1+ fracrefao(iprsm)
1794 27648 : sumf2= sumf2+ fracrefbo(iprsm)
1795 : enddo
1796 3072 : fracrefa(igc) = sumf1
1797 4608 : fracrefb(igc) = sumf2
1798 : enddo
1799 :
1800 1536 : end subroutine cmbgb14
1801 :
1802 : !***************************************************************************
1803 1536 : 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 15360 : do jn = 1,9
1822 84480 : do jt = 1,5
1823 981504 : do jp = 1,13
1824 898560 : iprsm = 0
1825 2764800 : do igc = 1,ngc(15)
1826 1797120 : sumk = 0.
1827 16174080 : do ipr = 1, ngn(ngs(14)+igc)
1828 14376960 : iprsm = iprsm + 1
1829 16174080 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
1830 : enddo
1831 2695680 : ka(jn,jt,jp,igc) = sumk
1832 : enddo
1833 : enddo
1834 : enddo
1835 : enddo
1836 :
1837 15360 : do jn = 1,9
1838 278016 : do jt = 1,19
1839 262656 : iprsm = 0
1840 801792 : do igc = 1,ngc(15)
1841 525312 : sumk = 0.
1842 4727808 : do ipr = 1, ngn(ngs(14)+igc)
1843 4202496 : iprsm = iprsm + 1
1844 4727808 : sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
1845 : enddo
1846 787968 : ka_mn2(jn,jt,igc) = sumk
1847 : enddo
1848 : enddo
1849 : enddo
1850 :
1851 16896 : do jt = 1,10
1852 15360 : iprsm = 0
1853 47616 : do igc = 1,ngc(15)
1854 30720 : sumk = 0.
1855 276480 : do ipr = 1, ngn(ngs(14)+igc)
1856 245760 : iprsm = iprsm + 1
1857 276480 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
1858 : enddo
1859 46080 : selfref(jt,igc) = sumk
1860 : enddo
1861 : enddo
1862 :
1863 7680 : do jt = 1,4
1864 6144 : iprsm = 0
1865 19968 : do igc = 1,ngc(15)
1866 12288 : sumk = 0.
1867 110592 : do ipr = 1, ngn(ngs(14)+igc)
1868 98304 : iprsm = iprsm + 1
1869 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
1870 : enddo
1871 18432 : forref(jt,igc) = sumk
1872 : enddo
1873 : enddo
1874 :
1875 15360 : do jp = 1,9
1876 13824 : iprsm = 0
1877 43008 : do igc = 1,ngc(15)
1878 27648 : sumf = 0.
1879 248832 : do ipr = 1, ngn(ngs(14)+igc)
1880 221184 : iprsm = iprsm + 1
1881 248832 : sumf = sumf + fracrefao(iprsm,jp)
1882 : enddo
1883 41472 : fracrefa(igc,jp) = sumf
1884 : enddo
1885 : enddo
1886 :
1887 1536 : end subroutine cmbgb15
1888 :
1889 : !***************************************************************************
1890 1536 : 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 15360 : do jn = 1,9
1908 84480 : do jt = 1,5
1909 981504 : do jp = 1,13
1910 898560 : iprsm = 0
1911 2764800 : do igc = 1,ngc(16)
1912 1797120 : sumk = 0.
1913 16174080 : do ipr = 1, ngn(ngs(15)+igc)
1914 14376960 : iprsm = iprsm + 1
1915 16174080 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
1916 : enddo
1917 2695680 : ka(jn,jt,jp,igc) = sumk
1918 : enddo
1919 : enddo
1920 : enddo
1921 : enddo
1922 :
1923 9216 : do jt = 1,5
1924 370176 : do jp = 13,59
1925 360960 : iprsm = 0
1926 1090560 : do igc = 1,ngc(16)
1927 721920 : sumk = 0.
1928 6497280 : do ipr = 1, ngn(ngs(15)+igc)
1929 5775360 : iprsm = iprsm + 1
1930 6497280 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
1931 : enddo
1932 1082880 : kb(jt,jp,igc) = sumk
1933 : enddo
1934 : enddo
1935 : enddo
1936 :
1937 16896 : do jt = 1,10
1938 15360 : iprsm = 0
1939 47616 : do igc = 1,ngc(16)
1940 30720 : sumk = 0.
1941 276480 : do ipr = 1, ngn(ngs(15)+igc)
1942 245760 : iprsm = iprsm + 1
1943 276480 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
1944 : enddo
1945 46080 : selfref(jt,igc) = sumk
1946 : enddo
1947 : enddo
1948 :
1949 7680 : do jt = 1,4
1950 6144 : iprsm = 0
1951 19968 : do igc = 1,ngc(16)
1952 12288 : sumk = 0.
1953 110592 : do ipr = 1, ngn(ngs(15)+igc)
1954 98304 : iprsm = iprsm + 1
1955 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
1956 : enddo
1957 18432 : forref(jt,igc) = sumk
1958 : enddo
1959 : enddo
1960 :
1961 1536 : iprsm = 0
1962 4608 : do igc = 1,ngc(16)
1963 3072 : sumf = 0.
1964 27648 : do ipr = 1, ngn(ngs(15)+igc)
1965 24576 : iprsm = iprsm + 1
1966 27648 : sumf = sumf + fracrefbo(iprsm)
1967 : enddo
1968 4608 : fracrefb(igc) = sumf
1969 : enddo
1970 :
1971 15360 : do jp = 1,9
1972 : iprsm = 0
1973 43008 : do igc = 1,ngc(16)
1974 27648 : sumf = 0.
1975 248832 : do ipr = 1, ngn(ngs(15)+igc)
1976 221184 : iprsm = iprsm + 1
1977 248832 : sumf = sumf + fracrefao(iprsm,jp)
1978 : enddo
1979 41472 : fracrefa(igc,jp) = sumf
1980 : enddo
1981 : enddo
1982 :
1983 1536 : end subroutine cmbgb16
1984 :
1985 : !***************************************************************************
1986 :
1987 : end module rrtmg_lw_init
1988 :
|
