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 1536 : 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 1536 : call swdatinit
65 1536 : call swcmbdat ! g-point interval reduction data
66 1536 : call swatmref ! reference MLS profile
67 1536 : call sw_kgb16 ! molecular absorption coefficients
68 1536 : call sw_kgb17
69 1536 : call sw_kgb18
70 1536 : call sw_kgb19
71 1536 : call sw_kgb20
72 1536 : call sw_kgb21
73 1536 : call sw_kgb22
74 1536 : call sw_kgb23
75 1536 : call sw_kgb24
76 1536 : call sw_kgb25
77 1536 : call sw_kgb26
78 1536 : call sw_kgb27
79 1536 : call sw_kgb28
80 1536 : 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 1536 : exp_tbl(0) = 1.0_r8
89 1536 : exp_tbl(ntbl) = 0.0_r8
90 1536 : bpade = 1.0_r8 / pade
91 15360000 : do itr = 1, ntbl-1
92 15358464 : tfn = float(itr) / float(ntbl)
93 15358464 : tau_tbl = bpade * tfn / (1._r8 - tfn)
94 15360000 : 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 23040 : do ibnd = 1,nbndsw
104 21504 : iprsm = 0
105 23040 : if (ngc(ibnd).lt.mg) then
106 193536 : do igc = 1,ngc(ibnd)
107 172032 : igcsm = igcsm + 1
108 172032 : wtsum = 0.
109 516096 : do ipr = 1, ngn(igcsm)
110 344064 : iprsm = iprsm + 1
111 516096 : wtsum = wtsum + wt(iprsm)
112 : enddo
113 193536 : wtsm(igc) = wtsum
114 : enddo
115 365568 : do ig = 1, ng(ibnd+15)
116 344064 : ind = (ibnd-1)*mg + ig
117 365568 : 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 1536 : call cmbgb16s
131 1536 : call cmbgb17
132 1536 : call cmbgb18
133 1536 : call cmbgb19
134 1536 : call cmbgb20
135 1536 : call cmbgb21
136 1536 : call cmbgb22
137 1536 : call cmbgb23
138 1536 : call cmbgb24
139 1536 : call cmbgb25
140 1536 : call cmbgb26
141 1536 : call cmbgb27
142 1536 : call cmbgb28
143 1536 : call cmbgb29
144 :
145 1536 : end subroutine rrtmg_sw_ini
146 :
147 : !***************************************************************************
148 1536 : 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 1536 : 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 1536 : 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 1536 : 4800._r8, 3150._r8, 6650._r8, 6350._r8, 9000._r8,12000._r8, 1780._r8/)
168 :
169 : ! Spectral band information
170 1536 : ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
171 1536 : nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
172 1536 : 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 1536 : grav = gravit
176 1536 : 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 1536 : 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 1536 : planck = 6.62606876e-27_r8
192 1536 : boltz = 1.3806503e-16_r8
193 1536 : clight = 2.99792458e+10_r8
194 : ! avogad = 6.02214199e+23_r8
195 1536 : alosmt = 2.6867775e+19_r8
196 1536 : gascon = 8.31447200e+07_r8
197 1536 : radcn1 = 1.191042722e-12_r8
198 1536 : 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 1536 : end subroutine swdatinit
209 :
210 : !***************************************************************************
211 1536 : 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 1536 : ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
237 1536 : 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 1536 : 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 1536 : 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 1536 : 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 1536 : 0.0000750000_r8 /)
335 :
336 1536 : end subroutine swcmbdat
337 :
338 : !***************************************************************************
339 1536 : 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 15360 : do jn = 1,9
368 84480 : do jt = 1,5
369 981504 : do jp = 1,13
370 898560 : iprsm = 0
371 6359040 : do igc = 1,ngc(1)
372 5391360 : sumk = 0.
373 19768320 : do ipr = 1, ngn(igc)
374 14376960 : iprsm = iprsm + 1
375 19768320 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
376 : enddo
377 6289920 : ka(jn,jt,jp,igc) = sumk
378 : enddo
379 : enddo
380 : enddo
381 : enddo
382 :
383 9216 : do jt = 1,5
384 370176 : do jp = 13,59
385 360960 : iprsm = 0
386 2534400 : do igc = 1,ngc(1)
387 2165760 : sumk = 0.
388 7941120 : do ipr = 1, ngn(igc)
389 5775360 : iprsm = iprsm + 1
390 7941120 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
391 : enddo
392 2526720 : kb(jt,jp,igc) = sumk
393 : enddo
394 : enddo
395 : enddo
396 :
397 16896 : do jt = 1,10
398 15360 : iprsm = 0
399 109056 : do igc = 1,ngc(1)
400 92160 : sumk = 0.
401 337920 : do ipr = 1, ngn(igc)
402 245760 : iprsm = iprsm + 1
403 337920 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
404 : enddo
405 107520 : selfref(jt,igc) = sumk
406 : enddo
407 : enddo
408 :
409 6144 : do jt = 1,3
410 4608 : iprsm = 0
411 33792 : do igc = 1,ngc(1)
412 27648 : sumk = 0.
413 101376 : do ipr = 1, ngn(igc)
414 73728 : iprsm = iprsm + 1
415 101376 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
416 : enddo
417 32256 : forref(jt,igc) = sumk
418 : enddo
419 : enddo
420 :
421 1536 : iprsm = 0
422 10752 : do igc = 1,ngc(1)
423 9216 : sumf = 0.
424 33792 : do ipr = 1, ngn(igc)
425 24576 : iprsm = iprsm + 1
426 33792 : sumf = sumf + sfluxrefo(iprsm)
427 : enddo
428 10752 : sfluxref(igc) = sumf
429 : enddo
430 :
431 1536 : end subroutine cmbgb16s
432 :
433 : !***************************************************************************
434 1536 : 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 15360 : do jn = 1,9
450 84480 : do jt = 1,5
451 981504 : do jp = 1,13
452 898560 : iprsm = 0
453 11750400 : do igc = 1,ngc(2)
454 10782720 : sumk = 0.
455 25159680 : do ipr = 1, ngn(ngs(1)+igc)
456 14376960 : iprsm = iprsm + 1
457 25159680 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
458 : enddo
459 11681280 : ka(jn,jt,jp,igc) = sumk
460 : enddo
461 : enddo
462 : enddo
463 : enddo
464 :
465 9216 : do jn = 1,5
466 47616 : do jt = 1,5
467 1850880 : do jp = 13,59
468 1804800 : iprsm = 0
469 23500800 : do igc = 1,ngc(2)
470 21657600 : sumk = 0.
471 50534400 : do ipr = 1, ngn(ngs(1)+igc)
472 28876800 : iprsm = iprsm + 1
473 50534400 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
474 : enddo
475 23462400 : kb(jn,jt,jp,igc) = sumk
476 : enddo
477 : enddo
478 : enddo
479 : enddo
480 :
481 16896 : do jt = 1,10
482 15360 : iprsm = 0
483 201216 : do igc = 1,ngc(2)
484 184320 : sumk = 0.
485 430080 : do ipr = 1, ngn(ngs(1)+igc)
486 245760 : iprsm = iprsm + 1
487 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
488 : enddo
489 199680 : selfref(jt,igc) = sumk
490 : enddo
491 : enddo
492 :
493 7680 : do jt = 1,4
494 6144 : iprsm = 0
495 81408 : do igc = 1,ngc(2)
496 73728 : sumk = 0.
497 172032 : do ipr = 1, ngn(ngs(1)+igc)
498 98304 : iprsm = iprsm + 1
499 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
500 : enddo
501 79872 : forref(jt,igc) = sumk
502 : enddo
503 : enddo
504 :
505 9216 : do jp = 1,5
506 7680 : iprsm = 0
507 101376 : do igc = 1,ngc(2)
508 92160 : sumf = 0.
509 215040 : do ipr = 1, ngn(ngs(1)+igc)
510 122880 : iprsm = iprsm + 1
511 215040 : sumf = sumf + sfluxrefo(iprsm,jp)
512 : enddo
513 99840 : sfluxref(igc,jp) = sumf
514 : enddo
515 : enddo
516 :
517 1536 : end subroutine cmbgb17
518 :
519 : !***************************************************************************
520 1536 : 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 15360 : do jn = 1,9
536 84480 : do jt = 1,5
537 981504 : do jp = 1,13
538 898560 : iprsm = 0
539 8156160 : do igc = 1,ngc(3)
540 7188480 : sumk = 0.
541 21565440 : do ipr = 1, ngn(ngs(2)+igc)
542 14376960 : iprsm = iprsm + 1
543 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
544 : enddo
545 8087040 : ka(jn,jt,jp,igc) = sumk
546 : enddo
547 : enddo
548 : enddo
549 : enddo
550 :
551 9216 : do jt = 1,5
552 370176 : do jp = 13,59
553 360960 : iprsm = 0
554 3256320 : do igc = 1,ngc(3)
555 2887680 : sumk = 0.
556 8663040 : do ipr = 1, ngn(ngs(2)+igc)
557 5775360 : iprsm = iprsm + 1
558 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
559 : enddo
560 3248640 : kb(jt,jp,igc) = sumk
561 : enddo
562 : enddo
563 : enddo
564 :
565 16896 : do jt = 1,10
566 15360 : iprsm = 0
567 139776 : do igc = 1,ngc(3)
568 122880 : sumk = 0.
569 368640 : do ipr = 1, ngn(ngs(2)+igc)
570 245760 : iprsm = iprsm + 1
571 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
572 : enddo
573 138240 : selfref(jt,igc) = sumk
574 : enddo
575 : enddo
576 :
577 6144 : do jt = 1,3
578 4608 : iprsm = 0
579 43008 : do igc = 1,ngc(3)
580 36864 : sumk = 0.
581 110592 : do ipr = 1, ngn(ngs(2)+igc)
582 73728 : iprsm = iprsm + 1
583 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
584 : enddo
585 41472 : forref(jt,igc) = sumk
586 : enddo
587 : enddo
588 :
589 15360 : do jp = 1,9
590 13824 : iprsm = 0
591 125952 : do igc = 1,ngc(3)
592 110592 : sumf = 0.
593 331776 : do ipr = 1, ngn(ngs(2)+igc)
594 221184 : iprsm = iprsm + 1
595 331776 : sumf = sumf + sfluxrefo(iprsm,jp)
596 : enddo
597 124416 : sfluxref(igc,jp) = sumf
598 : enddo
599 : enddo
600 :
601 1536 : end subroutine cmbgb18
602 :
603 : !***************************************************************************
604 1536 : 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 15360 : do jn = 1,9
620 84480 : do jt = 1,5
621 981504 : do jp = 1,13
622 898560 : iprsm = 0
623 8156160 : do igc = 1,ngc(4)
624 7188480 : sumk = 0.
625 21565440 : do ipr = 1, ngn(ngs(3)+igc)
626 14376960 : iprsm = iprsm + 1
627 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
628 : enddo
629 8087040 : ka(jn,jt,jp,igc) = sumk
630 : enddo
631 : enddo
632 : enddo
633 : enddo
634 :
635 9216 : do jt = 1,5
636 370176 : do jp = 13,59
637 360960 : iprsm = 0
638 3256320 : do igc = 1,ngc(4)
639 2887680 : sumk = 0.
640 8663040 : do ipr = 1, ngn(ngs(3)+igc)
641 5775360 : iprsm = iprsm + 1
642 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
643 : enddo
644 3248640 : kb(jt,jp,igc) = sumk
645 : enddo
646 : enddo
647 : enddo
648 :
649 16896 : do jt = 1,10
650 15360 : iprsm = 0
651 139776 : do igc = 1,ngc(4)
652 122880 : sumk = 0.
653 368640 : do ipr = 1, ngn(ngs(3)+igc)
654 245760 : iprsm = iprsm + 1
655 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
656 : enddo
657 138240 : selfref(jt,igc) = sumk
658 : enddo
659 : enddo
660 :
661 6144 : do jt = 1,3
662 4608 : iprsm = 0
663 43008 : do igc = 1,ngc(4)
664 36864 : sumk = 0.
665 110592 : do ipr = 1, ngn(ngs(3)+igc)
666 73728 : iprsm = iprsm + 1
667 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
668 : enddo
669 41472 : forref(jt,igc) = sumk
670 : enddo
671 : enddo
672 :
673 15360 : do jp = 1,9
674 13824 : iprsm = 0
675 125952 : do igc = 1,ngc(4)
676 110592 : sumf = 0.
677 331776 : do ipr = 1, ngn(ngs(3)+igc)
678 221184 : iprsm = iprsm + 1
679 331776 : sumf = sumf + sfluxrefo(iprsm,jp)
680 : enddo
681 124416 : sfluxref(igc,jp) = sumf
682 : enddo
683 : enddo
684 :
685 1536 : end subroutine cmbgb19
686 :
687 : !***************************************************************************
688 1536 : 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 9216 : do jt = 1,5
704 107520 : do jp = 1,13
705 99840 : iprsm = 0
706 1105920 : do igc = 1,ngc(5)
707 998400 : sumk = 0.
708 2595840 : do ipr = 1, ngn(ngs(4)+igc)
709 1597440 : iprsm = iprsm + 1
710 2595840 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
711 : enddo
712 1098240 : ka(jt,jp,igc) = sumk
713 : enddo
714 : enddo
715 370176 : do jp = 13,59
716 360960 : iprsm = 0
717 3978240 : do igc = 1,ngc(5)
718 3609600 : sumk = 0.
719 9384960 : do ipr = 1, ngn(ngs(4)+igc)
720 5775360 : iprsm = iprsm + 1
721 9384960 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
722 : enddo
723 3970560 : kb(jt,jp,igc) = sumk
724 : enddo
725 : enddo
726 : enddo
727 :
728 16896 : do jt = 1,10
729 15360 : iprsm = 0
730 170496 : do igc = 1,ngc(5)
731 153600 : sumk = 0.
732 399360 : do ipr = 1, ngn(ngs(4)+igc)
733 245760 : iprsm = iprsm + 1
734 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
735 : enddo
736 168960 : selfref(jt,igc) = sumk
737 : enddo
738 : enddo
739 :
740 7680 : do jt = 1,4
741 6144 : iprsm = 0
742 69120 : do igc = 1,ngc(5)
743 61440 : sumk = 0.
744 159744 : do ipr = 1, ngn(ngs(4)+igc)
745 98304 : iprsm = iprsm + 1
746 159744 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
747 : enddo
748 67584 : forref(jt,igc) = sumk
749 : enddo
750 : enddo
751 :
752 1536 : iprsm = 0
753 16896 : do igc = 1,ngc(5)
754 15360 : sumf1 = 0.
755 15360 : sumf2 = 0.
756 39936 : do ipr = 1, ngn(ngs(4)+igc)
757 24576 : iprsm = iprsm + 1
758 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
759 39936 : sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
760 : enddo
761 15360 : sfluxref(igc) = sumf1
762 16896 : absch4(igc) = sumf2
763 : enddo
764 :
765 1536 : end subroutine cmbgb20
766 :
767 : !***************************************************************************
768 1536 : 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 15360 : do jn = 1,9
784 84480 : do jt = 1,5
785 981504 : do jp = 1,13
786 898560 : iprsm = 0
787 9953280 : do igc = 1,ngc(6)
788 8985600 : sumk = 0.
789 23362560 : do ipr = 1, ngn(ngs(5)+igc)
790 14376960 : iprsm = iprsm + 1
791 23362560 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
792 : enddo
793 9884160 : ka(jn,jt,jp,igc) = sumk
794 : enddo
795 : enddo
796 : enddo
797 : enddo
798 :
799 9216 : do jn = 1,5
800 47616 : do jt = 1,5
801 1850880 : do jp = 13,59
802 1804800 : iprsm = 0
803 19891200 : do igc = 1,ngc(6)
804 18048000 : sumk = 0.
805 46924800 : do ipr = 1, ngn(ngs(5)+igc)
806 28876800 : iprsm = iprsm + 1
807 46924800 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
808 : enddo
809 19852800 : kb(jn,jt,jp,igc) = sumk
810 : enddo
811 : enddo
812 : enddo
813 : enddo
814 :
815 16896 : do jt = 1,10
816 15360 : iprsm = 0
817 170496 : do igc = 1,ngc(6)
818 153600 : sumk = 0.
819 399360 : do ipr = 1, ngn(ngs(5)+igc)
820 245760 : iprsm = iprsm + 1
821 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
822 : enddo
823 168960 : selfref(jt,igc) = sumk
824 : enddo
825 : enddo
826 :
827 7680 : do jt = 1,4
828 6144 : iprsm = 0
829 69120 : do igc = 1,ngc(6)
830 61440 : sumk = 0.
831 159744 : do ipr = 1, ngn(ngs(5)+igc)
832 98304 : iprsm = iprsm + 1
833 159744 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
834 : enddo
835 67584 : forref(jt,igc) = sumk
836 : enddo
837 : enddo
838 :
839 15360 : do jp = 1,9
840 13824 : iprsm = 0
841 153600 : do igc = 1,ngc(6)
842 138240 : sumf = 0.
843 359424 : do ipr = 1, ngn(ngs(5)+igc)
844 221184 : iprsm = iprsm + 1
845 359424 : sumf = sumf + sfluxrefo(iprsm,jp)
846 : enddo
847 152064 : sfluxref(igc,jp) = sumf
848 : enddo
849 : enddo
850 :
851 1536 : end subroutine cmbgb21
852 :
853 : !***************************************************************************
854 1536 : 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 15360 : do jn = 1,9
870 84480 : do jt = 1,5
871 981504 : do jp = 1,13
872 898560 : iprsm = 0
873 2764800 : do igc = 1,ngc(7)
874 1797120 : sumk = 0.
875 16174080 : do ipr = 1, ngn(ngs(6)+igc)
876 14376960 : iprsm = iprsm + 1
877 16174080 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
878 : enddo
879 2695680 : ka(jn,jt,jp,igc) = sumk
880 : enddo
881 : enddo
882 : enddo
883 : enddo
884 :
885 9216 : do jt = 1,5
886 370176 : do jp = 13,59
887 360960 : iprsm = 0
888 1090560 : do igc = 1,ngc(7)
889 721920 : sumk = 0.
890 6497280 : do ipr = 1, ngn(ngs(6)+igc)
891 5775360 : iprsm = iprsm + 1
892 6497280 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
893 : enddo
894 1082880 : kb(jt,jp,igc) = sumk
895 : enddo
896 : enddo
897 : enddo
898 :
899 16896 : do jt = 1,10
900 15360 : iprsm = 0
901 47616 : do igc = 1,ngc(7)
902 30720 : sumk = 0.
903 276480 : do ipr = 1, ngn(ngs(6)+igc)
904 245760 : iprsm = iprsm + 1
905 276480 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
906 : enddo
907 46080 : selfref(jt,igc) = sumk
908 : enddo
909 : enddo
910 :
911 6144 : do jt = 1,3
912 4608 : iprsm = 0
913 15360 : do igc = 1,ngc(7)
914 9216 : sumk = 0.
915 82944 : do ipr = 1, ngn(ngs(6)+igc)
916 73728 : iprsm = iprsm + 1
917 82944 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
918 : enddo
919 13824 : forref(jt,igc) = sumk
920 : enddo
921 : enddo
922 :
923 15360 : do jp = 1,9
924 13824 : iprsm = 0
925 43008 : do igc = 1,ngc(7)
926 27648 : sumf = 0.
927 248832 : do ipr = 1, ngn(ngs(6)+igc)
928 221184 : iprsm = iprsm + 1
929 248832 : sumf = sumf + sfluxrefo(iprsm,jp)
930 : enddo
931 41472 : sfluxref(igc,jp) = sumf
932 : enddo
933 : enddo
934 :
935 1536 : end subroutine cmbgb22
936 :
937 : !***************************************************************************
938 1536 : 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 9216 : do jt = 1,5
954 109056 : do jp = 1,13
955 99840 : iprsm = 0
956 1105920 : do igc = 1,ngc(8)
957 998400 : sumk = 0.
958 2595840 : do ipr = 1, ngn(ngs(7)+igc)
959 1597440 : iprsm = iprsm + 1
960 2595840 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
961 : enddo
962 1098240 : ka(jt,jp,igc) = sumk
963 : enddo
964 : enddo
965 : enddo
966 :
967 16896 : do jt = 1,10
968 15360 : iprsm = 0
969 170496 : do igc = 1,ngc(8)
970 153600 : sumk = 0.
971 399360 : do ipr = 1, ngn(ngs(7)+igc)
972 245760 : iprsm = iprsm + 1
973 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
974 : enddo
975 168960 : selfref(jt,igc) = sumk
976 : enddo
977 : enddo
978 :
979 6144 : do jt = 1,3
980 4608 : iprsm = 0
981 52224 : do igc = 1,ngc(8)
982 46080 : sumk = 0.
983 119808 : do ipr = 1, ngn(ngs(7)+igc)
984 73728 : iprsm = iprsm + 1
985 119808 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
986 : enddo
987 50688 : forref(jt,igc) = sumk
988 : enddo
989 : enddo
990 :
991 1536 : iprsm = 0
992 16896 : do igc = 1,ngc(8)
993 15360 : sumf1 = 0.
994 15360 : sumf2 = 0.
995 39936 : do ipr = 1, ngn(ngs(7)+igc)
996 24576 : iprsm = iprsm + 1
997 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
998 39936 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
999 : enddo
1000 15360 : sfluxref(igc) = sumf1
1001 16896 : rayl(igc) = sumf2
1002 : enddo
1003 :
1004 1536 : end subroutine cmbgb23
1005 :
1006 : !***************************************************************************
1007 1536 : 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 15360 : do jn = 1,9
1025 84480 : do jt = 1,5
1026 981504 : do jp = 1,13
1027 898560 : iprsm = 0
1028 8156160 : do igc = 1,ngc(9)
1029 7188480 : sumk = 0.
1030 21565440 : do ipr = 1, ngn(ngs(8)+igc)
1031 14376960 : iprsm = iprsm + 1
1032 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
1033 : enddo
1034 8087040 : ka(jn,jt,jp,igc) = sumk
1035 : enddo
1036 : enddo
1037 : enddo
1038 : enddo
1039 :
1040 9216 : do jt = 1,5
1041 370176 : do jp = 13,59
1042 360960 : iprsm = 0
1043 3256320 : do igc = 1,ngc(9)
1044 2887680 : sumk = 0.
1045 8663040 : do ipr = 1, ngn(ngs(8)+igc)
1046 5775360 : iprsm = iprsm + 1
1047 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
1048 : enddo
1049 3248640 : kb(jt,jp,igc) = sumk
1050 : enddo
1051 : enddo
1052 : enddo
1053 :
1054 16896 : do jt = 1,10
1055 15360 : iprsm = 0
1056 139776 : do igc = 1,ngc(9)
1057 122880 : sumk = 0.
1058 368640 : do ipr = 1, ngn(ngs(8)+igc)
1059 245760 : iprsm = iprsm + 1
1060 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
1061 : enddo
1062 138240 : selfref(jt,igc) = sumk
1063 : enddo
1064 : enddo
1065 :
1066 6144 : do jt = 1,3
1067 4608 : iprsm = 0
1068 43008 : do igc = 1,ngc(9)
1069 36864 : sumk = 0.
1070 110592 : do ipr = 1, ngn(ngs(8)+igc)
1071 73728 : iprsm = iprsm + 1
1072 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
1073 : enddo
1074 41472 : forref(jt,igc) = sumk
1075 : enddo
1076 : enddo
1077 :
1078 1536 : iprsm = 0
1079 13824 : do igc = 1,ngc(9)
1080 12288 : sumf1 = 0.
1081 12288 : sumf2 = 0.
1082 12288 : sumf3 = 0.
1083 36864 : do ipr = 1, ngn(ngs(8)+igc)
1084 24576 : iprsm = iprsm + 1
1085 24576 : sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
1086 24576 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
1087 36864 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
1088 : enddo
1089 12288 : raylb(igc) = sumf1
1090 12288 : abso3a(igc) = sumf2
1091 13824 : abso3b(igc) = sumf3
1092 : enddo
1093 :
1094 15360 : do jp = 1,9
1095 : iprsm = 0
1096 125952 : do igc = 1,ngc(9)
1097 110592 : sumf1 = 0.
1098 110592 : sumf2 = 0.
1099 331776 : do ipr = 1, ngn(ngs(8)+igc)
1100 221184 : iprsm = iprsm + 1
1101 221184 : sumf1 = sumf1 + sfluxrefo(iprsm,jp)
1102 331776 : sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
1103 : enddo
1104 110592 : sfluxref(igc,jp) = sumf1
1105 124416 : rayla(igc,jp) = sumf2
1106 : enddo
1107 : enddo
1108 :
1109 1536 : end subroutine cmbgb24
1110 :
1111 : !***************************************************************************
1112 1536 : 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 9216 : do jt = 1,5
1130 109056 : do jp = 1,13
1131 99840 : iprsm = 0
1132 706560 : do igc = 1,ngc(10)
1133 599040 : sumk = 0.
1134 2196480 : do ipr = 1, ngn(ngs(9)+igc)
1135 1597440 : iprsm = iprsm + 1
1136 2196480 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
1137 : enddo
1138 698880 : ka(jt,jp,igc) = sumk
1139 : enddo
1140 : enddo
1141 : enddo
1142 :
1143 1536 : iprsm = 0
1144 10752 : do igc = 1,ngc(10)
1145 9216 : sumf1 = 0.
1146 9216 : sumf2 = 0.
1147 9216 : sumf3 = 0.
1148 9216 : sumf4 = 0.
1149 33792 : do ipr = 1, ngn(ngs(9)+igc)
1150 24576 : iprsm = iprsm + 1
1151 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1152 24576 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
1153 24576 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
1154 33792 : sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
1155 : enddo
1156 9216 : sfluxref(igc) = sumf1
1157 9216 : abso3a(igc) = sumf2
1158 9216 : abso3b(igc) = sumf3
1159 10752 : rayl(igc) = sumf4
1160 : enddo
1161 :
1162 1536 : end subroutine cmbgb25
1163 :
1164 : !***************************************************************************
1165 1536 : 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 1536 : iprsm = 0
1181 10752 : do igc = 1,ngc(11)
1182 9216 : sumf1 = 0.
1183 9216 : sumf2 = 0.
1184 33792 : do ipr = 1, ngn(ngs(10)+igc)
1185 24576 : iprsm = iprsm + 1
1186 24576 : sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
1187 33792 : sumf2 = sumf2 + sfluxrefo(iprsm)
1188 : enddo
1189 9216 : rayl(igc) = sumf1
1190 10752 : sfluxref(igc) = sumf2
1191 : enddo
1192 :
1193 1536 : end subroutine cmbgb26
1194 :
1195 : !***************************************************************************
1196 1536 : 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 9216 : do jt = 1,5
1212 107520 : do jp = 1,13
1213 99840 : iprsm = 0
1214 906240 : do igc = 1,ngc(12)
1215 798720 : sumk = 0.
1216 2396160 : do ipr = 1, ngn(ngs(11)+igc)
1217 1597440 : iprsm = iprsm + 1
1218 2396160 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
1219 : enddo
1220 898560 : ka(jt,jp,igc) = sumk
1221 : enddo
1222 : enddo
1223 370176 : do jp = 13,59
1224 360960 : iprsm = 0
1225 3256320 : do igc = 1,ngc(12)
1226 2887680 : sumk = 0.
1227 8663040 : do ipr = 1, ngn(ngs(11)+igc)
1228 5775360 : iprsm = iprsm + 1
1229 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
1230 : enddo
1231 3248640 : kb(jt,jp,igc) = sumk
1232 : enddo
1233 : enddo
1234 : enddo
1235 :
1236 1536 : iprsm = 0
1237 13824 : do igc = 1,ngc(12)
1238 12288 : sumf1 = 0.
1239 12288 : sumf2 = 0.
1240 36864 : do ipr = 1, ngn(ngs(11)+igc)
1241 24576 : iprsm = iprsm + 1
1242 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1243 36864 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
1244 : enddo
1245 12288 : sfluxref(igc) = sumf1
1246 13824 : rayl(igc) = sumf2
1247 : enddo
1248 :
1249 1536 : end subroutine cmbgb27
1250 :
1251 : !***************************************************************************
1252 1536 : 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 15360 : do jn = 1,9
1268 84480 : do jt = 1,5
1269 981504 : do jp = 1,13
1270 898560 : iprsm = 0
1271 6359040 : do igc = 1,ngc(13)
1272 5391360 : sumk = 0.
1273 19768320 : do ipr = 1, ngn(ngs(12)+igc)
1274 14376960 : iprsm = iprsm + 1
1275 19768320 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1276 : enddo
1277 6289920 : ka(jn,jt,jp,igc) = sumk
1278 : enddo
1279 : enddo
1280 : enddo
1281 : enddo
1282 :
1283 9216 : do jn = 1,5
1284 47616 : do jt = 1,5
1285 1850880 : do jp = 13,59
1286 1804800 : iprsm = 0
1287 12672000 : do igc = 1,ngc(13)
1288 10828800 : sumk = 0.
1289 39705600 : do ipr = 1, ngn(ngs(12)+igc)
1290 28876800 : iprsm = iprsm + 1
1291 39705600 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1292 : enddo
1293 12633600 : kb(jn,jt,jp,igc) = sumk
1294 : enddo
1295 : enddo
1296 : enddo
1297 : enddo
1298 :
1299 9216 : do jp = 1,5
1300 7680 : iprsm = 0
1301 55296 : do igc = 1,ngc(13)
1302 46080 : sumf = 0.
1303 168960 : do ipr = 1, ngn(ngs(12)+igc)
1304 122880 : iprsm = iprsm + 1
1305 168960 : sumf = sumf + sfluxrefo(iprsm,jp)
1306 : enddo
1307 53760 : sfluxref(igc,jp) = sumf
1308 : enddo
1309 : enddo
1310 :
1311 1536 : end subroutine cmbgb28
1312 :
1313 : !***************************************************************************
1314 1536 : 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 9216 : do jt = 1,5
1332 107520 : do jp = 1,13
1333 99840 : iprsm = 0
1334 1305600 : do igc = 1,ngc(14)
1335 1198080 : sumk = 0.
1336 2795520 : do ipr = 1, ngn(ngs(13)+igc)
1337 1597440 : iprsm = iprsm + 1
1338 2795520 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
1339 : enddo
1340 1297920 : ka(jt,jp,igc) = sumk
1341 : enddo
1342 : enddo
1343 370176 : do jp = 13,59
1344 360960 : iprsm = 0
1345 4700160 : do igc = 1,ngc(14)
1346 4331520 : sumk = 0.
1347 10106880 : do ipr = 1, ngn(ngs(13)+igc)
1348 5775360 : iprsm = iprsm + 1
1349 10106880 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
1350 : enddo
1351 4692480 : kb(jt,jp,igc) = sumk
1352 : enddo
1353 : enddo
1354 : enddo
1355 :
1356 16896 : do jt = 1,10
1357 15360 : iprsm = 0
1358 201216 : do igc = 1,ngc(14)
1359 184320 : sumk = 0.
1360 430080 : do ipr = 1, ngn(ngs(13)+igc)
1361 245760 : iprsm = iprsm + 1
1362 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
1363 : enddo
1364 199680 : selfref(jt,igc) = sumk
1365 : enddo
1366 : enddo
1367 :
1368 7680 : do jt = 1,4
1369 6144 : iprsm = 0
1370 81408 : do igc = 1,ngc(14)
1371 73728 : sumk = 0.
1372 172032 : do ipr = 1, ngn(ngs(13)+igc)
1373 98304 : iprsm = iprsm + 1
1374 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
1375 : enddo
1376 79872 : forref(jt,igc) = sumk
1377 : enddo
1378 : enddo
1379 :
1380 1536 : iprsm = 0
1381 19968 : do igc = 1,ngc(14)
1382 18432 : sumf1 = 0.
1383 18432 : sumf2 = 0.
1384 18432 : sumf3 = 0.
1385 43008 : do ipr = 1, ngn(ngs(13)+igc)
1386 24576 : iprsm = iprsm + 1
1387 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1388 24576 : sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
1389 43008 : sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
1390 : enddo
1391 18432 : sfluxref(igc) = sumf1
1392 18432 : absco2(igc) = sumf2
1393 19968 : absh2o(igc) = sumf3
1394 : enddo
1395 :
1396 1536 : end subroutine cmbgb29
1397 :
1398 : !***************************************************************************
1399 :
1400 :
1401 : end module rrtmg_sw_init
1402 :
1403 :
|
