Line data Source code
1 : ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_sw/src/rrtmg_sw_init.f90,v $
2 : ! author: $Author: mike $
3 : ! revision: $Revision: 1.2 $
4 : ! created: $Date: 2007/08/23 20:40:13 $
5 :
6 : module rrtmg_sw_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 : ! ------- Modules -------
19 :
20 : use shr_kind_mod, only: r8 => shr_kind_r8
21 :
22 : ! use parkind, only : jpim, jprb
23 : use rrsw_wvn
24 : use rrtmg_sw_setcoef, only: swatmref
25 :
26 : implicit none
27 :
28 : contains
29 :
30 : ! **************************************************************************
31 768 : subroutine rrtmg_sw_ini
32 : ! **************************************************************************
33 : !
34 : ! Original version: Michael J. Iacono; February, 2004
35 : ! Revision for F90 formatting: M. J. Iacono, July, 2006
36 : !
37 : ! This subroutine performs calculations necessary for the initialization
38 : ! of the shortwave model. Lookup tables are computed for use in the SW
39 : ! radiative transfer, and input absorption coefficient data for each
40 : ! spectral band are reduced from 224 g-point intervals to 112.
41 : ! **************************************************************************
42 :
43 : use parrrsw, only : mg, nbndsw, ngptsw
44 : use rrsw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
45 :
46 : ! ------- Local -------
47 :
48 : integer :: ibnd, igc, ig, ind, ipr
49 : integer :: igcsm, iprsm
50 : integer :: itr
51 :
52 : real(kind=r8) :: wtsum, wtsm(mg)
53 : real(kind=r8) :: tfn
54 :
55 : ! ------- Definitions -------
56 : ! Arrays for 10000-point look-up tables:
57 : ! TAU_TBL Clear-sky optical depth
58 : ! EXP_TBL Exponential lookup table for transmittance
59 : ! PADE Pade approximation constant (= 0.278)
60 : ! BPADE Inverse of the Pade approximation constant
61 : !
62 :
63 : ! Initialize model data
64 768 : call swdatinit
65 768 : call swcmbdat ! g-point interval reduction data
66 768 : call swatmref ! reference MLS profile
67 768 : call sw_kgb16 ! molecular absorption coefficients
68 768 : call sw_kgb17
69 768 : call sw_kgb18
70 768 : call sw_kgb19
71 768 : call sw_kgb20
72 768 : call sw_kgb21
73 768 : call sw_kgb22
74 768 : call sw_kgb23
75 768 : call sw_kgb24
76 768 : call sw_kgb25
77 768 : call sw_kgb26
78 768 : call sw_kgb27
79 768 : call sw_kgb28
80 768 : call sw_kgb29
81 :
82 : ! Define exponential lookup tables for transmittance. Tau is
83 : ! computed as a function of the tau transition function, and transmittance
84 : ! is calculated as a function of tau. All tables are computed at intervals
85 : ! of 0.0001. The inverse of the constant used in the Pade approximation to
86 : ! the tau transition function is set to bpade.
87 :
88 768 : exp_tbl(0) = 1.0_r8
89 768 : exp_tbl(ntbl) = 0.0_r8
90 768 : bpade = 1.0_r8 / pade
91 7680000 : do itr = 1, ntbl-1
92 7679232 : tfn = float(itr) / float(ntbl)
93 7679232 : tau_tbl = bpade * tfn / (1._r8 - tfn)
94 7680000 : exp_tbl(itr) = exp(-tau_tbl)
95 : enddo
96 :
97 : ! Perform g-point reduction from 16 per band (224 total points) to
98 : ! a band dependent number (112 total points) for all absorption
99 : ! coefficient input data and Planck fraction input data.
100 : ! Compute relative weighting for new g-point combinations.
101 :
102 : igcsm = 0
103 11520 : do ibnd = 1,nbndsw
104 10752 : iprsm = 0
105 11520 : if (ngc(ibnd).lt.mg) then
106 96768 : do igc = 1,ngc(ibnd)
107 86016 : igcsm = igcsm + 1
108 86016 : wtsum = 0.
109 258048 : do ipr = 1, ngn(igcsm)
110 172032 : iprsm = iprsm + 1
111 258048 : wtsum = wtsum + wt(iprsm)
112 : enddo
113 96768 : wtsm(igc) = wtsum
114 : enddo
115 182784 : do ig = 1, ng(ibnd+15)
116 172032 : ind = (ibnd-1)*mg + ig
117 182784 : rwgt(ind) = wt(ig)/wtsm(ngm(ind))
118 : enddo
119 : else
120 0 : do ig = 1, ng(ibnd+15)
121 0 : igcsm = igcsm + 1
122 0 : ind = (ibnd-1)*mg + ig
123 0 : rwgt(ind) = 1.0_r8
124 : enddo
125 : endif
126 : enddo
127 :
128 : ! Reduce g-points for absorption coefficient data in each LW spectral band.
129 :
130 768 : call cmbgb16s
131 768 : call cmbgb17
132 768 : call cmbgb18
133 768 : call cmbgb19
134 768 : call cmbgb20
135 768 : call cmbgb21
136 768 : call cmbgb22
137 768 : call cmbgb23
138 768 : call cmbgb24
139 768 : call cmbgb25
140 768 : call cmbgb26
141 768 : call cmbgb27
142 768 : call cmbgb28
143 768 : call cmbgb29
144 :
145 768 : end subroutine rrtmg_sw_ini
146 :
147 : !***************************************************************************
148 768 : subroutine swdatinit
149 : !***************************************************************************
150 :
151 : ! --------- Modules ----------
152 :
153 : use rrsw_con, only: heatfac, grav, planck, boltz, &
154 : clight, avogad, alosmt, gascon, radcn1, radcn2
155 : use rrsw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave
156 : use shr_const_mod, only: shr_const_avogad
157 : use physconst, only: cday, gravit, cpair
158 :
159 : save
160 :
161 : ! Shortwave spectral band limits (wavenumbers)
162 : wavenum1(:) = (/2600._r8, 3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, &
163 768 : 8050._r8,12850._r8,16000._r8,22650._r8,29000._r8,38000._r8, 820._r8/)
164 : wavenum2(:) = (/3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, 8050._r8, &
165 768 : 12850._r8,16000._r8,22650._r8,29000._r8,38000._r8,50000._r8, 2600._r8/)
166 : delwave(:) = (/ 650._r8, 750._r8, 650._r8, 500._r8, 1000._r8, 1550._r8, 350._r8, &
167 768 : 4800._r8, 3150._r8, 6650._r8, 6350._r8, 9000._r8,12000._r8, 1780._r8/)
168 :
169 : ! Spectral band information
170 768 : ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
171 768 : nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
172 768 : nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
173 :
174 : ! Use constants set in CAM for consistency
175 768 : grav = gravit
176 768 : avogad = shr_const_avogad * 1.e-3_r8
177 :
178 : ! Heatfac is the factor by which one must multiply delta-flux/
179 : ! delta-pressure, with flux in w/m-2 and pressure in mbar, to get
180 : ! the heating rate in units of degrees/day. It is equal to
181 : ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
182 : ! = (9.8066)(86400)(1e-5)/(1.004)
183 : ! heatfac = 8.4391_r8
184 :
185 : ! Calculate heatfac directly from CAM constants:
186 768 : heatfac = grav * cday * 1.e-5_r8 / (cpair * 1.e-3_r8)
187 :
188 : ! Constants from NIST 01/11/2002
189 :
190 : ! grav = 9.8066_r8
191 768 : planck = 6.62606876e-27_r8
192 768 : boltz = 1.3806503e-16_r8
193 768 : clight = 2.99792458e+10_r8
194 : ! avogad = 6.02214199e+23_r8
195 768 : alosmt = 2.6867775e+19_r8
196 768 : gascon = 8.31447200e+07_r8
197 768 : radcn1 = 1.191042722e-12_r8
198 768 : radcn2 = 1.4387752_r8
199 :
200 : !
201 : ! units are generally cgs
202 : !
203 : ! The first and second radiation constants are taken from NIST.
204 : ! They were previously obtained from the relations:
205 : ! radcn1 = 2.*planck*clight*clight*1.e-07
206 : ! radcn2 = planck*clight/boltz
207 :
208 768 : end subroutine swdatinit
209 :
210 : !***************************************************************************
211 768 : subroutine swcmbdat
212 : !***************************************************************************
213 :
214 : use rrsw_wvn, only: ngc, ngs, ngn, ngb, ngm, wt
215 :
216 : save
217 :
218 : ! ------- Definitions -------
219 : ! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
220 : ! This mapping from 224 to 112 points has been carefully selected to
221 : ! minimize the effect on the resulting fluxes and cooling rates, and
222 : ! caution should be used if the mapping is modified. The full 224
223 : ! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
224 : ! ngpt The total number of new g-points
225 : ! ngc The number of new g-points in each band
226 : ! ngs The cumulative sum of new g-points for each band
227 : ! ngm The index of each new g-point relative to the original
228 : ! 16 g-points for each band.
229 : ! ngn The number of original g-points that are combined to make
230 : ! each new g-point in each band.
231 : ! ngb The band index for each new g-point.
232 : ! wt RRTM weights for 16 g-points.
233 :
234 : ! Use this set for 112 quadrature point (g-point) model
235 : ! ------- Data statements -------
236 768 : ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
237 768 : ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
238 : ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16
239 : 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17
240 : 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18
241 : 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19
242 : 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20
243 : 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21
244 : 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22
245 : 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23
246 : 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24
247 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25
248 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26
249 : 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27
250 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28
251 768 : 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29
252 : ngn(:) = (/ 2,2,2,2,4,4, & ! band 16
253 : 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17
254 : 1,1,1,1,2,2,4,4, & ! band 18
255 : 1,1,1,1,2,2,4,4, & ! band 19
256 : 1,1,1,1,1,1,1,1,2,6, & ! band 20
257 : 1,1,1,1,1,1,1,1,2,6, & ! band 21
258 : 8,8, & ! band 22
259 : 2,2,1,1,1,1,1,1,2,4, & ! band 23
260 : 2,2,2,2,2,2,2,2, & ! band 24
261 : 1,1,2,2,4,6, & ! band 25
262 : 1,1,2,2,4,6, & ! band 26
263 : 1,1,1,1,1,1,4,6, & ! band 27
264 : 1,1,2,2,4,6, & ! band 28
265 768 : 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29
266 : ngb(:) = (/ 16,16,16,16,16,16, & ! band 16
267 : 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
268 : 18,18,18,18,18,18,18,18, & ! band 18
269 : 19,19,19,19,19,19,19,19, & ! band 19
270 : 20,20,20,20,20,20,20,20,20,20, & ! band 20
271 : 21,21,21,21,21,21,21,21,21,21, & ! band 21
272 : 22,22, & ! band 22
273 : 23,23,23,23,23,23,23,23,23,23, & ! band 23
274 : 24,24,24,24,24,24,24,24, & ! band 24
275 : 25,25,25,25,25,25, & ! band 25
276 : 26,26,26,26,26,26, & ! band 26
277 : 27,27,27,27,27,27,27,27, & ! band 27
278 : 28,28,28,28,28,28, & ! band 28
279 768 : 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
280 :
281 : ! Use this set for full 224 quadrature point (g-point) model
282 : ! ------- Data statements -------
283 : ! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
284 : ! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
285 : ! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
286 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
287 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
288 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
289 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
290 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
291 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
292 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
293 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
294 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
295 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
296 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
297 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
298 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
299 : ! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
300 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
301 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
302 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
303 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
304 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
305 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
306 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
307 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
308 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
309 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
310 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
311 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
312 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
313 : ! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
314 : ! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
315 : ! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
316 : ! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
317 : ! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
318 : ! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
319 : ! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
320 : ! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
321 : ! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
322 : ! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
323 : ! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
324 : ! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
325 : ! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
326 : ! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
327 :
328 :
329 : wt(:) = (/ 0.1527534276_r8, 0.1491729617_r8, 0.1420961469_r8, &
330 : 0.1316886544_r8, 0.1181945205_r8, 0.1019300893_r8, &
331 : 0.0832767040_r8, 0.0626720116_r8, 0.0424925000_r8, &
332 : 0.0046269894_r8, 0.0038279891_r8, 0.0030260086_r8, &
333 : 0.0022199750_r8, 0.0014140010_r8, 0.0005330000_r8, &
334 768 : 0.0000750000_r8 /)
335 :
336 768 : end subroutine swcmbdat
337 :
338 : !***************************************************************************
339 768 : subroutine cmbgb16s
340 : !***************************************************************************
341 : !
342 : ! Original version: MJIacono; July 1998
343 : ! Revision for RRTM_SW: MJIacono; November 2002
344 : ! Revision for RRTMG_SW: MJIacono; December 2003
345 : ! Revision for F90 reformatting: MJIacono; July 2006
346 : !
347 : ! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
348 : ! data for each band, which are defined for 16 g-points and 14 spectral
349 : ! bands. The data are combined with appropriate weighting following the
350 : ! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
351 : ! function data in array SFLUXREF are combined without weighting. All
352 : ! g-point reduced data are put into new arrays for use in RRTMG_SW.
353 : !
354 : ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
355 : !
356 : !-----------------------------------------------------------------------
357 :
358 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
359 : use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
360 : ka, kb, selfref, forref, sfluxref
361 :
362 : ! ------- Local -------
363 : integer :: jn, jt, jp, igc, ipr, iprsm
364 : real(kind=r8) :: sumk, sumf
365 :
366 :
367 7680 : do jn = 1,9
368 42240 : do jt = 1,5
369 490752 : do jp = 1,13
370 449280 : iprsm = 0
371 3179520 : do igc = 1,ngc(1)
372 2695680 : sumk = 0.
373 9884160 : do ipr = 1, ngn(igc)
374 7188480 : iprsm = iprsm + 1
375 9884160 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
376 : enddo
377 3144960 : ka(jn,jt,jp,igc) = sumk
378 : enddo
379 : enddo
380 : enddo
381 : enddo
382 :
383 4608 : do jt = 1,5
384 185088 : do jp = 13,59
385 180480 : iprsm = 0
386 1267200 : do igc = 1,ngc(1)
387 1082880 : sumk = 0.
388 3970560 : do ipr = 1, ngn(igc)
389 2887680 : iprsm = iprsm + 1
390 3970560 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
391 : enddo
392 1263360 : kb(jt,jp,igc) = sumk
393 : enddo
394 : enddo
395 : enddo
396 :
397 8448 : do jt = 1,10
398 7680 : iprsm = 0
399 54528 : do igc = 1,ngc(1)
400 46080 : sumk = 0.
401 168960 : do ipr = 1, ngn(igc)
402 122880 : iprsm = iprsm + 1
403 168960 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
404 : enddo
405 53760 : selfref(jt,igc) = sumk
406 : enddo
407 : enddo
408 :
409 3072 : do jt = 1,3
410 2304 : iprsm = 0
411 16896 : do igc = 1,ngc(1)
412 13824 : sumk = 0.
413 50688 : do ipr = 1, ngn(igc)
414 36864 : iprsm = iprsm + 1
415 50688 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
416 : enddo
417 16128 : forref(jt,igc) = sumk
418 : enddo
419 : enddo
420 :
421 768 : iprsm = 0
422 5376 : do igc = 1,ngc(1)
423 4608 : sumf = 0.
424 16896 : do ipr = 1, ngn(igc)
425 12288 : iprsm = iprsm + 1
426 16896 : sumf = sumf + sfluxrefo(iprsm)
427 : enddo
428 5376 : sfluxref(igc) = sumf
429 : enddo
430 :
431 768 : end subroutine cmbgb16s
432 :
433 : !***************************************************************************
434 768 : subroutine cmbgb17
435 : !***************************************************************************
436 : !
437 : ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
438 : !-----------------------------------------------------------------------
439 :
440 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
441 : use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
442 : ka, kb, selfref, forref, sfluxref
443 :
444 : ! ------- Local -------
445 : integer :: jn, jt, jp, igc, ipr, iprsm
446 : real(kind=r8) :: sumk, sumf
447 :
448 :
449 7680 : do jn = 1,9
450 42240 : do jt = 1,5
451 490752 : do jp = 1,13
452 449280 : iprsm = 0
453 5875200 : do igc = 1,ngc(2)
454 5391360 : sumk = 0.
455 12579840 : do ipr = 1, ngn(ngs(1)+igc)
456 7188480 : iprsm = iprsm + 1
457 12579840 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
458 : enddo
459 5840640 : ka(jn,jt,jp,igc) = sumk
460 : enddo
461 : enddo
462 : enddo
463 : enddo
464 :
465 4608 : do jn = 1,5
466 23808 : do jt = 1,5
467 925440 : do jp = 13,59
468 902400 : iprsm = 0
469 11750400 : do igc = 1,ngc(2)
470 10828800 : sumk = 0.
471 25267200 : do ipr = 1, ngn(ngs(1)+igc)
472 14438400 : iprsm = iprsm + 1
473 25267200 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
474 : enddo
475 11731200 : kb(jn,jt,jp,igc) = sumk
476 : enddo
477 : enddo
478 : enddo
479 : enddo
480 :
481 8448 : do jt = 1,10
482 7680 : iprsm = 0
483 100608 : do igc = 1,ngc(2)
484 92160 : sumk = 0.
485 215040 : do ipr = 1, ngn(ngs(1)+igc)
486 122880 : iprsm = iprsm + 1
487 215040 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
488 : enddo
489 99840 : selfref(jt,igc) = sumk
490 : enddo
491 : enddo
492 :
493 3840 : do jt = 1,4
494 3072 : iprsm = 0
495 40704 : do igc = 1,ngc(2)
496 36864 : sumk = 0.
497 86016 : do ipr = 1, ngn(ngs(1)+igc)
498 49152 : iprsm = iprsm + 1
499 86016 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
500 : enddo
501 39936 : forref(jt,igc) = sumk
502 : enddo
503 : enddo
504 :
505 4608 : do jp = 1,5
506 3840 : iprsm = 0
507 50688 : do igc = 1,ngc(2)
508 46080 : sumf = 0.
509 107520 : do ipr = 1, ngn(ngs(1)+igc)
510 61440 : iprsm = iprsm + 1
511 107520 : sumf = sumf + sfluxrefo(iprsm,jp)
512 : enddo
513 49920 : sfluxref(igc,jp) = sumf
514 : enddo
515 : enddo
516 :
517 768 : end subroutine cmbgb17
518 :
519 : !***************************************************************************
520 768 : subroutine cmbgb18
521 : !***************************************************************************
522 : !
523 : ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
524 : !-----------------------------------------------------------------------
525 :
526 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
527 : use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
528 : ka, kb, selfref, forref, sfluxref
529 :
530 : ! ------- Local -------
531 : integer :: jn, jt, jp, igc, ipr, iprsm
532 : real(kind=r8) :: sumk, sumf
533 :
534 :
535 7680 : do jn = 1,9
536 42240 : do jt = 1,5
537 490752 : do jp = 1,13
538 449280 : iprsm = 0
539 4078080 : do igc = 1,ngc(3)
540 3594240 : sumk = 0.
541 10782720 : do ipr = 1, ngn(ngs(2)+igc)
542 7188480 : iprsm = iprsm + 1
543 10782720 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
544 : enddo
545 4043520 : ka(jn,jt,jp,igc) = sumk
546 : enddo
547 : enddo
548 : enddo
549 : enddo
550 :
551 4608 : do jt = 1,5
552 185088 : do jp = 13,59
553 180480 : iprsm = 0
554 1628160 : do igc = 1,ngc(3)
555 1443840 : sumk = 0.
556 4331520 : do ipr = 1, ngn(ngs(2)+igc)
557 2887680 : iprsm = iprsm + 1
558 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
559 : enddo
560 1624320 : kb(jt,jp,igc) = sumk
561 : enddo
562 : enddo
563 : enddo
564 :
565 8448 : do jt = 1,10
566 7680 : iprsm = 0
567 69888 : do igc = 1,ngc(3)
568 61440 : sumk = 0.
569 184320 : do ipr = 1, ngn(ngs(2)+igc)
570 122880 : iprsm = iprsm + 1
571 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
572 : enddo
573 69120 : selfref(jt,igc) = sumk
574 : enddo
575 : enddo
576 :
577 3072 : do jt = 1,3
578 2304 : iprsm = 0
579 21504 : do igc = 1,ngc(3)
580 18432 : sumk = 0.
581 55296 : do ipr = 1, ngn(ngs(2)+igc)
582 36864 : iprsm = iprsm + 1
583 55296 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
584 : enddo
585 20736 : forref(jt,igc) = sumk
586 : enddo
587 : enddo
588 :
589 7680 : do jp = 1,9
590 6912 : iprsm = 0
591 62976 : do igc = 1,ngc(3)
592 55296 : sumf = 0.
593 165888 : do ipr = 1, ngn(ngs(2)+igc)
594 110592 : iprsm = iprsm + 1
595 165888 : sumf = sumf + sfluxrefo(iprsm,jp)
596 : enddo
597 62208 : sfluxref(igc,jp) = sumf
598 : enddo
599 : enddo
600 :
601 768 : end subroutine cmbgb18
602 :
603 : !***************************************************************************
604 768 : subroutine cmbgb19
605 : !***************************************************************************
606 : !
607 : ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
608 : !-----------------------------------------------------------------------
609 :
610 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
611 : use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
612 : ka, kb, selfref, forref, sfluxref
613 :
614 : ! ------- Local -------
615 : integer :: jn, jt, jp, igc, ipr, iprsm
616 : real(kind=r8) :: sumk, sumf
617 :
618 :
619 7680 : do jn = 1,9
620 42240 : do jt = 1,5
621 490752 : do jp = 1,13
622 449280 : iprsm = 0
623 4078080 : do igc = 1,ngc(4)
624 3594240 : sumk = 0.
625 10782720 : do ipr = 1, ngn(ngs(3)+igc)
626 7188480 : iprsm = iprsm + 1
627 10782720 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
628 : enddo
629 4043520 : ka(jn,jt,jp,igc) = sumk
630 : enddo
631 : enddo
632 : enddo
633 : enddo
634 :
635 4608 : do jt = 1,5
636 185088 : do jp = 13,59
637 180480 : iprsm = 0
638 1628160 : do igc = 1,ngc(4)
639 1443840 : sumk = 0.
640 4331520 : do ipr = 1, ngn(ngs(3)+igc)
641 2887680 : iprsm = iprsm + 1
642 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
643 : enddo
644 1624320 : kb(jt,jp,igc) = sumk
645 : enddo
646 : enddo
647 : enddo
648 :
649 8448 : do jt = 1,10
650 7680 : iprsm = 0
651 69888 : do igc = 1,ngc(4)
652 61440 : sumk = 0.
653 184320 : do ipr = 1, ngn(ngs(3)+igc)
654 122880 : iprsm = iprsm + 1
655 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
656 : enddo
657 69120 : selfref(jt,igc) = sumk
658 : enddo
659 : enddo
660 :
661 3072 : do jt = 1,3
662 2304 : iprsm = 0
663 21504 : do igc = 1,ngc(4)
664 18432 : sumk = 0.
665 55296 : do ipr = 1, ngn(ngs(3)+igc)
666 36864 : iprsm = iprsm + 1
667 55296 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
668 : enddo
669 20736 : forref(jt,igc) = sumk
670 : enddo
671 : enddo
672 :
673 7680 : do jp = 1,9
674 6912 : iprsm = 0
675 62976 : do igc = 1,ngc(4)
676 55296 : sumf = 0.
677 165888 : do ipr = 1, ngn(ngs(3)+igc)
678 110592 : iprsm = iprsm + 1
679 165888 : sumf = sumf + sfluxrefo(iprsm,jp)
680 : enddo
681 62208 : sfluxref(igc,jp) = sumf
682 : enddo
683 : enddo
684 :
685 768 : end subroutine cmbgb19
686 :
687 : !***************************************************************************
688 768 : subroutine cmbgb20
689 : !***************************************************************************
690 : !
691 : ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
692 : !-----------------------------------------------------------------------
693 :
694 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
695 : use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
696 : ka, kb, selfref, forref, sfluxref, absch4
697 :
698 : ! ------- Local -------
699 : integer :: jt, jp, igc, ipr, iprsm
700 : real(kind=r8) :: sumk, sumf1, sumf2
701 :
702 :
703 4608 : do jt = 1,5
704 53760 : do jp = 1,13
705 49920 : iprsm = 0
706 552960 : do igc = 1,ngc(5)
707 499200 : sumk = 0.
708 1297920 : do ipr = 1, ngn(ngs(4)+igc)
709 798720 : iprsm = iprsm + 1
710 1297920 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
711 : enddo
712 549120 : ka(jt,jp,igc) = sumk
713 : enddo
714 : enddo
715 185088 : do jp = 13,59
716 180480 : iprsm = 0
717 1989120 : do igc = 1,ngc(5)
718 1804800 : sumk = 0.
719 4692480 : do ipr = 1, ngn(ngs(4)+igc)
720 2887680 : iprsm = iprsm + 1
721 4692480 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
722 : enddo
723 1985280 : kb(jt,jp,igc) = sumk
724 : enddo
725 : enddo
726 : enddo
727 :
728 8448 : do jt = 1,10
729 7680 : iprsm = 0
730 85248 : do igc = 1,ngc(5)
731 76800 : sumk = 0.
732 199680 : do ipr = 1, ngn(ngs(4)+igc)
733 122880 : iprsm = iprsm + 1
734 199680 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
735 : enddo
736 84480 : selfref(jt,igc) = sumk
737 : enddo
738 : enddo
739 :
740 3840 : do jt = 1,4
741 3072 : iprsm = 0
742 34560 : do igc = 1,ngc(5)
743 30720 : sumk = 0.
744 79872 : do ipr = 1, ngn(ngs(4)+igc)
745 49152 : iprsm = iprsm + 1
746 79872 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
747 : enddo
748 33792 : forref(jt,igc) = sumk
749 : enddo
750 : enddo
751 :
752 768 : iprsm = 0
753 8448 : do igc = 1,ngc(5)
754 7680 : sumf1 = 0.
755 7680 : sumf2 = 0.
756 19968 : do ipr = 1, ngn(ngs(4)+igc)
757 12288 : iprsm = iprsm + 1
758 12288 : sumf1 = sumf1 + sfluxrefo(iprsm)
759 19968 : sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
760 : enddo
761 7680 : sfluxref(igc) = sumf1
762 8448 : absch4(igc) = sumf2
763 : enddo
764 :
765 768 : end subroutine cmbgb20
766 :
767 : !***************************************************************************
768 768 : subroutine cmbgb21
769 : !***************************************************************************
770 : !
771 : ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
772 : !-----------------------------------------------------------------------
773 :
774 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
775 : use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
776 : ka, kb, selfref, forref, sfluxref
777 :
778 : ! ------- Local -------
779 : integer :: jn, jt, jp, igc, ipr, iprsm
780 : real(kind=r8) :: sumk, sumf
781 :
782 :
783 7680 : do jn = 1,9
784 42240 : do jt = 1,5
785 490752 : do jp = 1,13
786 449280 : iprsm = 0
787 4976640 : do igc = 1,ngc(6)
788 4492800 : sumk = 0.
789 11681280 : do ipr = 1, ngn(ngs(5)+igc)
790 7188480 : iprsm = iprsm + 1
791 11681280 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
792 : enddo
793 4942080 : ka(jn,jt,jp,igc) = sumk
794 : enddo
795 : enddo
796 : enddo
797 : enddo
798 :
799 4608 : do jn = 1,5
800 23808 : do jt = 1,5
801 925440 : do jp = 13,59
802 902400 : iprsm = 0
803 9945600 : do igc = 1,ngc(6)
804 9024000 : sumk = 0.
805 23462400 : do ipr = 1, ngn(ngs(5)+igc)
806 14438400 : iprsm = iprsm + 1
807 23462400 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
808 : enddo
809 9926400 : kb(jn,jt,jp,igc) = sumk
810 : enddo
811 : enddo
812 : enddo
813 : enddo
814 :
815 8448 : do jt = 1,10
816 7680 : iprsm = 0
817 85248 : do igc = 1,ngc(6)
818 76800 : sumk = 0.
819 199680 : do ipr = 1, ngn(ngs(5)+igc)
820 122880 : iprsm = iprsm + 1
821 199680 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
822 : enddo
823 84480 : selfref(jt,igc) = sumk
824 : enddo
825 : enddo
826 :
827 3840 : do jt = 1,4
828 3072 : iprsm = 0
829 34560 : do igc = 1,ngc(6)
830 30720 : sumk = 0.
831 79872 : do ipr = 1, ngn(ngs(5)+igc)
832 49152 : iprsm = iprsm + 1
833 79872 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
834 : enddo
835 33792 : forref(jt,igc) = sumk
836 : enddo
837 : enddo
838 :
839 7680 : do jp = 1,9
840 6912 : iprsm = 0
841 76800 : do igc = 1,ngc(6)
842 69120 : sumf = 0.
843 179712 : do ipr = 1, ngn(ngs(5)+igc)
844 110592 : iprsm = iprsm + 1
845 179712 : sumf = sumf + sfluxrefo(iprsm,jp)
846 : enddo
847 76032 : sfluxref(igc,jp) = sumf
848 : enddo
849 : enddo
850 :
851 768 : end subroutine cmbgb21
852 :
853 : !***************************************************************************
854 768 : subroutine cmbgb22
855 : !***************************************************************************
856 : !
857 : ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
858 : !-----------------------------------------------------------------------
859 :
860 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
861 : use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
862 : ka, kb, selfref, forref, sfluxref
863 :
864 : ! ------- Local -------
865 : integer :: jn, jt, jp, igc, ipr, iprsm
866 : real(kind=r8) :: sumk, sumf
867 :
868 :
869 7680 : do jn = 1,9
870 42240 : do jt = 1,5
871 490752 : do jp = 1,13
872 449280 : iprsm = 0
873 1382400 : do igc = 1,ngc(7)
874 898560 : sumk = 0.
875 8087040 : do ipr = 1, ngn(ngs(6)+igc)
876 7188480 : iprsm = iprsm + 1
877 8087040 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
878 : enddo
879 1347840 : ka(jn,jt,jp,igc) = sumk
880 : enddo
881 : enddo
882 : enddo
883 : enddo
884 :
885 4608 : do jt = 1,5
886 185088 : do jp = 13,59
887 180480 : iprsm = 0
888 545280 : do igc = 1,ngc(7)
889 360960 : sumk = 0.
890 3248640 : do ipr = 1, ngn(ngs(6)+igc)
891 2887680 : iprsm = iprsm + 1
892 3248640 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
893 : enddo
894 541440 : kb(jt,jp,igc) = sumk
895 : enddo
896 : enddo
897 : enddo
898 :
899 8448 : do jt = 1,10
900 7680 : iprsm = 0
901 23808 : do igc = 1,ngc(7)
902 15360 : sumk = 0.
903 138240 : do ipr = 1, ngn(ngs(6)+igc)
904 122880 : iprsm = iprsm + 1
905 138240 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
906 : enddo
907 23040 : selfref(jt,igc) = sumk
908 : enddo
909 : enddo
910 :
911 3072 : do jt = 1,3
912 2304 : iprsm = 0
913 7680 : do igc = 1,ngc(7)
914 4608 : sumk = 0.
915 41472 : do ipr = 1, ngn(ngs(6)+igc)
916 36864 : iprsm = iprsm + 1
917 41472 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
918 : enddo
919 6912 : forref(jt,igc) = sumk
920 : enddo
921 : enddo
922 :
923 7680 : do jp = 1,9
924 6912 : iprsm = 0
925 21504 : do igc = 1,ngc(7)
926 13824 : sumf = 0.
927 124416 : do ipr = 1, ngn(ngs(6)+igc)
928 110592 : iprsm = iprsm + 1
929 124416 : sumf = sumf + sfluxrefo(iprsm,jp)
930 : enddo
931 20736 : sfluxref(igc,jp) = sumf
932 : enddo
933 : enddo
934 :
935 768 : end subroutine cmbgb22
936 :
937 : !***************************************************************************
938 768 : subroutine cmbgb23
939 : !***************************************************************************
940 : !
941 : ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
942 : !-----------------------------------------------------------------------
943 :
944 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
945 : use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
946 : ka, selfref, forref, sfluxref, rayl
947 :
948 : ! ------- Local -------
949 : integer :: jt, jp, igc, ipr, iprsm
950 : real(kind=r8) :: sumk, sumf1, sumf2
951 :
952 :
953 4608 : do jt = 1,5
954 54528 : do jp = 1,13
955 49920 : iprsm = 0
956 552960 : do igc = 1,ngc(8)
957 499200 : sumk = 0.
958 1297920 : do ipr = 1, ngn(ngs(7)+igc)
959 798720 : iprsm = iprsm + 1
960 1297920 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
961 : enddo
962 549120 : ka(jt,jp,igc) = sumk
963 : enddo
964 : enddo
965 : enddo
966 :
967 8448 : do jt = 1,10
968 7680 : iprsm = 0
969 85248 : do igc = 1,ngc(8)
970 76800 : sumk = 0.
971 199680 : do ipr = 1, ngn(ngs(7)+igc)
972 122880 : iprsm = iprsm + 1
973 199680 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
974 : enddo
975 84480 : selfref(jt,igc) = sumk
976 : enddo
977 : enddo
978 :
979 3072 : do jt = 1,3
980 2304 : iprsm = 0
981 26112 : do igc = 1,ngc(8)
982 23040 : sumk = 0.
983 59904 : do ipr = 1, ngn(ngs(7)+igc)
984 36864 : iprsm = iprsm + 1
985 59904 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
986 : enddo
987 25344 : forref(jt,igc) = sumk
988 : enddo
989 : enddo
990 :
991 768 : iprsm = 0
992 8448 : do igc = 1,ngc(8)
993 7680 : sumf1 = 0.
994 7680 : sumf2 = 0.
995 19968 : do ipr = 1, ngn(ngs(7)+igc)
996 12288 : iprsm = iprsm + 1
997 12288 : sumf1 = sumf1 + sfluxrefo(iprsm)
998 19968 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
999 : enddo
1000 7680 : sfluxref(igc) = sumf1
1001 8448 : rayl(igc) = sumf2
1002 : enddo
1003 :
1004 768 : end subroutine cmbgb23
1005 :
1006 : !***************************************************************************
1007 768 : subroutine cmbgb24
1008 : !***************************************************************************
1009 : !
1010 : ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
1011 : !-----------------------------------------------------------------------
1012 :
1013 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1014 : use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
1015 : abso3ao, abso3bo, raylao, raylbo, &
1016 : ka, kb, selfref, forref, sfluxref, &
1017 : abso3a, abso3b, rayla, raylb
1018 :
1019 : ! ------- Local -------
1020 : integer :: jn, jt, jp, igc, ipr, iprsm
1021 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3
1022 :
1023 :
1024 7680 : do jn = 1,9
1025 42240 : do jt = 1,5
1026 490752 : do jp = 1,13
1027 449280 : iprsm = 0
1028 4078080 : do igc = 1,ngc(9)
1029 3594240 : sumk = 0.
1030 10782720 : do ipr = 1, ngn(ngs(8)+igc)
1031 7188480 : iprsm = iprsm + 1
1032 10782720 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
1033 : enddo
1034 4043520 : ka(jn,jt,jp,igc) = sumk
1035 : enddo
1036 : enddo
1037 : enddo
1038 : enddo
1039 :
1040 4608 : do jt = 1,5
1041 185088 : do jp = 13,59
1042 180480 : iprsm = 0
1043 1628160 : do igc = 1,ngc(9)
1044 1443840 : sumk = 0.
1045 4331520 : do ipr = 1, ngn(ngs(8)+igc)
1046 2887680 : iprsm = iprsm + 1
1047 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
1048 : enddo
1049 1624320 : kb(jt,jp,igc) = sumk
1050 : enddo
1051 : enddo
1052 : enddo
1053 :
1054 8448 : do jt = 1,10
1055 7680 : iprsm = 0
1056 69888 : do igc = 1,ngc(9)
1057 61440 : sumk = 0.
1058 184320 : do ipr = 1, ngn(ngs(8)+igc)
1059 122880 : iprsm = iprsm + 1
1060 184320 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
1061 : enddo
1062 69120 : selfref(jt,igc) = sumk
1063 : enddo
1064 : enddo
1065 :
1066 3072 : do jt = 1,3
1067 2304 : iprsm = 0
1068 21504 : do igc = 1,ngc(9)
1069 18432 : sumk = 0.
1070 55296 : do ipr = 1, ngn(ngs(8)+igc)
1071 36864 : iprsm = iprsm + 1
1072 55296 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
1073 : enddo
1074 20736 : forref(jt,igc) = sumk
1075 : enddo
1076 : enddo
1077 :
1078 768 : iprsm = 0
1079 6912 : do igc = 1,ngc(9)
1080 6144 : sumf1 = 0.
1081 6144 : sumf2 = 0.
1082 6144 : sumf3 = 0.
1083 18432 : do ipr = 1, ngn(ngs(8)+igc)
1084 12288 : iprsm = iprsm + 1
1085 12288 : sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
1086 12288 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
1087 18432 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
1088 : enddo
1089 6144 : raylb(igc) = sumf1
1090 6144 : abso3a(igc) = sumf2
1091 6912 : abso3b(igc) = sumf3
1092 : enddo
1093 :
1094 7680 : do jp = 1,9
1095 : iprsm = 0
1096 62976 : do igc = 1,ngc(9)
1097 55296 : sumf1 = 0.
1098 55296 : sumf2 = 0.
1099 165888 : do ipr = 1, ngn(ngs(8)+igc)
1100 110592 : iprsm = iprsm + 1
1101 110592 : sumf1 = sumf1 + sfluxrefo(iprsm,jp)
1102 165888 : sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
1103 : enddo
1104 55296 : sfluxref(igc,jp) = sumf1
1105 62208 : rayla(igc,jp) = sumf2
1106 : enddo
1107 : enddo
1108 :
1109 768 : end subroutine cmbgb24
1110 :
1111 : !***************************************************************************
1112 768 : subroutine cmbgb25
1113 : !***************************************************************************
1114 : !
1115 : ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
1116 : !-----------------------------------------------------------------------
1117 :
1118 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1119 : use rrsw_kg25, only : kao, sfluxrefo, &
1120 : abso3ao, abso3bo, raylo, &
1121 : ka, sfluxref, &
1122 : abso3a, abso3b, rayl
1123 :
1124 : ! ------- Local -------
1125 : integer :: jt, jp, igc, ipr, iprsm
1126 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3, sumf4
1127 :
1128 :
1129 4608 : do jt = 1,5
1130 54528 : do jp = 1,13
1131 49920 : iprsm = 0
1132 353280 : do igc = 1,ngc(10)
1133 299520 : sumk = 0.
1134 1098240 : do ipr = 1, ngn(ngs(9)+igc)
1135 798720 : iprsm = iprsm + 1
1136 1098240 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
1137 : enddo
1138 349440 : ka(jt,jp,igc) = sumk
1139 : enddo
1140 : enddo
1141 : enddo
1142 :
1143 768 : iprsm = 0
1144 5376 : do igc = 1,ngc(10)
1145 4608 : sumf1 = 0.
1146 4608 : sumf2 = 0.
1147 4608 : sumf3 = 0.
1148 4608 : sumf4 = 0.
1149 16896 : do ipr = 1, ngn(ngs(9)+igc)
1150 12288 : iprsm = iprsm + 1
1151 12288 : sumf1 = sumf1 + sfluxrefo(iprsm)
1152 12288 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
1153 12288 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
1154 16896 : sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
1155 : enddo
1156 4608 : sfluxref(igc) = sumf1
1157 4608 : abso3a(igc) = sumf2
1158 4608 : abso3b(igc) = sumf3
1159 5376 : rayl(igc) = sumf4
1160 : enddo
1161 :
1162 768 : end subroutine cmbgb25
1163 :
1164 : !***************************************************************************
1165 768 : subroutine cmbgb26
1166 : !***************************************************************************
1167 : !
1168 : ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1169 : !-----------------------------------------------------------------------
1170 :
1171 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1172 : use rrsw_kg26, only : sfluxrefo, raylo, &
1173 : sfluxref, rayl
1174 :
1175 : ! ------- Local -------
1176 : integer :: igc, ipr, iprsm
1177 : real(kind=r8) :: sumf1, sumf2
1178 :
1179 :
1180 768 : iprsm = 0
1181 5376 : do igc = 1,ngc(11)
1182 4608 : sumf1 = 0.
1183 4608 : sumf2 = 0.
1184 16896 : do ipr = 1, ngn(ngs(10)+igc)
1185 12288 : iprsm = iprsm + 1
1186 12288 : sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
1187 16896 : sumf2 = sumf2 + sfluxrefo(iprsm)
1188 : enddo
1189 4608 : rayl(igc) = sumf1
1190 5376 : sfluxref(igc) = sumf2
1191 : enddo
1192 :
1193 768 : end subroutine cmbgb26
1194 :
1195 : !***************************************************************************
1196 768 : subroutine cmbgb27
1197 : !***************************************************************************
1198 : !
1199 : ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1200 : !-----------------------------------------------------------------------
1201 :
1202 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1203 : use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
1204 : ka, kb, sfluxref, rayl
1205 :
1206 : ! ------- Local -------
1207 : integer :: jt, jp, igc, ipr, iprsm
1208 : real(kind=r8) :: sumk, sumf1, sumf2
1209 :
1210 :
1211 4608 : do jt = 1,5
1212 53760 : do jp = 1,13
1213 49920 : iprsm = 0
1214 453120 : do igc = 1,ngc(12)
1215 399360 : sumk = 0.
1216 1198080 : do ipr = 1, ngn(ngs(11)+igc)
1217 798720 : iprsm = iprsm + 1
1218 1198080 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
1219 : enddo
1220 449280 : ka(jt,jp,igc) = sumk
1221 : enddo
1222 : enddo
1223 185088 : do jp = 13,59
1224 180480 : iprsm = 0
1225 1628160 : do igc = 1,ngc(12)
1226 1443840 : sumk = 0.
1227 4331520 : do ipr = 1, ngn(ngs(11)+igc)
1228 2887680 : iprsm = iprsm + 1
1229 4331520 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
1230 : enddo
1231 1624320 : kb(jt,jp,igc) = sumk
1232 : enddo
1233 : enddo
1234 : enddo
1235 :
1236 768 : iprsm = 0
1237 6912 : do igc = 1,ngc(12)
1238 6144 : sumf1 = 0.
1239 6144 : sumf2 = 0.
1240 18432 : do ipr = 1, ngn(ngs(11)+igc)
1241 12288 : iprsm = iprsm + 1
1242 12288 : sumf1 = sumf1 + sfluxrefo(iprsm)
1243 18432 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
1244 : enddo
1245 6144 : sfluxref(igc) = sumf1
1246 6912 : rayl(igc) = sumf2
1247 : enddo
1248 :
1249 768 : end subroutine cmbgb27
1250 :
1251 : !***************************************************************************
1252 768 : subroutine cmbgb28
1253 : !***************************************************************************
1254 : !
1255 : ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
1256 : !-----------------------------------------------------------------------
1257 :
1258 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1259 : use rrsw_kg28, only : kao, kbo, sfluxrefo, &
1260 : ka, kb, sfluxref
1261 :
1262 : ! ------- Local -------
1263 : integer :: jn, jt, jp, igc, ipr, iprsm
1264 : real(kind=r8) :: sumk, sumf
1265 :
1266 :
1267 7680 : do jn = 1,9
1268 42240 : do jt = 1,5
1269 490752 : do jp = 1,13
1270 449280 : iprsm = 0
1271 3179520 : do igc = 1,ngc(13)
1272 2695680 : sumk = 0.
1273 9884160 : do ipr = 1, ngn(ngs(12)+igc)
1274 7188480 : iprsm = iprsm + 1
1275 9884160 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1276 : enddo
1277 3144960 : ka(jn,jt,jp,igc) = sumk
1278 : enddo
1279 : enddo
1280 : enddo
1281 : enddo
1282 :
1283 4608 : do jn = 1,5
1284 23808 : do jt = 1,5
1285 925440 : do jp = 13,59
1286 902400 : iprsm = 0
1287 6336000 : do igc = 1,ngc(13)
1288 5414400 : sumk = 0.
1289 19852800 : do ipr = 1, ngn(ngs(12)+igc)
1290 14438400 : iprsm = iprsm + 1
1291 19852800 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1292 : enddo
1293 6316800 : kb(jn,jt,jp,igc) = sumk
1294 : enddo
1295 : enddo
1296 : enddo
1297 : enddo
1298 :
1299 4608 : do jp = 1,5
1300 3840 : iprsm = 0
1301 27648 : do igc = 1,ngc(13)
1302 23040 : sumf = 0.
1303 84480 : do ipr = 1, ngn(ngs(12)+igc)
1304 61440 : iprsm = iprsm + 1
1305 84480 : sumf = sumf + sfluxrefo(iprsm,jp)
1306 : enddo
1307 26880 : sfluxref(igc,jp) = sumf
1308 : enddo
1309 : enddo
1310 :
1311 768 : end subroutine cmbgb28
1312 :
1313 : !***************************************************************************
1314 768 : subroutine cmbgb29
1315 : !***************************************************************************
1316 : !
1317 : ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1318 : !-----------------------------------------------------------------------
1319 :
1320 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1321 : use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
1322 : absh2oo, absco2o, &
1323 : ka, kb, selfref, forref, sfluxref, &
1324 : absh2o, absco2
1325 :
1326 : ! ------- Local -------
1327 : integer :: jt, jp, igc, ipr, iprsm
1328 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3
1329 :
1330 :
1331 4608 : do jt = 1,5
1332 53760 : do jp = 1,13
1333 49920 : iprsm = 0
1334 652800 : do igc = 1,ngc(14)
1335 599040 : sumk = 0.
1336 1397760 : do ipr = 1, ngn(ngs(13)+igc)
1337 798720 : iprsm = iprsm + 1
1338 1397760 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
1339 : enddo
1340 648960 : ka(jt,jp,igc) = sumk
1341 : enddo
1342 : enddo
1343 185088 : do jp = 13,59
1344 180480 : iprsm = 0
1345 2350080 : do igc = 1,ngc(14)
1346 2165760 : sumk = 0.
1347 5053440 : do ipr = 1, ngn(ngs(13)+igc)
1348 2887680 : iprsm = iprsm + 1
1349 5053440 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
1350 : enddo
1351 2346240 : kb(jt,jp,igc) = sumk
1352 : enddo
1353 : enddo
1354 : enddo
1355 :
1356 8448 : do jt = 1,10
1357 7680 : iprsm = 0
1358 100608 : do igc = 1,ngc(14)
1359 92160 : sumk = 0.
1360 215040 : do ipr = 1, ngn(ngs(13)+igc)
1361 122880 : iprsm = iprsm + 1
1362 215040 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
1363 : enddo
1364 99840 : selfref(jt,igc) = sumk
1365 : enddo
1366 : enddo
1367 :
1368 3840 : do jt = 1,4
1369 3072 : iprsm = 0
1370 40704 : do igc = 1,ngc(14)
1371 36864 : sumk = 0.
1372 86016 : do ipr = 1, ngn(ngs(13)+igc)
1373 49152 : iprsm = iprsm + 1
1374 86016 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
1375 : enddo
1376 39936 : forref(jt,igc) = sumk
1377 : enddo
1378 : enddo
1379 :
1380 768 : iprsm = 0
1381 9984 : do igc = 1,ngc(14)
1382 9216 : sumf1 = 0.
1383 9216 : sumf2 = 0.
1384 9216 : sumf3 = 0.
1385 21504 : do ipr = 1, ngn(ngs(13)+igc)
1386 12288 : iprsm = iprsm + 1
1387 12288 : sumf1 = sumf1 + sfluxrefo(iprsm)
1388 12288 : sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
1389 21504 : sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
1390 : enddo
1391 9216 : sfluxref(igc) = sumf1
1392 9216 : absco2(igc) = sumf2
1393 9984 : absh2o(igc) = sumf3
1394 : enddo
1395 :
1396 768 : end subroutine cmbgb29
1397 :
1398 : !***************************************************************************
1399 :
1400 :
1401 : end module rrtmg_sw_init
1402 :
1403 :
|
