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