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 : ! Modified values for consistency with CAM3:
186 : ! = (9.80616)(86400)(1e-5)/(1.00464)
187 : ! heatfac = 8.43339130434_r8
188 :
189 : ! Calculate heatfac directly from CAM constants:
190 1536 : heatfac = grav * cday * 1.e-5_r8 / (cpair * 1.e-3_r8)
191 :
192 : ! Constants from NIST 01/11/2002
193 :
194 : ! grav = 9.8066_r8
195 1536 : planck = 6.62606876e-27_r8
196 1536 : boltz = 1.3806503e-16_r8
197 1536 : clight = 2.99792458e+10_r8
198 : ! avogad = 6.02214199e+23_r8
199 1536 : alosmt = 2.6867775e+19_r8
200 1536 : gascon = 8.31447200e+07_r8
201 1536 : radcn1 = 1.191042722e-12_r8
202 1536 : radcn2 = 1.4387752_r8
203 :
204 : !
205 : ! units are generally cgs
206 : !
207 : ! The first and second radiation constants are taken from NIST.
208 : ! They were previously obtained from the relations:
209 : ! radcn1 = 2.*planck*clight*clight*1.e-07
210 : ! radcn2 = planck*clight/boltz
211 :
212 1536 : end subroutine swdatinit
213 :
214 : !***************************************************************************
215 1536 : subroutine swcmbdat
216 : !***************************************************************************
217 :
218 : use rrsw_wvn, only: ngc, ngs, ngn, ngb, ngm, wt
219 :
220 : save
221 :
222 : ! ------- Definitions -------
223 : ! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
224 : ! This mapping from 224 to 112 points has been carefully selected to
225 : ! minimize the effect on the resulting fluxes and cooling rates, and
226 : ! caution should be used if the mapping is modified. The full 224
227 : ! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
228 : ! ngpt The total number of new g-points
229 : ! ngc The number of new g-points in each band
230 : ! ngs The cumulative sum of new g-points for each band
231 : ! ngm The index of each new g-point relative to the original
232 : ! 16 g-points for each band.
233 : ! ngn The number of original g-points that are combined to make
234 : ! each new g-point in each band.
235 : ! ngb The band index for each new g-point.
236 : ! wt RRTM weights for 16 g-points.
237 :
238 : ! Use this set for 112 quadrature point (g-point) model
239 : ! ------- Data statements -------
240 1536 : ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
241 1536 : ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
242 : ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16
243 : 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17
244 : 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18
245 : 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19
246 : 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20
247 : 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21
248 : 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22
249 : 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23
250 : 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24
251 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25
252 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26
253 : 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27
254 : 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28
255 1536 : 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29
256 : ngn(:) = (/ 2,2,2,2,4,4, & ! band 16
257 : 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17
258 : 1,1,1,1,2,2,4,4, & ! band 18
259 : 1,1,1,1,2,2,4,4, & ! band 19
260 : 1,1,1,1,1,1,1,1,2,6, & ! band 20
261 : 1,1,1,1,1,1,1,1,2,6, & ! band 21
262 : 8,8, & ! band 22
263 : 2,2,1,1,1,1,1,1,2,4, & ! band 23
264 : 2,2,2,2,2,2,2,2, & ! band 24
265 : 1,1,2,2,4,6, & ! band 25
266 : 1,1,2,2,4,6, & ! band 26
267 : 1,1,1,1,1,1,4,6, & ! band 27
268 : 1,1,2,2,4,6, & ! band 28
269 1536 : 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29
270 : ngb(:) = (/ 16,16,16,16,16,16, & ! band 16
271 : 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
272 : 18,18,18,18,18,18,18,18, & ! band 18
273 : 19,19,19,19,19,19,19,19, & ! band 19
274 : 20,20,20,20,20,20,20,20,20,20, & ! band 20
275 : 21,21,21,21,21,21,21,21,21,21, & ! band 21
276 : 22,22, & ! band 22
277 : 23,23,23,23,23,23,23,23,23,23, & ! band 23
278 : 24,24,24,24,24,24,24,24, & ! band 24
279 : 25,25,25,25,25,25, & ! band 25
280 : 26,26,26,26,26,26, & ! band 26
281 : 27,27,27,27,27,27,27,27, & ! band 27
282 : 28,28,28,28,28,28, & ! band 28
283 1536 : 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
284 :
285 : ! Use this set for full 224 quadrature point (g-point) model
286 : ! ------- Data statements -------
287 : ! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
288 : ! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
289 : ! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
290 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
291 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
292 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
293 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
294 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
295 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
296 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
297 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
298 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
299 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
300 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
301 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
302 : ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
303 : ! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
304 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
305 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
306 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
307 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
308 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
309 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
310 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
311 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
312 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
313 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
314 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
315 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
316 : ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
317 : ! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
318 : ! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
319 : ! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
320 : ! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
321 : ! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
322 : ! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
323 : ! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
324 : ! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
325 : ! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
326 : ! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
327 : ! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
328 : ! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
329 : ! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
330 : ! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
331 :
332 :
333 : wt(:) = (/ 0.1527534276_r8, 0.1491729617_r8, 0.1420961469_r8, &
334 : 0.1316886544_r8, 0.1181945205_r8, 0.1019300893_r8, &
335 : 0.0832767040_r8, 0.0626720116_r8, 0.0424925000_r8, &
336 : 0.0046269894_r8, 0.0038279891_r8, 0.0030260086_r8, &
337 : 0.0022199750_r8, 0.0014140010_r8, 0.0005330000_r8, &
338 1536 : 0.0000750000_r8 /)
339 :
340 1536 : end subroutine swcmbdat
341 :
342 : !***************************************************************************
343 1536 : subroutine cmbgb16s
344 : !***************************************************************************
345 : !
346 : ! Original version: MJIacono; July 1998
347 : ! Revision for RRTM_SW: MJIacono; November 2002
348 : ! Revision for RRTMG_SW: MJIacono; December 2003
349 : ! Revision for F90 reformatting: MJIacono; July 2006
350 : !
351 : ! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
352 : ! data for each band, which are defined for 16 g-points and 14 spectral
353 : ! bands. The data are combined with appropriate weighting following the
354 : ! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
355 : ! function data in array SFLUXREF are combined without weighting. All
356 : ! g-point reduced data are put into new arrays for use in RRTMG_SW.
357 : !
358 : ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
359 : !
360 : !-----------------------------------------------------------------------
361 :
362 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
363 : use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
364 : ka, kb, selfref, forref, sfluxref
365 :
366 : ! ------- Local -------
367 : integer :: jn, jt, jp, igc, ipr, iprsm
368 : real(kind=r8) :: sumk, sumf
369 :
370 :
371 15360 : do jn = 1,9
372 84480 : do jt = 1,5
373 981504 : do jp = 1,13
374 898560 : iprsm = 0
375 6359040 : do igc = 1,ngc(1)
376 5391360 : sumk = 0.
377 19768320 : do ipr = 1, ngn(igc)
378 14376960 : iprsm = iprsm + 1
379 19768320 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
380 : enddo
381 6289920 : ka(jn,jt,jp,igc) = sumk
382 : enddo
383 : enddo
384 : enddo
385 : enddo
386 :
387 9216 : do jt = 1,5
388 370176 : do jp = 13,59
389 360960 : iprsm = 0
390 2534400 : do igc = 1,ngc(1)
391 2165760 : sumk = 0.
392 7941120 : do ipr = 1, ngn(igc)
393 5775360 : iprsm = iprsm + 1
394 7941120 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
395 : enddo
396 2526720 : kb(jt,jp,igc) = sumk
397 : enddo
398 : enddo
399 : enddo
400 :
401 16896 : do jt = 1,10
402 15360 : iprsm = 0
403 109056 : do igc = 1,ngc(1)
404 92160 : sumk = 0.
405 337920 : do ipr = 1, ngn(igc)
406 245760 : iprsm = iprsm + 1
407 337920 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
408 : enddo
409 107520 : selfref(jt,igc) = sumk
410 : enddo
411 : enddo
412 :
413 6144 : do jt = 1,3
414 4608 : iprsm = 0
415 33792 : do igc = 1,ngc(1)
416 27648 : sumk = 0.
417 101376 : do ipr = 1, ngn(igc)
418 73728 : iprsm = iprsm + 1
419 101376 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
420 : enddo
421 32256 : forref(jt,igc) = sumk
422 : enddo
423 : enddo
424 :
425 1536 : iprsm = 0
426 10752 : do igc = 1,ngc(1)
427 9216 : sumf = 0.
428 33792 : do ipr = 1, ngn(igc)
429 24576 : iprsm = iprsm + 1
430 33792 : sumf = sumf + sfluxrefo(iprsm)
431 : enddo
432 10752 : sfluxref(igc) = sumf
433 : enddo
434 :
435 1536 : end subroutine cmbgb16s
436 :
437 : !***************************************************************************
438 1536 : subroutine cmbgb17
439 : !***************************************************************************
440 : !
441 : ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
442 : !-----------------------------------------------------------------------
443 :
444 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
445 : use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
446 : ka, kb, selfref, forref, sfluxref
447 :
448 : ! ------- Local -------
449 : integer :: jn, jt, jp, igc, ipr, iprsm
450 : real(kind=r8) :: sumk, sumf
451 :
452 :
453 15360 : do jn = 1,9
454 84480 : do jt = 1,5
455 981504 : do jp = 1,13
456 898560 : iprsm = 0
457 11750400 : do igc = 1,ngc(2)
458 10782720 : sumk = 0.
459 25159680 : do ipr = 1, ngn(ngs(1)+igc)
460 14376960 : iprsm = iprsm + 1
461 25159680 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
462 : enddo
463 11681280 : ka(jn,jt,jp,igc) = sumk
464 : enddo
465 : enddo
466 : enddo
467 : enddo
468 :
469 9216 : do jn = 1,5
470 47616 : do jt = 1,5
471 1850880 : do jp = 13,59
472 1804800 : iprsm = 0
473 23500800 : do igc = 1,ngc(2)
474 21657600 : sumk = 0.
475 50534400 : do ipr = 1, ngn(ngs(1)+igc)
476 28876800 : iprsm = iprsm + 1
477 50534400 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
478 : enddo
479 23462400 : kb(jn,jt,jp,igc) = sumk
480 : enddo
481 : enddo
482 : enddo
483 : enddo
484 :
485 16896 : do jt = 1,10
486 15360 : iprsm = 0
487 201216 : do igc = 1,ngc(2)
488 184320 : sumk = 0.
489 430080 : do ipr = 1, ngn(ngs(1)+igc)
490 245760 : iprsm = iprsm + 1
491 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
492 : enddo
493 199680 : selfref(jt,igc) = sumk
494 : enddo
495 : enddo
496 :
497 7680 : do jt = 1,4
498 6144 : iprsm = 0
499 81408 : do igc = 1,ngc(2)
500 73728 : sumk = 0.
501 172032 : do ipr = 1, ngn(ngs(1)+igc)
502 98304 : iprsm = iprsm + 1
503 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
504 : enddo
505 79872 : forref(jt,igc) = sumk
506 : enddo
507 : enddo
508 :
509 9216 : do jp = 1,5
510 7680 : iprsm = 0
511 101376 : do igc = 1,ngc(2)
512 92160 : sumf = 0.
513 215040 : do ipr = 1, ngn(ngs(1)+igc)
514 122880 : iprsm = iprsm + 1
515 215040 : sumf = sumf + sfluxrefo(iprsm,jp)
516 : enddo
517 99840 : sfluxref(igc,jp) = sumf
518 : enddo
519 : enddo
520 :
521 1536 : end subroutine cmbgb17
522 :
523 : !***************************************************************************
524 1536 : subroutine cmbgb18
525 : !***************************************************************************
526 : !
527 : ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
528 : !-----------------------------------------------------------------------
529 :
530 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
531 : use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
532 : ka, kb, selfref, forref, sfluxref
533 :
534 : ! ------- Local -------
535 : integer :: jn, jt, jp, igc, ipr, iprsm
536 : real(kind=r8) :: sumk, sumf
537 :
538 :
539 15360 : do jn = 1,9
540 84480 : do jt = 1,5
541 981504 : do jp = 1,13
542 898560 : iprsm = 0
543 8156160 : do igc = 1,ngc(3)
544 7188480 : sumk = 0.
545 21565440 : do ipr = 1, ngn(ngs(2)+igc)
546 14376960 : iprsm = iprsm + 1
547 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
548 : enddo
549 8087040 : ka(jn,jt,jp,igc) = sumk
550 : enddo
551 : enddo
552 : enddo
553 : enddo
554 :
555 9216 : do jt = 1,5
556 370176 : do jp = 13,59
557 360960 : iprsm = 0
558 3256320 : do igc = 1,ngc(3)
559 2887680 : sumk = 0.
560 8663040 : do ipr = 1, ngn(ngs(2)+igc)
561 5775360 : iprsm = iprsm + 1
562 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
563 : enddo
564 3248640 : kb(jt,jp,igc) = sumk
565 : enddo
566 : enddo
567 : enddo
568 :
569 16896 : do jt = 1,10
570 15360 : iprsm = 0
571 139776 : do igc = 1,ngc(3)
572 122880 : sumk = 0.
573 368640 : do ipr = 1, ngn(ngs(2)+igc)
574 245760 : iprsm = iprsm + 1
575 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
576 : enddo
577 138240 : selfref(jt,igc) = sumk
578 : enddo
579 : enddo
580 :
581 6144 : do jt = 1,3
582 4608 : iprsm = 0
583 43008 : do igc = 1,ngc(3)
584 36864 : sumk = 0.
585 110592 : do ipr = 1, ngn(ngs(2)+igc)
586 73728 : iprsm = iprsm + 1
587 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
588 : enddo
589 41472 : forref(jt,igc) = sumk
590 : enddo
591 : enddo
592 :
593 15360 : do jp = 1,9
594 13824 : iprsm = 0
595 125952 : do igc = 1,ngc(3)
596 110592 : sumf = 0.
597 331776 : do ipr = 1, ngn(ngs(2)+igc)
598 221184 : iprsm = iprsm + 1
599 331776 : sumf = sumf + sfluxrefo(iprsm,jp)
600 : enddo
601 124416 : sfluxref(igc,jp) = sumf
602 : enddo
603 : enddo
604 :
605 1536 : end subroutine cmbgb18
606 :
607 : !***************************************************************************
608 1536 : subroutine cmbgb19
609 : !***************************************************************************
610 : !
611 : ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
612 : !-----------------------------------------------------------------------
613 :
614 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
615 : use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
616 : ka, kb, selfref, forref, sfluxref
617 :
618 : ! ------- Local -------
619 : integer :: jn, jt, jp, igc, ipr, iprsm
620 : real(kind=r8) :: sumk, sumf
621 :
622 :
623 15360 : do jn = 1,9
624 84480 : do jt = 1,5
625 981504 : do jp = 1,13
626 898560 : iprsm = 0
627 8156160 : do igc = 1,ngc(4)
628 7188480 : sumk = 0.
629 21565440 : do ipr = 1, ngn(ngs(3)+igc)
630 14376960 : iprsm = iprsm + 1
631 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
632 : enddo
633 8087040 : ka(jn,jt,jp,igc) = sumk
634 : enddo
635 : enddo
636 : enddo
637 : enddo
638 :
639 9216 : do jt = 1,5
640 370176 : do jp = 13,59
641 360960 : iprsm = 0
642 3256320 : do igc = 1,ngc(4)
643 2887680 : sumk = 0.
644 8663040 : do ipr = 1, ngn(ngs(3)+igc)
645 5775360 : iprsm = iprsm + 1
646 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
647 : enddo
648 3248640 : kb(jt,jp,igc) = sumk
649 : enddo
650 : enddo
651 : enddo
652 :
653 16896 : do jt = 1,10
654 15360 : iprsm = 0
655 139776 : do igc = 1,ngc(4)
656 122880 : sumk = 0.
657 368640 : do ipr = 1, ngn(ngs(3)+igc)
658 245760 : iprsm = iprsm + 1
659 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
660 : enddo
661 138240 : selfref(jt,igc) = sumk
662 : enddo
663 : enddo
664 :
665 6144 : do jt = 1,3
666 4608 : iprsm = 0
667 43008 : do igc = 1,ngc(4)
668 36864 : sumk = 0.
669 110592 : do ipr = 1, ngn(ngs(3)+igc)
670 73728 : iprsm = iprsm + 1
671 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
672 : enddo
673 41472 : forref(jt,igc) = sumk
674 : enddo
675 : enddo
676 :
677 15360 : do jp = 1,9
678 13824 : iprsm = 0
679 125952 : do igc = 1,ngc(4)
680 110592 : sumf = 0.
681 331776 : do ipr = 1, ngn(ngs(3)+igc)
682 221184 : iprsm = iprsm + 1
683 331776 : sumf = sumf + sfluxrefo(iprsm,jp)
684 : enddo
685 124416 : sfluxref(igc,jp) = sumf
686 : enddo
687 : enddo
688 :
689 1536 : end subroutine cmbgb19
690 :
691 : !***************************************************************************
692 1536 : subroutine cmbgb20
693 : !***************************************************************************
694 : !
695 : ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
696 : !-----------------------------------------------------------------------
697 :
698 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
699 : use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
700 : ka, kb, selfref, forref, sfluxref, absch4
701 :
702 : ! ------- Local -------
703 : integer :: jt, jp, igc, ipr, iprsm
704 : real(kind=r8) :: sumk, sumf1, sumf2
705 :
706 :
707 9216 : do jt = 1,5
708 107520 : do jp = 1,13
709 99840 : iprsm = 0
710 1105920 : do igc = 1,ngc(5)
711 998400 : sumk = 0.
712 2595840 : do ipr = 1, ngn(ngs(4)+igc)
713 1597440 : iprsm = iprsm + 1
714 2595840 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
715 : enddo
716 1098240 : ka(jt,jp,igc) = sumk
717 : enddo
718 : enddo
719 370176 : do jp = 13,59
720 360960 : iprsm = 0
721 3978240 : do igc = 1,ngc(5)
722 3609600 : sumk = 0.
723 9384960 : do ipr = 1, ngn(ngs(4)+igc)
724 5775360 : iprsm = iprsm + 1
725 9384960 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
726 : enddo
727 3970560 : kb(jt,jp,igc) = sumk
728 : enddo
729 : enddo
730 : enddo
731 :
732 16896 : do jt = 1,10
733 15360 : iprsm = 0
734 170496 : do igc = 1,ngc(5)
735 153600 : sumk = 0.
736 399360 : do ipr = 1, ngn(ngs(4)+igc)
737 245760 : iprsm = iprsm + 1
738 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
739 : enddo
740 168960 : selfref(jt,igc) = sumk
741 : enddo
742 : enddo
743 :
744 7680 : do jt = 1,4
745 6144 : iprsm = 0
746 69120 : do igc = 1,ngc(5)
747 61440 : sumk = 0.
748 159744 : do ipr = 1, ngn(ngs(4)+igc)
749 98304 : iprsm = iprsm + 1
750 159744 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
751 : enddo
752 67584 : forref(jt,igc) = sumk
753 : enddo
754 : enddo
755 :
756 1536 : iprsm = 0
757 16896 : do igc = 1,ngc(5)
758 15360 : sumf1 = 0.
759 15360 : sumf2 = 0.
760 39936 : do ipr = 1, ngn(ngs(4)+igc)
761 24576 : iprsm = iprsm + 1
762 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
763 39936 : sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
764 : enddo
765 15360 : sfluxref(igc) = sumf1
766 16896 : absch4(igc) = sumf2
767 : enddo
768 :
769 1536 : end subroutine cmbgb20
770 :
771 : !***************************************************************************
772 1536 : subroutine cmbgb21
773 : !***************************************************************************
774 : !
775 : ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
776 : !-----------------------------------------------------------------------
777 :
778 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
779 : use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
780 : ka, kb, selfref, forref, sfluxref
781 :
782 : ! ------- Local -------
783 : integer :: jn, jt, jp, igc, ipr, iprsm
784 : real(kind=r8) :: sumk, sumf
785 :
786 :
787 15360 : do jn = 1,9
788 84480 : do jt = 1,5
789 981504 : do jp = 1,13
790 898560 : iprsm = 0
791 9953280 : do igc = 1,ngc(6)
792 8985600 : sumk = 0.
793 23362560 : do ipr = 1, ngn(ngs(5)+igc)
794 14376960 : iprsm = iprsm + 1
795 23362560 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
796 : enddo
797 9884160 : ka(jn,jt,jp,igc) = sumk
798 : enddo
799 : enddo
800 : enddo
801 : enddo
802 :
803 9216 : do jn = 1,5
804 47616 : do jt = 1,5
805 1850880 : do jp = 13,59
806 1804800 : iprsm = 0
807 19891200 : do igc = 1,ngc(6)
808 18048000 : sumk = 0.
809 46924800 : do ipr = 1, ngn(ngs(5)+igc)
810 28876800 : iprsm = iprsm + 1
811 46924800 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
812 : enddo
813 19852800 : kb(jn,jt,jp,igc) = sumk
814 : enddo
815 : enddo
816 : enddo
817 : enddo
818 :
819 16896 : do jt = 1,10
820 15360 : iprsm = 0
821 170496 : do igc = 1,ngc(6)
822 153600 : sumk = 0.
823 399360 : do ipr = 1, ngn(ngs(5)+igc)
824 245760 : iprsm = iprsm + 1
825 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
826 : enddo
827 168960 : selfref(jt,igc) = sumk
828 : enddo
829 : enddo
830 :
831 7680 : do jt = 1,4
832 6144 : iprsm = 0
833 69120 : do igc = 1,ngc(6)
834 61440 : sumk = 0.
835 159744 : do ipr = 1, ngn(ngs(5)+igc)
836 98304 : iprsm = iprsm + 1
837 159744 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
838 : enddo
839 67584 : forref(jt,igc) = sumk
840 : enddo
841 : enddo
842 :
843 15360 : do jp = 1,9
844 13824 : iprsm = 0
845 153600 : do igc = 1,ngc(6)
846 138240 : sumf = 0.
847 359424 : do ipr = 1, ngn(ngs(5)+igc)
848 221184 : iprsm = iprsm + 1
849 359424 : sumf = sumf + sfluxrefo(iprsm,jp)
850 : enddo
851 152064 : sfluxref(igc,jp) = sumf
852 : enddo
853 : enddo
854 :
855 1536 : end subroutine cmbgb21
856 :
857 : !***************************************************************************
858 1536 : subroutine cmbgb22
859 : !***************************************************************************
860 : !
861 : ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
862 : !-----------------------------------------------------------------------
863 :
864 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
865 : use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
866 : ka, kb, selfref, forref, sfluxref
867 :
868 : ! ------- Local -------
869 : integer :: jn, jt, jp, igc, ipr, iprsm
870 : real(kind=r8) :: sumk, sumf
871 :
872 :
873 15360 : do jn = 1,9
874 84480 : do jt = 1,5
875 981504 : do jp = 1,13
876 898560 : iprsm = 0
877 2764800 : do igc = 1,ngc(7)
878 1797120 : sumk = 0.
879 16174080 : do ipr = 1, ngn(ngs(6)+igc)
880 14376960 : iprsm = iprsm + 1
881 16174080 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
882 : enddo
883 2695680 : ka(jn,jt,jp,igc) = sumk
884 : enddo
885 : enddo
886 : enddo
887 : enddo
888 :
889 9216 : do jt = 1,5
890 370176 : do jp = 13,59
891 360960 : iprsm = 0
892 1090560 : do igc = 1,ngc(7)
893 721920 : sumk = 0.
894 6497280 : do ipr = 1, ngn(ngs(6)+igc)
895 5775360 : iprsm = iprsm + 1
896 6497280 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
897 : enddo
898 1082880 : kb(jt,jp,igc) = sumk
899 : enddo
900 : enddo
901 : enddo
902 :
903 16896 : do jt = 1,10
904 15360 : iprsm = 0
905 47616 : do igc = 1,ngc(7)
906 30720 : sumk = 0.
907 276480 : do ipr = 1, ngn(ngs(6)+igc)
908 245760 : iprsm = iprsm + 1
909 276480 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
910 : enddo
911 46080 : selfref(jt,igc) = sumk
912 : enddo
913 : enddo
914 :
915 6144 : do jt = 1,3
916 4608 : iprsm = 0
917 15360 : do igc = 1,ngc(7)
918 9216 : sumk = 0.
919 82944 : do ipr = 1, ngn(ngs(6)+igc)
920 73728 : iprsm = iprsm + 1
921 82944 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
922 : enddo
923 13824 : forref(jt,igc) = sumk
924 : enddo
925 : enddo
926 :
927 15360 : do jp = 1,9
928 13824 : iprsm = 0
929 43008 : do igc = 1,ngc(7)
930 27648 : sumf = 0.
931 248832 : do ipr = 1, ngn(ngs(6)+igc)
932 221184 : iprsm = iprsm + 1
933 248832 : sumf = sumf + sfluxrefo(iprsm,jp)
934 : enddo
935 41472 : sfluxref(igc,jp) = sumf
936 : enddo
937 : enddo
938 :
939 1536 : end subroutine cmbgb22
940 :
941 : !***************************************************************************
942 1536 : subroutine cmbgb23
943 : !***************************************************************************
944 : !
945 : ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
946 : !-----------------------------------------------------------------------
947 :
948 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
949 : use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
950 : ka, selfref, forref, sfluxref, rayl
951 :
952 : ! ------- Local -------
953 : integer :: jt, jp, igc, ipr, iprsm
954 : real(kind=r8) :: sumk, sumf1, sumf2
955 :
956 :
957 9216 : do jt = 1,5
958 109056 : do jp = 1,13
959 99840 : iprsm = 0
960 1105920 : do igc = 1,ngc(8)
961 998400 : sumk = 0.
962 2595840 : do ipr = 1, ngn(ngs(7)+igc)
963 1597440 : iprsm = iprsm + 1
964 2595840 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
965 : enddo
966 1098240 : ka(jt,jp,igc) = sumk
967 : enddo
968 : enddo
969 : enddo
970 :
971 16896 : do jt = 1,10
972 15360 : iprsm = 0
973 170496 : do igc = 1,ngc(8)
974 153600 : sumk = 0.
975 399360 : do ipr = 1, ngn(ngs(7)+igc)
976 245760 : iprsm = iprsm + 1
977 399360 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
978 : enddo
979 168960 : selfref(jt,igc) = sumk
980 : enddo
981 : enddo
982 :
983 6144 : do jt = 1,3
984 4608 : iprsm = 0
985 52224 : do igc = 1,ngc(8)
986 46080 : sumk = 0.
987 119808 : do ipr = 1, ngn(ngs(7)+igc)
988 73728 : iprsm = iprsm + 1
989 119808 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
990 : enddo
991 50688 : forref(jt,igc) = sumk
992 : enddo
993 : enddo
994 :
995 1536 : iprsm = 0
996 16896 : do igc = 1,ngc(8)
997 15360 : sumf1 = 0.
998 15360 : sumf2 = 0.
999 39936 : do ipr = 1, ngn(ngs(7)+igc)
1000 24576 : iprsm = iprsm + 1
1001 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1002 39936 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
1003 : enddo
1004 15360 : sfluxref(igc) = sumf1
1005 16896 : rayl(igc) = sumf2
1006 : enddo
1007 :
1008 1536 : end subroutine cmbgb23
1009 :
1010 : !***************************************************************************
1011 1536 : subroutine cmbgb24
1012 : !***************************************************************************
1013 : !
1014 : ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
1015 : !-----------------------------------------------------------------------
1016 :
1017 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1018 : use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
1019 : abso3ao, abso3bo, raylao, raylbo, &
1020 : ka, kb, selfref, forref, sfluxref, &
1021 : abso3a, abso3b, rayla, raylb
1022 :
1023 : ! ------- Local -------
1024 : integer :: jn, jt, jp, igc, ipr, iprsm
1025 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3
1026 :
1027 :
1028 15360 : do jn = 1,9
1029 84480 : do jt = 1,5
1030 981504 : do jp = 1,13
1031 898560 : iprsm = 0
1032 8156160 : do igc = 1,ngc(9)
1033 7188480 : sumk = 0.
1034 21565440 : do ipr = 1, ngn(ngs(8)+igc)
1035 14376960 : iprsm = iprsm + 1
1036 21565440 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
1037 : enddo
1038 8087040 : ka(jn,jt,jp,igc) = sumk
1039 : enddo
1040 : enddo
1041 : enddo
1042 : enddo
1043 :
1044 9216 : do jt = 1,5
1045 370176 : do jp = 13,59
1046 360960 : iprsm = 0
1047 3256320 : do igc = 1,ngc(9)
1048 2887680 : sumk = 0.
1049 8663040 : do ipr = 1, ngn(ngs(8)+igc)
1050 5775360 : iprsm = iprsm + 1
1051 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
1052 : enddo
1053 3248640 : kb(jt,jp,igc) = sumk
1054 : enddo
1055 : enddo
1056 : enddo
1057 :
1058 16896 : do jt = 1,10
1059 15360 : iprsm = 0
1060 139776 : do igc = 1,ngc(9)
1061 122880 : sumk = 0.
1062 368640 : do ipr = 1, ngn(ngs(8)+igc)
1063 245760 : iprsm = iprsm + 1
1064 368640 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
1065 : enddo
1066 138240 : selfref(jt,igc) = sumk
1067 : enddo
1068 : enddo
1069 :
1070 6144 : do jt = 1,3
1071 4608 : iprsm = 0
1072 43008 : do igc = 1,ngc(9)
1073 36864 : sumk = 0.
1074 110592 : do ipr = 1, ngn(ngs(8)+igc)
1075 73728 : iprsm = iprsm + 1
1076 110592 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
1077 : enddo
1078 41472 : forref(jt,igc) = sumk
1079 : enddo
1080 : enddo
1081 :
1082 1536 : iprsm = 0
1083 13824 : do igc = 1,ngc(9)
1084 12288 : sumf1 = 0.
1085 12288 : sumf2 = 0.
1086 12288 : sumf3 = 0.
1087 36864 : do ipr = 1, ngn(ngs(8)+igc)
1088 24576 : iprsm = iprsm + 1
1089 24576 : sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
1090 24576 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
1091 36864 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
1092 : enddo
1093 12288 : raylb(igc) = sumf1
1094 12288 : abso3a(igc) = sumf2
1095 13824 : abso3b(igc) = sumf3
1096 : enddo
1097 :
1098 15360 : do jp = 1,9
1099 : iprsm = 0
1100 125952 : do igc = 1,ngc(9)
1101 110592 : sumf1 = 0.
1102 110592 : sumf2 = 0.
1103 331776 : do ipr = 1, ngn(ngs(8)+igc)
1104 221184 : iprsm = iprsm + 1
1105 221184 : sumf1 = sumf1 + sfluxrefo(iprsm,jp)
1106 331776 : sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
1107 : enddo
1108 110592 : sfluxref(igc,jp) = sumf1
1109 124416 : rayla(igc,jp) = sumf2
1110 : enddo
1111 : enddo
1112 :
1113 1536 : end subroutine cmbgb24
1114 :
1115 : !***************************************************************************
1116 1536 : subroutine cmbgb25
1117 : !***************************************************************************
1118 : !
1119 : ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
1120 : !-----------------------------------------------------------------------
1121 :
1122 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1123 : use rrsw_kg25, only : kao, sfluxrefo, &
1124 : abso3ao, abso3bo, raylo, &
1125 : ka, sfluxref, &
1126 : abso3a, abso3b, rayl
1127 :
1128 : ! ------- Local -------
1129 : integer :: jt, jp, igc, ipr, iprsm
1130 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3, sumf4
1131 :
1132 :
1133 9216 : do jt = 1,5
1134 109056 : do jp = 1,13
1135 99840 : iprsm = 0
1136 706560 : do igc = 1,ngc(10)
1137 599040 : sumk = 0.
1138 2196480 : do ipr = 1, ngn(ngs(9)+igc)
1139 1597440 : iprsm = iprsm + 1
1140 2196480 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
1141 : enddo
1142 698880 : ka(jt,jp,igc) = sumk
1143 : enddo
1144 : enddo
1145 : enddo
1146 :
1147 1536 : iprsm = 0
1148 10752 : do igc = 1,ngc(10)
1149 9216 : sumf1 = 0.
1150 9216 : sumf2 = 0.
1151 9216 : sumf3 = 0.
1152 9216 : sumf4 = 0.
1153 33792 : do ipr = 1, ngn(ngs(9)+igc)
1154 24576 : iprsm = iprsm + 1
1155 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1156 24576 : sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
1157 24576 : sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
1158 33792 : sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
1159 : enddo
1160 9216 : sfluxref(igc) = sumf1
1161 9216 : abso3a(igc) = sumf2
1162 9216 : abso3b(igc) = sumf3
1163 10752 : rayl(igc) = sumf4
1164 : enddo
1165 :
1166 1536 : end subroutine cmbgb25
1167 :
1168 : !***************************************************************************
1169 1536 : subroutine cmbgb26
1170 : !***************************************************************************
1171 : !
1172 : ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1173 : !-----------------------------------------------------------------------
1174 :
1175 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1176 : use rrsw_kg26, only : sfluxrefo, raylo, &
1177 : sfluxref, rayl
1178 :
1179 : ! ------- Local -------
1180 : integer :: igc, ipr, iprsm
1181 : real(kind=r8) :: sumf1, sumf2
1182 :
1183 :
1184 1536 : iprsm = 0
1185 10752 : do igc = 1,ngc(11)
1186 9216 : sumf1 = 0.
1187 9216 : sumf2 = 0.
1188 33792 : do ipr = 1, ngn(ngs(10)+igc)
1189 24576 : iprsm = iprsm + 1
1190 24576 : sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
1191 33792 : sumf2 = sumf2 + sfluxrefo(iprsm)
1192 : enddo
1193 9216 : rayl(igc) = sumf1
1194 10752 : sfluxref(igc) = sumf2
1195 : enddo
1196 :
1197 1536 : end subroutine cmbgb26
1198 :
1199 : !***************************************************************************
1200 1536 : subroutine cmbgb27
1201 : !***************************************************************************
1202 : !
1203 : ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1204 : !-----------------------------------------------------------------------
1205 :
1206 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1207 : use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
1208 : ka, kb, sfluxref, rayl
1209 :
1210 : ! ------- Local -------
1211 : integer :: jt, jp, igc, ipr, iprsm
1212 : real(kind=r8) :: sumk, sumf1, sumf2
1213 :
1214 :
1215 9216 : do jt = 1,5
1216 107520 : do jp = 1,13
1217 99840 : iprsm = 0
1218 906240 : do igc = 1,ngc(12)
1219 798720 : sumk = 0.
1220 2396160 : do ipr = 1, ngn(ngs(11)+igc)
1221 1597440 : iprsm = iprsm + 1
1222 2396160 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
1223 : enddo
1224 898560 : ka(jt,jp,igc) = sumk
1225 : enddo
1226 : enddo
1227 370176 : do jp = 13,59
1228 360960 : iprsm = 0
1229 3256320 : do igc = 1,ngc(12)
1230 2887680 : sumk = 0.
1231 8663040 : do ipr = 1, ngn(ngs(11)+igc)
1232 5775360 : iprsm = iprsm + 1
1233 8663040 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
1234 : enddo
1235 3248640 : kb(jt,jp,igc) = sumk
1236 : enddo
1237 : enddo
1238 : enddo
1239 :
1240 1536 : iprsm = 0
1241 13824 : do igc = 1,ngc(12)
1242 12288 : sumf1 = 0.
1243 12288 : sumf2 = 0.
1244 36864 : do ipr = 1, ngn(ngs(11)+igc)
1245 24576 : iprsm = iprsm + 1
1246 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1247 36864 : sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
1248 : enddo
1249 12288 : sfluxref(igc) = sumf1
1250 13824 : rayl(igc) = sumf2
1251 : enddo
1252 :
1253 1536 : end subroutine cmbgb27
1254 :
1255 : !***************************************************************************
1256 1536 : subroutine cmbgb28
1257 : !***************************************************************************
1258 : !
1259 : ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
1260 : !-----------------------------------------------------------------------
1261 :
1262 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1263 : use rrsw_kg28, only : kao, kbo, sfluxrefo, &
1264 : ka, kb, sfluxref
1265 :
1266 : ! ------- Local -------
1267 : integer :: jn, jt, jp, igc, ipr, iprsm
1268 : real(kind=r8) :: sumk, sumf
1269 :
1270 :
1271 15360 : do jn = 1,9
1272 84480 : do jt = 1,5
1273 981504 : do jp = 1,13
1274 898560 : iprsm = 0
1275 6359040 : do igc = 1,ngc(13)
1276 5391360 : sumk = 0.
1277 19768320 : do ipr = 1, ngn(ngs(12)+igc)
1278 14376960 : iprsm = iprsm + 1
1279 19768320 : sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1280 : enddo
1281 6289920 : ka(jn,jt,jp,igc) = sumk
1282 : enddo
1283 : enddo
1284 : enddo
1285 : enddo
1286 :
1287 9216 : do jn = 1,5
1288 47616 : do jt = 1,5
1289 1850880 : do jp = 13,59
1290 1804800 : iprsm = 0
1291 12672000 : do igc = 1,ngc(13)
1292 10828800 : sumk = 0.
1293 39705600 : do ipr = 1, ngn(ngs(12)+igc)
1294 28876800 : iprsm = iprsm + 1
1295 39705600 : sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
1296 : enddo
1297 12633600 : kb(jn,jt,jp,igc) = sumk
1298 : enddo
1299 : enddo
1300 : enddo
1301 : enddo
1302 :
1303 9216 : do jp = 1,5
1304 7680 : iprsm = 0
1305 55296 : do igc = 1,ngc(13)
1306 46080 : sumf = 0.
1307 168960 : do ipr = 1, ngn(ngs(12)+igc)
1308 122880 : iprsm = iprsm + 1
1309 168960 : sumf = sumf + sfluxrefo(iprsm,jp)
1310 : enddo
1311 53760 : sfluxref(igc,jp) = sumf
1312 : enddo
1313 : enddo
1314 :
1315 1536 : end subroutine cmbgb28
1316 :
1317 : !***************************************************************************
1318 1536 : subroutine cmbgb29
1319 : !***************************************************************************
1320 : !
1321 : ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1322 : !-----------------------------------------------------------------------
1323 :
1324 : use rrsw_wvn, only : ngc, ngs, ngn, wt, rwgt
1325 : use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
1326 : absh2oo, absco2o, &
1327 : ka, kb, selfref, forref, sfluxref, &
1328 : absh2o, absco2
1329 :
1330 : ! ------- Local -------
1331 : integer :: jt, jp, igc, ipr, iprsm
1332 : real(kind=r8) :: sumk, sumf1, sumf2, sumf3
1333 :
1334 :
1335 9216 : do jt = 1,5
1336 107520 : do jp = 1,13
1337 99840 : iprsm = 0
1338 1305600 : do igc = 1,ngc(14)
1339 1198080 : sumk = 0.
1340 2795520 : do ipr = 1, ngn(ngs(13)+igc)
1341 1597440 : iprsm = iprsm + 1
1342 2795520 : sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
1343 : enddo
1344 1297920 : ka(jt,jp,igc) = sumk
1345 : enddo
1346 : enddo
1347 370176 : do jp = 13,59
1348 360960 : iprsm = 0
1349 4700160 : do igc = 1,ngc(14)
1350 4331520 : sumk = 0.
1351 10106880 : do ipr = 1, ngn(ngs(13)+igc)
1352 5775360 : iprsm = iprsm + 1
1353 10106880 : sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
1354 : enddo
1355 4692480 : kb(jt,jp,igc) = sumk
1356 : enddo
1357 : enddo
1358 : enddo
1359 :
1360 16896 : do jt = 1,10
1361 15360 : iprsm = 0
1362 201216 : do igc = 1,ngc(14)
1363 184320 : sumk = 0.
1364 430080 : do ipr = 1, ngn(ngs(13)+igc)
1365 245760 : iprsm = iprsm + 1
1366 430080 : sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
1367 : enddo
1368 199680 : selfref(jt,igc) = sumk
1369 : enddo
1370 : enddo
1371 :
1372 7680 : do jt = 1,4
1373 6144 : iprsm = 0
1374 81408 : do igc = 1,ngc(14)
1375 73728 : sumk = 0.
1376 172032 : do ipr = 1, ngn(ngs(13)+igc)
1377 98304 : iprsm = iprsm + 1
1378 172032 : sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
1379 : enddo
1380 79872 : forref(jt,igc) = sumk
1381 : enddo
1382 : enddo
1383 :
1384 1536 : iprsm = 0
1385 19968 : do igc = 1,ngc(14)
1386 18432 : sumf1 = 0.
1387 18432 : sumf2 = 0.
1388 18432 : sumf3 = 0.
1389 43008 : do ipr = 1, ngn(ngs(13)+igc)
1390 24576 : iprsm = iprsm + 1
1391 24576 : sumf1 = sumf1 + sfluxrefo(iprsm)
1392 24576 : sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
1393 43008 : sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
1394 : enddo
1395 18432 : sfluxref(igc) = sumf1
1396 18432 : absco2(igc) = sumf2
1397 19968 : absh2o(igc) = sumf3
1398 : enddo
1399 :
1400 1536 : end subroutine cmbgb29
1401 :
1402 : !***************************************************************************
1403 :
1404 :
1405 : end module rrtmg_sw_init
1406 :
1407 :
|
