| blob | cf1b9728c13fdd87d15a3f29125616643fbaa766 |
1 #if( BUILD_RRTMK != 1)
2 MODULE module_ra_rrtmg_swk
3 CONTAINS
4 SUBROUTINE rrtmg_sw
5 REAL :: dummy
6 dummy = 1
7 END SUBROUTINE rrtmg_sw
8 END MODULE module_ra_rrtmg_swk
9 #else
10 !
11 !-------------------------------------------------------------------------------
12 module parrrsw_k
13 !-------------------------------------------------------------------------------
14 ! abstract : rrtmg_sw main parameters
15 !
16 ! history log :
17 ! 1998-07 JJMorcrette Initial version
18 ! 2006-06 MJIacono Revised
19 ! 2008-08 MJIacono Revised
20 !
21 ! variable :
22 !-------------------------------------------------------------------------------
23 !
24 ! name type purpose
25 ! ----- : ---- : -----------------------------------------------------------
26 ! mxlay : integer: maximum number of layers
27 ! mg : integer: number of original g-intervals per spectral band
28 ! nbndsw : integer: number of spectral bands
29 ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option)
30 ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw
31 ! ngNN : integer: number of reduced g-intervals per spectral band
32 ! ngsNN : integer: cumulative number of g-intervals per band
33 !-------------------------------------------------------------------------------
34 use parkind_k , only : im => kind_im, rb => kind_rb
35 !
36 ! implicit none
37 !
38 save
39 integer(kind=im), parameter :: mxlay = 203 !jplay, klev
40 integer(kind=im), parameter :: mg = 16 !jpg
41 integer(kind=im), parameter :: nbndsw = 14 !jpsw, ksw
42 integer(kind=im), parameter :: naerec = 6 !jpaer
43 integer(kind=im), parameter :: mxmol = 38
44 integer(kind=im), parameter :: nstr = 2
45 integer(kind=im), parameter :: nmol = 7
46 !
47 ! Use for 112 g-point model
48 !
49 integer(kind=im), parameter :: ngptsw = 112 !jpgpt
50 !
51 ! Use for 224 g-point model
52 ! integer(kind=im), parameter :: ngptsw = 224 !jpgpt
53 !
54 ! may need to rename these - from v2.6
55 !
56 integer(kind=im), parameter :: jpband = 29
57 integer(kind=im), parameter :: jpb1 = 16 !istart
58 integer(kind=im), parameter :: jpb2 = 29 !iend
59 integer(kind=im), parameter :: jmcmu = 32
60 integer(kind=im), parameter :: jmumu = 32
61 integer(kind=im), parameter :: jmphi = 3
62 integer(kind=im), parameter :: jmxang = 4
63 integer(kind=im), parameter :: jmxstr = 16
64 !
65 ! Use for 112 g-point model
66 !
67 integer(kind=im), parameter :: ng16 = 6
68 integer(kind=im), parameter :: ng17 = 12
69 integer(kind=im), parameter :: ng18 = 8
70 integer(kind=im), parameter :: ng19 = 8
71 integer(kind=im), parameter :: ng20 = 10
72 integer(kind=im), parameter :: ng21 = 10
73 integer(kind=im), parameter :: ng22 = 2
74 integer(kind=im), parameter :: ng23 = 10
75 integer(kind=im), parameter :: ng24 = 8
76 integer(kind=im), parameter :: ng25 = 6
77 integer(kind=im), parameter :: ng26 = 6
78 integer(kind=im), parameter :: ng27 = 8
79 integer(kind=im), parameter :: ng28 = 6
80 integer(kind=im), parameter :: ng29 = 12
81 integer(kind=im), parameter :: ngs16 = 6
82 integer(kind=im), parameter :: ngs17 = 18
83 integer(kind=im), parameter :: ngs18 = 26
84 integer(kind=im), parameter :: ngs19 = 34
85 integer(kind=im), parameter :: ngs20 = 44
86 integer(kind=im), parameter :: ngs21 = 54
87 integer(kind=im), parameter :: ngs22 = 56
88 integer(kind=im), parameter :: ngs23 = 66
89 integer(kind=im), parameter :: ngs24 = 74
90 integer(kind=im), parameter :: ngs25 = 80
91 integer(kind=im), parameter :: ngs26 = 86
92 integer(kind=im), parameter :: ngs27 = 94
93 integer(kind=im), parameter :: ngs28 = 100
94 integer(kind=im), parameter :: ngs29 = 112
95 !
96 ! Use for 224 g-point model
97 ! integer(kind=im), parameter :: ng16 = 16
98 ! integer(kind=im), parameter :: ng17 = 16
99 ! integer(kind=im), parameter :: ng18 = 16
100 ! integer(kind=im), parameter :: ng19 = 16
101 ! integer(kind=im), parameter :: ng20 = 16
102 ! integer(kind=im), parameter :: ng21 = 16
103 ! integer(kind=im), parameter :: ng22 = 16
104 ! integer(kind=im), parameter :: ng23 = 16
105 ! integer(kind=im), parameter :: ng24 = 16
106 ! integer(kind=im), parameter :: ng25 = 16
107 ! integer(kind=im), parameter :: ng26 = 16
108 ! integer(kind=im), parameter :: ng27 = 16
109 ! integer(kind=im), parameter :: ng28 = 16
110 ! integer(kind=im), parameter :: ng29 = 16
111 !
112 ! integer(kind=im), parameter :: ngs16 = 16
113 ! integer(kind=im), parameter :: ngs17 = 32
114 ! integer(kind=im), parameter :: ngs18 = 48
115 ! integer(kind=im), parameter :: ngs19 = 64
116 ! integer(kind=im), parameter :: ngs20 = 80
117 ! integer(kind=im), parameter :: ngs21 = 96
118 ! integer(kind=im), parameter :: ngs22 = 112
119 ! integer(kind=im), parameter :: ngs23 = 128
120 ! integer(kind=im), parameter :: ngs24 = 144
121 ! integer(kind=im), parameter :: ngs25 = 160
122 ! integer(kind=im), parameter :: ngs26 = 176
123 ! integer(kind=im), parameter :: ngs27 = 192
124 ! integer(kind=im), parameter :: ngs28 = 208
125 ! integer(kind=im), parameter :: ngs29 = 224
126 !
127 ! Source function solar constant
128 !
129 real(kind=rb), parameter :: rrsw_scon = 1.36822e+03 ! W/m2
130 !-------------------------------------------------------------------------------
131 end module parrrsw_k
132 !-------------------------------------------------------------------------------
133 !
134 !
135 !-------------------------------------------------------------------------------
136 module rrsw_aer_k
137 !-------------------------------------------------------------------------------
138 ! abstract :
139 ! rrtmg_sw aerosol optical properties
140 ! Data derived from six ECMWF aerosol types and defined for
141 ! the rrtmg_sw spectral intervals
142 !
143 ! history log :
144 ! 2003-03 J.-J. Morcrette, ECMWF Initial
145 ! 2006-07 MJIacono Revised
146 ! 2008-08 MJIacono Revised
147 !-------------------------------------------------------------------------------
148 !
149 !-- The six ECMWF aerosol types ar e respectively:
150 !
151 ! 1/ continental average 2/ maritime
152 ! 3/ desert 4/ urban
153 ! 5/ volcanic active 6/ stratospheric background
154 !
155 ! computed from Hess and Koepke (con, mar, des, urb)
156 ! from Bonnel et al. (vol, str)
157 !
158 ! rrtmg_sw 14 spectral intervals (microns):
159 ! 3.846 - 3.077
160 ! 3.077 - 2.500
161 ! 2.500 - 2.150
162 ! 2.150 - 1.942
163 ! 1.942 - 1.626
164 ! 1.626 - 1.299
165 ! 1.299 - 1.242
166 ! 1.242 - 0.7782
167 ! 0.7782- 0.6250
168 ! 0.6250- 0.4415
169 ! 0.4415- 0.3448
170 ! 0.3448- 0.2632
171 ! 0.2632- 0.2000
172 ! 12.195 - 3.846
173 !
174 !-------------------------------------------------------------------------------
175 !
176 ! name type purpose
177 ! ----- : ---- : ----------------------------------------------
178 ! rsrtaua : real : ratio of average optical thickness in
179 ! spectral band to that at 0.55 micron
180 ! rsrpiza : real : average single scattering albedo (unitless)
181 ! rsrasya : real : average asymmetry parameter (unitless)
182 !-------------------------------------------------------------------------------
183 use parkind_k, only : im => kind_im, rb => kind_rb
184 use parrrsw_k, only : nbndsw, naerec
185 !
186 ! implicit none
187 !
188 save
189 real(kind=rb), dimension(nbndsw,naerec) :: rsrtaua
190 real(kind=rb), dimension(nbndsw,naerec) :: rsrpiza
191 real(kind=rb), dimension(nbndsw,naerec) :: rsrasya
192 !-------------------------------------------------------------------------------
193 end module rrsw_aer_k
194 !-------------------------------------------------------------------------------
195 !
196 !
197 !-------------------------------------------------------------------------------
198 module rrsw_cld_k
199 !-------------------------------------------------------------------------------
200 ! abstract :
201 ! rrtmg_sw cloud property coefficients
202 !
203 ! history log :
204 ! 1999-08 J.-J. Morcrette, ECMWF Initial
205 ! 2005-08 J. Delamere/MJIacono, AER, Revised
206 ! 2005-11 MJIacono, AER Revised
207 ! 2008-08 MJIacono, AER Revised
208 !-------------------------------------------------------------------------------
209 !
210 ! name type purpose
211 ! ----- : ---- : --------------------------------------------------------
212 ! xxxliq1 : real : optical properties (extinction coefficient, single
213 ! scattering albedo, assymetry factor) from
214 ! Hu & Stamnes, j. clim., 6, 728-742, 1993.
215 ! xxxice2 : real : optical properties (extinction coefficient, single
216 ! scattering albedo, assymetry factor) from streamer v3.0,
217 ! Key, streamer user's guide, cooperative institude
218 ! for meteorological studies, 95 pp., 2001.
219 ! xxxice3 : real : optical properties (extinction coefficient, single
220 ! scattering albedo, assymetry factor) from
221 ! Fu, j. clim., 9, 1996.
222 ! xbari : real : optical property coefficients for five spectral
223 ! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
224 ! and 14285-40000 wavenumbers) following
225 ! Ebert and Curry, jgr, 97, 3831-3836, 1992.
226 !-------------------------------------------------------------------------------
227 use parkind_k, only : im => kind_im, rb => kind_rb
228 !
229 ! implicit none
230 !
231 save
232 real(kind=rb), dimension(58,16:29) :: extliq1, ssaliq1, asyliq1
233 real(kind=rb), dimension(43,16:29) :: extice2, ssaice2, asyice2
234 real(kind=rb), dimension(46,16:29) :: extice3, ssaice3, asyice3
235 real(kind=rb), dimension(46,16:29) :: fdlice3
236 real(kind=rb), dimension(5) :: abari, bbari, cbari, dbari, ebari, fbari
237 !-------------------------------------------------------------------------------
238 end module rrsw_cld_k
239 !-------------------------------------------------------------------------------
240 !
241 !
242 !-------------------------------------------------------------------------------
243 module rrsw_con_k
244 !-------------------------------------------------------------------------------
245 ! abstract :
246 ! rrtmg_sw constants
247 !
248 ! history log :
249 ! 2006-06 MJIacono AER Initial
250 ! 2008-08 MJIacono AER Revised
251 !-------------------------------------------------------------------------------
252 ! name type purpose
253 ! ----- : ---- : -----------------------------------------------------------
254 ! fluxfac: real : radiance to flux conversion factor
255 ! heatfac: real : flux to heating rate conversion factor
256 !oneminus: real : 1.-1.e-6
257 ! pi : real : pi
258 ! grav : real : acceleration of gravity
259 ! planck : real : planck constant
260 ! boltz : real : boltzmann constant
261 ! clight : real : speed of light
262 ! avogad : real : avogadro constant
263 ! alosmt : real : loschmidt constant
264 ! gascon : real : molar gas constant
265 ! radcn1 : real : first radiation constant
266 ! radcn2 : real : second radiation constant
267 ! sbcnst : real : stefan-boltzmann constant
268 ! secdy : real : seconds per day
269 !-------------------------------------------------------------------------------
270 use parkind_k, only : im => kind_im, rb => kind_rb
271 !
272 ! implicit none
273 !
274 save
275 real(kind=rb) :: fluxfac, heatfac
276 real(kind=rb) :: oneminus, pi, grav
277 real(kind=rb) :: planck, boltz, clight
278 real(kind=rb) :: avogad, alosmt, gascon
279 real(kind=rb) :: radcn1, radcn2
280 real(kind=rb) :: sbcnst, secdy
281 !-------------------------------------------------------------------------------
282 end module rrsw_con_k
283 !-------------------------------------------------------------------------------
284 !
285 !
286 !
287 !-------------------------------------------------------------------------------
288 module rrsw_kg16_k
289 !-------------------------------------------------------------------------------
290 ! abstract :
291 ! rrtmg_sw ORIGINAL abs. coefficients for interval 16
292 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
293 !
294 ! history log :
295 ! 1999-10 JJMorcrette Initial version
296 ! 2006-07 MJIacono Revised, AER
297 ! 2008-08 MJIacono Revised, AER
298 !-------------------------------------------------------------------------------
299 !
300 ! name type purpose
301 ! ---- : ---- : ---------------------------------------------
302 ! kao : real
303 ! kbo : real
304 ! selfrefo: real
305 ! forrefo : real
306 !sfluxrefo: real
307 !-------------------------------------------------------------------------------
308 ! rrtmg_sw COMBINED abs. coefficients for interval 16
309 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
310 !
311 ! Initial version: JJMorcrette, ECMWF, oct1999
312 ! Revised: MJIacono, AER, jul2006
313 ! Revised: MJIacono, AER, aug2008
314 !-------------------------------------------------------------------------------
315 !
316 ! name type purpose
317 ! ---- : ---- : ---------------------------------------------
318 ! ka : real
319 ! kb : real
320 ! absa : real
321 ! absb : real
322 ! selfref : real
323 ! forref : real
324 ! sfluxref: real
325 !-------------------------------------------------------------------------------
326 use parkind_k, only : im => kind_im, rb => kind_rb
327 use parrrsw_k, only : ng16
328 !
329 ! implicit none
330 !
331 save
332 integer(kind=im), parameter :: no16 = 16
333 real(kind=rb), dimension(9,5,13,no16) :: kao
334 real(kind=rb), dimension(5,13:59,no16):: kbo
335 real(kind=rb), dimension(10,no16) :: selfrefo
336 real(kind=rb), dimension(3,no16) :: forrefo
337 real(kind=rb), dimension(no16) :: sfluxrefo
338 integer(kind=im) :: layreffr
339 real(kind=rb) :: rayl, strrat1
340 !
341 real(kind=rb), dimension(9,5,13,ng16) :: ka
342 real(kind=rb), dimension(585,ng16) :: absa
343 real(kind=rb), dimension(5,13:59,ng16):: kb
344 real(kind=rb), dimension(235,ng16) :: absb
345 real(kind=rb), dimension(10,ng16) :: selfref
346 real(kind=rb), dimension(3,ng16) :: forref
347 real(kind=rb), dimension(ng16) :: sfluxref
348 !
349 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
350 !-------------------------------------------------------------------------------
351 end module rrsw_kg16_k
352 !-------------------------------------------------------------------------------
353 !
354 !
355 !-------------------------------------------------------------------------------
356 module rrsw_kg17_k
357 !-------------------------------------------------------------------------------
358 ! abstract :
359 ! rrtmg_sw ORIGINAL abs. coefficients for interval 17
360 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
361 !
362 ! history log :
363 ! 1999-10 JJMorcrette Initial version
364 ! 2006-07 MJIacono Revised, AER
365 ! 2008-08 MJIacono Revised, AER
366 !-----------------------------------------------------------------
367 !
368 ! name type purpose
369 ! ---- : ---- : ---------------------------------------------
370 ! kao : real
371 ! kbo : real
372 ! selfrefo: real
373 ! forrefo : real
374 !sfluxrefo: real
375 !-------------------------------------------------------------------------------
376 ! rrtmg_sw COMBINED abs. coefficients for interval 17
377 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
378 !
379 ! Initial version: JJMorcrette, ECMWF, oct1999
380 ! Revised: MJIacono, AER, jul2006
381 ! Revised: MJIacono, AER, aug2008
382 !-------------------------------------------------------------------------------
383 !
384 ! name type purpose
385 ! ---- : ---- : ---------------------------------------------
386 ! ka : real
387 ! kb : real
388 ! absa : real
389 ! absb : real
390 ! selfref : real
391 ! forref : real
392 ! sfluxref: real
393 !-------------------------------------------------------------------------------
394 use parkind_k, only : im => kind_im, rb => kind_rb
395 use parrrsw_k, only : ng17
396 !-------------------------------------------------------------------------------
397 !
398 ! implicit none
399 !
400 save
401 integer(kind=im), parameter :: no17 = 16
402 !
403 real(kind=rb), dimension(9,5,13,no17) :: kao
404 real(kind=rb), dimension(5,5,13:59,no17):: kbo
405 real(kind=rb), dimension(10,no17) :: selfrefo
406 real(kind=rb), dimension(4,no17) :: forrefo
407 real(kind=rb), dimension(no17,5) :: sfluxrefo
408 !
409 integer(kind=im) :: layreffr
410 real(kind=rb) :: rayl, strrat
411 !
412 real(kind=rb), dimension(9,5,13,ng17) :: ka
413 real(kind=rb), dimension(585,ng17) :: absa
414 real(kind=rb), dimension(5,5,13:59,ng17):: kb
415 real(kind=rb), dimension(1175,ng17) :: absb
416 real(kind=rb), dimension(10,ng17) :: selfref
417 real(kind=rb), dimension(4,ng17) :: forref
418 real(kind=rb), dimension(ng17,5) :: sfluxref
419 !
420 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
421 !-------------------------------------------------------------------------------
422 end module rrsw_kg17_k
423 !-------------------------------------------------------------------------------
424 !
425 !
426 !-------------------------------------------------------------------------------
427 module rrsw_kg18_k
428 !-------------------------------------------------------------------------------
429 ! abstract :
430 ! rrtmg_sw ORIGINAL abs. coefficients for interval 18
431 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
432 !
433 ! history log :
434 ! 1999-10 JJMorcrette Initial version
435 ! 2006-07 MJIacono Revised, AER
436 ! 2008-08 MJIacono Revised, AER
437 !-------------------------------------------------------------------------------
438 !
439 ! name type purpose
440 ! ---- : ---- : ---------------------------------------------
441 ! kao : real
442 ! kbo : real
443 ! selfrefo: real
444 ! forrefo : real
445 !sfluxrefo: real
446 !-------------------------------------------------------------------------------
447 ! rrtmg_sw COMBINED abs. coefficients for interval 18
448 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
449 !
450 ! Initial version: JJMorcrette, ECMWF, oct1999
451 ! Revised: MJIacono, AER, jul2006
452 ! Revised: MJIacono, AER, aug2008
453 !-------------------------------------------------------------------------------
454 !
455 ! name type purpose
456 ! ---- : ---- : ---------------------------------------------
457 ! ka : real
458 ! kb : real
459 ! absa : real
460 ! absb : real
461 ! selfref : real
462 ! forref : real
463 ! sfluxref: real
464 !-------------------------------------------------------------------------------
465 use parkind_k, only : im => kind_im, rb => kind_rb
466 use parrrsw_k, only : ng18
467 !
468 ! implicit none
469 !
470 save
471 integer(kind=im), parameter :: no18 = 16
472 !
473 real(kind=rb), dimension(9,5,13,no18) :: kao
474 real(kind=rb), dimension(5,13:59,no18) :: kbo
475 real(kind=rb), dimension(10,no18) :: selfrefo
476 real(kind=rb), dimension(3,no18) :: forrefo
477 real(kind=rb), dimension(no18,9) :: sfluxrefo
478 !
479 integer(kind=im) :: layreffr
480 real(kind=rb) :: rayl, strrat
481 !
482 real(kind=rb), dimension(9,5,13,ng18) :: ka
483 real(kind=rb), dimension(585,ng18) :: absa
484 real(kind=rb), dimension(5,13:59,ng18) :: kb
485 real(kind=rb), dimension(235,ng18) :: absb
486 real(kind=rb), dimension(10,ng18) :: selfref
487 real(kind=rb), dimension(3,ng18) :: forref
488 real(kind=rb), dimension(ng18,9) :: sfluxref
489 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
490 !-------------------------------------------------------------------------------
491 end module rrsw_kg18_k
492 !-------------------------------------------------------------------------------
493 !
494 !
495 !-------------------------------------------------------------------------------
496 module rrsw_kg19_k
497 !-------------------------------------------------------------------------------
498 ! abstract :
499 ! rrtmg_sw ORIGINAL abs. coefficients for interval 19
500 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
501 !
502 ! history log :
503 ! 1999-10 JJMorcrette Initial version
504 ! 2006-07 MJIacono Revised, AER
505 ! 2008-08 MJIacono Revised, AER
506 !-------------------------------------------------------------------------------
507 !
508 ! name type purpose
509 ! ---- : ---- : ---------------------------------------------
510 ! kao : real
511 ! kbo : real
512 ! selfrefo: real
513 ! forrefo : real
514 !sfluxrefo: real
515 !-------------------------------------------------------------------------------
516 ! rrtmg_sw COMBINED abs. coefficients for interval 19
517 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
518 !
519 ! Initial version: JJMorcrette, ECMWF, oct1999
520 ! Revised: MJIacono, AER, jul2006
521 ! Revised: MJIacono, AER, aug2008
522 !-------------------------------------------------------------------------------
523 !
524 ! name type purpose
525 ! ---- : ---- : ---------------------------------------------
526 ! ka : real
527 ! kb : real
528 ! absa : real
529 ! absb : real
530 ! selfref : real
531 ! forref : real
532 ! sfluxref: real
533 !-------------------------------------------------------------------------------
534 use parkind_k, only : im => kind_im, rb => kind_rb
535 use parrrsw_k, only : ng19
536 !
537 ! implicit none
538 !
539 save
540 integer(kind=im), parameter :: no19 = 16
541 !
542 real(kind=rb), dimension(9,5,13,no19) :: kao
543 real(kind=rb), dimension(5,13:59,no19) :: kbo
544 real(kind=rb), dimension(10,no19) :: selfrefo
545 real(kind=rb), dimension(3,no19) :: forrefo
546 real(kind=rb), dimension(no19,9) :: sfluxrefo
547 !
548 integer(kind=im) :: layreffr
549 real(kind=rb) :: rayl, strrat
550 !
551 real(kind=rb), dimension(9,5,13,ng19) :: ka
552 real(kind=rb), dimension(585,ng19) :: absa
553 real(kind=rb), dimension(5,13:59,ng19) :: kb
554 real(kind=rb), dimension(235,ng19) :: absb
555 real(kind=rb), dimension(10,ng19) :: selfref
556 real(kind=rb), dimension(3,ng19) :: forref
557 real(kind=rb), dimension(ng19,9) :: sfluxref
558 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
559 !-------------------------------------------------------------------------------
560 end module rrsw_kg19_k
561 !-------------------------------------------------------------------------------
562 !
563 !
564 !-------------------------------------------------------------------------------
565 module rrsw_kg20_k
566 !-------------------------------------------------------------------------------
567 ! abstract :
568 ! rrtmg_sw ORIGINAL abs. coefficients for interval 20
569 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
570 !
571 ! history log :
572 ! 1999-10 JJMorcrette Initial version
573 ! 2006-07 MJIacono Revised, AER
574 ! 2008-08 MJIacono Revised, AER
575 !-------------------------------------------------------------------------------
576 !
577 ! name type purpose
578 ! ---- : ---- : ---------------------------------------------
579 ! kao : real
580 ! kbo : real
581 ! selfrefo: real
582 ! forrefo : real
583 !sfluxrefo: real
584 ! absch4o : real
585 !-------------------------------------------------------------------------------
586 ! rrtmg_sw COMBINED abs. coefficients for interval 20
587 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
588 !
589 ! Initial version: JJMorcrette, ECMWF, oct1999
590 ! Revised: MJIacono, AER, jul2006
591 ! Revised: MJIacono, AER, aug2008
592 !-------------------------------------------------------------------------------
593 !
594 ! name type purpose
595 ! ---- : ---- : ---------------------------------------------
596 ! ka : real
597 ! kb : real
598 ! absa : real
599 ! absb : real
600 ! selfref : real
601 ! forref : real
602 ! sfluxref: real
603 ! absch4 : real
604 !-------------------------------------------------------------------------------
605 use parkind_k, only : im => kind_im, rb => kind_rb
606 use parrrsw_k, only : ng20
607 !
608 ! implicit none
609 !
610 save
611 integer(kind=im), parameter :: no20 = 16
612 !
613 real(kind=rb), dimension(5,13,no20) :: kao
614 real(kind=rb), dimension(5,13:59,no20) :: kbo
615 real(kind=rb), dimension(10,no20) :: selfrefo
616 real(kind=rb), dimension(4,no20) :: forrefo
617 real(kind=rb), dimension(no20) :: sfluxrefo
618 real(kind=rb), dimension(no20) :: absch4o
619 !
620 integer(kind=im) :: layreffr
621 real(kind=rb) :: rayl, strrat
622 !
623 real(kind=rb), dimension(5,13,ng20) :: ka
624 real(kind=rb), dimension(65,ng20) :: absa
625 real(kind=rb), dimension(5,13:59,ng20) :: kb
626 real(kind=rb), dimension(235,ng20) :: absb
627 real(kind=rb), dimension(10,ng20) :: selfref
628 real(kind=rb), dimension(4,ng20) :: forref
629 real(kind=rb), dimension(ng20) :: sfluxref
630 real(kind=rb), dimension(no20) :: absch4
631 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
632 !-------------------------------------------------------------------------------
633 end module rrsw_kg20_k
634 !-------------------------------------------------------------------------------
635 !
636 !
637 !-------------------------------------------------------------------------------
638 module rrsw_kg21_k
639 !-------------------------------------------------------------------------------
640 ! abstract :
641 ! rrtmg_sw ORIGINAL abs. coefficients for interval 21
642 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
643 !
644 ! history log :
645 ! 1999-10 JJMorcrette Initial version
646 ! 2006-07 MJIacono Revised, AER
647 ! 2008-08 MJIacono Revised, AER
648 !-------------------------------------------------------------------------------
649 !
650 ! name type purpose
651 ! ---- : ---- : ---------------------------------------------
652 ! kao : real
653 ! kbo : real
654 ! selfrefo: real
655 ! forrefo : real
656 !sfluxrefo: real
657 !-------------------------------------------------------------------------------
658 ! rrtmg_sw COMBINED abs. coefficients for interval 21
659 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
660 !
661 ! Initial version: JJMorcrette, ECMWF, oct1999
662 ! Revised: MJIacono, AER, jul2006
663 ! Revised: MJIacono, AER, aug2008
664 !-------------------------------------------------------------------------------
665 !
666 ! name type purpose
667 ! ---- : ---- : ---------------------------------------------
668 ! ka : real
669 ! kb : real
670 ! absa : real
671 ! absb : real
672 ! selfref : real
673 ! forref : real
674 ! sfluxref: real
675 !-------------------------------------------------------------------------------
676 use parkind_k, only : im => kind_im, rb => kind_rb
677 use parrrsw_k, only : ng21
678 !
679 ! implicit none
680 !
681 save
682 integer(kind=im), parameter :: no21 = 16
683 !
684 real(kind=rb), dimension(9,5,13,no21) :: kao
685 real(kind=rb), dimension(5,5,13:59,no21) :: kbo
686 real(kind=rb), dimension(10,no21) :: selfrefo
687 real(kind=rb), dimension(4,no21) :: forrefo
688 real(kind=rb), dimension(no21,9) :: sfluxrefo
689 !
690 integer(kind=im) :: layreffr
691 real(kind=rb) :: rayl, strrat
692 !
693 real(kind=rb), dimension(9,5,13,ng21) :: ka
694 real(kind=rb), dimension(585,ng21) :: absa
695 real(kind=rb), dimension(5,5,13:59,ng21) :: kb
696 real(kind=rb), dimension(1175,ng21) :: absb
697 real(kind=rb), dimension(10,ng21) :: selfref
698 real(kind=rb), dimension(4,ng21) :: forref
699 real(kind=rb), dimension(ng21,9) :: sfluxref
700 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
701 !-------------------------------------------------------------------------------
702 end module rrsw_kg21_k
703 !-------------------------------------------------------------------------------
704 !
705 !
706 !-------------------------------------------------------------------------------
707 module rrsw_kg22_k
708 !-------------------------------------------------------------------------------
709 ! abstract :
710 ! rrtmg_sw ORIGINAL abs. coefficients for interval 22
711 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
712 !
713 ! history log :
714 ! 1999-10 JJMorcrette Initial version
715 ! 2006-07 MJIacono Revised, AER
716 ! 2008-08 MJIacono Revised, AER
717 !-------------------------------------------------------------------------------
718 !
719 ! name type purpose
720 ! ---- : ---- : ---------------------------------------------
721 ! kao : real
722 ! kbo : real
723 ! selfrefo: real
724 ! forrefo : real
725 !sfluxrefo: real
726 !-------------------------------------------------------------------------------
727 ! rrtmg_sw ORIGINAL abs. coefficients for interval 22
728 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
729 !
730 ! Initial version: JJMorcrette, ECMWF, oct1999
731 ! Revised: MJIacono, AER, jul2006
732 ! Revised: MJIacono, AER, aug2008
733 !-------------------------------------------------------------------------------
734 !
735 ! name type purpose
736 ! ---- : ---- : ---------------------------------------------
737 ! kao : real
738 ! kbo : real
739 ! selfrefo: real
740 ! forrefo : real
741 !sfluxrefo: real
742 !-------------------------------------------------------------------------------
743 use parkind_k, only : im => kind_im, rb => kind_rb
744 use parrrsw_k, only : ng22
745 !
746 ! implicit none
747 !
748 save
749 integer(kind=im), parameter :: no22 = 16
750 !
751 real(kind=rb), dimension(9,5,13,no22) :: kao
752 real(kind=rb), dimension(5,13:59,no22) :: kbo
753 real(kind=rb), dimension(10,no22) :: selfrefo
754 real(kind=rb), dimension(3,no22) :: forrefo
755 real(kind=rb), dimension(no22,9) :: sfluxrefo
756 !
757 integer(kind=im) :: layreffr
758 real(kind=rb) :: rayl, strrat
759 !
760 real(kind=rb), dimension(9,5,13,ng22) :: ka
761 real(kind=rb), dimension(585,ng22) :: absa
762 real(kind=rb), dimension(5,13:59,ng22) :: kb
763 real(kind=rb), dimension(235,ng22) :: absb
764 real(kind=rb), dimension(10,ng22) :: selfref
765 real(kind=rb), dimension(3,ng22) :: forref
766 real(kind=rb), dimension(ng22,9) :: sfluxref
767 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
768 !-------------------------------------------------------------------------------
769 end module rrsw_kg22_k
770 !-------------------------------------------------------------------------------
771 !
772 !
773 !-------------------------------------------------------------------------------
774 module rrsw_kg23_k
775 !-------------------------------------------------------------------------------
776 ! abstract :
777 ! rrtmg_sw ORIGINAL abs. coefficients for interval 23
778 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
779 !
780 ! history log :
781 ! 1999-10 JJMorcrette Initial version
782 ! 2006-07 MJIacono Revised, AER
783 ! 2008-08 MJIacono Revised, AER
784 !-------------------------------------------------------------------------------
785 !
786 ! name type purpose
787 ! ---- : ---- : ---------------------------------------------
788 ! kao : real
789 ! kbo : real
790 ! selfrefo: real
791 ! forrefo : real
792 !sfluxrefo: real
793 !-------------------------------------------------------------------------------
794 ! rrtmg_sw COMBINED abs. coefficients for interval 23
795 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
796 !
797 ! Initial version: JJMorcrette, ECMWF, oct1999
798 ! Revised: MJIacono, AER, jul2006
799 ! Revised: MJIacono, AER, aug2008
800 !-------------------------------------------------------------------------------
801 !
802 ! name type purpose
803 ! ---- : ---- : ---------------------------------------------
804 ! ka : real
805 ! kb : real
806 ! absa : real
807 ! absb : real
808 ! selfref : real
809 ! forref : real
810 ! sfluxref: real
811 !-------------------------------------------------------------------------------
812 use parkind_k, only : im => kind_im, rb => kind_rb
813 use parrrsw_k, only : ng23
814 !
815 ! implicit none
816 !
817 save
818 integer(kind=im), parameter :: no23 = 16
819 !
820 real(kind=rb), dimension(5,13,no23) :: kao
821 real(kind=rb), dimension(10,no23) :: selfrefo
822 real(kind=rb), dimension(3,no23) :: forrefo
823 real(kind=rb), dimension(no23) :: sfluxrefo
824 real(kind=rb), dimension(no23) :: raylo
825 !
826 integer(kind=im) :: layreffr
827 real(kind=rb) :: givfac
828 !
829 real(kind=rb), dimension(5,13,ng23) :: ka
830 real(kind=rb), dimension(65,ng23) :: absa
831 real(kind=rb), dimension(10,ng23) :: selfref
832 real(kind=rb), dimension(3,ng23) :: forref
833 real(kind=rb), dimension(ng23) :: sfluxref
834 real(kind=rb), dimension(no23) :: rayl
835 equivalence (ka(1,1,1),absa(1,1))
836 !-------------------------------------------------------------------------------
837 end module rrsw_kg23_k
838 !-------------------------------------------------------------------------------
839 !
840 !
841 !-------------------------------------------------------------------------------
842 module rrsw_kg24_k
843 !-------------------------------------------------------------------------------
844 ! abstract :
845 ! rrtmg_sw ORIGINAL abs. coefficients for interval 24
846 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
847 !
848 ! history log :
849 ! 1999-10 JJMorcrette Initial version
850 ! 2006-07 MJIacono Revised, AER
851 ! 2008-08 MJIacono Revised, AER
852 !-------------------------------------------------------------------------------
853 !
854 ! name type purpose
855 ! ---- : ---- : ---------------------------------------------
856 ! kao : real
857 ! kbo : real
858 ! selfrefo: real
859 ! forrefo : real
860 !sfluxrefo: real
861 ! abso3ao : real
862 ! abso3bo : real
863 ! raylao : real
864 ! raylbo : real
865 !-------------------------------------------------------------------------------
866 ! rrtmg_sw COMBINED abs. coefficients for interval 24
867 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
868 !
869 ! Initial version: JJMorcrette, ECMWF, oct1999
870 ! Revised: MJIacono, AER, jul2006
871 ! Revised: MJIacono, AER, aug2008
872 !-------------------------------------------------------------------------------
873 !
874 ! name type purpose
875 ! ---- : ---- : ---------------------------------------------
876 ! ka : real
877 ! kb : real
878 ! absa : real
879 ! absb : real
880 ! selfref : real
881 ! forref : real
882 ! sfluxref: real
883 ! abso3a : real
884 ! abso3b : real
885 ! rayla : real
886 ! raylb : real
887 !-------------------------------------------------------------------------------
888 use parkind_k, only : im => kind_im, rb => kind_rb
889 use parrrsw_k, only : ng24
890 !
891 ! implicit none
892 !
893 save
894 integer(kind=im), parameter :: no24 = 16
895 !
896 real(kind=rb), dimension(9,5,13,no24) :: kao
897 real(kind=rb), dimension(5,13:59,no24) :: kbo
898 real(kind=rb), dimension(10,no24) :: selfrefo
899 real(kind=rb), dimension(3,no24) :: forrefo
900 real(kind=rb), dimension(no24,9) :: sfluxrefo
901 real(kind=rb), dimension(no24) :: abso3ao
902 real(kind=rb), dimension(no24) :: abso3bo
903 real(kind=rb), dimension(no24,9) :: raylao
904 real(kind=rb), dimension(no24) :: raylbo
905 !
906 integer(kind=im) :: layreffr
907 real(kind=rb) :: strrat
908 !
909 real(kind=rb), dimension(9,5,13,ng24) :: ka
910 real(kind=rb), dimension(585,ng24) :: absa
911 real(kind=rb), dimension(5,13:59,ng24) :: kb
912 real(kind=rb), dimension(235,ng24) :: absb
913 real(kind=rb), dimension(10,ng24) :: selfref
914 real(kind=rb), dimension(3,ng24) :: forref
915 real(kind=rb), dimension(ng24,9) :: sfluxref
916 real(kind=rb), dimension(ng24) :: abso3a
917 real(kind=rb), dimension(ng24) :: abso3b
918 real(kind=rb), dimension(ng24,9) :: rayla
919 real(kind=rb), dimension(ng24) :: raylb
920 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
921 !-------------------------------------------------------------------------------
922 end module rrsw_kg24_k
923 !-------------------------------------------------------------------------------
924 !
925 !
926 !-------------------------------------------------------------------------------
927 module rrsw_kg25_k
928 !-------------------------------------------------------------------------------
929 ! abstract :
930 ! rrtmg_sw ORIGINAL abs. coefficients for interval 25
931 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
932 !
933 ! history log :
934 ! 1999-10 JJMorcrette Initial version
935 ! 2006-07 MJIacono Revised, AER
936 ! 2008-08 MJIacono Revised, AER
937 !-------------------------------------------------------------------------------
938 !
939 ! name type purpose
940 ! ---- : ---- : ---------------------------------------------
941 ! kao : real
942 !sfluxrefo: real
943 ! abso3ao : real
944 ! abso3bo : real
945 ! raylo : real
946 !-------------------------------------------------------------------------------
947 ! rrtmg_sw COMBINED abs. coefficients for interval 25
948 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
949 !
950 ! Initial version: JJMorcrette, ECMWF, oct1999
951 ! Revised: MJIacono, AER, jul2006
952 ! Revised: MJIacono, AER, aug2008
953 !-------------------------------------------------------------------------------
954 !
955 ! name type purpose
956 ! ---- : ---- : ---------------------------------------------
957 ! ka : real
958 ! absa : real
959 ! sfluxref: real
960 ! abso3a : real
961 ! abso3b : real
962 ! rayl : real
963 !-------------------------------------------------------------------------------
964 use parkind_k, only : im => kind_im, rb => kind_rb
965 use parrrsw_k, only : ng25
966 !
967 ! implicit none
968 !
969 save
970 integer(kind=im), parameter :: no25 = 16
971 !
972 real(kind=rb), dimension(5,13,no25) :: kao
973 real(kind=rb), dimension(no25) :: sfluxrefo
974 real(kind=rb), dimension(no25) :: abso3ao
975 real(kind=rb), dimension(no25) :: abso3bo
976 real(kind=rb), dimension(no25) :: raylo
977 !
978 integer(kind=im) :: layreffr
979 !
980 real(kind=rb), dimension(5,13,ng25) :: ka
981 real(kind=rb), dimension(65,ng25) :: absa
982 real(kind=rb), dimension(ng25) :: sfluxref
983 real(kind=rb), dimension(ng25) :: abso3a
984 real(kind=rb), dimension(ng25) :: abso3b
985 real(kind=rb), dimension(ng25) :: rayl
986 equivalence (ka(1,1,1),absa(1,1))
987 !-------------------------------------------------------------------------------
988 end module rrsw_kg25_k
989 !-------------------------------------------------------------------------------
990 !
991 !
992 !-------------------------------------------------------------------------------
993 module rrsw_kg26_k
994 !-------------------------------------------------------------------------------
995 ! abstract :
996 ! rrtmg_sw ORIGINAL abs. coefficients for interval 26
997 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
998 !
999 ! history log :
1000 ! 1999-10 JJMorcrette Initial version
1001 ! 2006-07 MJIacono Revised, AER
1002 ! 2008-08 MJIacono Revised, AER
1003 !-------------------------------------------------------------------------------
1004 !
1005 ! name type purpose
1006 ! ---- : ---- : ---------------------------------------------
1007 !sfluxrefo: real
1008 ! raylo : real
1009 !-------------------------------------------------------------------------------
1010 ! rrtmg_sw COMBINED abs. coefficients for interval 26
1011 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1012 !
1013 ! Initial version: JJMorcrette, ECMWF, oct1999
1014 ! Revised: MJIacono, AER, jul2006
1015 ! Revised: MJIacono, AER, aug2008
1016 !-------------------------------------------------------------------------------
1017 !
1018 ! name type purpose
1019 ! ---- : ---- : ---------------------------------------------
1020 ! sfluxref: real
1021 ! rayl : real
1022 !-------------------------------------------------------------------------------
1023 use parkind_k, only : im => kind_im, rb => kind_rb
1024 use parrrsw_k, only : ng26
1025 !
1026 ! implicit none
1027 !
1028 save
1029 integer(kind=im), parameter :: no26 = 16
1030 !
1031 real(kind=rb), dimension(no26) :: sfluxrefo
1032 real(kind=rb), dimension(no26) :: raylo
1033 !
1034 real(kind=rb), dimension(ng26) :: sfluxref
1035 real(kind=rb), dimension(ng26) :: rayl
1036 !-------------------------------------------------------------------------------
1037 end module rrsw_kg26_k
1038 !-------------------------------------------------------------------------------
1039 !
1040 !
1041 !-------------------------------------------------------------------------------
1042 module rrsw_kg27_k
1043 !-------------------------------------------------------------------------------
1044 ! abstract :
1045 ! rrtmg_sw ORIGINAL abs. coefficients for interval 27
1046 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1047 !
1048 ! history log :
1049 ! 1999-10 JJMorcrette Initial version
1050 ! 2006-07 MJIacono Revised, AER
1051 ! 2008-08 MJIacono Revised, AER
1052 !-------------------------------------------------------------------------------
1053 !
1054 ! name type purpose
1055 ! ---- : ---- : ---------------------------------------------
1056 ! kao : real
1057 ! kbo : real
1058 !sfluxrefo: real
1059 ! raylo : real
1060 !-------------------------------------------------------------------------------
1061 ! rrtmg_sw COMBINED abs. coefficients for interval 27
1062 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1063 !
1064 ! Initial version: JJMorcrette, ECMWF, oct1999
1065 ! Revised: MJIacono, AER, jul2006
1066 ! Revised: MJIacono, AER, aug2008
1067 !-------------------------------------------------------------------------------
1068 !
1069 ! name type purpose
1070 ! ---- : ---- : ---------------------------------------------
1071 ! ka : real
1072 ! kb : real
1073 ! absa : real
1074 ! absb : real
1075 ! sfluxref: real
1076 ! rayl : real
1077 !-------------------------------------------------------------------------------
1078 use parkind_k, only : im => kind_im, rb => kind_rb
1079 use parrrsw_k, only : ng27
1080 !
1081 ! implicit none
1082 !
1083 save
1084 integer(kind=im), parameter :: no27 = 16
1085 !
1086 real(kind=rb), dimension(5,13,no27) :: kao
1087 real(kind=rb), dimension(5,13:59,no27) :: kbo
1088 real(kind=rb), dimension(no27) :: sfluxrefo
1089 real(kind=rb), dimension(no27) :: raylo
1090 !
1091 integer(kind=im) :: layreffr
1092 real(kind=rb) :: scalekur
1093 !
1094 real(kind=rb), dimension(5,13,ng27) :: ka
1095 real(kind=rb), dimension(65,ng27) :: absa
1096 real(kind=rb), dimension(5,13:59,ng27) :: kb
1097 real(kind=rb), dimension(235,ng27) :: absb
1098 real(kind=rb), dimension(ng27) :: sfluxref
1099 real(kind=rb), dimension(ng27) :: rayl
1100 !
1101 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1102 !-------------------------------------------------------------------------------
1103 end module rrsw_kg27_k
1104 !-------------------------------------------------------------------------------
1105 !
1106 !
1107 !-------------------------------------------------------------------------------
1108 module rrsw_kg28_k
1109 !-------------------------------------------------------------------------------
1110 ! abstract :
1111 ! rrtmg_sw ORIGINAL abs. coefficients for interval 28
1112 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1113 !
1114 ! history log :
1115 ! 1999-10 JJMorcrette Initial version
1116 ! 2006-07 MJIacono Revised, AER
1117 ! 2008-08 MJIacono Revised, AER
1118 !-------------------------------------------------------------------------------
1119 !
1120 ! name type purpose
1121 ! ---- : ---- : ---------------------------------------------
1122 ! kao : real
1123 ! kbo : real
1124 !sfluxrefo: real
1125 !-------------------------------------------------------------------------------
1126 ! rrtmg_sw COMBINED abs. coefficients for interval 28
1127 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1128 !
1129 ! Initial version: JJMorcrette, ECMWF, oct1999
1130 ! Revised: MJIacono, AER, jul2006
1131 ! Revised: MJIacono, AER, aug2008
1132 !-------------------------------------------------------------------------------
1133 !
1134 ! name type purpose
1135 ! ---- : ---- : ---------------------------------------------
1136 ! ka : real
1137 ! kb : real
1138 ! sfluxref: real
1139 !-------------------------------------------------------------------------------
1140 use parkind_k, only : im => kind_im, rb => kind_rb
1141 use parrrsw_k, only : ng28
1142 !
1143 ! implicit none
1144 !
1145 save
1146 integer(kind=im), parameter :: no28 = 16
1147 !
1148 real(kind=rb), dimension(9,5,13,no28) :: kao
1149 real(kind=rb), dimension(5,5,13:59,no28) :: kbo
1150 real(kind=rb), dimension(no28,5) :: sfluxrefo
1151 !
1152 integer(kind=im) :: layreffr
1153 real(kind=rb) :: rayl, strrat
1154 !
1155 real(kind=rb), dimension(9,5,13,ng28) :: ka
1156 real(kind=rb), dimension(585,ng28) :: absa
1157 real(kind=rb), dimension(5,5,13:59,ng28) :: kb
1158 real(kind=rb), dimension(1175,ng28) :: absb
1159 real(kind=rb), dimension(ng28,5) :: sfluxref
1160 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
1161 !-------------------------------------------------------------------------------
1162 end module rrsw_kg28_k
1163 !-------------------------------------------------------------------------------
1164 !
1165 !
1166 !-------------------------------------------------------------------------------
1167 module rrsw_kg29_k
1168 !-------------------------------------------------------------------------------
1169 ! abstract :
1170 ! rrtmg_sw ORIGINAL abs. coefficients for interval 29
1171 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1172 !
1173 ! history log :
1174 ! 1999-10 JJMorcrette Initial version
1175 ! 2006-07 MJIacono Revised, AER
1176 ! 2008-08 MJIacono Revised, AER
1177 !-------------------------------------------------------------------------------
1178 !
1179 ! name type purpose
1180 ! ---- : ---- : ---------------------------------------------
1181 ! kao : real
1182 ! kbo : real
1183 ! selfrefo: real
1184 ! forrefo : real
1185 !sfluxrefo: real
1186 ! absh2oo : real
1187 ! absco2o : real
1188 !-------------------------------------------------------------------------------
1189 ! rrtmg_sw COMBINED abs. coefficients for interval 29
1190 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1191 !
1192 ! Initial version: JJMorcrette, ECMWF, oct1999
1193 ! Revised: MJIacono, AER, jul2006
1194 ! Revised: MJIacono, AER, aug2008
1195 !-------------------------------------------------------------------------------
1196 !
1197 ! name type purpose
1198 ! ---- : ---- : ---------------------------------------------
1199 ! ka : real
1200 ! kb : real
1201 ! selfref : real
1202 ! forref : real
1203 ! sfluxref: real
1204 ! absh2o : real
1205 ! absco2 : real
1206 !-------------------------------------------------------------------------------
1207 !
1208 use parkind_k, only : im => kind_im, rb => kind_rb
1209 use parrrsw_k, only : ng29
1210 !
1211 ! implicit none
1212 !
1213 save
1214 integer(kind=im), parameter :: no29 = 16
1215 !
1216 real(kind=rb), dimension(5,13,no29) :: kao
1217 real(kind=rb), dimension(5,13:59,no29) :: kbo
1218 real(kind=rb), dimension(10,no29) :: selfrefo
1219 real(kind=rb), dimension(4,no29) :: forrefo
1220 real(kind=rb), dimension(no29) :: sfluxrefo
1221 real(kind=rb), dimension(no29) :: absh2oo, absco2o
1222 !
1223 integer(kind=im) :: layreffr
1224 real(kind=rb) :: rayl
1225 !
1226 real(kind=rb), dimension(5,13,ng29) :: ka
1227 real(kind=rb), dimension(65,ng29) :: absa
1228 real(kind=rb), dimension(5,13:59,ng29) :: kb
1229 real(kind=rb), dimension(235,ng29) :: absb
1230 real(kind=rb), dimension(10,ng29) :: selfref
1231 real(kind=rb), dimension(4,ng29) :: forref
1232 real(kind=rb), dimension(ng29) :: sfluxref
1233 real(kind=rb), dimension(ng29) :: absh2o,absco2
1234 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1235 !-------------------------------------------------------------------------------
1236 end module rrsw_kg29_k
1237 !-------------------------------------------------------------------------------
1238 !
1239 !
1240 !-------------------------------------------------------------------------------
1241 module rrsw_ref_k
1242 !-------------------------------------------------------------------------------
1243 ! abstract :
1244 ! rrtmg_sw reference atmosphere
1245 ! Based on standard mid-latitude summer profile
1246 !
1247 ! history log :
1248 ! 1998-07 JJMorcrette Initial version
1249 ! 2006-07 MJIacono Revised, AER
1250 ! 2008-08 MJIacono Revised, AER
1251 !-------------------------------------------------------------------------------
1252 ! name type purpose
1253 ! ----- : ---- : ----------------------------------------------
1254 ! pref : real : Reference pressure levels
1255 ! preflog: real : Reference pressure levels, ln(pref)
1256 ! tref : real : Reference temperature levels for MLS profile
1257 !-------------------------------------------------------------------------------
1258 use parkind_k, only : im => kind_im, rb => kind_rb
1259 !
1260 ! implicit none
1261 !
1262 save
1263 real(kind=rb) , dimension(59) :: pref
1264 real(kind=rb) , dimension(59) :: preflog
1265 real(kind=rb) , dimension(59) :: tref
1266 !-------------------------------------------------------------------------------
1267 end module rrsw_ref_k
1268 !-------------------------------------------------------------------------------
1269 !
1270 !
1271 !-------------------------------------------------------------------------------
1272 module rrsw_tbl_k
1273 !-------------------------------------------------------------------------------
1274 ! abstract :
1275 ! rrtmg_sw lookup table arrays
1276 !
1277 ! history log :
1278 ! 2007-05 MJIAcono Initial version
1279 ! 2006-07 MJIacono Revised, AER
1280 ! 2008-08 MJIacono Revised, AER
1281 !-------------------------------------------------------------------------------
1282 ! name type purpose
1283 ! ----- : ---- : ----------------------------------------------
1284 ! ntbl : integer: Lookup table dimension
1285 ! tblint : real : Lookup table conversion factor
1286 ! tau_tbl: real : Clear-sky optical depth
1287 ! exp_tbl: real : Exponential lookup table for transmittance
1288 ! od_lo : real : Value of tau below which expansion is used
1289 ! : in place of lookup table
1290 ! pade : real : Pade approximation constant
1291 ! bpade : real : Inverse of Pade constant
1292 !-------------------------------------------------------------------------------
1293 use parkind_k, only : im => kind_im, rb => kind_rb
1294 !
1295 ! implicit none
1296 !
1297 save
1298 integer(kind=im), parameter :: ntbl = 10000
1299 real(kind=rb), parameter :: tblint = 10000.0_rb
1300 real(kind=rb), parameter :: od_lo = 0.06_rb
1301 real(kind=rb) :: tau_tbl
1302 real(kind=rb), dimension(0:ntbl) :: exp_tbl
1303 !
1304 real(kind=rb), parameter :: pade = 0.278_rb
1305 real(kind=rb) :: bpade
1306 !
1307 end module rrsw_tbl_k
1308 !-------------------------------------------------------------------------------
1309 !
1310 !
1311 !-------------------------------------------------------------------------------
1312 module rrsw_vsn_k
1313 !-------------------------------------------------------------------------------
1314 ! abstract :
1315 ! rrtmg_sw version information
1316 !
1317 ! history log :
1318 ! 1998-07 JJMorcrette Initial version
1319 ! 2006-07 MJIacono Revised, AER
1320 ! 2008-08 MJIacono Revised, AER
1321 !-------------------------------------------------------------------------------
1322 ! name type purpose
1323 ! ----- : ---- : ----------------------------------------------
1324 !hnamrtm :character:
1325 !hnamini :character:
1326 !hnamcld :character:
1327 !hnamclc :character:
1328 !hnamrft :character:
1329 !hnamspv :character:
1330 !hnamspc :character:
1331 !hnamset :character:
1332 !hnamtau :character:
1333 !hnamvqd :character:
1334 !hnamatm :character:
1335 !hnamutl :character:
1336 !hnamext :character:
1337 !hnamkg :character:
1338 !
1339 ! hvrrtm :character:
1340 ! hvrini :character:
1341 ! hvrcld :character:
1342 ! hvrclc :character:
1343 ! hvrrft :character:
1344 ! hvrspv :character:
1345 ! hvrspc :character:
1346 ! hvrset :character:
1347 ! hvrtau :character:
1348 ! hvrvqd :character:
1349 ! hvratm :character:
1350 ! hvrutl :character:
1351 ! hvrext :character:
1352 ! hvrkg :character:
1353 !-------------------------------------------------------------------------------
1354 !
1355 ! implicit none
1356 !
1357 save
1358 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
1359 hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
1360 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
1361 hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
1362 !
1363 character*18 hvrkg
1364 character*20 hnamkg
1365 !-------------------------------------------------------------------------------
1366 end module rrsw_vsn_k
1367 !-------------------------------------------------------------------------------
1368 !
1369 !
1370 !-------------------------------------------------------------------------------
1371 module rrsw_wvn_k
1372 !-------------------------------------------------------------------------------
1373 use parkind_k, only : im => kind_im, rb => kind_rb
1374 use parrrsw_k, only : nbndsw, mg, ngptsw, jpb1, jpb2
1375 !-------------------------------------------------------------------------------
1376 ! abstract :
1377 ! rrtmg_sw spectral information
1378 !
1379 ! history log :
1380 ! 1998-07 JJMorcrette Initial version
1381 ! 2006-07 MJIacono Revised, AER
1382 ! 2008-08 MJIacono Revised, AER
1383 !-------------------------------------------------------------------------------
1384 ! name type purpose
1385 ! ----- : ---- : ----------------------------------------------
1386 ! ng : integer: Number of original g-intervals in each spectral band
1387 ! nspa : integer:
1388 ! nspb : integer:
1389 !wavenum1: real : Spectral band lower boundary in wavenumbers
1390 !wavenum2: real : Spectral band upper boundary in wavenumbers
1391 ! delwave: real : Spectral band width in wavenumbers
1392 !
1393 ! ngc : integer: The number of new g-intervals in each band
1394 ! ngs : integer: The cumulative sum of new g-intervals for each band
1395 ! ngm : integer: The index of each new g-interval relative to the
1396 ! original 16 g-intervals in each band
1397 ! ngn : integer: The number of original g-intervals that are
1398 ! combined to make each new g-intervals in each band
1399 ! ngb : integer: The band index for each new g-interval
1400 ! wt : real : RRTM weights for the original 16 g-intervals
1401 ! rwgt : real : Weights for combining original 16 g-intervals
1402 ! (224 total) into reduced set of g-intervals
1403 ! (112 total)
1404 !-------------------------------------------------------------------------------
1405 !
1406 ! implicit none
1407 !
1408 save
1409 integer(kind=im), dimension(jpb1:jpb2) :: ng, nspa, nspb
1410 !
1411 real(kind=rb), dimension(jpb1:jpb2) :: wavenum1, wavenum2, delwave
1412 !
1413 integer(kind=im), dimension(nbndsw) :: ngc, ngs
1414 integer(kind=im), dimension(ngptsw) :: ngn, ngb
1415 integer(kind=im), dimension(nbndsw*mg) :: ngm
1416 !
1417 real(kind=rb), dimension(mg) :: wt
1418 real(kind=rb), dimension(nbndsw*mg) :: rwgt
1419 !-------------------------------------------------------------------------------
1420 end module rrsw_wvn_k
1421 !-------------------------------------------------------------------------------
1422 !
1423 !
1424 !-------------------------------------------------------------------------------
1425 module rrtmg_sw_cldprmc_k
1426 !-------------------------------------------------------------------------------
1427 ! --------------------------------------------------------------------------
1428 ! | |
1429 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
1430 ! | This software may be used, copied, or redistributed as long as it is |
1431 ! | not sold and this copyright notice is reproduced on each copy made. |
1432 ! | This model is provided as is without any express or implied warranties. |
1433 ! | (http://www.rtweb.aer.com/) |
1434 ! | |
1435 ! --------------------------------------------------------------------------
1436 ! ------- Modules -------
1437 !
1438 use parkind_k, only : im => kind_im, rb => kind_rb
1439 use parrrsw_k, only : ngptsw, jpband, jpb1, jpb2
1440 use rrsw_cld_k, only : extliq1, ssaliq1, asyliq1, &
1441 extice2, ssaice2, asyice2, &
1442 extice3, ssaice3, asyice3, fdlice3, &
1443 abari, bbari, cbari, dbari, ebari, fbari
1444 use rrsw_wvn_k, only : wavenum1, wavenum2, ngb
1445 use rrsw_vsn_k, only : hvrclc, hnamclc
1446 !
1447 implicit none
1448 !
1449 contains
1450 !-------------------------------------------------------------------------------
1451 subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
1452 ciwpmc, clwpmc, reicmc, relqmc, &
1453 cswpmc, resnmc, &
1454 dtliq, dtice, dtsno, dwliq, dwice, dwsno, &
1455 daliq, daice, dasno, &
1456 taormc, taucmc, ssacmc, asmcmc, fsfcmc)
1457 !-------------------------------------------------------------------------------
1458 !
1459 ! abstract:
1460 ! Compute the cloud optical properties for each cloudy layer
1461 ! and g-point interval for use by the McICA method.
1462 ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available;
1463 !
1464 ! history log :
1465 !
1466 ! reference :
1467 ! Hu & Stamnes, Key, and Fu
1468 !
1469 ! variables :
1470 ! input :
1471 ! nlayer - total number of layers
1472 ! inflag - see definitions
1473 ! iceflag - see definitions
1474 ! liqflag - see definitions
1475 ! cldfmc(ngptsw,nlayers) - cloud fraction [mcica]
1476 ! ciwpmc(ngptsw,nlayers) - cloud ice water path [mcica]
1477 ! clwpmc(ngptsw,nlayers) - cloud liquid water path [mcica]
1478 ! cswpmc(ngptsw,nlayers) - cloud snow water path [mcica]
1479 ! relqmc(nlayers) - cloud liquid particle effective radius (microns)
1480 ! reicmc(nlayers) - cloud ice particle effective radius (microns)
1481 ! resnmc(nlayers) - cloud snow particle effective radius (microns)
1482 !
1483 ! specific definition of reicmc depends on setting of iceflag:
1484 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
1485 ! r_ec range is limited to 13.0 to 130.0 microns
1486 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
1487 ! r_k range is limited to 5.0 to 131.0 microns
1488 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
1489 ! dge range is limited to 5.0 to 140.0 microns
1490 ! [dge = 1.0315 * r_ec]
1491 ! fsfcmc(ngptsw,nlayers) - cloud forward scattering fraction
1492 !
1493 ! output :
1494 ! taucmc(ngptsw,nlayers) - cloud optical depth (delta scaled)
1495 ! ssacmc(ngptsw,nlayers) - single scattering albedo (delta scaled)
1496 ! asmcmc(ngptsw,nlayers) - asymmetry parameter (delta scaled)
1497 ! taormc(ngptsw,nlayers) - cloud optical depth (non-delta scaled)
1498 !
1499 ! local :
1500 ! eps - epsilon
1501 ! cldmin - minimum value for cloud quantities
1502 ! cwp - total cloud water path
1503 ! radliq - cloud liquid droplet radius (microns)
1504 ! radice - cloud ice effective size (microns)
1505 ! radsno - cloud snow effective size (microns)
1506 !
1507 ! ------- Input -------
1508 !
1509 integer(kind=im), intent(in ) :: nlayers
1510 integer(kind=im), intent(in ) :: inflag
1511 integer(kind=im), intent(in ) :: iceflag
1512 integer(kind=im), intent(in ) :: liqflag
1513 real(kind=rb), dimension(:,:), intent(in ) :: cldfmc
1514 real(kind=rb), dimension(:,:), intent(in ) :: ciwpmc
1515 real(kind=rb), dimension(:,:), intent(in ) :: clwpmc
1516 real(kind=rb), dimension(:,:), intent(in ) :: cswpmc
1517 real(kind=rb), dimension(:), intent(in ) :: relqmc
1518 real(kind=rb), dimension(:), intent(in ) :: reicmc
1519 real(kind=rb), dimension(:), intent(in ) :: resnmc
1520 real(kind=rb), dimension(:,:), intent(in ) :: fsfcmc
1521 !
1522 ! ------- Output -------
1523 !
1524 real(kind=rb), dimension(:,:), intent(inout) :: taucmc
1525 real(kind=rb), dimension(:,:), intent(inout) :: ssacmc
1526 real(kind=rb), dimension(:,:), intent(inout) :: asmcmc
1527 real(kind=rb), dimension(:,:), intent(out) :: taormc
1528 real(kind=rb), dimension(:,:), intent(inout) :: dtliq, dtice, dtsno
1529 real(kind=rb), dimension(:,:), intent(inout) :: dwliq, dwice, dwsno
1530 real(kind=rb), dimension(:,:), intent(inout) :: daliq, daice, dasno
1531 !
1532 ! ------- Local -------
1533 !
1534 integer(kind=im) :: ib, lay, istr, index, icx, ig
1535 !
1536 real(kind=rb), parameter :: eps = 1.e-06_rb
1537 real(kind=rb), parameter :: cldmin = 1.e-20_rb
1538 real(kind=rb) :: cwp
1539 real(kind=rb) :: radliq
1540 real(kind=rb) :: radice
1541 real(kind=rb) :: radsno
1542 real(kind=rb) :: factor
1543 real(kind=rb) :: fint
1544 !
1545 real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
1546 real(kind=rb) :: tauiceorig, scatice, ssaice, tauice
1547 real(kind=rb) :: tauliqorig, scatliq, ssaliq, tauliq
1548 real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno
1549 real(kind=rb), dimension(ngptsw) :: fdelta
1550 real(kind=rb), dimension(ngptsw) :: extcoice, gice
1551 real(kind=rb), dimension(ngptsw) :: ssacoice, forwice
1552 real(kind=rb), dimension(ngptsw) :: extcoliq, gliq
1553 real(kind=rb), dimension(ngptsw) :: ssacoliq, forwliq
1554 real(kind=rb), dimension(ngptsw) :: extcosno, gsno
1555 real(kind=rb), dimension(ngptsw) :: ssacosno, forwsno
1556 !-------------------------------------------------------------------------------
1557 !
1558 ! Initialize
1559 !
1560 hvrclc = '$Revision: 1.3 $'
1561 !
1562 ! Some of these initializations are done elsewhere
1563 !
1564 do lay = 1,nlayers
1565 do ig = 1,ngptsw
1566 taormc(ig,lay) = taucmc(ig,lay)
1567 ! taucmc(ig,lay) = 0.0_rb
1568 ! ssacmc(ig,lay) = 1.0_rb
1569 ! asmcmc(ig,lay) = 0.0_rb
1570 enddo
1571 enddo
1572 !
1573 ! Main layer loop
1574 !
1575 do lay = 1,nlayers
1576 !
1577 ! Main g-point interval loop
1578 !
1579 do ig = 1,ngptsw
1580 cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
1581 if(cldfmc(ig,lay).ge.cldmin .and. &
1582 (cwp.ge.cldmin .or. taucmc(ig,lay).ge.cldmin)) then
1583 !
1584 ! (inflag=0): Cloud optical properties input directly
1585 !
1586 if(inflag.eq.0) then
1587 !
1588 ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are
1589 ! unscaled; Apply delta-M scaling here (using Henyey-Greenstein approximation)
1590 !
1591 taucldorig_a = taucmc(ig,lay)
1592 ffp = fsfcmc(ig,lay)
1593 ffp1 = 1.0_rb-ffp
1594 ffpssa = 1.0_rb-ffp*ssacmc(ig,lay)
1595 ssacloud_a = ffp1*ssacmc(ig,lay)/ffpssa
1596 taucloud_a = ffpssa*taucldorig_a
1597 !
1598 taormc(ig,lay) = taucldorig_a
1599 ssacmc(ig,lay) = ssacloud_a
1600 taucmc(ig,lay) = taucloud_a
1601 asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1)
1602 !
1603 elseif(inflag.eq.1) then
1604 stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
1605 !
1606 ! (inflag=2): Separate treatement of ice clouds and water clouds.
1607 !
1608 elseif(inflag.ge.2) then
1609 radice = reicmc(lay)
1610 !
1611 ! Calculation of absorption coefficients due to ice clouds.
1612 !
1613 if((ciwpmc(ig,lay)+cswpmc(ig,lay)).eq.0.0_rb) then
1614 extcoice(ig) = 0.0_rb
1615 ssacoice(ig) = 0.0_rb
1616 gice(ig) = 0.0_rb
1617 forwice(ig) = 0.0_rb
1618 extcosno(ig) = 0.0_rb
1619 ssacosno(ig) = 0.0_rb
1620 gsno(ig) = 0.0_rb
1621 forwsno(ig) = 0.0_rb
1622 !
1623 ! (iceflag = 1):
1624 ! Note: This option uses Ebert and Curry approach for all particle sizes similar
1625 ! to CAM3 implementation, though this is somewhat unjustified for large ice
1626 ! particles
1627 !
1628 elseif(iceflag.eq.1) then
1629 ib = ngb(ig)
1630 if(wavenum2(ib).gt.1.43e04_rb) then
1631 icx = 1
1632 elseif (wavenum2(ib).gt.7.7e03_rb) then
1633 icx = 2
1634 elseif (wavenum2(ib).gt.5.3e03_rb) then
1635 icx = 3
1636 elseif (wavenum2(ib).gt.4.0e03_rb) then
1637 icx = 4
1638 elseif (wavenum2(ib).ge.2.5e03_rb) then
1639 icx = 5
1640 endif
1641 extcoice(ig) = (abari(icx)+bbari(icx)/radice)
1642 ssacoice(ig) = 1._rb-cbari(icx)-dbari(icx)*radice
1643 gice(ig) = ebari(icx)+fbari(icx)*radice
1644 !
1645 ! Check to ensure upper limit of gice is within physical limits for large
1646 ! particles
1647 !
1648 if (gice(ig).ge.1._rb) gice(ig) = 1._rb-eps
1649 forwice(ig) = gice(ig)*gice(ig)
1650 !
1651 ! Check to ensure all calculated quantities are within physical limits.
1652 !
1653 if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1654 if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1655 if(ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1656 if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1657 if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1658 !
1659 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0
1660 ! microns
1661 !
1662 elseif (iceflag .eq. 2) then
1663 if(radice.lt.5.0_rb .or. radice.gt.131.0_rb) &
1664 stop 'ICE RADIUS OUT OF BOUNDS'
1665 factor = (radice - 2._rb)/3._rb
1666 index = int(factor)
1667 if(index.eq.43) index = 42
1668 fint = factor - real(index)
1669 ib = ngb(ig)
1670 extcoice(ig) = extice2(index,ib) + fint * &
1671 (extice2(index+1,ib) - extice2(index,ib))
1672 ssacoice(ig) = ssaice2(index,ib) + fint * &
1673 (ssaice2(index+1,ib) - ssaice2(index,ib))
1674 gice(ig) = asyice2(index,ib) + fint * &
1675 (asyice2(index+1,ib) - asyice2(index,ib))
1676 forwice(ig) = gice(ig)*gice(ig)
1677 !
1678 ! Check to ensure all calculated quantities are within physical limits.
1679 !
1680 if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1681 if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1682 if(ssacoice(ig).lt.0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1683 if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1684 if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1685 !
1686 ! For iceflag=3 option, ice particle generalized effective size is limited to
1687 ! 5.0 to 140.0 microns
1688 !
1689 elseif(iceflag.ge.3) then
1690 !
1691 if(radice.lt.5.0_rb .or. radice.gt.140.0_rb) &
1692 stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
1693 factor = (radice - 2._rb)/3._rb
1694 index = int(factor)
1695 if(index.eq.46) index = 45
1696 fint = factor - real(index)
1697 ib = ngb(ig)
1698 extcoice(ig) = extice3(index,ib)+fint* &
1699 (extice3(index+1,ib)-extice3(index,ib))
1700 ssacoice(ig) = ssaice3(index,ib)+fint* &
1701 (ssaice3(index+1,ib)-ssaice3(index,ib))
1702 gice(ig) = asyice3(index,ib)+fint* &
1703 (asyice3(index+1,ib)-asyice3(index,ib))
1704 fdelta(ig) = fdlice3(index,ib)+fint* &
1705 (fdlice3(index+1,ib)-fdlice3(index,ib))
1706 if(fdelta(ig).lt.0.0_rb) stop 'FDELTA LESS THAN 0.0'
1707 if(fdelta(ig).gt.1.0_rb) stop 'FDELTA GT THAN 1.0'
1708 forwice(ig) = fdelta(ig)+0.5_rb/ssacoice(ig)
1709 !
1710 ! See Fu 1996 p. 2067
1711 !
1712 if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
1713 !
1714 ! Check to ensure all calculated quantities are within physical limits.
1715 !
1716 if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1717 if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1718 if(ssacoice(ig).lt.0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1719 if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1720 if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1721 endif
1722 !
1723 ! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
1724 ! Although far from perfect, the snow will utilize the
1725 ! same lookup table constants as cloud ice. Changes
1726 ! to those constants for larger particle snow would be
1727 ! an improvement.
1728 !
1729 if(cswpmc(ig,lay).gt.0.0_rb .and. iceflag.eq.5) then
1730 radsno = resnmc(lay)
1731 if(radsno.lt.5.0_rb .or. radsno.gt.140.0_rb) stop &
1732 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
1733 factor = (radsno - 2._rb)/3._rb
1734 index = int(factor)
1735 if(index.eq.46) index = 45
1736 fint = factor-real(index)
1737 ib = ngb(ig)
1738 extcosno(ig) = extice3(index,ib)+fint* &
1739 (extice3(index+1,ib)-extice3(index,ib))
1740 ssacosno(ig) = ssaice3(index,ib)+fint* &
1741 (ssaice3(index+1,ib)-ssaice3(index,ib))
1742 gsno(ig) = asyice3(index,ib)+fint* &
1743 (asyice3(index+1,ib)-asyice3(index,ib))
1744 fdelta(ig) = fdlice3(index,ib)+fint* &
1745 (fdlice3(index+1,ib)-fdlice3(index,ib))
1746 if(fdelta(ig).lt.0.0_rb) stop 'FDELTA LESS THAN 0.0'
1747 if(fdelta(ig).gt.1.0_rb) stop 'FDELTA GT THAN 1.0'
1748 forwsno(ig) = fdelta(ig)+0.5_rb/ssacosno(ig)
1749 if(forwsno(ig).gt.gsno(ig)) forwsno(ig) = gsno(ig)
1750 !
1751 ! Check to ensure all calculated quantities are within physical limits.
1752 !
1753 if(extcosno(ig).lt.0.0_rb) stop 'SNOW EXTINCTION LESS THAN 0.0'
1754 if(ssacosno(ig).gt.1.0_rb) stop 'SNOW SSA GRTR THAN 1.0'
1755 if(ssacosno(ig).lt.0.0_rb) stop 'SNOW SSA LESS THAN 0.0'
1756 if(gsno(ig).gt.1.0_rb) stop 'SNOW ASYM GRTR THAN 1.0'
1757 if(gsno(ig).lt.0.0_rb) stop 'SNOW ASYM LESS THAN 0.0'
1758 else
1759 extcosno(ig) = 0.0_rb
1760 ssacosno(ig) = 0.0_rb
1761 gsno(ig) = 0.0_rb
1762 forwsno(ig) = 0.0_rb
1763 endif
1764 !
1765 ! Calculation of absorption coefficients due to water clouds.
1766 !
1767 if (clwpmc(ig,lay) .eq. 0.0_rb) then
1768 extcoliq(ig) = 0.0_rb
1769 ssacoliq(ig) = 0.0_rb
1770 gliq(ig) = 0.0_rb
1771 forwliq(ig) = 0.0_rb
1772 elseif (liqflag .eq. 1) then
1773 radliq = relqmc(lay)
1774 if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop &
1775 'liquid effective radius out of bounds'
1776 index = int(radliq - 1.5_rb)
1777 if (index .eq. 0) index = 1
1778 if (index .eq. 58) index = 57
1779 fint = radliq - 1.5_rb - real(index)
1780 ib = ngb(ig)
1781 extcoliq(ig) = extliq1(index,ib) + fint * &
1782 (extliq1(index+1,ib) - extliq1(index,ib))
1783 ssacoliq(ig) = ssaliq1(index,ib) + fint * &
1784 (ssaliq1(index+1,ib) - ssaliq1(index,ib))
1785 if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb) &
1786 ssacoliq(ig) = ssaliq1(index,ib)
1787 gliq(ig) = asyliq1(index,ib) + fint * &
1788 (asyliq1(index+1,ib) - asyliq1(index,ib))
1789 forwliq(ig) = gliq(ig)*gliq(ig)
1790 !
1791 ! Check to ensure all calculated quantities are within physical limits.
1792 !
1793 if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
1794 if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
1795 if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
1796 if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
1797 if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
1798 endif
1799 !
1800 if(iceflag.lt.5) then
1801 tauliqorig = clwpmc(ig,lay)*extcoliq(ig)
1802 tauiceorig = ciwpmc(ig,lay)*extcoice(ig)
1803 taormc(ig,lay) = tauliqorig+tauiceorig
1804 !
1805 ssaliq = ssacoliq(ig)*(1._rb-forwliq(ig)) &
1806 /(1._rb-forwliq(ig)*ssacoliq(ig))
1807 tauliq = (1._rb-forwliq(ig)*ssacoliq(ig))*tauliqorig
1808 ssaice = ssacoice(ig)*(1._rb-forwice(ig)) &
1809 /(1._rb-forwice(ig)*ssacoice(ig))
1810 tauice = (1._rb-forwice(ig)*ssacoice(ig))*tauiceorig
1811 !
1812 scatliq = ssaliq*tauliq
1813 scatice = ssaice*tauice
1814 scatsno = 0.0_rb
1815 taucmc(ig,lay) = tauliq+tauice
1816 else
1817 tauliqorig = clwpmc(ig,lay)*extcoliq(ig)
1818 tauiceorig = ciwpmc(ig,lay)*extcoice(ig)
1819 tausnoorig = cswpmc(ig,lay)*extcosno(ig)
1820 taormc(ig,lay) = tauliqorig+tauiceorig+tausnoorig
1821 !
1822 ssaliq = ssacoliq(ig)*(1._rb-forwliq(ig)) &
1823 /(1._rb-forwliq(ig)*ssacoliq(ig))
1824 tauliq = (1._rb-forwliq(ig)*ssacoliq(ig))*tauliqorig
1825 ssaice = ssacoice(ig)*(1._rb-forwice(ig)) &
1826 /(1._rb-forwice(ig)*ssacoice(ig))
1827 tauice = (1._rb-forwice(ig)*ssacoice(ig))*tauiceorig
1828 ssasno = ssacosno(ig)*(1._rb-forwsno(ig)) &
1829 /(1._rb-forwsno(ig)*ssacosno(ig))
1830 tausno = (1._rb-forwsno(ig)*ssacosno(ig))*tausnoorig
1831 scatliq = ssaliq*tauliq
1832 scatice = ssaice*tauice
1833 scatsno = ssasno*tausno
1834 taucmc(ig,lay) = tauliq+tauice+tausno
1835 endif
1836 dtliq(ig,lay)=tauliq ; dwliq(ig,lay)=ssaliq
1837 dtice(ig,lay)=tauice ; dwice(ig,lay)=ssaice
1838 dtsno(ig,lay)=tausno ; dwsno(ig,lay)=ssasno
1839 daliq(ig,lay)=(gliq(ig)-forwliq(ig))/(1._rb-forwliq(ig))
1840 daice(ig,lay)=(gice(ig)-forwice(ig))/(1._rb-forwice(ig))
1841 dasno(ig,lay)=(gsno(ig)-forwsno(ig))/(1._rb-forwsno(ig))
1842 !
1843 ! Ensure non-zero taucmc and scatice
1844 !
1845 if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
1846 if(scatice.eq.0.) scatice = cldmin
1847 if(scatsno.eq.0.) scatsno = cldmin
1848 !
1849 if(iceflag.lt.5) then
1850 ssacmc(ig,lay) = (scatliq+scatice)/taucmc(ig,lay)
1851 else
1852 ssacmc(ig,lay) = (scatliq+scatice+scatsno)/taucmc(ig,lay)
1853 endif
1854 !
1855 if(iceflag.eq.3 .or. iceflag.eq.4) then
1856 !
1857 ! In accordance with the 1996 Fu paper, equation A.3,
1858 ! the moments for ice were calculated depending on whether using spheres
1859 ! or hexagonal ice crystals.
1860 ! Set asymetry parameter to first moment (istr=1)
1861 !
1862 istr = 1
1863 asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))* &
1864 (scatliq*(gliq(ig)**istr - forwliq(ig)) / &
1865 (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
1866 (1.0_rb - forwice(ig)))**istr)
1867 elseif(iceflag.eq.5) then
1868 istr = 1
1869 asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno)) &
1870 *(scatliq*(gliq(ig)**istr-forwliq(ig))/(1.0_rb-forwliq(ig)) &
1871 + scatice*((gice(ig)-forwice(ig))/(1.0_rb-forwice(ig))) &
1872 + scatsno*((gsno(ig)-forwsno(ig))/ &
1873 (1.0_rb-forwsno(ig)))**istr)
1874 else
1875 !
1876 ! This code is the standard method for delta-m scaling.
1877 ! Set asymetry parameter to first moment (istr=1)
1878 !
1879 istr = 1
1880 asmcmc(ig,lay) = (scatliq * &
1881 (gliq(ig)**istr - forwliq(ig)) / &
1882 (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / &
1883 (1.0_rb - forwice(ig)))/(scatliq + scatice)
1884 endif
1885 !
1886 endif
1887 !
1888 endif
1889 !
1890 ! End g-point interval loop
1891 !
1892 enddo
1893 !
1894 ! End layer loop
1895 !
1896 enddo
1897 !
1898 end subroutine cldprmc_sw
1899 !-------------------------------------------------------------------------------
1900 !
1901 !
1902 !-------------------------------------------------------------------------------
1903 end module rrtmg_sw_cldprmc_k
1904 !-------------------------------------------------------------------------------
1905 !
1906 !
1907 !-------------------------------------------------------------------------------
1908 module rrtmg_sw_reftra_k
1909 !-------------------------------------------------------------------------------
1910 ! --------------------------------------------------------------------------
1911 ! | |
1912 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
1913 ! | This software may be used, copied, or redistributed as long as it is |
1914 ! | not sold and this copyright notice is reproduced on each copy made. |
1915 ! | This model is provided as is without any express or implied warranties. |
1916 ! | (http://www.rtweb.aer.com/) |
1917 ! | |
1918 ! --------------------------------------------------------------------------
1919 ! ------- Modules -------
1920 !
1921 use parkind_k, only : im => kind_im, rb => kind_rb
1922 use rrsw_tbl_k, only : tblint, bpade, od_lo, exp_tbl
1923 use rrsw_vsn_k, only : hvrrft, hnamrft
1924 !
1925 implicit none
1926 !
1927 contains
1928 !-------------------------------------------------------------------------------
1929 !
1930 !
1931 !-------------------------------------------------------------------------------
1932 subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, &
1933 al1, al2, al3, &
1934 pref, prefd, ptra, ptrad)
1935 !-------------------------------------------------------------------------------
1936 !
1937 ! abstract:
1938 ! computes the reflectivity and transmissivity of a clear or
1939 ! cloudy layer using a choice of various approximations.
1940 !
1941 ! history log :
1942 ! 2016-10-27 sunghye baek revised TSA
1943 ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
1944 !
1945 ! Description:
1946 ! explicit arguments :
1947 ! --------------------
1948 ! inputs
1949 ! ------
1950 ! lrtchk = .t. for all layers in clear profile
1951 ! lrtchk = .t. for cloudy layers in cloud profile
1952 ! = .f. for clear layers in cloud profile
1953 ! pgg = assymetry factor
1954 ! prmuz = cosine solar zenith angle
1955 ! ptau = optical thickness
1956 ! pw = single scattering albedo
1957 ! al,a2,a3= coefficients for Ritter and Geleyn 1992 convention
1958 !
1959 ! outputs
1960 ! -------
1961 ! pref : collimated beam reflectivity
1962 ! prefd : diffuse beam reflectivity
1963 ! ptra : collimated beam transmissivity
1964 ! ptrad : diffuse beam transmissivity
1965 !
1966 !
1967 ! Method:
1968 ! -------
1969 ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
1970 ! kmodts = 1 eddington (joseph et al., 1976)
1971 ! = 2 pifm (zdunkowski et al., 1980)
1972 ! = 3 discrete ordinates (liou, 1973)
1973 ! = 4 same as pifm, but Ritter and Geleyn 1992 convention
1974 ! = 5 revised TSA (sunghye baek)
1975 !
1976 ! Modifications:
1977 ! --------------
1978 ! Original: J-JMorcrette, ECMWF, Feb 2003
1979 ! Revised for F90 reformatting: MJIacono, AER, Jul 2006
1980 ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
1981 ! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008
1982 !
1983 !
1984 ! lrtchk(nlayers) : Logical flag for reflectivity and transmissivity calculation
1985 ! pgg(nlayers) : asymmetry parameter
1986 ! ptau(nlayers) : optical depth
1987 ! pw(nlayers) : single scattering albedo
1988 ! prmuz : cosine of solar zenith angle
1989 !
1990 ! pref(nlayers+1) : direct beam reflectivity
1991 ! prefd(nlayers+1) : diffuse beam reflectivity
1992 ! ptra(nlayers+1) : direct beam transmissivity
1993 ! ptrad(nlayers+1) : diffuse beam transmissivity
1994 ! ------------------------------------------------------------------------------
1995 !
1996 ! ------- Declarations ------
1997 !
1998 ! ------- Input -------
1999 !
2000 integer(kind=im), intent(in ) :: nlayers
2001 logical, dimension(:), intent(in ) :: lrtchk
2002 real(kind=rb), dimension(:), intent(in ) :: pgg
2003 real(kind=rb), dimension(:), intent(in ) :: ptau
2004 real(kind=rb), dimension(:), intent(in ) :: pw
2005 real(kind=rb), intent(in ) :: prmuz
2006 real(kind=rb), dimension(:), intent(in ) :: al1
2007 real(kind=rb), dimension(:), intent(in ) :: al2
2008 real(kind=rb), dimension(:), intent(in ) :: al3
2009 !
2010 ! ------- Output -------
2011 !
2012 real(kind=rb), dimension(:), intent(inout) :: pref
2013 real(kind=rb), dimension(:), intent(inout) :: prefd
2014 real(kind=rb), dimension(:), intent(inout) :: ptra
2015 real(kind=rb), dimension(:), intent(inout) :: ptrad
2016 !
2017 ! ------- Local -------
2018 !
2019 integer(kind=im) :: jk, jl, kmodts
2020 integer(kind=im) :: itind
2021 !
2022 real(kind=rb) :: tblind
2023 real(kind=rb) :: za, za1, za2
2024 real(kind=rb) :: zbeta, zdend, zdenr, zdent
2025 real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
2026 real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
2027 real(kind=rb) :: zr1, zr2, zr3, zr4, zr5
2028 real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
2029 real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
2030 real(kind=rb) :: zw, zwcrit, zwo
2031 real(kind=rb) :: denom
2032 !
2033 real(kind=rb), parameter :: eps = 1.e-08_rb
2034 real(kind=rb) :: zbetab, zbetad, ztos, ztoa, zto2
2035 !-------------------------------------------------------------------------------
2036 !
2037 ! Initialize
2038 !
2039 hvrrft = '$Revision: 1.3 $'
2040 zsr3=sqrt(3._rb)
2041 zwcrit=0.9999995_rb
2042 kmodts=5
2043 !
2044 do jk = 1,nlayers
2045 if (.not.lrtchk(jk)) then
2046 pref(jk) =0._rb
2047 ptra(jk) =1._rb
2048 prefd(jk)=0._rb
2049 ptrad(jk)=1._rb
2050 else
2051 zto1=ptau(jk)
2052 zw =pw(jk)
2053 zg =pgg(jk)
2054 !
2055 ! General two-stream expressions
2056 !
2057 zg3= 3._rb * zg
2058 if (kmodts == 1) then
2059 zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb
2060 zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb
2061 zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2062 else if (kmodts == 2) then
2063 zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb
2064 zgamma2= 3._rb *(zw * (1._rb - zg )) * 0.25_rb
2065 zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2066 else if (kmodts == 3) then
2067 zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb
2068 zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb
2069 zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb
2070 else if (kmodts == 4) then ! Ritter and Geleyn 1992 convention
2071 zbetad = 3._rb*0.125_rb*(1._rb-zg)
2072 zbetab = 0.25_rb*(2._rb-3._rb*zg*prmuz)
2073 ztos = zw*zto1
2074 ztoa = zto1 - ztos
2075 zto2 = ztos/zto1
2076 zgamma1= (2._rb * ztoa + 2._rb * zbetad * ztos) / zto1
2077 zgamma2= 2._rb * zbetad * zto2
2078 zgamma3= zbetab*zw
2079 else if (kmodts == 5) then
2080 zgamma1= al1(jk)
2081 zgamma2= al2(jk)
2082 zgamma3= al3(jk)
2083 end if
2084 if(kmodts .ge. 4) then
2085 zgamma4= zw - zgamma3
2086 else
2087 zgamma4= 1._rb - zgamma3
2088 endif
2089 !
2090 ! Recompute original s.s.a. to test for conservative solution
2091 !
2092 zwo = 0._rb
2093 denom = 1._rb
2094 if (zg .ne. 1._rb) denom = (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2)
2095 if (zw .gt. 0._rb .and. denom .ne. 0._rb) zwo = zw / denom
2096 !
2097 if (zwo >= zwcrit) then
2098 !
2099 ! Conservative scattering
2100 !
2101 za = zgamma1 * prmuz
2102 za1 = za - zgamma3
2103 zgt = zgamma1 * zto1
2104 !
2105 ! Homogeneous reflectance and transmittance,
2106 ! collimated beam
2107 !
2108 ze1 = min ( zto1 / prmuz , 500._rb)
2109 ! ze2 = exp( -ze1 )
2110 !
2111 ! Use exponential lookup table for transmittance, or expansion of
2112 ! exponential for low tau
2113 !
2114 if (ze1 .le. od_lo) then
2115 ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2116 else
2117 tblind = ze1 / (bpade + ze1)
2118 itind = tblint * tblind + 0.5_rb
2119 ze2 = exp_tbl(itind)
2120 endif
2121 !
2122 pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt)
2123 ptra(jk) = 1._rb - pref(jk)
2124 !
2125 ! isotropic incidence
2126 !
2127 prefd(jk) = zgt / (1._rb + zgt)
2128 ptrad(jk) = 1._rb - prefd(jk)
2129 !
2130 ! This is applied for consistency between total (delta-scaled) and direct
2131 ! (unscaled) calculations at very low optical depths (tau < 1.e-4) when
2132 ! the exponential lookup table returns a transmittance of 1.0.
2133 !
2134 if (ze2 .eq. 1.0_rb) then
2135 pref(jk) = 0.0_rb
2136 ptra(jk) = 1.0_rb
2137 prefd(jk) = 0.0_rb
2138 ptrad(jk) = 1.0_rb
2139 endif
2140 !
2141 else
2142 !
2143 ! Non-conservative scattering
2144 !
2145 za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
2146 za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
2147 zrk = sqrt ( zgamma1**2 - zgamma2**2)
2148 zrp = zrk * prmuz
2149 zrp1 = 1._rb + zrp
2150 zrm1 = 1._rb - zrp
2151 zrk2 = 2._rb * zrk
2152 zrpp = 1._rb - zrp*zrp
2153 zrkg = zrk + zgamma1
2154 zr1 = zrm1 * (za2 + zrk * zgamma3)
2155 zr2 = zrp1 * (za2 - zrk * zgamma3)
2156 zr3 = zrk2 * (zgamma3 - za2 * prmuz )
2157 zr4 = zrpp * zrkg
2158 zr5 = zrpp * (zrk - zgamma1)
2159 zt1 = zrp1 * (za1 + zrk * zgamma4)
2160 zt2 = zrm1 * (za1 - zrk * zgamma4)
2161 zt3 = zrk2 * (zgamma4 + za1 * prmuz )
2162 zt4 = zr4
2163 zt5 = zr5
2164 !
2165 ! mji - reformulated code to avoid potential floating point exceptions
2166 ! zbeta = - zr5 / zr4
2167 zbeta = (zgamma1 - zrk) / zrkg
2168 !
2169 ! Homogeneous reflectance and transmittance
2170 !
2171 ze1 = min ( zrk * zto1, 500._rb)
2172 ze2 = min ( zto1 / prmuz , 500._rb)
2173 !
2174 ! Original
2175 ! zep1 = exp( ze1 )
2176 ! zem1 = exp(-ze1 )
2177 ! zep2 = exp( ze2 )
2178 ! zem2 = exp(-ze2 )
2179 !
2180 ! Revised original, to reduce exponentials
2181 ! zep1 = exp( ze1 )
2182 ! zem1 = 1._rb / zep1
2183 ! zep2 = exp( ze2 )
2184 ! zem2 = 1._rb / zep2
2185 !
2186 ! Use exponential lookup table for transmittance, or expansion of
2187 ! exponential for low tau
2188 !
2189 if (ze1 .le. od_lo) then
2190 zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2191 zep1 = 1._rb / zem1
2192 else
2193 tblind = ze1 / (bpade + ze1)
2194 itind = tblint * tblind + 0.5_rb
2195 zem1 = exp_tbl(itind)
2196 zep1 = 1._rb / zem1
2197 endif
2198 !
2199 if (ze2 .le. od_lo) then
2200 zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2
2201 zep2 = 1._rb / zem2
2202 else
2203 tblind = ze2 / (bpade + ze2)
2204 itind = tblint * tblind + 0.5_rb
2205 zem2 = exp_tbl(itind)
2206 zep2 = 1._rb / zem2
2207 endif
2208 !
2209 ! collimated beam
2210 !
2211 ! mji - reformulated code to avoid potential floating point exceptions
2212 ! zdenr = zr4*zep1 + zr5*zem1
2213 ! pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2214 ! zdent = zt4*zep1 + zt5*zem1
2215 ! ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2216 !
2217 zdenr = zr4*zep1 + zr5*zem1
2218 zdent = zt4*zep1 + zt5*zem1
2219 if (zdenr .ge. -eps .and. zdenr .le. eps) then
2220 pref(jk) = eps
2221 ptra(jk) = zem2
2222 else
2223 if(kmodts .ge. 4) then
2224 pref(jk) = (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2225 ptra(jk) = zem2 - zem2 * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2226 else
2227 pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2228 ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2229 endif
2230 endif
2231 !
2232 ! diffuse beam
2233 !
2234 zemm = zem1*zem1
2235 zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg)
2236 prefd(jk) = zgamma2 * (1._rb - zemm) * zdend
2237 ptrad(jk) = zrk2*zem1*zdend
2238 endif
2239 !
2240 endif
2241 !
2242 enddo
2243 !
2244 end subroutine reftra_sw
2245 !-------------------------------------------------------------------------------
2246 !
2247 !
2248 !-------------------------------------------------------------------------------
2249 end module rrtmg_sw_reftra_k
2250 !-------------------------------------------------------------------------------
2251 !
2252 !
2253 !-------------------------------------------------------------------------------
2254 module rrtmg_sw_setcoef_k
2255 !-------------------------------------------------------------------------------
2256 ! --------------------------------------------------------------------------
2257 ! | |
2258 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2259 ! | This software may be used, copied, or redistributed as long as it is |
2260 ! | not sold and this copyright notice is reproduced on each copy made. |
2261 ! | This model is provided as is without any express or implied warranties. |
2262 ! | (http://www.rtweb.aer.com/) |
2263 ! | |
2264 ! --------------------------------------------------------------------------
2265 ! ------- Modules -------
2266 !
2267 use parkind_k, only : im => kind_im, rb => kind_rb
2268 use parrrsw_k, only : mxmol
2269 use rrsw_ref_k, only : pref, preflog, tref
2270 use rrsw_vsn_k, only : hvrset, hnamset
2271 !
2272 implicit none
2273 !
2274 contains
2275 !-------------------------------------------------------------------------------
2276 !
2277 !
2278 !-------------------------------------------------------------------------------
2279 subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
2280 laytrop, layswtch, laylow, jp, jt, jt1, &
2281 co2mult, colch4, colco2, colh2o, colmol, coln2o, &
2282 colo2, colo3, fac00, fac01, fac10, fac11, &
2283 selffac, selffrac, indself, forfac, forfrac, indfor)
2284 !-------------------------------------------------------------------------------
2285 !
2286 ! abstract: For a given atmosphere, calculate the indices and
2287 ! fractions related to the pressure and temperature interpolations.
2288 !
2289 ! history log:
2290 ! 2002-04-01 J. Delamere, AER, Inc. version 2.5
2291 ! 2003-02-24 JJMorcrette Rewritten and adapted to ECMWF F90
2292 ! 2006-07 MJIacono For uniform rrtmg formatting
2293 !
2294 ! input :
2295 ! nlayers : total number of layers
2296 ! pavel(nlayers) : layer pressures (mb)
2297 ! tavel(nlayers) : layer temperatures (K)
2298 ! pz(0:nlayers) : level (interface) pressures (hPa, mb)
2299 ! tz(0:nlayers) : level (interface) temperatures (K)
2300 ! tbound : surface temperature (K)
2301 ! coldry(nlayers) : dry air column density (mol/cm2)
2302 ! wkl(mxmol,nlayers) : molecular amounts (mol/cm-2)
2303 !
2304 ! output :
2305 ! laytrop : tropopause layer index
2306 ! jp(nlayers)
2307 ! jt(nlayers)
2308 ! jt1(nlayers)
2309 ! colh2o(nlayers) column amount (h2o)
2310 ! colco2(nlayers) column amount (co2)
2311 ! colo3(nlayers) column amount (o3)
2312 ! coln2o(nlayers) column amount (n20)
2313 ! colch4(nlayers) column amount (ch4)
2314 ! colo2(nlayers) column amount (o2)
2315 ! colmol(nlayers)
2316 ! co2mult(nlayers)
2317 !
2318 ! indself(nlayers)
2319 ! indfor(nlayers)
2320 ! selffac(nlayers)
2321 ! forfac(nlayers)
2322 ! forfrac(nlayers)
2323 ! fac00(nlayers), fac01, fac10, fac11
2324 !-------------------------------------------------------------------------------
2325 !
2326 ! ----- Input -----
2327 !
2328 integer(kind=im), intent(in ) :: nlayers
2329 real(kind=rb), dimension(:), intent(in ) :: pavel
2330 real(kind=rb), dimension(:), intent(in ) :: tavel
2331 real(kind=rb), dimension(0:), intent(in ) :: pz
2332 real(kind=rb), dimension(0:), intent(in ) :: tz
2333 real(kind=rb), intent(in ) :: tbound
2334 real(kind=rb), dimension(:), intent(in ) :: coldry
2335 real(kind=rb), dimension(:,:),intent(in ) :: wkl
2336 !
2337 ! ----- Output -----
2338 !
2339 integer(kind=im), intent( out) :: laytrop
2340 integer(kind=im), intent( out) :: layswtch
2341 integer(kind=im), intent( out) :: laylow
2342 integer(kind=im), dimension(:), intent( out) :: jp
2343 integer(kind=im), dimension(:), intent( out) :: jt
2344 integer(kind=im), dimension(:), intent( out) :: jt1
2345 real(kind=rb), dimension(:), intent( out) :: colh2o
2346 real(kind=rb), dimension(:), intent( out) :: colco2
2347 real(kind=rb), dimension(:), intent( out) :: colo3
2348 real(kind=rb), dimension(:), intent( out) :: coln2o
2349 real(kind=rb), dimension(:), intent( out) :: colch4
2350 real(kind=rb), dimension(:), intent( out) :: colo2
2351 real(kind=rb), dimension(:), intent( out) :: colmol
2352 real(kind=rb), dimension(:), intent( out) :: co2mult
2353 !
2354 integer(kind=im), dimension(:), intent( out) :: indself
2355 integer(kind=im), dimension(:), intent( out) :: indfor
2356 real(kind=rb), dimension(:), intent(out) :: selffac
2357 real(kind=rb), dimension(:), intent(out) :: selffrac
2358 real(kind=rb), dimension(:), intent(out) :: forfac
2359 real(kind=rb), dimension(:), intent(out) :: forfrac
2360 real(kind=rb), dimension(:), intent(out) :: fac00, fac01
2361 real(kind=rb), dimension(:), intent(out) :: fac10, fac11
2362 !
2363 ! ----- Local -----
2364 !
2365 integer(kind=im) :: indbound
2366 integer(kind=im) :: indlev0
2367 integer(kind=im) :: lay
2368 integer(kind=im) :: jp1
2369 !
2370 real(kind=rb) :: stpfac
2371 real(kind=rb) :: tbndfrac
2372 real(kind=rb) :: t0frac
2373 real(kind=rb) :: plog
2374 real(kind=rb) :: fp
2375 real(kind=rb) :: ft
2376 real(kind=rb) :: ft1
2377 real(kind=rb) :: water
2378 real(kind=rb) :: scalefac
2379 real(kind=rb) :: factor
2380 real(kind=rb) :: co2reg
2381 real(kind=rb) :: compfp
2382 !-------------------------------------------------------------------------------
2383 !
2384 ! Initializations
2385 !
2386 stpfac = 296._rb/1013._rb
2387 !
2388 indbound = tbound - 159._rb
2389 tbndfrac = tbound - int(tbound)
2390 indlev0 = tz(0) - 159._rb
2391 t0frac = tz(0) - int(tz(0))
2392 !
2393 laytrop = 0
2394 layswtch = 0
2395 laylow = 0
2396 !
2397 ! Begin layer loop
2398 !
2399 do lay = 1,nlayers
2400 !
2401 ! Find the two reference pressures on either side of the
2402 ! layer pressure. Store them in JP and JP1. Store in FP the
2403 ! fraction of the difference (in ln(pressure)) between these
2404 ! two values that the layer pressure lies.
2405 !
2406 plog = log(pavel(lay))
2407 jp(lay) = int(36._rb - 5*(plog+0.04_rb))
2408 if (jp(lay) .lt. 1) then
2409 jp(lay) = 1
2410 elseif (jp(lay) .gt. 58) then
2411 jp(lay) = 58
2412 endif
2413 jp1 = jp(lay) + 1
2414 fp = 5._rb * (preflog(jp(lay)) - plog)
2415 !
2416 ! Determine, for each reference pressure (JP and JP1), which
2417 ! reference temperature (these are different for each
2418 ! reference pressure) is nearest the layer temperature but does
2419 ! not exceed it. Store these indices in JT and JT1, resp.
2420 ! Store in FT (resp. FT1) the fraction of the way between JT
2421 ! (JT1) and the next highest reference temperature that the
2422 ! layer temperature falls.
2423 !
2424 jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
2425 if (jt(lay) .lt. 1) then
2426 jt(lay) = 1
2427 elseif (jt(lay) .gt. 4) then
2428 jt(lay) = 4
2429 endif
2430 ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - real(jt(lay)-3)
2431 jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
2432 if (jt1(lay) .lt. 1) then
2433 jt1(lay) = 1
2434 elseif (jt1(lay) .gt. 4) then
2435 jt1(lay) = 4
2436 endif
2437 ft1 = ((tavel(lay)-tref(jp1))/15._rb) - real(jt1(lay)-3)
2438 !
2439 water = wkl(1,lay)/coldry(lay)
2440 scalefac = pavel(lay) * stpfac / tavel(lay)
2441 !
2442 ! If the pressure is less than ~100mb, perform a different
2443 ! set of species interpolations.
2444 !
2445 if (plog .le. 4.56_rb) go to 5300
2446 laytrop = laytrop + 1
2447 if (plog .ge. 6.62_rb) laylow = laylow + 1
2448 !
2449 ! Set up factors needed to separately include the water vapor
2450 ! foreign-continuum in the calculation of absorption coefficient.
2451 !
2452 forfac(lay) = scalefac / (1.+water)
2453 factor = (332.0_rb-tavel(lay))/36.0_rb
2454 indfor(lay) = min(2, max(1, int(factor)))
2455 forfrac(lay) = factor - real(indfor(lay))
2456 !
2457 ! Set up factors needed to separately include the water vapor
2458 ! self-continuum in the calculation of absorption coefficient.
2459 !
2460 selffac(lay) = water * forfac(lay)
2461 factor = (tavel(lay)-188.0_rb)/7.2_rb
2462 indself(lay) = min(9, max(1, int(factor)-7))
2463 selffrac(lay) = factor - real(indself(lay) + 7)
2464 !
2465 ! Calculate needed column amounts.
2466 !
2467 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
2468 colco2(lay) = 1.e-20_rb * wkl(2,lay)
2469 colo3(lay) = 1.e-20_rb * wkl(3,lay)
2470 ! colo3(lay) = 0._rb
2471 ! colo3(lay) = colo3(lay)/1.16_rb
2472 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
2473 colch4(lay) = 1.e-20_rb * wkl(6,lay)
2474 colo2(lay) = 1.e-20_rb * wkl(7,lay)
2475 colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
2476 ! colco2(lay) = 0._rb
2477 ! colo3(lay) = 0._rb
2478 ! coln2o(lay) = 0._rb
2479 ! colch4(lay) = 0._rb
2480 ! colo2(lay) = 0._rb
2481 ! colmol(lay) = 0._rb
2482 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
2483 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
2484 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
2485 if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
2486 !
2487 ! Using E = 1334.2 cm-1.
2488 !
2489 co2reg = 3.55e-24_rb * coldry(lay)
2490 co2mult(lay)= (colco2(lay) - co2reg) * &
2491 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
2492 goto 5400
2493 !
2494 ! Above laytrop.
2495 !
2496 5300 continue
2497 !
2498 ! Set up factors needed to separately include the water vapor
2499 ! foreign-continuum in the calculation of absorption coefficient.
2500 !
2501 forfac(lay) = scalefac / (1.+water)
2502 factor = (tavel(lay)-188.0_rb)/36.0_rb
2503 indfor(lay) = 3
2504 forfrac(lay) = factor - 1.0_rb
2505 !
2506 ! Calculate needed column amounts.
2507 !
2508 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
2509 colco2(lay) = 1.e-20_rb * wkl(2,lay)
2510 colo3(lay) = 1.e-20_rb * wkl(3,lay)
2511 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
2512 colch4(lay) = 1.e-20_rb * wkl(6,lay)
2513 colo2(lay) = 1.e-20_rb * wkl(7,lay)
2514 colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
2515 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
2516 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
2517 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
2518 if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
2519 co2reg = 3.55e-24_rb * coldry(lay)
2520 co2mult(lay)= (colco2(lay) - co2reg) * &
2521 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
2522 selffac(lay) = 0._rb
2523 selffrac(lay)= 0._rb
2524 indself(lay) = 0
2525 !
2526 5400 continue
2527 !
2528 ! We have now isolated the layer ln pressure and temperature,
2529 ! between two reference pressures and two reference temperatures
2530 ! (for each reference pressure). We multiply the pressure
2531 ! fraction FP with the appropriate temperature fractions to get
2532 ! the factors that will be needed for the interpolation that yields
2533 ! the optical depths (performed in routines TAUGBn for band n).
2534 !
2535 compfp = 1._rb - fp
2536 fac10(lay) = compfp * ft
2537 fac00(lay) = compfp * (1._rb - ft)
2538 fac11(lay) = fp * ft1
2539 fac01(lay) = fp * (1._rb - ft1)
2540 !
2541 ! End layer loop
2542 !
2543 enddo
2544 !
2545 end subroutine setcoef_sw
2546 !-------------------------------------------------------------------------------
2547 !
2548 !
2549 !-------------------------------------------------------------------------------
2550 subroutine swatmref
2551 !-------------------------------------------------------------------------------
2552 !
2553 save
2554 !
2555 ! These pressures are chosen such that the ln of the first pressure
2556 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
2557 ! each subsequent ln(pressure) differs from the previous one by 0.2.
2558 !
2559 pref(:) = (/ &
2560 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
2561 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
2562 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
2563 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
2564 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
2565 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
2566 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
2567 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
2568 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
2569 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
2570 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
2571 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /)
2572 !
2573 preflog(:) = (/ &
2574 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
2575 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
2576 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
2577 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
2578 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
2579 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
2580 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
2581 -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
2582 -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
2583 -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
2584 -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
2585 -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /)
2586 !
2587 ! These are the temperatures associated with the respective
2588 ! pressures for the MLS standard atmosphere.
2589 !
2590 tref(:) = (/ &
2591 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
2592 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
2593 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
2594 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
2595 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
2596 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
2597 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
2598 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
2599 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
2600 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
2601 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
2602 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /)
2603 !
2604 end subroutine swatmref
2605 !-------------------------------------------------------------------------------
2606 !
2607 !
2608 !-------------------------------------------------------------------------------
2609 end module rrtmg_sw_setcoef_k
2610 !-------------------------------------------------------------------------------
2611 !
2612 !
2613 !-------------------------------------------------------------------------------
2614 module rrtmg_sw_taumol_k
2615 !-------------------------------------------------------------------------------
2616 ! --------------------------------------------------------------------------
2617 ! | |
2618 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2619 ! | This software may be used, copied, or redistributed as long as it is |
2620 ! | not sold and this copyright notice is reproduced on each copy made. |
2621 ! | This model is provided as is without any express or implied warranties. |
2622 ! | (http://www.rtweb.aer.com/) |
2623 ! | |
2624 ! --------------------------------------------------------------------------
2625 ! ------- Modules -------
2626 !
2627 use parkind_k, only : im => kind_im, rb => kind_rb
2628 ! use parrrsw, only : mg, jpband, nbndsw, ngptsw
2629 use rrsw_con_k, only: oneminus
2630 use rrsw_wvn_k, only: nspa, nspb
2631 use rrsw_vsn_k, only: hvrtau, hnamtau
2632 !
2633 implicit none
2634 !
2635 contains
2636 !-------------------------------------------------------------------------------
2637 !
2638 !
2639 !-------------------------------------------------------------------------------
2640 subroutine taumol_sw(nlayers, &
2641 colh2o, colco2, colch4, colo2, colo3, colmol, &
2642 laytrop, jp, jt, jt1, &
2643 fac00, fac01, fac10, fac11, &
2644 selffac, selffrac, indself, forfac, forfrac, indfor,&
2645 sfluxzen, taug, taur)
2646 !-------------------------------------------------------------------------------
2647 ! ******************************************************************************
2648 ! * *
2649 ! * Optical depths developed for the *
2650 ! * *
2651 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
2652 ! * *
2653 ! * *
2654 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
2655 ! * 131 HARTWELL AVENUE *
2656 ! * LEXINGTON, MA 02421 *
2657 ! * *
2658 ! * *
2659 ! * ELI J. MLAWER *
2660 ! * JENNIFER DELAMERE *
2661 ! * STEVEN J. TAUBMAN *
2662 ! * SHEPARD A. CLOUGH *
2663 ! * *
2664 ! * *
2665 ! * *
2666 ! * *
2667 ! * email: mlawer@aer.com *
2668 ! * email: jdelamer@aer.com *
2669 ! * *
2670 ! * The authors wish to acknowledge the contributions of the *
2671 ! * following people: Patrick D. Brown, Michael J. Iacono, *
2672 ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
2673 ! * *
2674 ! ******************************************************************************
2675 ! * TAUMOL *
2676 ! * *
2677 ! * This file contains the subroutines TAUGBn (where n goes from *
2678 ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions *
2679 ! * per g-value and layer for band n. *
2680 ! * *
2681 ! * Output: optical depths (unitless) *
2682 ! * fractions needed to compute Planck functions at every layer *
2683 ! * and g-value *
2684 ! * *
2685 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
2686 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
2687 ! * *
2688 ! * Input *
2689 ! * *
2690 ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) *
2691 ! * *
2692 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
2693 ! * COMMON /PRECISE/ ONEMINUS *
2694 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
2695 ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND *
2696 ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, *
2697 ! * & COLH2O(MXLAY),COLCO2(MXLAY), *
2698 ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), *
2699 ! * & COLO2(MXLAY),CO2MULT(MXLAY) *
2700 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
2701 ! * & FAC10(MXLAY),FAC11(MXLAY) *
2702 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
2703 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
2704 ! * *
2705 ! * Description: *
2706 ! * NG(IBAND) - number of g-values in band IBAND *
2707 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
2708 ! * atmospheres that are stored for band IBAND per *
2709 ! * pressure level and temperature. Each of these *
2710 ! * atmospheres has different relative amounts of the *
2711 ! * key species for the band (i.e. different binary *
2712 ! * species parameters). *
2713 ! * NSPB(IBAND) - same for upper atmosphere *
2714 ! * ONEMINUS - since problems are caused in some cases by interpolation *
2715 ! * parameters equal to or greater than 1, for these cases *
2716 ! * these parameters are set to this value, slightly < 1. *
2717 ! * PAVEL - layer pressures (mb) *
2718 ! * TAVEL - layer temperatures (degrees K) *
2719 ! * PZ - level pressures (mb) *
2720 ! * TZ - level temperatures (degrees K) *
2721 ! * LAYTROP - layer at which switch is made from one combination of *
2722 ! * key species to another *
2723 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
2724 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
2725 ! * respectively (molecules/cm**2) *
2726 ! * CO2MULT - for bands in which carbon dioxide is implemented as a *
2727 ! * trace species, this is the factor used to multiply the *
2728 ! * band's average CO2 absorption coefficient to get the added *
2729 ! * contribution to the optical depth relative to 355 ppm. *
2730 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
2731 ! * compute the interpolation factors that multiply the *
2732 ! * appropriate reference k-values. A value of 0 (1) for *
2733 ! * i,j indicates that the corresponding factor multiplies *
2734 ! * reference k-value for the lower (higher) of the two *
2735 ! * appropriate temperatures, and altitudes, respectively. *
2736 ! * JP - the index of the lower (in altitude) of the two appropriate *
2737 ! * reference pressure levels needed for interpolation *
2738 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
2739 ! * temperatures needed for interpolation (for pressure *
2740 ! * levels JP and JP+1, respectively) *
2741 ! * SELFFAC - scale factor needed to water vapor self-continuum, equals *
2742 ! * (water vapor density)/(atmospheric density at 296K and *
2743 ! * 1013 mb) *
2744 ! * SELFFRAC - factor needed for temperature interpolation of reference *
2745 ! * water vapor self-continuum data *
2746 ! * INDSELF - index of the lower of the two appropriate reference *
2747 ! * temperatures needed for the self-continuum interpolation *
2748 ! * *
2749 ! * Data input *
2750 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
2751 ! * (note: n is the band number) *
2752 ! * *
2753 ! * Description: *
2754 ! * KA - k-values for low reference atmospheres (no water vapor *
2755 ! * self-continuum) (units: cm**2/molecule) *
2756 ! * KB - k-values for high reference atmospheres (all sources) *
2757 ! * (units: cm**2/molecule) *
2758 ! * SELFREF - k-values for water vapor self-continuum for reference *
2759 ! * atmospheres (used below LAYTROP) *
2760 ! * (units: cm**2/molecule) *
2761 ! * *
2762 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
2763 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
2764 ! * *
2765 ! *****************************************************************************
2766 !
2767 ! history log :
2768 !
2769 ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003
2770 ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003
2771 ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
2772 !
2773 ! input :
2774 ! nlayers : total number of layers
2775 ! laytrop : tropopause layer index
2776 ! jp(nlayers)
2777 ! jt(nlayers)
2778 ! jt1(nlayers)
2779 !
2780 ! colh2o(nlayers) column amount (h2o)
2781 ! colco2(nlayers) column amount (co2)
2782 ! colo3(nlayers) column amount (o3)
2783 ! coln2o(nlayers) column amount (n20)
2784 ! colch4(nlayers) column amount (ch4)
2785 ! colo2(nlayers) column amount (o2)
2786 ! colmol(nlayers)
2787 !
2788 ! indself(nlayers)
2789 ! indfor(nlayers)
2790 ! selffac(nlayers)
2791 ! selffrac(nlayers)
2792 ! forfac(nlayers)
2793 ! forfrac(nlayers)
2794 ! fac00(nlayers), fac01, fac10, fac11
2795 !
2796 ! output :
2797 ! sfluxzen(ngptsw) : solar source function
2798 ! taug(nlayers,ngptsw) : gaseous optical depth
2799 ! taur(nlayers,ngptsw) : Rayleigh scattering
2800 ! ssa(nlayers,ngptsw) : single scattering albedo (inactive)
2801 ! ------- Declarations -------
2802 !
2803 ! ----- Input -----
2804 integer(kind=im), intent(in ) :: nlayers
2805 integer(kind=im), intent(in ) :: laytrop
2806 integer(kind=im), dimension(:), intent(in ) :: jp
2807 integer(kind=im), dimension(:), intent(in ) :: jt
2808 integer(kind=im), dimension(:), intent(in ) :: jt1
2809 real(kind=rb), dimension(:), intent(in ) :: colh2o
2810 real(kind=rb), dimension(:), intent(in ) :: colco2
2811 real(kind=rb), dimension(:), intent(in ) :: colo3
2812 real(kind=rb), dimension(:), intent(in ) :: colch4
2813 real(kind=rb), dimension(:), intent(in ) :: colo2
2814 real(kind=rb), dimension(:), intent(in ) :: colmol
2815 integer(kind=im), dimension(:), intent(in ) :: indself
2816 integer(kind=im), dimension(:), intent(in ) :: indfor
2817 real(kind=rb), dimension(:), intent(in ) :: selffac
2818 real(kind=rb), dimension(:), intent(in ) :: selffrac
2819 real(kind=rb), dimension(:), intent(in ) :: forfac
2820 real(kind=rb), dimension(:), intent(in ) :: forfrac
2821 real(kind=rb), dimension(:), intent(in ) :: fac00, fac01
2822 real(kind=rb), dimension(:), intent(in ) :: fac10, fac11
2823 !
2824 ! ----- Output -----
2825 !
2826 real(kind=rb), dimension(:), intent( out) :: sfluxzen
2827 real(kind=rb), dimension(:,:), intent( out) :: taug
2828 real(kind=rb), dimension(:,:), intent( out) :: taur
2829 ! real(kind=rb), intent(out) :: ssa(:,:)
2830 hvrtau = '$Revision: 1.3 $'
2831 !
2832 ! Calculate gaseous optical depth and planck fractions for each spectral band.
2833 !
2834 call taumol16
2835 call taumol17
2836 call taumol18
2837 call taumol19
2838 call taumol20
2839 call taumol21
2840 call taumol22
2841 call taumol23
2842 call taumol24
2843 call taumol25
2844 call taumol26
2845 call taumol27
2846 call taumol28
2847 call taumol29
2848 !
2849 contains
2850 !-------------------------------------------------------------------------------
2851 !
2852 !
2853 !-------------------------------------------------------------------------------
2854 subroutine taumol16
2855 !-------------------------------------------------------------------------------
2856 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
2857 !-------------------------------------------------------------------------------
2858 !
2859 ! ------- Modules -------
2860 !
2861 use parrrsw_k, only : ng16
2862 use rrsw_kg16_k, only : absa, ka, absb, kb, forref, selfref, &
2863 sfluxref, rayl, layreffr, strrat1
2864 !
2865 ! ------- Declarations -------
2866 !
2867 ! Local
2868 !
2869 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2870 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
2871 fac110, fac111, fs, speccomb, specmult, specparm, &
2872 tauray
2873 !-------------------------------------------------------------------------------
2874 !
2875 ! Compute the optical depth by interpolating in ln(pressure),
2876 ! temperature, and appropriate species. Below LAYTROP, the water
2877 ! vapor self-continuum is interpolated (in temperature) separately.
2878 !
2879 ! Lower atmosphere loop
2880 !
2881 do lay = 1,laytrop
2882 speccomb = colh2o(lay) + strrat1*colch4(lay)
2883 specparm = colh2o(lay)/speccomb
2884 if (specparm .ge. oneminus) specparm = oneminus
2885 specmult = 8._rb*(specparm)
2886 js = 1 + int(specmult)
2887 fs = mod(specmult, 1._rb )
2888 fac000 = (1._rb - fs) * fac00(lay)
2889 fac010 = (1._rb - fs) * fac10(lay)
2890 fac100 = fs * fac00(lay)
2891 fac110 = fs * fac10(lay)
2892 fac001 = (1._rb - fs) * fac01(lay)
2893 fac011 = (1._rb - fs) * fac11(lay)
2894 fac101 = fs * fac01(lay)
2895 fac111 = fs * fac11(lay)
2896 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
2897 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js
2898 inds = indself(lay)
2899 indf = indfor(lay)
2900 tauray = colmol(lay) * rayl
2901 do ig = 1,ng16
2902 taug(lay,ig) = speccomb * &
2903 (fac000 * absa(ind0 ,ig) + &
2904 fac100 * absa(ind0 +1,ig) + &
2905 fac010 * absa(ind0 +9,ig) + &
2906 fac110 * absa(ind0+10,ig) + &
2907 fac001 * absa(ind1 ,ig) + &
2908 fac101 * absa(ind1 +1,ig) + &
2909 fac011 * absa(ind1 +9,ig) + &
2910 fac111 * absa(ind1+10,ig)) + &
2911 colh2o(lay) * &
2912 (selffac(lay) * (selfref(inds,ig) + &
2913 selffrac(lay) * &
2914 (selfref(inds+1,ig) - selfref(inds,ig))) + &
2915 forfac(lay) * (forref(indf,ig) + &
2916 forfrac(lay) * &
2917 (forref(indf+1,ig) - forref(indf,ig))))
2918 ! ssa(lay,ig) = tauray/taug(lay,ig)
2919 taur(lay,ig) = tauray
2920 enddo
2921 enddo
2922 !
2923 laysolfr = nlayers
2924 !
2925 ! Upper atmosphere loop
2926 !
2927 do lay = laytrop+1,nlayers
2928 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
2929 laysolfr = lay
2930 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
2931 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
2932 tauray = colmol(lay) * rayl
2933 do ig = 1,ng16
2934 taug(lay,ig) = colch4(lay) * &
2935 (fac00(lay) * absb(ind0 ,ig) + &
2936 fac10(lay) * absb(ind0+1,ig) + &
2937 fac01(lay) * absb(ind1 ,ig) + &
2938 fac11(lay) * absb(ind1+1,ig))
2939 ! ssa(lay,ig) = tauray/taug(lay,ig)
2940 if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig)
2941 taur(lay,ig) = tauray
2942 enddo
2943 enddo
2944 !
2945 end subroutine taumol16
2946 !-------------------------------------------------------------------------------
2947 !
2948 !
2949 !-------------------------------------------------------------------------------
2950 subroutine taumol17
2951 !-------------------------------------------------------------------------------
2952 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
2953 !-------------------------------------------------------------------------------
2954 !
2955 ! ------- Modules -------
2956 !
2957 use parrrsw_k, only : ng17, ngs16
2958 use rrsw_kg17_k, only : absa, ka, absb, kb, forref, selfref, &
2959 sfluxref, rayl, layreffr, strrat
2960 !
2961 ! ------- Declarations -------
2962 !
2963 ! Local
2964 !
2965 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2966 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
2967 fac110, fac111, fs, speccomb, specmult, specparm, &
2968 tauray
2969 !-------------------------------------------------------------------------------
2970 !
2971 ! Compute the optical depth by interpolating in ln(pressure),
2972 ! temperature, and appropriate species. Below LAYTROP, the water
2973 ! vapor self-continuum is interpolated (in temperature) separately.
2974 !
2975 ! Lower atmosphere loop
2976 !
2977 do lay = 1,laytrop
2978 speccomb = colh2o(lay) + strrat*colco2(lay)
2979 specparm = colh2o(lay)/speccomb
2980 if (specparm .ge. oneminus) specparm = oneminus
2981 specmult = 8._rb*(specparm)
2982 js = 1 + int(specmult)
2983 fs = mod(specmult, 1._rb )
2984 fac000 = (1._rb - fs) * fac00(lay)
2985 fac010 = (1._rb - fs) * fac10(lay)
2986 fac100 = fs * fac00(lay)
2987 fac110 = fs * fac10(lay)
2988 fac001 = (1._rb - fs) * fac01(lay)
2989 fac011 = (1._rb - fs) * fac11(lay)
2990 fac101 = fs * fac01(lay)
2991 fac111 = fs * fac11(lay)
2992 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js
2993 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js
2994 inds = indself(lay)
2995 indf = indfor(lay)
2996 tauray = colmol(lay) * rayl
2997 do ig = 1,ng17
2998 taug(lay,ngs16+ig) = speccomb * &
2999 (fac000 * absa(ind0,ig) + &
3000 fac100 * absa(ind0+1,ig) + &
3001 fac010 * absa(ind0+9,ig) + &
3002 fac110 * absa(ind0+10,ig) + &
3003 fac001 * absa(ind1,ig) + &
3004 fac101 * absa(ind1+1,ig) + &
3005 fac011 * absa(ind1+9,ig) + &
3006 fac111 * absa(ind1+10,ig)) + &
3007 colh2o(lay) * &
3008 (selffac(lay) * (selfref(inds,ig) + &
3009 selffrac(lay) * &
3010 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3011 forfac(lay) * (forref(indf,ig) + &
3012 forfrac(lay) * &
3013 (forref(indf+1,ig) - forref(indf,ig))))
3014 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3015 taur(lay,ngs16+ig) = tauray
3016 enddo
3017 enddo
3018 !
3019 laysolfr = nlayers
3020 !
3021 ! Upper atmosphere loop
3022 !
3023 do lay = laytrop+1,nlayers
3024 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
3025 laysolfr = lay
3026 speccomb = colh2o(lay) + strrat*colco2(lay)
3027 specparm = colh2o(lay)/speccomb
3028 if (specparm .ge. oneminus) specparm = oneminus
3029 specmult = 4._rb*(specparm)
3030 js = 1 + int(specmult)
3031 fs = mod(specmult, 1._rb )
3032 fac000 = (1._rb - fs) * fac00(lay)
3033 fac010 = (1._rb - fs) * fac10(lay)
3034 fac100 = fs * fac00(lay)
3035 fac110 = fs * fac10(lay)
3036 fac001 = (1._rb - fs) * fac01(lay)
3037 fac011 = (1._rb - fs) * fac11(lay)
3038 fac101 = fs * fac01(lay)
3039 fac111 = fs * fac11(lay)
3040 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js
3041 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js
3042 indf = indfor(lay)
3043 tauray = colmol(lay) * rayl
3044 do ig = 1,ng17
3045 taug(lay,ngs16+ig) = speccomb * &
3046 (fac000 * absb(ind0,ig) + &
3047 fac100 * absb(ind0+1,ig) + &
3048 fac010 * absb(ind0+5,ig) + &
3049 fac110 * absb(ind0+6,ig) + &
3050 fac001 * absb(ind1,ig) + &
3051 fac101 * absb(ind1+1,ig) + &
3052 fac011 * absb(ind1+5,ig) + &
3053 fac111 * absb(ind1+6,ig)) + &
3054 colh2o(lay) * &
3055 forfac(lay) * (forref(indf,ig) + &
3056 forfrac(lay) * &
3057 (forref(indf+1,ig) - forref(indf,ig)))
3058 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3059 if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js) &
3060 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3061 taur(lay,ngs16+ig) = tauray
3062 enddo
3063 enddo
3064 !
3065 end subroutine taumol17
3066 !-------------------------------------------------------------------------------
3067 !
3068 !
3069 !-------------------------------------------------------------------------------
3070 subroutine taumol18
3071 !-------------------------------------------------------------------------------
3072 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
3073 !-------------------------------------------------------------------------------
3074 !
3075 ! ------- Modules -------
3076 !
3077 use parrrsw_k, only : ng18, ngs17
3078 use rrsw_kg18_k, only : absa, ka, absb, kb, forref, selfref, &
3079 sfluxref, rayl, layreffr, strrat
3080 !
3081 ! ------- Declarations -------
3082 !
3083 ! Local
3084 !
3085 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3086 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3087 fac110, fac111, fs, speccomb, specmult, specparm, &
3088 tauray
3089 !-------------------------------------------------------------------------------
3090 !
3091 ! Compute the optical depth by interpolating in ln(pressure),
3092 ! temperature, and appropriate species. Below LAYTROP, the water
3093 ! vapor self-continuum is interpolated (in temperature) separately.
3094 !
3095 laysolfr = laytrop
3096 !
3097 ! Lower atmosphere loop
3098 !
3099 do lay = 1,laytrop
3100 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3101 laysolfr = min(lay+1,laytrop)
3102 speccomb = colh2o(lay) + strrat*colch4(lay)
3103 specparm = colh2o(lay)/speccomb
3104 if (specparm .ge. oneminus) specparm = oneminus
3105 specmult = 8._rb*(specparm)
3106 js = 1 + int(specmult)
3107 fs = mod(specmult, 1._rb )
3108 fac000 = (1._rb - fs) * fac00(lay)
3109 fac010 = (1._rb - fs) * fac10(lay)
3110 fac100 = fs * fac00(lay)
3111 fac110 = fs * fac10(lay)
3112 fac001 = (1._rb - fs) * fac01(lay)
3113 fac011 = (1._rb - fs) * fac11(lay)
3114 fac101 = fs * fac01(lay)
3115 fac111 = fs * fac11(lay)
3116 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js
3117 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js
3118 inds = indself(lay)
3119 indf = indfor(lay)
3120 tauray = colmol(lay) * rayl
3121 do ig = 1,ng18
3122 taug(lay,ngs17+ig) = speccomb * &
3123 (fac000 * absa(ind0,ig) + &
3124 fac100 * absa(ind0+1,ig) + &
3125 fac010 * absa(ind0+9,ig) + &
3126 fac110 * absa(ind0+10,ig) + &
3127 fac001 * absa(ind1,ig) + &
3128 fac101 * absa(ind1+1,ig) + &
3129 fac011 * absa(ind1+9,ig) + &
3130 fac111 * absa(ind1+10,ig)) + &
3131 colh2o(lay) * &
3132 (selffac(lay) * (selfref(inds,ig) + &
3133 selffrac(lay) * &
3134 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3135 forfac(lay) * (forref(indf,ig) + &
3136 forfrac(lay) * &
3137 (forref(indf+1,ig) - forref(indf,ig))))
3138 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3139 if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js) &
3140 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3141 taur(lay,ngs17+ig) = tauray
3142 enddo
3143 enddo
3144 !
3145 ! Upper atmosphere loop
3146 !
3147 do lay = laytrop+1,nlayers
3148 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1
3149 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1
3150 tauray = colmol(lay) * rayl
3151 !
3152 do ig = 1,ng18
3153 taug(lay,ngs17+ig) = colch4(lay) * &
3154 (fac00(lay) * absb(ind0,ig) + &
3155 fac10(lay) * absb(ind0+1,ig) + &
3156 fac01(lay) * absb(ind1,ig) + &
3157 fac11(lay) * absb(ind1+1,ig))
3158 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3159 taur(lay,ngs17+ig) = tauray
3160 enddo
3161 enddo
3162 !
3163 end subroutine taumol18
3164 !-------------------------------------------------------------------------------
3165 !
3166 !
3167 !-------------------------------------------------------------------------------
3168 subroutine taumol19
3169 !-------------------------------------------------------------------------------
3170 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
3171 !-------------------------------------------------------------------------------
3172 !
3173 ! ------- Modules -------
3174 !
3175 use parrrsw_k, only : ng19, ngs18
3176 use rrsw_kg19_k, only : absa, ka, absb, kb, forref, selfref, &
3177 sfluxref, rayl, layreffr, strrat
3178 !
3179 ! ------- Declarations -------
3180 !
3181 ! Local
3182 !
3183 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3184 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3185 fac110, fac111, fs, speccomb, specmult, specparm, &
3186 tauray
3187 !-------------------------------------------------------------------------------
3188 !
3189 ! Compute the optical depth by interpolating in ln(pressure),
3190 ! temperature, and appropriate species. Below LAYTROP, the water
3191 ! vapor self-continuum is interpolated (in temperature) separately.
3192 !
3193 laysolfr = laytrop
3194 !
3195 ! Lower atmosphere loop
3196 !
3197 do lay = 1,laytrop
3198 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3199 laysolfr = min(lay+1,laytrop)
3200 speccomb = colh2o(lay) + strrat*colco2(lay)
3201 specparm = colh2o(lay)/speccomb
3202 if (specparm .ge. oneminus) specparm = oneminus
3203 specmult = 8._rb*(specparm)
3204 js = 1 + int(specmult)
3205 fs = mod(specmult, 1._rb )
3206 fac000 = (1._rb - fs) * fac00(lay)
3207 fac010 = (1._rb - fs) * fac10(lay)
3208 fac100 = fs * fac00(lay)
3209 fac110 = fs * fac10(lay)
3210 fac001 = (1._rb - fs) * fac01(lay)
3211 fac011 = (1._rb - fs) * fac11(lay)
3212 fac101 = fs * fac01(lay)
3213 fac111 = fs * fac11(lay)
3214 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js
3215 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js
3216 inds = indself(lay)
3217 indf = indfor(lay)
3218 tauray = colmol(lay) * rayl
3219 do ig = 1,ng19
3220 taug(lay,ngs18+ig) = speccomb * &
3221 (fac000 * absa(ind0,ig) + &
3222 fac100 * absa(ind0+1,ig) + &
3223 fac010 * absa(ind0+9,ig) + &
3224 fac110 * absa(ind0+10,ig) + &
3225 fac001 * absa(ind1,ig) + &
3226 fac101 * absa(ind1+1,ig) + &
3227 fac011 * absa(ind1+9,ig) + &
3228 fac111 * absa(ind1+10,ig)) + &
3229 colh2o(lay) * &
3230 (selffac(lay) * (selfref(inds,ig) + &
3231 selffrac(lay) * &
3232 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3233 forfac(lay) * (forref(indf,ig) + &
3234 forfrac(lay) * &
3235 (forref(indf+1,ig) - forref(indf,ig))))
3236 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3237 if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js) &
3238 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3239 taur(lay,ngs18+ig) = tauray
3240 enddo
3241 enddo
3242 !
3243 ! Upper atmosphere loop
3244 !
3245 do lay = laytrop+1,nlayers
3246 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1
3247 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1
3248 tauray = colmol(lay) * rayl
3249 do ig = 1,ng19
3250 taug(lay,ngs18+ig) = colco2(lay) * &
3251 (fac00(lay) * absb(ind0,ig) + &
3252 fac10(lay) * absb(ind0+1,ig) + &
3253 fac01(lay) * absb(ind1,ig) + &
3254 fac11(lay) * absb(ind1+1,ig))
3255 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3256 taur(lay,ngs18+ig) = tauray
3257 enddo
3258 enddo
3259 !
3260 end subroutine taumol19
3261 !-------------------------------------------------------------------------------
3262 !
3263 !
3264 !-------------------------------------------------------------------------------
3265 subroutine taumol20
3266 !-------------------------------------------------------------------------------
3267 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
3268 !-------------------------------------------------------------------------------
3269 !
3270 ! ------- Modules -------
3271 !
3272 use parrrsw_k, only : ng20, ngs19
3273 use rrsw_kg20_k, only : absa, ka, absb, kb, forref, selfref, &
3274 sfluxref, absch4, rayl, layreffr
3275 !
3276 implicit none
3277 !
3278 !
3279 ! ------- Declarations -------
3280 !
3281 ! Local
3282 !
3283 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3284 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3285 fac110, fac111, fs, speccomb, specmult, specparm, &
3286 tauray
3287 !-------------------------------------------------------------------------------
3288 !
3289 ! Compute the optical depth by interpolating in ln(pressure),
3290 ! temperature, and appropriate species. Below LAYTROP, the water
3291 ! vapor self-continuum is interpolated (in temperature) separately.
3292 !
3293 laysolfr = laytrop
3294 !
3295 ! Lower atmosphere loop
3296 !
3297 do lay = 1,laytrop
3298 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3299 laysolfr = min(lay+1,laytrop)
3300 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1
3301 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1
3302 inds = indself(lay)
3303 indf = indfor(lay)
3304 tauray = colmol(lay) * rayl
3305 do ig = 1,ng20
3306 taug(lay,ngs19+ig) = colh2o(lay) * &
3307 ((fac00(lay) * absa(ind0,ig) + &
3308 fac10(lay) * absa(ind0+1,ig) + &
3309 fac01(lay) * absa(ind1,ig) + &
3310 fac11(lay) * absa(ind1+1,ig)) + &
3311 selffac(lay) * (selfref(inds,ig) + &
3312 selffrac(lay) * &
3313 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3314 forfac(lay) * (forref(indf,ig) + &
3315 forfrac(lay) * &
3316 (forref(indf+1,ig) - forref(indf,ig)))) &
3317 + colch4(lay) * absch4(ig)
3318 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3319 taur(lay,ngs19+ig) = tauray
3320 if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig)
3321 enddo
3322 enddo
3323 !
3324 ! Upper atmosphere loop
3325 !
3326 do lay = laytrop+1,nlayers
3327 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1
3328 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1
3329 indf = indfor(lay)
3330 tauray = colmol(lay) * rayl
3331 do ig = 1,ng20
3332 taug(lay,ngs19+ig) = colh2o(lay) * &
3333 (fac00(lay) * absb(ind0,ig) + &
3334 fac10(lay) * absb(ind0+1,ig) + &
3335 fac01(lay) * absb(ind1,ig) + &
3336 fac11(lay) * absb(ind1+1,ig) + &
3337 forfac(lay) * (forref(indf,ig) + &
3338 forfrac(lay) * &
3339 (forref(indf+1,ig) - forref(indf,ig)))) + &
3340 colch4(lay) * absch4(ig)
3341 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3342 taur(lay,ngs19+ig) = tauray
3343 enddo
3344 enddo
3345 !
3346 end subroutine taumol20
3347 !-------------------------------------------------------------------------------
3348 !
3349 !
3350 !-------------------------------------------------------------------------------
3351 subroutine taumol21
3352 !-------------------------------------------------------------------------------
3353 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
3354 !-------------------------------------------------------------------------------
3355 !
3356 ! ------- Modules -------
3357 !
3358 use parrrsw_k, only : ng21, ngs20
3359 use rrsw_kg21_k, only : absa, ka, absb, kb, forref, selfref, &
3360 sfluxref, rayl, layreffr, strrat
3361 !
3362 ! ------- Declarations -------
3363 !
3364 ! Local
3365 !
3366 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3367 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3368 fac110, fac111, fs, speccomb, specmult, specparm, &
3369 tauray
3370 !-------------------------------------------------------------------------------
3371 !
3372 ! Compute the optical depth by interpolating in ln(pressure),
3373 ! temperature, and appropriate species. Below LAYTROP, the water
3374 ! vapor self-continuum is interpolated (in temperature) separately.
3375 !
3376 laysolfr = laytrop
3377 !
3378 ! Lower atmosphere loop
3379 !
3380 do lay = 1,laytrop
3381 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3382 laysolfr = min(lay+1,laytrop)
3383 speccomb = colh2o(lay) + strrat*colco2(lay)
3384 specparm = colh2o(lay)/speccomb
3385 if (specparm .ge. oneminus) specparm = oneminus
3386 specmult = 8._rb*(specparm)
3387 js = 1 + int(specmult)
3388 fs = mod(specmult, 1._rb )
3389 fac000 = (1._rb - fs) * fac00(lay)
3390 fac010 = (1._rb - fs) * fac10(lay)
3391 fac100 = fs * fac00(lay)
3392 fac110 = fs * fac10(lay)
3393 fac001 = (1._rb - fs) * fac01(lay)
3394 fac011 = (1._rb - fs) * fac11(lay)
3395 fac101 = fs * fac01(lay)
3396 fac111 = fs * fac11(lay)
3397 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js
3398 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js
3399 inds = indself(lay)
3400 indf = indfor(lay)
3401 tauray = colmol(lay) * rayl
3402 do ig = 1,ng21
3403 taug(lay,ngs20+ig) = speccomb * &
3404 (fac000 * absa(ind0,ig) + &
3405 fac100 * absa(ind0+1,ig) + &
3406 fac010 * absa(ind0+9,ig) + &
3407 fac110 * absa(ind0+10,ig) + &
3408 fac001 * absa(ind1,ig) + &
3409 fac101 * absa(ind1+1,ig) + &
3410 fac011 * absa(ind1+9,ig) + &
3411 fac111 * absa(ind1+10,ig)) + &
3412 colh2o(lay) * &
3413 (selffac(lay) * (selfref(inds,ig) + &
3414 selffrac(lay) * &
3415 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3416 forfac(lay) * (forref(indf,ig) + &
3417 forfrac(lay) * &
3418 (forref(indf+1,ig) - forref(indf,ig))))
3419 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3420 if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js) &
3421 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3422 taur(lay,ngs20+ig) = tauray
3423 enddo
3424 enddo
3425 !
3426 ! Upper atmosphere loop
3427 !
3428 do lay = laytrop+1,nlayers
3429 speccomb = colh2o(lay) + strrat*colco2(lay)
3430 specparm = colh2o(lay)/speccomb
3431 if (specparm .ge. oneminus) specparm = oneminus
3432 specmult = 4._rb*(specparm)
3433 js = 1 + int(specmult)
3434 fs = mod(specmult, 1._rb )
3435 fac000 = (1._rb - fs) * fac00(lay)
3436 fac010 = (1._rb - fs) * fac10(lay)
3437 fac100 = fs * fac00(lay)
3438 fac110 = fs * fac10(lay)
3439 fac001 = (1._rb - fs) * fac01(lay)
3440 fac011 = (1._rb - fs) * fac11(lay)
3441 fac101 = fs * fac01(lay)
3442 fac111 = fs * fac11(lay)
3443 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js
3444 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js
3445 indf = indfor(lay)
3446 tauray = colmol(lay) * rayl
3447 do ig = 1,ng21
3448 taug(lay,ngs20+ig) = speccomb * &
3449 (fac000 * absb(ind0,ig) + &
3450 fac100 * absb(ind0+1,ig) + &
3451 fac010 * absb(ind0+5,ig) + &
3452 fac110 * absb(ind0+6,ig) + &
3453 fac001 * absb(ind1,ig) + &
3454 fac101 * absb(ind1+1,ig) + &
3455 fac011 * absb(ind1+5,ig) + &
3456 fac111 * absb(ind1+6,ig)) + &
3457 colh2o(lay) * &
3458 forfac(lay) * (forref(indf,ig) + &
3459 forfrac(lay) * &
3460 (forref(indf+1,ig) - forref(indf,ig)))
3461 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3462 taur(lay,ngs20+ig) = tauray
3463 enddo
3464 enddo
3465 !
3466 end subroutine taumol21
3467 !-------------------------------------------------------------------------------
3468 !
3469 !
3470 !-------------------------------------------------------------------------------
3471 subroutine taumol22
3472 !-------------------------------------------------------------------------------
3473 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
3474 !-------------------------------------------------------------------------------
3475 !
3476 ! ------- Modules -------
3477 !
3478 use parrrsw_k, only : ng22, ngs21
3479 use rrsw_kg22_k, only : absa, ka, absb, kb, forref, selfref, &
3480 sfluxref, rayl, layreffr, strrat
3481 !
3482 ! ------- Declarations -------
3483 !
3484 ! Local
3485 !
3486 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3487 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3488 fac110, fac111, fs, speccomb, specmult, specparm, &
3489 tauray, o2adj, o2cont
3490 !-------------------------------------------------------------------------------
3491 !
3492 ! The following factor is the ratio of total O2 band intensity (lines
3493 ! and Mate continuum) to O2 band intensity (line only). It is needed
3494 ! to adjust the optical depths since the k's include only lines.
3495 !
3496 o2adj = 1.6_rb
3497 !
3498 ! Compute the optical depth by interpolating in ln(pressure),
3499 ! temperature, and appropriate species. Below LAYTROP, the water
3500 ! vapor self-continuum is interpolated (in temperature) separately.
3501 !
3502 laysolfr = laytrop
3503 !
3504 ! Lower atmosphere loop
3505 !
3506 do lay = 1,laytrop
3507 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3508 laysolfr = min(lay+1,laytrop)
3509 o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
3510 speccomb = colh2o(lay) + o2adj*strrat*colo2(lay)
3511 specparm = colh2o(lay)/speccomb
3512 if (specparm .ge. oneminus) specparm = oneminus
3513 specmult = 8._rb*(specparm)
3514 ! odadj = specparm + o2adj * (1._rb - specparm)
3515 js = 1 + int(specmult)
3516 fs = mod(specmult, 1._rb )
3517 fac000 = (1._rb - fs) * fac00(lay)
3518 fac010 = (1._rb - fs) * fac10(lay)
3519 fac100 = fs * fac00(lay)
3520 fac110 = fs * fac10(lay)
3521 fac001 = (1._rb - fs) * fac01(lay)
3522 fac011 = (1._rb - fs) * fac11(lay)
3523 fac101 = fs * fac01(lay)
3524 fac111 = fs * fac11(lay)
3525 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js
3526 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js
3527 inds = indself(lay)
3528 indf = indfor(lay)
3529 tauray = colmol(lay) * rayl
3530 do ig = 1,ng22
3531 taug(lay,ngs21+ig) = speccomb * &
3532 (fac000 * absa(ind0,ig) + &
3533 fac100 * absa(ind0+1,ig) + &
3534 fac010 * absa(ind0+9,ig) + &
3535 fac110 * absa(ind0+10,ig) + &
3536 fac001 * absa(ind1,ig) + &
3537 fac101 * absa(ind1+1,ig) + &
3538 fac011 * absa(ind1+9,ig) + &
3539 fac111 * absa(ind1+10,ig)) + &
3540 colh2o(lay) * &
3541 (selffac(lay) * (selfref(inds,ig) + &
3542 selffrac(lay) * &
3543 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3544 forfac(lay) * (forref(indf,ig) + &
3545 forfrac(lay) * &
3546 (forref(indf+1,ig) - forref(indf,ig)))) &
3547 + o2cont
3548 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
3549 if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js) &
3550 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3551 taur(lay,ngs21+ig) = tauray
3552 enddo
3553 enddo
3554 !
3555 ! Upper atmosphere loop
3556 !
3557 do lay = laytrop+1,nlayers
3558 o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
3559 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1
3560 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1
3561 tauray = colmol(lay) * rayl
3562 do ig = 1,ng22
3563 taug(lay,ngs21+ig) = colo2(lay) * o2adj * &
3564 (fac00(lay) * absb(ind0,ig) + &
3565 fac10(lay) * absb(ind0+1,ig) + &
3566 fac01(lay) * absb(ind1,ig) + &
3567 fac11(lay) * absb(ind1+1,ig)) + &
3568 o2cont
3569 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
3570 taur(lay,ngs21+ig) = tauray
3571 enddo
3572 enddo
3573 !
3574 end subroutine taumol22
3575 !-------------------------------------------------------------------------------
3576 !
3577 !
3578 !-------------------------------------------------------------------------------
3579 subroutine taumol23
3580 !-------------------------------------------------------------------------------
3581 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
3582 !-------------------------------------------------------------------------------
3583 !
3584 ! ------- Modules -------
3585 !
3586 use parrrsw_k, only : ng23, ngs22
3587 use rrsw_kg23_k, only : absa, ka, forref, selfref, &
3588 sfluxref, rayl, layreffr, givfac
3589 !
3590 ! ------- Declarations -------
3591 !
3592 ! Local
3593 !
3594 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3595 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3596 fac110, fac111, fs, speccomb, specmult, specparm, &
3597 tauray
3598 !-------------------------------------------------------------------------------
3599 !
3600 ! Compute the optical depth by interpolating in ln(pressure),
3601 ! temperature, and appropriate species. Below LAYTROP, the water
3602 ! vapor self-continuum is interpolated (in temperature) separately.
3603 !
3604 laysolfr = laytrop
3605 !
3606 ! Lower atmosphere loop
3607 !
3608 do lay = 1,laytrop
3609 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3610 laysolfr = min(lay+1,laytrop)
3611 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1
3612 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1
3613 inds = indself(lay)
3614 indf = indfor(lay)
3615 do ig = 1,ng23
3616 tauray = colmol(lay) * rayl(ig)
3617 taug(lay,ngs22+ig) = colh2o(lay) * &
3618 (givfac * (fac00(lay) * absa(ind0,ig) + &
3619 fac10(lay) * absa(ind0+1,ig) + &
3620 fac01(lay) * absa(ind1,ig) + &
3621 fac11(lay) * absa(ind1+1,ig)) + &
3622 selffac(lay) * (selfref(inds,ig) + &
3623 selffrac(lay) * &
3624 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3625 forfac(lay) * (forref(indf,ig) + &
3626 forfrac(lay) * &
3627 (forref(indf+1,ig) - forref(indf,ig))))
3628 ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
3629 if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig)
3630 taur(lay,ngs22+ig) = tauray
3631 enddo
3632 enddo
3633 !
3634 ! Upper atmosphere loop
3635 !
3636 do lay = laytrop+1,nlayers
3637 do ig = 1,ng23
3638 ! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
3639 ! ssa(lay,ngs22+ig) = 1.0_rb
3640 taug(lay,ngs22+ig) = 0._rb
3641 taur(lay,ngs22+ig) = colmol(lay) * rayl(ig)
3642 enddo
3643 enddo
3644 !
3645 end subroutine taumol23
3646 !-------------------------------------------------------------------------------
3647 !
3648 !
3649 !-------------------------------------------------------------------------------
3650 subroutine taumol24
3651 !-------------------------------------------------------------------------------
3652 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
3653 !-------------------------------------------------------------------------------
3654 !
3655 ! ------- Modules -------
3656 !
3657 use parrrsw_k, only : ng24, ngs23
3658 use rrsw_kg24_k, only : absa, ka, absb, kb, forref, selfref, &
3659 sfluxref, abso3a, abso3b, rayla, raylb, &
3660 layreffr, strrat
3661 !
3662 ! ------- Declarations -------
3663 !
3664 ! Local
3665 !
3666 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3667 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3668 fac110, fac111, fs, speccomb, specmult, specparm, &
3669 tauray
3670 !-------------------------------------------------------------------------------
3671 !
3672 ! Compute the optical depth by interpolating in ln(pressure),
3673 ! temperature, and appropriate species. Below LAYTROP, the water
3674 ! vapor self-continuum is interpolated (in temperature) separately.
3675 !
3676 laysolfr = laytrop
3677 !
3678 ! Lower atmosphere loop
3679 !
3680 do lay = 1,laytrop
3681 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3682 laysolfr = min(lay+1,laytrop)
3683 speccomb = colh2o(lay) + strrat*colo2(lay)
3684 specparm = colh2o(lay)/speccomb
3685 if (specparm .ge. oneminus) specparm = oneminus
3686 specmult = 8._rb*(specparm)
3687 js = 1 + int(specmult)
3688 fs = mod(specmult, 1._rb )
3689 fac000 = (1._rb - fs) * fac00(lay)
3690 fac010 = (1._rb - fs) * fac10(lay)
3691 fac100 = fs * fac00(lay)
3692 fac110 = fs * fac10(lay)
3693 fac001 = (1._rb - fs) * fac01(lay)
3694 fac011 = (1._rb - fs) * fac11(lay)
3695 fac101 = fs * fac01(lay)
3696 fac111 = fs * fac11(lay)
3697 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js
3698 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js
3699 inds = indself(lay)
3700 indf = indfor(lay)
3701 do ig = 1,ng24
3702 tauray = colmol(lay) * (rayla(ig,js) + &
3703 fs * (rayla(ig,js+1) - rayla(ig,js)))
3704 taug(lay,ngs23+ig) = speccomb * &
3705 (fac000 * absa(ind0,ig) + &
3706 fac100 * absa(ind0+1,ig) + &
3707 fac010 * absa(ind0+9,ig) + &
3708 fac110 * absa(ind0+10,ig) + &
3709 fac001 * absa(ind1,ig) + &
3710 fac101 * absa(ind1+1,ig) + &
3711 fac011 * absa(ind1+9,ig) + &
3712 fac111 * absa(ind1+10,ig)) + &
3713 colo3(lay) * abso3a(ig) + &
3714 colh2o(lay) * &
3715 (selffac(lay) * (selfref(inds,ig) + &
3716 selffrac(lay) * &
3717 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3718 forfac(lay) * (forref(indf,ig) + &
3719 forfrac(lay) * &
3720 (forref(indf+1,ig) - forref(indf,ig))))
3721 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
3722 if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js) &
3723 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3724 taur(lay,ngs23+ig) = tauray
3725 enddo
3726 enddo
3727 !
3728 ! Upper atmosphere loop
3729 !
3730 do lay = laytrop+1,nlayers
3731 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1
3732 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1
3733 do ig = 1,ng24
3734 tauray = colmol(lay) * raylb(ig)
3735 taug(lay,ngs23+ig) = colo2(lay) * &
3736 (fac00(lay) * absb(ind0,ig) + &
3737 fac10(lay) * absb(ind0+1,ig) + &
3738 fac01(lay) * absb(ind1,ig) + &
3739 fac11(lay) * absb(ind1+1,ig)) + &
3740 colo3(lay) * abso3b(ig)
3741 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
3742 taur(lay,ngs23+ig) = tauray
3743 enddo
3744 enddo
3745 !
3746 end subroutine taumol24
3747 !-------------------------------------------------------------------------------
3748 !
3749 !
3750 !-------------------------------------------------------------------------------
3751 subroutine taumol25
3752 !-------------------------------------------------------------------------------
3753 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
3754 !-------------------------------------------------------------------------------
3755 !
3756 ! ------- Modules -------
3757 !
3758 use parrrsw_k, only : ng25, ngs24
3759 use rrsw_kg25_k, only : absa, ka, &
3760 sfluxref, abso3a, abso3b, rayl, layreffr
3761 !
3762 ! ------- Declarations -------
3763 !
3764 ! Local
3765 !
3766 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3767 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3768 fac110, fac111, fs, speccomb, specmult, specparm, &
3769 tauray
3770 !-------------------------------------------------------------------------------
3771 !
3772 ! Compute the optical depth by interpolating in ln(pressure),
3773 ! temperature, and appropriate species. Below LAYTROP, the water
3774 ! vapor self-continuum is interpolated (in temperature) separately.
3775 !
3776 laysolfr = laytrop
3777 !
3778 ! Lower atmosphere loop
3779 !
3780 do lay = 1,laytrop
3781 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3782 laysolfr = min(lay+1,laytrop)
3783 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1
3784 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1
3785 do ig = 1,ng25
3786 tauray = colmol(lay) * rayl(ig)
3787 taug(lay,ngs24+ig) = colh2o(lay) * &
3788 (fac00(lay) * absa(ind0,ig) + &
3789 fac10(lay) * absa(ind0+1,ig) + &
3790 fac01(lay) * absa(ind1,ig) + &
3791 fac11(lay) * absa(ind1+1,ig)) + &
3792 colo3(lay) * abso3a(ig)
3793 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
3794 if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig)
3795 taur(lay,ngs24+ig) = tauray
3796 enddo
3797 enddo
3798 !
3799 ! Upper atmosphere loop
3800 !
3801 do lay = laytrop+1,nlayers
3802 do ig = 1,ng25
3803 tauray = colmol(lay) * rayl(ig)
3804 taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig)
3805 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
3806 taur(lay,ngs24+ig) = tauray
3807 enddo
3808 enddo
3809 !
3810 end subroutine taumol25
3811 !-------------------------------------------------------------------------------
3812 !
3813 !
3814 !-------------------------------------------------------------------------------
3815 subroutine taumol26
3816 !-------------------------------------------------------------------------------
3817 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
3818 !-------------------------------------------------------------------------------
3819 !
3820 ! ------- Modules -------
3821 !
3822 use parrrsw_k, only : ng26, ngs25
3823 use rrsw_kg26_k, only : sfluxref, rayl
3824 !
3825 ! ------- Declarations -------
3826 !
3827 ! Local
3828 !
3829 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3830 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3831 fac110, fac111, fs, speccomb, specmult, specparm, &
3832 tauray
3833 !-------------------------------------------------------------------------------
3834 !
3835 ! Compute the optical depth by interpolating in ln(pressure),
3836 ! temperature, and appropriate species. Below LAYTROP, the water
3837 ! vapor self-continuum is interpolated (in temperature) separately.
3838 !
3839 laysolfr = laytrop
3840 !
3841 ! Lower atmosphere loop
3842 !
3843 do lay = 1,laytrop
3844 do ig = 1,ng26
3845 ! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3846 ! ssa(lay,ngs25+ig) = 1.0_rb
3847 if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig)
3848 taug(lay,ngs25+ig) = 0._rb
3849 taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3850 enddo
3851 enddo
3852 !
3853 ! Upper atmosphere loop
3854 !
3855 do lay = laytrop+1,nlayers
3856 do ig = 1,ng26
3857 ! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3858 ! ssa(lay,ngs25+ig) = 1.0_rb
3859 taug(lay,ngs25+ig) = 0._rb
3860 taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3861 enddo
3862 enddo
3863 !
3864 end subroutine taumol26
3865 !-------------------------------------------------------------------------------
3866 !
3867 !
3868 !-------------------------------------------------------------------------------
3869 subroutine taumol27
3870 !-------------------------------------------------------------------------------
3871 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
3872 !-------------------------------------------------------------------------------
3873 !
3874 ! ------- Modules -------
3875 !
3876 use parrrsw_k, only : ng27, ngs26
3877 use rrsw_kg27_k, only : absa, ka, absb, kb, &
3878 sfluxref, rayl, layreffr, scalekur
3879 !
3880 ! ------- Declarations -------
3881 !
3882 ! Local
3883 !
3884 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3885 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3886 fac110, fac111, fs, speccomb, specmult, specparm, &
3887 tauray
3888 !-------------------------------------------------------------------------------
3889 !
3890 ! Compute the optical depth by interpolating in ln(pressure),
3891 ! temperature, and appropriate species. Below LAYTROP, the water
3892 ! vapor self-continuum is interpolated (in temperature) separately.
3893 !
3894 ! Lower atmosphere loop
3895 !
3896 do lay = 1,laytrop
3897 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1
3898 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1
3899 do ig = 1,ng27
3900 tauray = colmol(lay) * rayl(ig)
3901 taug(lay,ngs26+ig) = colo3(lay) * &
3902 (fac00(lay) * absa(ind0,ig) + &
3903 fac10(lay) * absa(ind0+1,ig) + &
3904 fac01(lay) * absa(ind1,ig) + &
3905 fac11(lay) * absa(ind1+1,ig))
3906 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
3907 taur(lay,ngs26+ig) = tauray
3908 enddo
3909 enddo
3910 !
3911 laysolfr = nlayers
3912 !
3913 ! Upper atmosphere loop
3914 !
3915 do lay = laytrop+1,nlayers
3916 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
3917 laysolfr = lay
3918 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1
3919 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1
3920 do ig = 1,ng27
3921 tauray = colmol(lay) * rayl(ig)
3922 taug(lay,ngs26+ig) = colo3(lay) * &
3923 (fac00(lay) * absb(ind0,ig) + &
3924 fac10(lay) * absb(ind0+1,ig) + &
3925 fac01(lay) * absb(ind1,ig) + &
3926 fac11(lay) * absb(ind1+1,ig))
3927 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
3928 if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig)
3929 taur(lay,ngs26+ig) = tauray
3930 enddo
3931 enddo
3932 !
3933 end subroutine taumol27
3934 !-------------------------------------------------------------------------------
3935 !
3936 !
3937 !-------------------------------------------------------------------------------
3938 subroutine taumol28
3939 !-------------------------------------------------------------------------------
3940 ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
3941 !------------------------------------------------------------------------------
3942 !
3943 ! ------- Modules -------
3944 !
3945 use parrrsw_k, only : ng28, ngs27
3946 use rrsw_kg28_k, only : absa, ka, absb, kb, &
3947 sfluxref, rayl, layreffr, strrat
3948 !
3949 ! ------- Declarations -------
3950 !
3951 ! Local
3952 !
3953 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3954 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3955 fac110, fac111, fs, speccomb, specmult, specparm, &
3956 tauray
3957 !-------------------------------------------------------------------------------
3958 !
3959 ! Compute the optical depth by interpolating in ln(pressure),
3960 ! temperature, and appropriate species. Below LAYTROP, the water
3961 ! vapor self-continuum is interpolated (in temperature) separately.
3962 !
3963 ! Lower atmosphere loop
3964 !
3965 do lay = 1,laytrop
3966 speccomb = colo3(lay) + strrat*colo2(lay)
3967 specparm = colo3(lay)/speccomb
3968 if (specparm .ge. oneminus) specparm = oneminus
3969 specmult = 8._rb*(specparm)
3970 js = 1 + int(specmult)
3971 fs = mod(specmult, 1._rb )
3972 fac000 = (1._rb - fs) * fac00(lay)
3973 fac010 = (1._rb - fs) * fac10(lay)
3974 fac100 = fs * fac00(lay)
3975 fac110 = fs * fac10(lay)
3976 fac001 = (1._rb - fs) * fac01(lay)
3977 fac011 = (1._rb - fs) * fac11(lay)
3978 fac101 = fs * fac01(lay)
3979 fac111 = fs * fac11(lay)
3980 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js
3981 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js
3982 tauray = colmol(lay) * rayl
3983 do ig = 1,ng28
3984 taug(lay,ngs27+ig) = speccomb * &
3985 (fac000 * absa(ind0,ig) + &
3986 fac100 * absa(ind0+1,ig) + &
3987 fac010 * absa(ind0+9,ig) + &
3988 fac110 * absa(ind0+10,ig) + &
3989 fac001 * absa(ind1,ig) + &
3990 fac101 * absa(ind1+1,ig) + &
3991 fac011 * absa(ind1+9,ig) + &
3992 fac111 * absa(ind1+10,ig))
3993 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
3994 taur(lay,ngs27+ig) = tauray
3995 enddo
3996 enddo
3997 !
3998 laysolfr = nlayers
3999 !
4000 ! Upper atmosphere loop
4001 !
4002 do lay = laytrop+1,nlayers
4003 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
4004 laysolfr = lay
4005 speccomb = colo3(lay) + strrat*colo2(lay)
4006 specparm = colo3(lay)/speccomb
4007 if (specparm .ge. oneminus) specparm = oneminus
4008 specmult = 4._rb*(specparm)
4009 js = 1 + int(specmult)
4010 fs = mod(specmult, 1._rb )
4011 fac000 = (1._rb - fs) * fac00(lay)
4012 fac010 = (1._rb - fs) * fac10(lay)
4013 fac100 = fs * fac00(lay)
4014 fac110 = fs * fac10(lay)
4015 fac001 = (1._rb - fs) * fac01(lay)
4016 fac011 = (1._rb - fs) * fac11(lay)
4017 fac101 = fs * fac01(lay)
4018 fac111 = fs * fac11(lay)
4019 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js
4020 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js
4021 tauray = colmol(lay) * rayl
4022 do ig = 1,ng28
4023 taug(lay,ngs27+ig) = speccomb * &
4024 (fac000 * absb(ind0,ig) + &
4025 fac100 * absb(ind0+1,ig) + &
4026 fac010 * absb(ind0+5,ig) + &
4027 fac110 * absb(ind0+6,ig) + &
4028 fac001 * absb(ind1,ig) + &
4029 fac101 * absb(ind1+1,ig) + &
4030 fac011 * absb(ind1+5,ig) + &
4031 fac111 * absb(ind1+6,ig))
4032 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
4033 if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js) &
4034 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4035 taur(lay,ngs27+ig) = tauray
4036 enddo
4037 enddo
4038 !
4039 end subroutine taumol28
4040 !-------------------------------------------------------------------------------
4041 !
4042 !
4043 !-------------------------------------------------------------------------------
4044 subroutine taumol29
4045 !-------------------------------------------------------------------------------
4046 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
4047 !-------------------------------------------------------------------------------
4048 !
4049 ! ------- Modules -------
4050 !
4051 use parrrsw_k, only : ng29, ngs28
4052 use rrsw_kg29_k, only : absa, ka, absb, kb, forref, selfref, &
4053 sfluxref, absh2o, absco2, rayl, layreffr
4054 !
4055 ! ------- Declarations -------
4056 ! Local
4057 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4058 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4059 fac110, fac111, fs, speccomb, specmult, specparm, &
4060 tauray
4061 !-------------------------------------------------------------------------------
4062 !
4063 ! Compute the optical depth by interpolating in ln(pressure),
4064 ! temperature, and appropriate species. Below LAYTROP, the water
4065 ! vapor self-continuum is interpolated (in temperature) separately.
4066 !
4067 ! Lower atmosphere loop
4068 !
4069 do lay = 1,laytrop
4070 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1
4071 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1
4072 inds = indself(lay)
4073 indf = indfor(lay)
4074 tauray = colmol(lay) * rayl
4075 do ig = 1,ng29
4076 taug(lay,ngs28+ig) = colh2o(lay) * &
4077 ((fac00(lay) * absa(ind0,ig) + &
4078 fac10(lay) * absa(ind0+1,ig) + &
4079 fac01(lay) * absa(ind1,ig) + &
4080 fac11(lay) * absa(ind1+1,ig)) + &
4081 selffac(lay) * (selfref(inds,ig) + &
4082 selffrac(lay) * &
4083 (selfref(inds+1,ig) - selfref(inds,ig))) + &
4084 forfac(lay) * (forref(indf,ig) + &
4085 forfrac(lay) * &
4086 (forref(indf+1,ig) - forref(indf,ig)))) &
4087 + colco2(lay) * absco2(ig)
4088 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4089 taur(lay,ngs28+ig) = tauray
4090 enddo
4091 enddo
4092 !
4093 laysolfr = nlayers
4094 !
4095 ! Upper atmosphere loop
4096 !
4097 do lay = laytrop+1,nlayers
4098 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
4099 laysolfr = lay
4100 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1
4101 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1
4102 tauray = colmol(lay) * rayl
4103 do ig = 1,ng29
4104 taug(lay,ngs28+ig) = colco2(lay) * &
4105 (fac00(lay) * absb(ind0,ig) + &
4106 fac10(lay) * absb(ind0+1,ig) + &
4107 fac01(lay) * absb(ind1,ig) + &
4108 fac11(lay) * absb(ind1+1,ig)) &
4109 + colh2o(lay) * absh2o(ig)
4110 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4111 if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig)
4112 taur(lay,ngs28+ig) = tauray
4113 enddo
4114 enddo
4115 !
4116 end subroutine taumol29
4117 !-------------------------------------------------------------------------------
4118 !
4119 !
4120 !-------------------------------------------------------------------------------
4121 end subroutine taumol_sw
4122 !-------------------------------------------------------------------------------
4123 !
4124 !
4125 !-------------------------------------------------------------------------------
4126 end module rrtmg_sw_taumol_k
4127 !-------------------------------------------------------------------------------
4128 !
4129 !
4130 !-------------------------------------------------------------------------------
4131 module rrtmg_sw_init_k
4132 !-------------------------------------------------------------------------------
4133 ! --------------------------------------------------------------------------
4134 ! | |
4135 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
4136 ! | This software may be used, copied, or redistributed as long as it is |
4137 ! | not sold and this copyright notice is reproduced on each copy made. |
4138 ! | This model is provided as is without any express or implied warranties. |
4139 ! | (http://www.rtweb.aer.com/) |
4140 ! | |
4141 ! --------------------------------------------------------------------------
4142 ! ------- Modules -------
4143 !
4144 use parkind_k, only : im => kind_im, rb => kind_rb
4145 use rrsw_wvn_k
4146 use rrtmg_sw_setcoef_k, only: swatmref
4147 !
4148 implicit none
4149 !
4150 contains
4151 !-------------------------------------------------------------------------------
4152 !
4153 !
4154 !-------------------------------------------------------------------------------
4155 subroutine rrtmg_sw_ini(cpdair)
4156 !-------------------------------------------------------------------------------
4157 ! abstract :
4158 ! This subroutine performs calculations necessary for the initialization
4159 ! of the shortwave model. Lookup tables are computed for use in the SW
4160 ! radiative transfer, and input absorption coefficient data for each
4161 ! spectral band are reduced from 224 g-point intervals to 112.
4162 !
4163 ! history log :
4164 ! 2004-02 Michael J. Iacono Original version
4165 ! 2006-07 M. J. Iacono Revision for F90 formatting
4166 !
4167 !-------------------------------------------------------------------------------
4168 use parrrsw_k, only : mg, nbndsw, ngptsw
4169 use rrsw_tbl_k, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
4170 use rrsw_vsn_k, only: hvrini, hnamini
4171 !
4172 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
4173 ! at constant pressure at 273 K
4174 ! (J kg-1 K-1)
4175 !
4176 ! ------- Local -------
4177 !
4178 integer(kind=im) :: ibnd, igc, ig, ind, ipr
4179 integer(kind=im) :: igcsm, iprsm
4180 integer(kind=im) :: itr
4181 !
4182 real(kind=rb) :: wtsum, wtsm(mg)
4183 real(kind=rb) :: tfn
4184 !
4185 real(kind=rb), parameter :: expeps = 1.e-20
4186 ! Smallest value for exponential table
4187 !
4188 ! ------- Definitions -------
4189 ! Arrays for 10000-point look-up tables:
4190 ! TAU_TBL Clear-sky optical depth
4191 ! EXP_TBL Exponential lookup table for transmittance
4192 ! PADE Pade approximation constant (= 0.278)
4193 ! BPADE Inverse of the Pade approximation constant
4194 !
4195 hvrini = '$Revision: 1.3 $'
4196 !
4197 ! Initialize model data
4198 !
4199 call swdatinit(cpdair)
4200 call swcmbdat ! g-point interval reduction data
4201 call swaerpr ! aerosol optical properties
4202 call swcldpr ! cloud optical properties
4203 call swatmref ! reference MLS profile
4204 !
4205 ! Moved to module_ra_rrtmg_sw for WRF
4206 ! call sw_kgb16 ! molecular absorption coefficients
4207 ! call sw_kgb17
4208 ! call sw_kgb18
4209 ! call sw_kgb19
4210 ! call sw_kgb20
4211 ! call sw_kgb21
4212 ! call sw_kgb22
4213 ! call sw_kgb23
4214 ! call sw_kgb24
4215 ! call sw_kgb25
4216 ! call sw_kgb26
4217 ! call sw_kgb27
4218 ! call sw_kgb28
4219 ! call sw_kgb29
4220 !
4221 ! Define exponential lookup tables for transmittance. Tau is
4222 ! computed as a function of the tau transition function, and transmittance
4223 ! is calculated as a function of tau. All tables are computed at intervals
4224 ! of 0.0001. The inverse of the constant used in the Pade approximation to
4225 ! the tau transition function is set to bpade.
4226 !
4227 exp_tbl(0) = 1.0_rb
4228 exp_tbl(ntbl) = expeps
4229 bpade = 1.0_rb / pade
4230 do itr = 1,ntbl-1
4231 tfn = real(itr) / real(ntbl)
4232 tau_tbl = bpade * tfn / (1._rb - tfn)
4233 exp_tbl(itr) = exp(-tau_tbl)
4234 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
4235 enddo
4236 !
4237 ! Perform g-point reduction from 16 per band (224 total points) to
4238 ! a band dependent number (112 total points) for all absorption
4239 ! coefficient input data and Planck fraction input data.
4240 ! Compute relative weighting for new g-point combinations.
4241 !
4242 igcsm = 0
4243 do ibnd = 1,nbndsw
4244 iprsm = 0
4245 if (ngc(ibnd).lt.mg) then
4246 do igc = 1,ngc(ibnd)
4247 igcsm = igcsm + 1
4248 wtsum = 0.
4249 do ipr = 1,ngn(igcsm)
4250 iprsm = iprsm + 1
4251 wtsum = wtsum + wt(iprsm)
4252 enddo
4253 wtsm(igc) = wtsum
4254 enddo
4255 do ig = 1,ng(ibnd+15)
4256 ind = (ibnd-1)*mg + ig
4257 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
4258 enddo
4259 else
4260 do ig = 1,ng(ibnd+15)
4261 igcsm = igcsm + 1
4262 ind = (ibnd-1)*mg + ig
4263 rwgt(ind) = 1.0_rb
4264 enddo
4265 endif
4266 enddo
4267 !
4268 ! Reduce g-points for absorption coefficient data in each LW spectral band.
4269 !
4270 call cmbgb16s
4271 call cmbgb17
4272 call cmbgb18
4273 call cmbgb19
4274 call cmbgb20
4275 call cmbgb21
4276 call cmbgb22
4277 call cmbgb23
4278 call cmbgb24
4279 call cmbgb25
4280 call cmbgb26
4281 call cmbgb27
4282 call cmbgb28
4283 call cmbgb29
4284 !
4285 end subroutine rrtmg_sw_ini
4286 !-------------------------------------------------------------------------------
4287 !
4288 !
4289 !-------------------------------------------------------------------------------
4290 subroutine swdatinit(cpdair)
4291 !
4292 ! --------- Modules ----------
4293 !
4294 use rrsw_con_k, only: heatfac, grav, planck, boltz, &
4295 clight, avogad, alosmt, gascon, radcn1, radcn2, &
4296 sbcnst, secdy
4297 use rrsw_vsn_k
4298 !
4299 save
4300 !
4301 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
4302 ! at constant pressure at 273 K
4303 ! (J kg-1 K-1)
4304 !
4305 ! Shortwave spectral band limits (wavenumbers)
4306 !
4307 wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, &
4308 7700._rb, 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb, &
4309 38000._rb, 820._rb/)
4310 wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, &
4311 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb, &
4312 50000._rb, 2600._rb/)
4313 delwave(:) = (/ 650._rb, 750._rb, 650._rb, 500._rb, 1000._rb, 1550._rb, &
4314 350._rb, 4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb, &
4315 12000._rb, 1780._rb/)
4316 !
4317 ! Spectral band information
4318 !
4319 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
4320 nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
4321 nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
4322 !
4323 ! Fundamental physical constants from NIST 2002
4324 !
4325 grav = 9.8066_rb ! Acceleration of gravity
4326 ! (m s-2)
4327 planck = 6.62606876e-27_rb ! Planck constant
4328 ! (ergs s; g cm2 s-1)
4329 boltz = 1.3806503e-16_rb ! Boltzmann constant
4330 ! (ergs K-1; g cm2 s-2 K-1)
4331 clight = 2.99792458e+10_rb ! Speed of light in a vacuum
4332 ! (cm s-1)
4333 avogad = 6.02214199e+23_rb ! Avogadro constant
4334 ! (mol-1)
4335 alosmt = 2.6867775e+19_rb ! Loschmidt constant
4336 ! (cm-3)
4337 gascon = 8.31447200e+07_rb ! Molar gas constant
4338 ! (ergs mol-1 K-1)
4339 radcn1 = 1.191042772e-12_rb ! First radiation constant
4340 ! (W cm2 sr-1)
4341 radcn2 = 1.4387752_rb ! Second radiation constant
4342 ! (cm K)
4343 sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
4344 ! (W cm-2 K-4)
4345 secdy = 8.6400e4_rb ! Number of seconds per day
4346 ! (s d-1)
4347 !
4348 ! units are generally cgs
4349 !
4350 ! The first and second radiation constants are taken from NIST.
4351 ! They were previously obtained from the relations:
4352 ! radcn1 = 2.*planck*clight*clight*1.e-07
4353 ! radcn2 = planck*clight/boltz
4354 !
4355 ! Heatfac is the factor by which delta-flux / delta-pressure is
4356 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
4357 ! the heating rate in units of degrees/day. It is equal to:
4358 ! Original value:
4359 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4360 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
4361 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4362 ! = (9.8066)(86400)(1e-5)/(1.004)
4363 ! heatfac = 8.4391_rb
4364 !
4365 ! Modified value for consistency with CAM3:
4366 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4367 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
4368 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4369 ! = (9.80616)(86400)(1e-5)/(1.00464)
4370 ! heatfac = 8.43339130434_rb
4371 !
4372 ! Calculated value (from constants above and input cpdair)
4373 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
4374 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
4375 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
4376 !
4377 heatfac = grav * secdy / (cpdair * 1.e2_rb)
4378 !
4379 end subroutine swdatinit
4380 !-------------------------------------------------------------------------------
4381 !
4382 !
4383 !-------------------------------------------------------------------------------
4384 subroutine swcmbdat
4385 !-------------------------------------------------------------------------------
4386 !
4387 ! ------- Definitions -------
4388 ! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
4389 ! This mapping from 224 to 112 points has been carefully selected to
4390 ! minimize the effect on the resulting fluxes and cooling rates, and
4391 ! caution should be used if the mapping is modified. The full 224
4392 ! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
4393 ! ngpt The total number of new g-points
4394 ! ngc The number of new g-points in each band
4395 ! ngs The cumulative sum of new g-points for each band
4396 ! ngm The index of each new g-point relative to the original
4397 ! 16 g-points for each band.
4398 ! ngn The number of original g-points that are combined to make
4399 ! each new g-point in each band.
4400 ! ngb The band index for each new g-point.
4401 ! wt RRTM weights for 16 g-points.
4402 !
4403 ! Use this set for 112 quadrature point (g-point) model
4404 ! ------- Data statements -------
4405 !
4406 save
4407 ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
4408 ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
4409 ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, &
4410 ! band 16
4411 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, &
4412 ! band 17
4413 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &
4414 ! band 18
4415 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &
4416 ! band 19
4417 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &
4418 ! band 20
4419 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &
4420 ! band 21
4421 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, &
4422 ! band 22
4423 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, &
4424 ! band 23
4425 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, &
4426 ! band 24
4427 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &
4428 ! band 25
4429 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &
4430 ! band 26
4431 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, &
4432 ! band 27
4433 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &
4434 ! band 28
4435 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /)
4436 ! band 29
4437 ngn(:) = (/ 2,2,2,2,4,4, &
4438 ! band 16
4439 1,1,1,1,1,2,1,2,1,2,1,2, &
4440 ! band 17
4441 1,1,1,1,2,2,4,4, &
4442 ! band 18
4443 1,1,1,1,2,2,4,4, &
4444 ! band 19
4445 1,1,1,1,1,1,1,1,2,6, &
4446 ! band 20
4447 1,1,1,1,1,1,1,1,2,6, &
4448 ! band 21
4449 8,8, &
4450 ! band 22
4451 2,2,1,1,1,1,1,1,2,4, &
4452 ! band 23
4453 2,2,2,2,2,2,2,2, &
4454 ! band 24
4455 1,1,2,2,4,6, &
4456 ! band 25
4457 1,1,2,2,4,6, &
4458 ! band 26
4459 1,1,1,1,1,1,4,6, &
4460 ! band 27
4461 1,1,2,2,4,6, &
4462 ! band 28
4463 1,1,1,1,2,2,2,2,1,1,1,1 /)
4464 ! band 29
4465 ngb(:) = (/ 16,16,16,16,16,16, &
4466 ! band 16
4467 17,17,17,17,17,17,17,17,17,17,17,17, &
4468 ! band 17
4469 18,18,18,18,18,18,18,18, &
4470 ! band 18
4471 19,19,19,19,19,19,19,19, &
4472 ! band 19
4473 20,20,20,20,20,20,20,20,20,20, &
4474 ! band 20
4475 21,21,21,21,21,21,21,21,21,21, &
4476 ! band 21
4477 22,22, &
4478 ! band 22
4479 23,23,23,23,23,23,23,23,23,23, &
4480 ! band 23
4481 24,24,24,24,24,24,24,24, &
4482 ! band 24
4483 25,25,25,25,25,25, &
4484 ! band 25
4485 26,26,26,26,26,26, &
4486 ! band 26
4487 27,27,27,27,27,27,27,27, &
4488 ! band 27
4489 28,28,28,28,28,28, &
4490 ! band 28
4491 29,29,29,29,29,29,29,29,29,29,29,29 /)
4492 ! band 29
4493 !
4494 ! Use this set for full 224 quadrature point (g-point) model
4495 ! ------- Data statements -------
4496 ! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
4497 ! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
4498 ! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
4499 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
4500 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
4501 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
4502 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
4503 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
4504 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
4505 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
4506 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
4507 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
4508 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
4509 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
4510 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
4511 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
4512 ! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
4513 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
4514 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
4515 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
4516 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
4517 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
4518 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
4519 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
4520 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
4521 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
4522 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
4523 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
4524 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
4525 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
4526 ! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
4527 ! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
4528 ! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
4529 ! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
4530 ! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
4531 ! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
4532 ! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
4533 ! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
4534 ! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
4535 ! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
4536 ! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
4537 ! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
4538 ! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
4539 ! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
4540 wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
4541 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
4542 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
4543 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
4544 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
4545 0.0000750000_rb /)
4546 !
4547 end subroutine swcmbdat
4548 !-------------------------------------------------------------------------------
4549 !
4550 !
4551 !-------------------------------------------------------------------------------
4552 subroutine swaerpr
4553 !-------------------------------------------------------------------------------
4554 !
4555 ! abstract:
4556 ! Define spectral aerosol properties for six ECMWF aerosol types
4557 ! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
4558 !
4559 ! history log :
4560 ! 2003-02 JJMorcrette, ECMWF Defined for rrtmg_sw 14 spectral bands
4561 ! 2006-07 MJIacono, AER Reformatted for consistency with rrtmg_lw
4562 !
4563 !-------------------------------------------------------------------------------
4564 use rrsw_aer_k, only : rsrtaua, rsrpiza, rsrasya
4565 !
4566 save
4567 !
4568 rsrtaua( 1, :) = (/ &
4569 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4570 rsrtaua( 2, :) = (/ &
4571 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4572 rsrtaua( 3, :) = (/ &
4573 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4574 rsrtaua( 4, :) = (/ &
4575 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4576 rsrtaua( 5, :) = (/ &
4577 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4578 rsrtaua( 6, :) = (/ &
4579 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4580 rsrtaua( 7, :) = (/ &
4581 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4582 rsrtaua( 8, :) = (/ &
4583 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
4584 rsrtaua( 9, :) = (/ &
4585 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
4586 rsrtaua(10, :) = (/ &
4587 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4588 rsrtaua(11, :) = (/ &
4589 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4590 rsrtaua(12, :) = (/ &
4591 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4592 rsrtaua(13, :) = (/ &
4593 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4594 rsrtaua(14, :) = (/ &
4595 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4596 !
4597 rsrpiza( 1, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, &
4598 .8748231_rb, .2355667_rb/)
4599 rsrpiza( 2, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, &
4600 .8748231_rb, .2355667_rb/)
4601 rsrpiza( 3, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, &
4602 .9467578_rb, .9955938_rb/)
4603 rsrpiza( 4, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, &
4604 .9467578_rb, .9955938_rb/)
4605 rsrpiza( 5, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, &
4606 .9467578_rb, .9955938_rb/)
4607 rsrpiza( 6, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, &
4608 .9467578_rb, .9955938_rb/)
4609 rsrpiza( 7, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, &
4610 .9467578_rb, .9955938_rb/)
4611 rsrpiza( 8, :) = (/.8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, &
4612 .9532763_rb, .9999999_rb/)
4613 rsrpiza( 9, :) = (/.8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, &
4614 .9532763_rb, .9999999_rb/)
4615 rsrpiza(10, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, &
4616 .9401905_rb, .9999999_rb/)
4617 rsrpiza(11, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, &
4618 .9401905_rb, .9999999_rb/)
4619 rsrpiza(12, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, &
4620 .9401905_rb, .9999999_rb/)
4621 rsrpiza(13, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, &
4622 .9401905_rb, .9999999_rb/)
4623 rsrpiza(14, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, &
4624 .8748231_rb, .2355667_rb/)
4625 !
4626 rsrasya( 1, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, &
4627 .4629866_rb, .1907639_rb/)
4628 rsrasya( 2, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, &
4629 .4629866_rb, .1907639_rb/)
4630 rsrasya( 3, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, &
4631 .6105750_rb, .4760794_rb/)
4632 rsrasya( 4, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, &
4633 .6105750_rb, .4760794_rb/)
4634 rsrasya( 5, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, &
4635 .6105750_rb, .4760794_rb/)
4636 rsrasya( 6, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, &
4637 .6105750_rb, .4760794_rb/)
4638 rsrasya( 7, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, &
4639 .6105750_rb, .4760794_rb/)
4640 rsrasya( 8, :) = (/0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, &
4641 .6735182_rb, .6519706_rb/)
4642 rsrasya( 9, :) = (/0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, &
4643 .6735182_rb, .6519706_rb/)
4644 rsrasya(10, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, &
4645 .7008249_rb, .7270548_rb/)
4646 rsrasya(11, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, &
4647 .7008249_rb, .7270548_rb/)
4648 rsrasya(12, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, &
4649 .7008249_rb, .7270548_rb/)
4650 rsrasya(13, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, &
4651 .7008249_rb, .7270548_rb/)
4652 rsrasya(14, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, &
4653 .4629866_rb, .1907639_rb/)
4654 !
4655 end subroutine swaerpr
4656 !-------------------------------------------------------------------------------
4657 !
4658 !
4659 !-------------------------------------------------------------------------------
4660 subroutine cmbgb16s
4661 !-------------------------------------------------------------------------------
4662 !
4663 ! abstract :
4664 ! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
4665 ! data for each band, which are defined for 16 g-points and 14 spectral
4666 ! bands. The data are combined with appropriate weighting following the
4667 ! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
4668 ! function data in array SFLUXREF are combined without weighting. All
4669 ! g-point reduced data are put into new arrays for use in RRTMG_SW.
4670 !
4671 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
4672 !
4673 ! history log :
4674 ! 1998-07 MJIacono Original version
4675 ! 2002-11 MJIacono Revision for RRTM_SW
4676 ! 2003-12 MJIacono Revision for RRTMG_SW
4677 ! 2006-07 MJIacono Revision for F90 reformatting
4678 !-----------------------------------------------------------------------
4679 !
4680 use rrsw_kg16_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
4681 absa, ka, absb, kb, selfref, forref, sfluxref
4682 !
4683 ! ------- Local -------
4684 !
4685 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4686 real(kind=rb) :: sumk, sumf
4687 !-------------------------------------------------------------------------------
4688 do jn = 1,9
4689 do jt = 1,5
4690 do jp = 1,13
4691 iprsm = 0
4692 do igc = 1,ngc(1)
4693 sumk = 0.
4694 do ipr = 1,ngn(igc)
4695 iprsm = iprsm + 1
4696 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
4697 enddo
4698 ka(jn,jt,jp,igc) = sumk
4699 enddo
4700 enddo
4701 enddo
4702 enddo
4703 !
4704 do jt = 1,5
4705 do jp = 13,59
4706 iprsm = 0
4707 do igc = 1,ngc(1)
4708 sumk = 0.
4709 do ipr = 1,ngn(igc)
4710 iprsm = iprsm + 1
4711 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
4712 enddo
4713 kb(jt,jp,igc) = sumk
4714 enddo
4715 enddo
4716 enddo
4717 !
4718 do jt = 1,10
4719 iprsm = 0
4720 do igc = 1,ngc(1)
4721 sumk = 0.
4722 do ipr = 1,ngn(igc)
4723 iprsm = iprsm + 1
4724 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
4725 enddo
4726 selfref(jt,igc) = sumk
4727 enddo
4728 enddo
4729 !
4730 do jt = 1,3
4731 iprsm = 0
4732 do igc = 1,ngc(1)
4733 sumk = 0.
4734 do ipr = 1,ngn(igc)
4735 iprsm = iprsm + 1
4736 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
4737 enddo
4738 forref(jt,igc) = sumk
4739 enddo
4740 enddo
4741 !
4742 iprsm = 0
4743 do igc = 1,ngc(1)
4744 sumf = 0.
4745 do ipr = 1,ngn(igc)
4746 iprsm = iprsm + 1
4747 sumf = sumf + sfluxrefo(iprsm)
4748 enddo
4749 sfluxref(igc) = sumf
4750 enddo
4751 !
4752 end subroutine cmbgb16s
4753 !-------------------------------------------------------------------------------
4754 !
4755 !
4756 !-------------------------------------------------------------------------------
4757 subroutine cmbgb17
4758 !-------------------------------------------------------------------------------
4759 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
4760 !-------------------------------------------------------------------------------
4761 !
4762 use rrsw_kg17_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
4763 absa, ka, absb, kb, selfref, forref, sfluxref
4764 !
4765 ! ------- Local -------
4766 !
4767 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4768 real(kind=rb) :: sumk, sumf
4769 !-------------------------------------------------------------------------------
4770 do jn = 1,9
4771 do jt = 1,5
4772 do jp = 1,13
4773 iprsm = 0
4774 do igc = 1,ngc(2)
4775 sumk = 0.
4776 do ipr = 1,ngn(ngs(1)+igc)
4777 iprsm = iprsm + 1
4778 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
4779 enddo
4780 ka(jn,jt,jp,igc) = sumk
4781 enddo
4782 enddo
4783 enddo
4784 enddo
4785 !
4786 do jn = 1,5
4787 do jt = 1,5
4788 do jp = 13,59
4789 iprsm = 0
4790 do igc = 1,ngc(2)
4791 sumk = 0.
4792 do ipr = 1,ngn(ngs(1)+igc)
4793 iprsm = iprsm + 1
4794 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
4795 enddo
4796 kb(jn,jt,jp,igc) = sumk
4797 enddo
4798 enddo
4799 enddo
4800 enddo
4801 !
4802 do jt = 1,10
4803 iprsm = 0
4804 do igc = 1,ngc(2)
4805 sumk = 0.
4806 do ipr = 1,ngn(ngs(1)+igc)
4807 iprsm = iprsm + 1
4808 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
4809 enddo
4810 selfref(jt,igc) = sumk
4811 enddo
4812 enddo
4813 !
4814 do jt = 1,4
4815 iprsm = 0
4816 do igc = 1,ngc(2)
4817 sumk = 0.
4818 do ipr = 1,ngn(ngs(1)+igc)
4819 iprsm = iprsm + 1
4820 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
4821 enddo
4822 forref(jt,igc) = sumk
4823 enddo
4824 enddo
4825 !
4826 do jp = 1,5
4827 iprsm = 0
4828 do igc = 1,ngc(2)
4829 sumf = 0.
4830 do ipr = 1,ngn(ngs(1)+igc)
4831 iprsm = iprsm + 1
4832 sumf = sumf + sfluxrefo(iprsm,jp)
4833 enddo
4834 sfluxref(igc,jp) = sumf
4835 enddo
4836 enddo
4837 !
4838 end subroutine cmbgb17
4839 !-------------------------------------------------------------------------------
4840 !
4841 !
4842 !-------------------------------------------------------------------------------
4843 subroutine cmbgb18
4844 !-------------------------------------------------------------------------------
4845 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
4846 !-------------------------------------------------------------------------------
4847 !
4848 use rrsw_kg18_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
4849 absa, ka, absb, kb, selfref, forref, sfluxref
4850 !
4851 ! ------- Local -------
4852 !
4853 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4854 real(kind=rb) :: sumk, sumf
4855 !-------------------------------------------------------------------------------
4856 do jn = 1,9
4857 do jt = 1,5
4858 do jp = 1,13
4859 iprsm = 0
4860 do igc = 1,ngc(3)
4861 sumk = 0.
4862 do ipr = 1,ngn(ngs(2)+igc)
4863 iprsm = iprsm + 1
4864 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
4865 enddo
4866 ka(jn,jt,jp,igc) = sumk
4867 enddo
4868 enddo
4869 enddo
4870 enddo
4871 !
4872 do jt = 1,5
4873 do jp = 13,59
4874 iprsm = 0
4875 do igc = 1,ngc(3)
4876 sumk = 0.
4877 do ipr = 1,ngn(ngs(2)+igc)
4878 iprsm = iprsm + 1
4879 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
4880 enddo
4881 kb(jt,jp,igc) = sumk
4882 enddo
4883 enddo
4884 enddo
4885 !
4886 do jt = 1,10
4887 iprsm = 0
4888 do igc = 1,ngc(3)
4889 sumk = 0.
4890 do ipr = 1,ngn(ngs(2)+igc)
4891 iprsm = iprsm + 1
4892 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
4893 enddo
4894 selfref(jt,igc) = sumk
4895 enddo
4896 enddo
4897 !
4898 do jt = 1,3
4899 iprsm = 0
4900 do igc = 1,ngc(3)
4901 sumk = 0.
4902 do ipr = 1,ngn(ngs(2)+igc)
4903 iprsm = iprsm + 1
4904 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
4905 enddo
4906 forref(jt,igc) = sumk
4907 enddo
4908 enddo
4909 !
4910 do jp = 1,9
4911 iprsm = 0
4912 do igc = 1,ngc(3)
4913 sumf = 0.
4914 do ipr = 1,ngn(ngs(2)+igc)
4915 iprsm = iprsm + 1
4916 sumf = sumf + sfluxrefo(iprsm,jp)
4917 enddo
4918 sfluxref(igc,jp) = sumf
4919 enddo
4920 enddo
4921 !
4922 end subroutine cmbgb18
4923 !-------------------------------------------------------------------------------
4924 !
4925 !
4926 !-------------------------------------------------------------------------------
4927 subroutine cmbgb19
4928 !-------------------------------------------------------------------------------
4929 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
4930 !-------------------------------------------------------------------------------
4931 !
4932 use rrsw_kg19_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
4933 absa, ka, absb, kb, selfref, forref, sfluxref
4934 !
4935 ! ------- Local -------
4936 !
4937 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4938 real(kind=rb) :: sumk, sumf
4939 !-------------------------------------------------------------------------------
4940 do jn = 1,9
4941 do jt = 1,5
4942 do jp = 1,13
4943 iprsm = 0
4944 do igc = 1,ngc(4)
4945 sumk = 0.
4946 do ipr = 1,ngn(ngs(3)+igc)
4947 iprsm = iprsm + 1
4948 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
4949 enddo
4950 ka(jn,jt,jp,igc) = sumk
4951 enddo
4952 enddo
4953 enddo
4954 enddo
4955 !
4956 do jt = 1,5
4957 do jp = 13,59
4958 iprsm = 0
4959 do igc = 1,ngc(4)
4960 sumk = 0.
4961 do ipr = 1,ngn(ngs(3)+igc)
4962 iprsm = iprsm + 1
4963 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
4964 enddo
4965 kb(jt,jp,igc) = sumk
4966 enddo
4967 enddo
4968 enddo
4969 !
4970 do jt = 1,10
4971 iprsm = 0
4972 do igc = 1,ngc(4)
4973 sumk = 0.
4974 do ipr = 1,ngn(ngs(3)+igc)
4975 iprsm = iprsm + 1
4976 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
4977 enddo
4978 selfref(jt,igc) = sumk
4979 enddo
4980 enddo
4981 !
4982 do jt = 1,3
4983 iprsm = 0
4984 do igc = 1,ngc(4)
4985 sumk = 0.
4986 do ipr = 1,ngn(ngs(3)+igc)
4987 iprsm = iprsm + 1
4988 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
4989 enddo
4990 forref(jt,igc) = sumk
4991 enddo
4992 enddo
4993 !
4994 do jp = 1,9
4995 iprsm = 0
4996 do igc = 1,ngc(4)
4997 sumf = 0.
4998 do ipr = 1,ngn(ngs(3)+igc)
4999 iprsm = iprsm + 1
5000 sumf = sumf + sfluxrefo(iprsm,jp)
5001 enddo
5002 sfluxref(igc,jp) = sumf
5003 enddo
5004 enddo
5005 !
5006 end subroutine cmbgb19
5007 !-------------------------------------------------------------------------------
5008 !
5009 !
5010 !-------------------------------------------------------------------------------
5011 subroutine cmbgb20
5012 !-------------------------------------------------------------------------------
5013 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
5014 !-------------------------------------------------------------------------------
5015 !
5016 use rrsw_kg20_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
5017 absa, ka, absb, kb, selfref, forref, sfluxref, absch4
5018 !
5019 ! ------- Local -------
5020 !
5021 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5022 real(kind=rb) :: sumk, sumf1, sumf2
5023 !-------------------------------------------------------------------------------
5024 do jt = 1,5
5025 do jp = 1,13
5026 iprsm = 0
5027 do igc = 1,ngc(5)
5028 sumk = 0.
5029 do ipr = 1,ngn(ngs(4)+igc)
5030 iprsm = iprsm + 1
5031 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
5032 enddo
5033 ka(jt,jp,igc) = sumk
5034 enddo
5035 enddo
5036 do jp = 13,59
5037 iprsm = 0
5038 do igc = 1,ngc(5)
5039 sumk = 0.
5040 do ipr = 1,ngn(ngs(4)+igc)
5041 iprsm = iprsm + 1
5042 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
5043 enddo
5044 kb(jt,jp,igc) = sumk
5045 enddo
5046 enddo
5047 enddo
5048 !
5049 do jt = 1,10
5050 iprsm = 0
5051 do igc = 1,ngc(5)
5052 sumk = 0.
5053 do ipr = 1,ngn(ngs(4)+igc)
5054 iprsm = iprsm + 1
5055 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
5056 enddo
5057 selfref(jt,igc) = sumk
5058 enddo
5059 enddo
5060 !
5061 do jt = 1,4
5062 iprsm = 0
5063 do igc = 1,ngc(5)
5064 sumk = 0.
5065 do ipr = 1,ngn(ngs(4)+igc)
5066 iprsm = iprsm + 1
5067 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
5068 enddo
5069 forref(jt,igc) = sumk
5070 enddo
5071 enddo
5072 !
5073 iprsm = 0
5074 do igc = 1,ngc(5)
5075 sumf1 = 0.
5076 sumf2 = 0.
5077 do ipr = 1,ngn(ngs(4)+igc)
5078 iprsm = iprsm + 1
5079 sumf1 = sumf1 + sfluxrefo(iprsm)
5080 sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
5081 enddo
5082 sfluxref(igc) = sumf1
5083 absch4(igc) = sumf2
5084 enddo
5085 !
5086 end subroutine cmbgb20
5087 !-------------------------------------------------------------------------------
5088 !
5089 !
5090 !-------------------------------------------------------------------------------
5091 subroutine cmbgb21
5092 !-------------------------------------------------------------------------------
5093 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
5094 !-------------------------------------------------------------------------------
5095 !
5096 use rrsw_kg21_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5097 absa, ka, absb, kb, selfref, forref, sfluxref
5098 !
5099 ! ------- Local -------
5100 !
5101 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5102 real(kind=rb) :: sumk, sumf
5103 !-------------------------------------------------------------------------------
5104 do jn = 1,9
5105 do jt = 1,5
5106 do jp = 1,13
5107 iprsm = 0
5108 do igc = 1,ngc(6)
5109 sumk = 0.
5110 do ipr = 1,ngn(ngs(5)+igc)
5111 iprsm = iprsm + 1
5112 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5113 enddo
5114 ka(jn,jt,jp,igc) = sumk
5115 enddo
5116 enddo
5117 enddo
5118 enddo
5119 !
5120 do jn = 1,5
5121 do jt = 1,5
5122 do jp = 13,59
5123 iprsm = 0
5124 do igc = 1,ngc(6)
5125 sumk = 0.
5126 do ipr = 1,ngn(ngs(5)+igc)
5127 iprsm = iprsm + 1
5128 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5129 enddo
5130 kb(jn,jt,jp,igc) = sumk
5131 enddo
5132 enddo
5133 enddo
5134 enddo
5135 !
5136 do jt = 1,10
5137 iprsm = 0
5138 do igc = 1,ngc(6)
5139 sumk = 0.
5140 do ipr = 1,ngn(ngs(5)+igc)
5141 iprsm = iprsm + 1
5142 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
5143 enddo
5144 selfref(jt,igc) = sumk
5145 enddo
5146 enddo
5147 !
5148 do jt = 1,4
5149 iprsm = 0
5150 do igc = 1,ngc(6)
5151 sumk = 0.
5152 do ipr = 1,ngn(ngs(5)+igc)
5153 iprsm = iprsm + 1
5154 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
5155 enddo
5156 forref(jt,igc) = sumk
5157 enddo
5158 enddo
5159 !
5160 do jp = 1,9
5161 iprsm = 0
5162 do igc = 1,ngc(6)
5163 sumf = 0.
5164 do ipr = 1,ngn(ngs(5)+igc)
5165 iprsm = iprsm + 1
5166 sumf = sumf + sfluxrefo(iprsm,jp)
5167 enddo
5168 sfluxref(igc,jp) = sumf
5169 enddo
5170 enddo
5171 !
5172 end subroutine cmbgb21
5173 !-------------------------------------------------------------------------------
5174 !
5175 !
5176 !-------------------------------------------------------------------------------
5177 subroutine cmbgb22
5178 !-------------------------------------------------------------------------------
5179 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
5180 !-------------------------------------------------------------------------------
5181 !
5182 use rrsw_kg22_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5183 absa, ka, absb, kb, selfref, forref, sfluxref
5184 !
5185 ! ------- Local -------
5186 !
5187 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5188 real(kind=rb) :: sumk, sumf
5189 !-------------------------------------------------------------------------------
5190 do jn = 1,9
5191 do jt = 1,5
5192 do jp = 1,13
5193 iprsm = 0
5194 do igc = 1,ngc(7)
5195 sumk = 0.
5196 do ipr = 1,ngn(ngs(6)+igc)
5197 iprsm = iprsm + 1
5198 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
5199 enddo
5200 ka(jn,jt,jp,igc) = sumk
5201 enddo
5202 enddo
5203 enddo
5204 enddo
5205 !
5206 do jt = 1,5
5207 do jp = 13,59
5208 iprsm = 0
5209 do igc = 1,ngc(7)
5210 sumk = 0.
5211 do ipr = 1,ngn(ngs(6)+igc)
5212 iprsm = iprsm + 1
5213 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
5214 enddo
5215 kb(jt,jp,igc) = sumk
5216 enddo
5217 enddo
5218 enddo
5219 !
5220 do jt = 1,10
5221 iprsm = 0
5222 do igc = 1,ngc(7)
5223 sumk = 0.
5224 do ipr = 1,ngn(ngs(6)+igc)
5225 iprsm = iprsm + 1
5226 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
5227 enddo
5228 selfref(jt,igc) = sumk
5229 enddo
5230 enddo
5231 !
5232 do jt = 1,3
5233 iprsm = 0
5234 do igc = 1,ngc(7)
5235 sumk = 0.
5236 do ipr = 1,ngn(ngs(6)+igc)
5237 iprsm = iprsm + 1
5238 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
5239 enddo
5240 forref(jt,igc) = sumk
5241 enddo
5242 enddo
5243 !
5244 do jp = 1,9
5245 iprsm = 0
5246 do igc = 1,ngc(7)
5247 sumf = 0.
5248 do ipr = 1,ngn(ngs(6)+igc)
5249 iprsm = iprsm + 1
5250 sumf = sumf + sfluxrefo(iprsm,jp)
5251 enddo
5252 sfluxref(igc,jp) = sumf
5253 enddo
5254 enddo
5255 !
5256 end subroutine cmbgb22
5257 !-------------------------------------------------------------------------------
5258 !
5259 !
5260 !-------------------------------------------------------------------------------
5261 subroutine cmbgb23
5262 !-------------------------------------------------------------------------------
5263 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
5264 !-------------------------------------------------------------------------------
5265 !
5266 use rrsw_kg23_k, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
5267 absa, ka, selfref, forref, sfluxref, rayl
5268 !
5269 ! ------- Local -------
5270 !
5271 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5272 real(kind=rb) :: sumk, sumf1, sumf2
5273 !-------------------------------------------------------------------------------
5274 do jt = 1,5
5275 do jp = 1,13
5276 iprsm = 0
5277 do igc = 1,ngc(8)
5278 sumk = 0.
5279 do ipr = 1,ngn(ngs(7)+igc)
5280 iprsm = iprsm + 1
5281 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
5282 enddo
5283 ka(jt,jp,igc) = sumk
5284 enddo
5285 enddo
5286 enddo
5287 !
5288 do jt = 1,10
5289 iprsm = 0
5290 do igc = 1,ngc(8)
5291 sumk = 0.
5292 do ipr = 1,ngn(ngs(7)+igc)
5293 iprsm = iprsm + 1
5294 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
5295 enddo
5296 selfref(jt,igc) = sumk
5297 enddo
5298 enddo
5299 !
5300 do jt = 1,3
5301 iprsm = 0
5302 do igc = 1,ngc(8)
5303 sumk = 0.
5304 do ipr = 1,ngn(ngs(7)+igc)
5305 iprsm = iprsm + 1
5306 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
5307 enddo
5308 forref(jt,igc) = sumk
5309 enddo
5310 enddo
5311 !
5312 iprsm = 0
5313 do igc = 1,ngc(8)
5314 sumf1 = 0.
5315 sumf2 = 0.
5316 do ipr = 1,ngn(ngs(7)+igc)
5317 iprsm = iprsm + 1
5318 sumf1 = sumf1 + sfluxrefo(iprsm)
5319 sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
5320 enddo
5321 sfluxref(igc) = sumf1
5322 rayl(igc) = sumf2
5323 enddo
5324 !
5325 end subroutine cmbgb23
5326 !-------------------------------------------------------------------------------
5327 !
5328 !
5329 !-------------------------------------------------------------------------------
5330 subroutine cmbgb24
5331 !-------------------------------------------------------------------------------
5332 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
5333 !-------------------------------------------------------------------------------
5334 !
5335 use rrsw_kg24_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5336 abso3ao, abso3bo, raylao, raylbo, &
5337 absa, ka, absb, kb, selfref, forref, sfluxref, &
5338 abso3a, abso3b, rayla, raylb
5339 !
5340 ! ------- Local -------
5341 !
5342 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5343 real(kind=rb) :: sumk, sumf1, sumf2, sumf3
5344 !-------------------------------------------------------------------------------
5345 do jn = 1,9
5346 do jt = 1,5
5347 do jp = 1,13
5348 iprsm = 0
5349 do igc = 1,ngc(9)
5350 sumk = 0.
5351 do ipr = 1,ngn(ngs(8)+igc)
5352 iprsm = iprsm + 1
5353 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
5354 enddo
5355 ka(jn,jt,jp,igc) = sumk
5356 enddo
5357 enddo
5358 enddo
5359 enddo
5360 !
5361 do jt = 1,5
5362 do jp = 13,59
5363 iprsm = 0
5364 do igc = 1,ngc(9)
5365 sumk = 0.
5366 do ipr = 1,ngn(ngs(8)+igc)
5367 iprsm = iprsm + 1
5368 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
5369 enddo
5370 kb(jt,jp,igc) = sumk
5371 enddo
5372 enddo
5373 enddo
5374 !
5375 do jt = 1,10
5376 iprsm = 0
5377 do igc = 1,ngc(9)
5378 sumk = 0.
5379 do ipr = 1,ngn(ngs(8)+igc)
5380 iprsm = iprsm + 1
5381 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
5382 enddo
5383 selfref(jt,igc) = sumk
5384 enddo
5385 enddo
5386 !
5387 do jt = 1,3
5388 iprsm = 0
5389 do igc = 1,ngc(9)
5390 sumk = 0.
5391 do ipr = 1,ngn(ngs(8)+igc)
5392 iprsm = iprsm + 1
5393 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
5394 enddo
5395 forref(jt,igc) = sumk
5396 enddo
5397 enddo
5398 !
5399 iprsm = 0
5400 do igc = 1,ngc(9)
5401 sumf1 = 0.
5402 sumf2 = 0.
5403 sumf3 = 0.
5404 do ipr = 1,ngn(ngs(8)+igc)
5405 iprsm = iprsm + 1
5406 sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
5407 sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
5408 sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
5409 enddo
5410 raylb(igc) = sumf1
5411 abso3a(igc) = sumf2
5412 abso3b(igc) = sumf3
5413 enddo
5414 !
5415 do jp = 1,9
5416 iprsm = 0
5417 do igc = 1,ngc(9)
5418 sumf1 = 0.
5419 sumf2 = 0.
5420 do ipr = 1,ngn(ngs(8)+igc)
5421 iprsm = iprsm + 1
5422 sumf1 = sumf1 + sfluxrefo(iprsm,jp)
5423 sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
5424 enddo
5425 sfluxref(igc,jp) = sumf1
5426 rayla(igc,jp) = sumf2
5427 enddo
5428 enddo
5429 !
5430 end subroutine cmbgb24
5431 !-------------------------------------------------------------------------------
5432 !
5433 !
5434 !-------------------------------------------------------------------------------
5435 subroutine cmbgb25
5436 !-------------------------------------------------------------------------------
5437 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
5438 !-------------------------------------------------------------------------------
5439 !
5440 use rrsw_kg25_k, only : kao, sfluxrefo, &
5441 abso3ao, abso3bo, raylo, &
5442 absa, ka, sfluxref, &
5443 abso3a, abso3b, rayl
5444 !
5445 ! ------- Local -------
5446 !
5447 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5448 real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4
5449 !-------------------------------------------------------------------------------
5450 do jt = 1,5
5451 do jp = 1,13
5452 iprsm = 0
5453 do igc = 1,ngc(10)
5454 sumk = 0.
5455 do ipr = 1,ngn(ngs(9)+igc)
5456 iprsm = iprsm + 1
5457 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
5458 enddo
5459 ka(jt,jp,igc) = sumk
5460 enddo
5461 enddo
5462 enddo
5463 !
5464 iprsm = 0
5465 do igc = 1,ngc(10)
5466 sumf1 = 0.
5467 sumf2 = 0.
5468 sumf3 = 0.
5469 sumf4 = 0.
5470 do ipr = 1,ngn(ngs(9)+igc)
5471 iprsm = iprsm + 1
5472 sumf1 = sumf1 + sfluxrefo(iprsm)
5473 sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
5474 sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
5475 sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
5476 enddo
5477 sfluxref(igc) = sumf1
5478 abso3a(igc) = sumf2
5479 abso3b(igc) = sumf3
5480 rayl(igc) = sumf4
5481 enddo
5482 !
5483 end subroutine cmbgb25
5484 !-------------------------------------------------------------------------------
5485 !
5486 !
5487 !-------------------------------------------------------------------------------
5488 subroutine cmbgb26
5489 !-------------------------------------------------------------------------------
5490 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
5491 !-------------------------------------------------------------------------------
5492 !
5493 use rrsw_kg26_k, only : sfluxrefo, raylo, sfluxref, rayl
5494 !
5495 ! ------- Local -------
5496 !
5497 integer(kind=im) :: igc, ipr, iprsm
5498 real(kind=rb) :: sumf1, sumf2
5499 !-------------------------------------------------------------------------------
5500 iprsm = 0
5501 do igc = 1,ngc(11)
5502 sumf1 = 0.
5503 sumf2 = 0.
5504 do ipr = 1,ngn(ngs(10)+igc)
5505 iprsm = iprsm + 1
5506 sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
5507 sumf2 = sumf2 + sfluxrefo(iprsm)
5508 enddo
5509 rayl(igc) = sumf1
5510 sfluxref(igc) = sumf2
5511 enddo
5512 !
5513 end subroutine cmbgb26
5514 !-------------------------------------------------------------------------------
5515 !
5516 !
5517 !-------------------------------------------------------------------------------
5518 subroutine cmbgb27
5519 !-------------------------------------------------------------------------------
5520 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
5521 !-------------------------------------------------------------------------------
5522 !
5523 use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo, &
5524 absa, ka, absb, kb, sfluxref, rayl
5525 !
5526 ! ------- Local -------
5527 !
5528 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5529 real(kind=rb) :: sumk, sumf1, sumf2
5530 !-------------------------------------------------------------------------------
5531 do jt = 1,5
5532 do jp = 1,13
5533 iprsm = 0
5534 do igc = 1,ngc(12)
5535 sumk = 0.
5536 do ipr = 1,ngn(ngs(11)+igc)
5537 iprsm = iprsm + 1
5538 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
5539 enddo
5540 ka(jt,jp,igc) = sumk
5541 enddo
5542 enddo
5543 do jp = 13,59
5544 iprsm = 0
5545 do igc = 1,ngc(12)
5546 sumk = 0.
5547 do ipr = 1,ngn(ngs(11)+igc)
5548 iprsm = iprsm + 1
5549 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
5550 enddo
5551 kb(jt,jp,igc) = sumk
5552 enddo
5553 enddo
5554 enddo
5555 !
5556 iprsm = 0
5557 do igc = 1,ngc(12)
5558 sumf1 = 0.
5559 sumf2 = 0.
5560 do ipr = 1,ngn(ngs(11)+igc)
5561 iprsm = iprsm + 1
5562 sumf1 = sumf1 + sfluxrefo(iprsm)
5563 sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
5564 enddo
5565 sfluxref(igc) = sumf1
5566 rayl(igc) = sumf2
5567 enddo
5568 !
5569 end subroutine cmbgb27
5570 !-------------------------------------------------------------------------------
5571 !
5572 !
5573 !-------------------------------------------------------------------------------
5574 subroutine cmbgb28
5575 !-------------------------------------------------------------------------------
5576 ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
5577 !-------------------------------------------------------------------------------
5578 !
5579 use rrsw_kg28_k, only : kao, kbo, sfluxrefo, &
5580 absa, ka, absb, kb, sfluxref
5581 !
5582 ! ------- Local -------
5583 !
5584 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5585 real(kind=rb) :: sumk, sumf
5586 !-------------------------------------------------------------------------------
5587 do jn = 1,9
5588 do jt = 1,5
5589 do jp = 1,13
5590 iprsm = 0
5591 do igc = 1,ngc(13)
5592 sumk = 0.
5593 do ipr = 1,ngn(ngs(12)+igc)
5594 iprsm = iprsm + 1
5595 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
5596 enddo
5597 ka(jn,jt,jp,igc) = sumk
5598 enddo
5599 enddo
5600 enddo
5601 enddo
5602 !
5603 do jn = 1,5
5604 do jt = 1,5
5605 do jp = 13,59
5606 iprsm = 0
5607 do igc = 1,ngc(13)
5608 sumk = 0.
5609 do ipr = 1,ngn(ngs(12)+igc)
5610 iprsm = iprsm + 1
5611 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
5612 enddo
5613 kb(jn,jt,jp,igc) = sumk
5614 enddo
5615 enddo
5616 enddo
5617 enddo
5618 !
5619 do jp = 1,5
5620 iprsm = 0
5621 do igc = 1,ngc(13)
5622 sumf = 0.
5623 do ipr = 1,ngn(ngs(12)+igc)
5624 iprsm = iprsm + 1
5625 sumf = sumf + sfluxrefo(iprsm,jp)
5626 enddo
5627 sfluxref(igc,jp) = sumf
5628 enddo
5629 enddo
5630 !
5631 end subroutine cmbgb28
5632 !-------------------------------------------------------------------------------
5633 !
5634 !
5635 !-------------------------------------------------------------------------------
5636 subroutine cmbgb29
5637 !-------------------------------------------------------------------------------
5638 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
5639 !-------------------------------------------------------------------------------
5640 !
5641 use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5642 absh2oo, absco2o, &
5643 absa, ka, absb, kb, selfref, forref, sfluxref, &
5644 absh2o, absco2
5645 !
5646 ! ------- Local -------
5647 !
5648 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5649 real(kind=rb) :: sumk, sumf1, sumf2, sumf3
5650 !-------------------------------------------------------------------------------
5651 do jt = 1,5
5652 do jp = 1,13
5653 iprsm = 0
5654 do igc = 1,ngc(14)
5655 sumk = 0.
5656 do ipr = 1,ngn(ngs(13)+igc)
5657 iprsm = iprsm + 1
5658 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
5659 enddo
5660 ka(jt,jp,igc) = sumk
5661 enddo
5662 enddo
5663 do jp = 13,59
5664 iprsm = 0
5665 do igc = 1,ngc(14)
5666 sumk = 0.
5667 do ipr = 1,ngn(ngs(13)+igc)
5668 iprsm = iprsm + 1
5669 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
5670 enddo
5671 kb(jt,jp,igc) = sumk
5672 enddo
5673 enddo
5674 enddo
5675 !
5676 do jt = 1,10
5677 iprsm = 0
5678 do igc = 1,ngc(14)
5679 sumk = 0.
5680 do ipr = 1,ngn(ngs(13)+igc)
5681 iprsm = iprsm + 1
5682 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
5683 enddo
5684 selfref(jt,igc) = sumk
5685 enddo
5686 enddo
5687 !
5688 do jt = 1,4
5689 iprsm = 0
5690 do igc = 1,ngc(14)
5691 sumk = 0.
5692 do ipr = 1,ngn(ngs(13)+igc)
5693 iprsm = iprsm + 1
5694 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
5695 enddo
5696 forref(jt,igc) = sumk
5697 enddo
5698 enddo
5699 !
5700 iprsm = 0
5701 do igc = 1,ngc(14)
5702 sumf1 = 0.
5703 sumf2 = 0.
5704 sumf3 = 0.
5705 do ipr = 1,ngn(ngs(13)+igc)
5706 iprsm = iprsm + 1
5707 sumf1 = sumf1 + sfluxrefo(iprsm)
5708 sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
5709 sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
5710 enddo
5711 sfluxref(igc) = sumf1
5712 absco2(igc) = sumf2
5713 absh2o(igc) = sumf3
5714 enddo
5715 !
5716 end subroutine cmbgb29
5717 !-------------------------------------------------------------------------------
5718 !
5719 !
5720 !-------------------------------------------------------------------------------
5721 subroutine swcldpr
5722 !-------------------------------------------------------------------------------
5723 !
5724 ! abstract:
5725 ! Define cloud extinction coefficient, single scattering albedo
5726 ! and asymmetry parameter data.
5727 !
5728 ! history log :
5729 !
5730 !-------------------------------------------------------------------------------
5731 !
5732 ! Explanation of the method for each value of INFLAG. A value of
5733 ! 0 for INFLAG do not distingish being liquid and ice clouds.
5734 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
5735 ! requires further user input to specify the method to be used to
5736 ! compute the aborption due to each.
5737 ! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical
5738 ! depth, the cloud single-scattering albedo, and the
5739 ! moments of the phase function (0:NSTREAM). Note
5740 ! that these values are delta-m scaled within this
5741 ! subroutine.
5742 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
5743 ! water path (g/m2), and cloud ice fraction are input.
5744 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
5745 ! optical properties due to ice clouds are computed from
5746 ! the optical properties stored in the RT code, STREAMER v3.0
5747 ! (Reference: Key. J., Streamer User's Guide, Cooperative
5748 ! Institute for Meteorological Satellite Studies, 2001, 96 pp.).
5749 ! Valid range of values for re are between 5.0 and
5750 ! 131.0 micron.
5751 ! This version uses Ebert and Curry, JGR, (1992) method for
5752 ! ice particles larger than 131.0 microns.
5753 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
5754 ! and the optical depths, single-scattering albedo,
5755 ! and phase function moments are calculated as in
5756 ! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
5757 ! tables which were appropriately averaged for the
5758 ! bands in RRTM_SW. Linear interpolation is used to
5759 ! get the coefficients from the stored tables.
5760 ! Valid range of values for dge are between 5.0 and
5761 ! 140.0 micron.
5762 ! This version uses Ebert and Curry, JGR, (1992) method for
5763 ! ice particles larger than 140.0 microns.
5764 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
5765 ! and the optical depths due to water clouds are computed
5766 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
5767 ! The values for absorption coefficients appropriate for
5768 ! the spectral bands in RRTM have been obtained for a
5769 ! range of effective radii by an averaging procedure
5770 ! based on the work of J. Pinto (private communication).
5771 ! Linear interpolation is used to get the absorption
5772 ! coefficients for the input effective radius.
5773 !
5774 ! ------------------------------------------------------------------
5775 !
5776 use rrsw_cld_k, only : extliq1, ssaliq1, asyliq1, &
5777 extice2, ssaice2, asyice2, &
5778 extice3, ssaice3, asyice3, fdlice3, &
5779 abari, bbari, cbari, dbari, ebari, fbari
5780 !
5781 save
5782 ! Everything below is for INFLAG = 2.
5783 !
5784 ! Coefficients for Ebert and Curry method
5785 !
5786 abari(:) = (/ &
5787 3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /)
5788 bbari(:) = (/ &
5789 2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /)
5790 cbari(:) = (/ &
5791 1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /)
5792 dbari(:) = (/ &
5793 0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /)
5794 ebari(:) = (/ &
5795 7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /)
5796 fbari(:) = (/ &
5797 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /)
5798 !
5799 ! Extinction coefficient
5800 !
5801 extliq1(:, 16) = (/ &
5802 8.981463e-01_rb,6.317895e-01_rb,4.557508e-01_rb,3.481624e-01_rb, &
5803 2.797950e-01_rb,2.342753e-01_rb,2.026934e-01_rb,1.800102e-01_rb, &
5804 1.632408e-01_rb,1.505384e-01_rb,1.354524e-01_rb,1.246520e-01_rb, &
5805 1.154342e-01_rb,1.074756e-01_rb,1.005353e-01_rb,9.442987e-02_rb, &
5806 8.901760e-02_rb,8.418693e-02_rb,7.984904e-02_rb,7.593229e-02_rb, &
5807 7.237827e-02_rb,6.913887e-02_rb,6.617415e-02_rb,6.345061e-02_rb, &
5808 6.094001e-02_rb,5.861834e-02_rb,5.646506e-02_rb,5.446250e-02_rb, &
5809 5.249596e-02_rb,5.081114e-02_rb,4.922243e-02_rb,4.772189e-02_rb, &
5810 4.630243e-02_rb,4.495766e-02_rb,4.368189e-02_rb,4.246995e-02_rb, &
5811 4.131720e-02_rb,4.021941e-02_rb,3.917276e-02_rb,3.817376e-02_rb, &
5812 3.721926e-02_rb,3.630635e-02_rb,3.543237e-02_rb,3.459491e-02_rb, &
5813 3.379171e-02_rb,3.302073e-02_rb,3.228007e-02_rb,3.156798e-02_rb, &
5814 3.088284e-02_rb,3.022315e-02_rb,2.958753e-02_rb,2.897468e-02_rb, &
5815 2.838340e-02_rb,2.781258e-02_rb,2.726117e-02_rb,2.672821e-02_rb, &
5816 2.621278e-02_rb,2.5714e-02_rb /)
5817 extliq1(:, 17) = (/ &
5818 8.293797e-01_rb,6.048371e-01_rb,4.465706e-01_rb,3.460387e-01_rb, &
5819 2.800064e-01_rb,2.346584e-01_rb,2.022399e-01_rb,1.782626e-01_rb, &
5820 1.600153e-01_rb,1.457903e-01_rb,1.334061e-01_rb,1.228548e-01_rb, &
5821 1.138396e-01_rb,1.060486e-01_rb,9.924856e-02_rb,9.326208e-02_rb, &
5822 8.795158e-02_rb,8.320883e-02_rb,7.894750e-02_rb,7.509792e-02_rb, &
5823 7.160323e-02_rb,6.841653e-02_rb,6.549889e-02_rb,6.281763e-02_rb, &
5824 6.034516e-02_rb,5.805802e-02_rb,5.593615e-02_rb,5.396226e-02_rb, &
5825 5.202302e-02_rb,5.036246e-02_rb,4.879606e-02_rb,4.731610e-02_rb, &
5826 4.591565e-02_rb,4.458852e-02_rb,4.332912e-02_rb,4.213243e-02_rb, &
5827 4.099390e-02_rb,3.990941e-02_rb,3.887522e-02_rb,3.788792e-02_rb, &
5828 3.694440e-02_rb,3.604183e-02_rb,3.517760e-02_rb,3.434934e-02_rb, &
5829 3.355485e-02_rb,3.279211e-02_rb,3.205925e-02_rb,3.135458e-02_rb, &
5830 3.067648e-02_rb,3.002349e-02_rb,2.939425e-02_rb,2.878748e-02_rb, &
5831 2.820200e-02_rb,2.763673e-02_rb,2.709062e-02_rb,2.656272e-02_rb, &
5832 2.605214e-02_rb,2.5558e-02_rb /)
5833 extliq1(:, 18) = (/ &
5834 9.193685e-01_rb,6.128292e-01_rb,4.344150e-01_rb,3.303048e-01_rb, &
5835 2.659500e-01_rb,2.239727e-01_rb,1.953457e-01_rb,1.751012e-01_rb, &
5836 1.603515e-01_rb,1.493360e-01_rb,1.323791e-01_rb,1.219335e-01_rb, &
5837 1.130076e-01_rb,1.052926e-01_rb,9.855839e-02_rb,9.262925e-02_rb, &
5838 8.736918e-02_rb,8.267112e-02_rb,7.844965e-02_rb,7.463585e-02_rb, &
5839 7.117343e-02_rb,6.801601e-02_rb,6.512503e-02_rb,6.246815e-02_rb, &
5840 6.001806e-02_rb,5.775154e-02_rb,5.564872e-02_rb,5.369250e-02_rb, &
5841 5.176284e-02_rb,5.011536e-02_rb,4.856099e-02_rb,4.709211e-02_rb, &
5842 4.570193e-02_rb,4.438430e-02_rb,4.313375e-02_rb,4.194529e-02_rb, &
5843 4.081443e-02_rb,3.973712e-02_rb,3.870966e-02_rb,3.772866e-02_rb, &
5844 3.679108e-02_rb,3.589409e-02_rb,3.503514e-02_rb,3.421185e-02_rb, &
5845 3.342206e-02_rb,3.266377e-02_rb,3.193513e-02_rb,3.123447e-02_rb, &
5846 3.056018e-02_rb,2.991081e-02_rb,2.928502e-02_rb,2.868154e-02_rb, &
5847 2.809920e-02_rb,2.753692e-02_rb,2.699367e-02_rb,2.646852e-02_rb, &
5848 2.596057e-02_rb,2.5469e-02_rb /)
5849 extliq1(:, 19) = (/ &
5850 9.136931e-01_rb,5.743244e-01_rb,4.080708e-01_rb,3.150572e-01_rb, &
5851 2.577261e-01_rb,2.197900e-01_rb,1.933037e-01_rb,1.740212e-01_rb, &
5852 1.595056e-01_rb,1.482756e-01_rb,1.312164e-01_rb,1.209246e-01_rb, &
5853 1.121227e-01_rb,1.045095e-01_rb,9.785967e-02_rb,9.200149e-02_rb, &
5854 8.680170e-02_rb,8.215531e-02_rb,7.797850e-02_rb,7.420361e-02_rb, &
5855 7.077530e-02_rb,6.764798e-02_rb,6.478369e-02_rb,6.215063e-02_rb, &
5856 5.972189e-02_rb,5.747458e-02_rb,5.538913e-02_rb,5.344866e-02_rb, &
5857 5.153216e-02_rb,4.989745e-02_rb,4.835476e-02_rb,4.689661e-02_rb, &
5858 4.551629e-02_rb,4.420777e-02_rb,4.296563e-02_rb,4.178497e-02_rb, &
5859 4.066137e-02_rb,3.959081e-02_rb,3.856963e-02_rb,3.759452e-02_rb, &
5860 3.666244e-02_rb,3.577061e-02_rb,3.491650e-02_rb,3.409777e-02_rb, &
5861 3.331227e-02_rb,3.255803e-02_rb,3.183322e-02_rb,3.113617e-02_rb, &
5862 3.046530e-02_rb,2.981918e-02_rb,2.919646e-02_rb,2.859591e-02_rb, &
5863 2.801635e-02_rb,2.745671e-02_rb,2.691599e-02_rb,2.639324e-02_rb, &
5864 2.588759e-02_rb,2.5398e-02_rb /)
5865 extliq1(:, 20) = (/ &
5866 8.447548e-01_rb,5.326840e-01_rb,3.921523e-01_rb,3.119082e-01_rb, &
5867 2.597055e-01_rb,2.228737e-01_rb,1.954157e-01_rb,1.741155e-01_rb, &
5868 1.570881e-01_rb,1.431520e-01_rb,1.302034e-01_rb,1.200491e-01_rb, &
5869 1.113571e-01_rb,1.038330e-01_rb,9.725657e-02_rb,9.145949e-02_rb, &
5870 8.631112e-02_rb,8.170840e-02_rb,7.756901e-02_rb,7.382641e-02_rb, &
5871 7.042616e-02_rb,6.732338e-02_rb,6.448069e-02_rb,6.186672e-02_rb, &
5872 5.945494e-02_rb,5.722277e-02_rb,5.515089e-02_rb,5.322262e-02_rb, &
5873 5.132153e-02_rb,4.969799e-02_rb,4.816556e-02_rb,4.671686e-02_rb, &
5874 4.534525e-02_rb,4.404480e-02_rb,4.281014e-02_rb,4.163643e-02_rb, &
5875 4.051930e-02_rb,3.945479e-02_rb,3.843927e-02_rb,3.746945e-02_rb, &
5876 3.654234e-02_rb,3.565518e-02_rb,3.480547e-02_rb,3.399088e-02_rb, &
5877 3.320930e-02_rb,3.245876e-02_rb,3.173745e-02_rb,3.104371e-02_rb, &
5878 3.037600e-02_rb,2.973287e-02_rb,2.911300e-02_rb,2.851516e-02_rb, &
5879 2.793818e-02_rb,2.738101e-02_rb,2.684264e-02_rb,2.632214e-02_rb, &
5880 2.581863e-02_rb,2.5331e-02_rb /)
5881 extliq1(:, 21) = (/ &
5882 7.727642e-01_rb,5.034865e-01_rb,3.808673e-01_rb,3.080333e-01_rb, &
5883 2.586453e-01_rb,2.224989e-01_rb,1.947060e-01_rb,1.725821e-01_rb, &
5884 1.545096e-01_rb,1.394456e-01_rb,1.288683e-01_rb,1.188852e-01_rb, &
5885 1.103317e-01_rb,1.029214e-01_rb,9.643967e-02_rb,9.072239e-02_rb, &
5886 8.564194e-02_rb,8.109758e-02_rb,7.700875e-02_rb,7.331026e-02_rb, &
5887 6.994879e-02_rb,6.688028e-02_rb,6.406807e-02_rb,6.148133e-02_rb, &
5888 5.909400e-02_rb,5.688388e-02_rb,5.483197e-02_rb,5.292185e-02_rb, &
5889 5.103763e-02_rb,4.942905e-02_rb,4.791039e-02_rb,4.647438e-02_rb, &
5890 4.511453e-02_rb,4.382497e-02_rb,4.260043e-02_rb,4.143616e-02_rb, &
5891 4.032784e-02_rb,3.927155e-02_rb,3.826375e-02_rb,3.730117e-02_rb, &
5892 3.638087e-02_rb,3.550013e-02_rb,3.465646e-02_rb,3.384759e-02_rb, &
5893 3.307141e-02_rb,3.232598e-02_rb,3.160953e-02_rb,3.092040e-02_rb, &
5894 3.025706e-02_rb,2.961810e-02_rb,2.900220e-02_rb,2.840814e-02_rb, &
5895 2.783478e-02_rb,2.728106e-02_rb,2.674599e-02_rb,2.622864e-02_rb, &
5896 2.572816e-02_rb,2.5244e-02_rb /)
5897 extliq1(:, 22) = (/ &
5898 7.416833e-01_rb,4.959591e-01_rb,3.775057e-01_rb,3.056353e-01_rb, &
5899 2.565943e-01_rb,2.206935e-01_rb,1.931479e-01_rb,1.712860e-01_rb, &
5900 1.534837e-01_rb,1.386906e-01_rb,1.281198e-01_rb,1.182344e-01_rb, &
5901 1.097595e-01_rb,1.024137e-01_rb,9.598552e-02_rb,9.031320e-02_rb, &
5902 8.527093e-02_rb,8.075927e-02_rb,7.669869e-02_rb,7.302481e-02_rb, &
5903 6.968491e-02_rb,6.663542e-02_rb,6.384008e-02_rb,6.126838e-02_rb, &
5904 5.889452e-02_rb,5.669654e-02_rb,5.465558e-02_rb,5.275540e-02_rb, &
5905 5.087937e-02_rb,4.927904e-02_rb,4.776796e-02_rb,4.633895e-02_rb, &
5906 4.498557e-02_rb,4.370202e-02_rb,4.248306e-02_rb,4.132399e-02_rb, &
5907 4.022052e-02_rb,3.916878e-02_rb,3.816523e-02_rb,3.720665e-02_rb, &
5908 3.629011e-02_rb,3.541290e-02_rb,3.457257e-02_rb,3.376685e-02_rb, &
5909 3.299365e-02_rb,3.225105e-02_rb,3.153728e-02_rb,3.085069e-02_rb, &
5910 3.018977e-02_rb,2.955310e-02_rb,2.893940e-02_rb,2.834742e-02_rb, &
5911 2.777606e-02_rb,2.722424e-02_rb,2.669099e-02_rb,2.617539e-02_rb, &
5912 2.567658e-02_rb,2.5194e-02_rb /)
5913 extliq1(:, 23) = (/ &
5914 7.058580e-01_rb,4.866573e-01_rb,3.712238e-01_rb,2.998638e-01_rb, &
5915 2.513441e-01_rb,2.161972e-01_rb,1.895576e-01_rb,1.686669e-01_rb, &
5916 1.518437e-01_rb,1.380046e-01_rb,1.267564e-01_rb,1.170399e-01_rb, &
5917 1.087026e-01_rb,1.014704e-01_rb,9.513729e-02_rb,8.954555e-02_rb, &
5918 8.457221e-02_rb,8.012009e-02_rb,7.611136e-02_rb,7.248294e-02_rb, &
5919 6.918317e-02_rb,6.616934e-02_rb,6.340584e-02_rb,6.086273e-02_rb, &
5920 5.851465e-02_rb,5.634001e-02_rb,5.432027e-02_rb,5.243946e-02_rb, &
5921 5.058070e-02_rb,4.899628e-02_rb,4.749975e-02_rb,4.608411e-02_rb, &
5922 4.474303e-02_rb,4.347082e-02_rb,4.226237e-02_rb,4.111303e-02_rb, &
5923 4.001861e-02_rb,3.897528e-02_rb,3.797959e-02_rb,3.702835e-02_rb, &
5924 3.611867e-02_rb,3.524791e-02_rb,3.441364e-02_rb,3.361360e-02_rb, &
5925 3.284577e-02_rb,3.210823e-02_rb,3.139923e-02_rb,3.071716e-02_rb, &
5926 3.006052e-02_rb,2.942791e-02_rb,2.881806e-02_rb,2.822974e-02_rb, &
5927 2.766185e-02_rb,2.711335e-02_rb,2.658326e-02_rb,2.607066e-02_rb, &
5928 2.557473e-02_rb,2.5095e-02_rb /)
5929 extliq1(:, 24) = (/ &
5930 6.822779e-01_rb,4.750373e-01_rb,3.634834e-01_rb,2.940726e-01_rb, &
5931 2.468060e-01_rb,2.125768e-01_rb,1.866586e-01_rb,1.663588e-01_rb, &
5932 1.500326e-01_rb,1.366192e-01_rb,1.253472e-01_rb,1.158052e-01_rb, &
5933 1.076101e-01_rb,1.004954e-01_rb,9.426089e-02_rb,8.875268e-02_rb, &
5934 8.385090e-02_rb,7.946063e-02_rb,7.550578e-02_rb,7.192466e-02_rb, &
5935 6.866669e-02_rb,6.569001e-02_rb,6.295971e-02_rb,6.044642e-02_rb, &
5936 5.812526e-02_rb,5.597500e-02_rb,5.397746e-02_rb,5.211690e-02_rb, &
5937 5.027505e-02_rb,4.870703e-02_rb,4.722555e-02_rb,4.582373e-02_rb, &
5938 4.449540e-02_rb,4.323497e-02_rb,4.203742e-02_rb,4.089821e-02_rb, &
5939 3.981321e-02_rb,3.877867e-02_rb,3.779118e-02_rb,3.684762e-02_rb, &
5940 3.594514e-02_rb,3.508114e-02_rb,3.425322e-02_rb,3.345917e-02_rb, &
5941 3.269698e-02_rb,3.196477e-02_rb,3.126082e-02_rb,3.058352e-02_rb, &
5942 2.993141e-02_rb,2.930310e-02_rb,2.869732e-02_rb,2.811289e-02_rb, &
5943 2.754869e-02_rb,2.700371e-02_rb,2.647698e-02_rb,2.596760e-02_rb, &
5944 2.547473e-02_rb,2.4998e-02_rb /)
5945 extliq1(:, 25) = (/ &
5946 6.666233e-01_rb,4.662044e-01_rb,3.579517e-01_rb,2.902984e-01_rb, &
5947 2.440475e-01_rb,2.104431e-01_rb,1.849277e-01_rb,1.648970e-01_rb, &
5948 1.487555e-01_rb,1.354714e-01_rb,1.244173e-01_rb,1.149913e-01_rb, &
5949 1.068903e-01_rb,9.985323e-02_rb,9.368351e-02_rb,8.823009e-02_rb, &
5950 8.337507e-02_rb,7.902511e-02_rb,7.510529e-02_rb,7.155482e-02_rb, &
5951 6.832386e-02_rb,6.537113e-02_rb,6.266218e-02_rb,6.016802e-02_rb, &
5952 5.786408e-02_rb,5.572939e-02_rb,5.374598e-02_rb,5.189830e-02_rb, &
5953 5.006825e-02_rb,4.851081e-02_rb,4.703906e-02_rb,4.564623e-02_rb, &
5954 4.432621e-02_rb,4.307349e-02_rb,4.188312e-02_rb,4.075060e-02_rb, &
5955 3.967183e-02_rb,3.864313e-02_rb,3.766111e-02_rb,3.672269e-02_rb, &
5956 3.582505e-02_rb,3.496559e-02_rb,3.414196e-02_rb,3.335198e-02_rb, &
5957 3.259362e-02_rb,3.186505e-02_rb,3.116454e-02_rb,3.049052e-02_rb, &
5958 2.984152e-02_rb,2.921617e-02_rb,2.861322e-02_rb,2.803148e-02_rb, &
5959 2.746986e-02_rb,2.692733e-02_rb,2.640295e-02_rb,2.589582e-02_rb, &
5960 2.540510e-02_rb,2.4930e-02_rb /)
5961 extliq1(:, 26) = (/ &
5962 6.535669e-01_rb,4.585865e-01_rb,3.529226e-01_rb,2.867245e-01_rb, &
5963 2.413848e-01_rb,2.083956e-01_rb,1.833191e-01_rb,1.636150e-01_rb, &
5964 1.477247e-01_rb,1.346392e-01_rb,1.236449e-01_rb,1.143095e-01_rb, &
5965 1.062828e-01_rb,9.930773e-02_rb,9.319029e-02_rb,8.778150e-02_rb, &
5966 8.296497e-02_rb,7.864847e-02_rb,7.475799e-02_rb,7.123343e-02_rb, &
5967 6.802549e-02_rb,6.509332e-02_rb,6.240285e-02_rb,5.992538e-02_rb, &
5968 5.763657e-02_rb,5.551566e-02_rb,5.354483e-02_rb,5.170870e-02_rb, &
5969 4.988866e-02_rb,4.834061e-02_rb,4.687751e-02_rb,4.549264e-02_rb, &
5970 4.417999e-02_rb,4.293410e-02_rb,4.175006e-02_rb,4.062344e-02_rb, &
5971 3.955019e-02_rb,3.852663e-02_rb,3.754943e-02_rb,3.661553e-02_rb, &
5972 3.572214e-02_rb,3.486669e-02_rb,3.404683e-02_rb,3.326040e-02_rb, &
5973 3.250542e-02_rb,3.178003e-02_rb,3.108254e-02_rb,3.041139e-02_rb, &
5974 2.976511e-02_rb,2.914235e-02_rb,2.854187e-02_rb,2.796247e-02_rb, &
5975 2.740309e-02_rb,2.686271e-02_rb,2.634038e-02_rb,2.583520e-02_rb, &
5976 2.534636e-02_rb,2.4873e-02_rb /)
5977 extliq1(:, 27) = (/ &
5978 6.448790e-01_rb,4.541425e-01_rb,3.503348e-01_rb,2.850494e-01_rb, &
5979 2.401966e-01_rb,2.074811e-01_rb,1.825631e-01_rb,1.629515e-01_rb, &
5980 1.471142e-01_rb,1.340574e-01_rb,1.231462e-01_rb,1.138628e-01_rb, &
5981 1.058802e-01_rb,9.894286e-02_rb,9.285818e-02_rb,8.747802e-02_rb, &
5982 8.268676e-02_rb,7.839271e-02_rb,7.452230e-02_rb,7.101580e-02_rb, &
5983 6.782418e-02_rb,6.490685e-02_rb,6.222991e-02_rb,5.976484e-02_rb, &
5984 5.748742e-02_rb,5.537703e-02_rb,5.341593e-02_rb,5.158883e-02_rb, &
5985 4.977355e-02_rb,4.823172e-02_rb,4.677430e-02_rb,4.539465e-02_rb, &
5986 4.408680e-02_rb,4.284533e-02_rb,4.166539e-02_rb,4.054257e-02_rb, &
5987 3.947283e-02_rb,3.845256e-02_rb,3.747842e-02_rb,3.654737e-02_rb, &
5988 3.565665e-02_rb,3.480370e-02_rb,3.398620e-02_rb,3.320198e-02_rb, &
5989 3.244908e-02_rb,3.172566e-02_rb,3.103002e-02_rb,3.036062e-02_rb, &
5990 2.971600e-02_rb,2.909482e-02_rb,2.849582e-02_rb,2.791785e-02_rb, &
5991 2.735982e-02_rb,2.682072e-02_rb,2.629960e-02_rb,2.579559e-02_rb, &
5992 2.530786e-02_rb,2.4836e-02_rb /)
5993 extliq1(:, 28) = (/ &
5994 6.422688e-01_rb,4.528453e-01_rb,3.497232e-01_rb,2.847724e-01_rb, &
5995 2.400815e-01_rb,2.074403e-01_rb,1.825502e-01_rb,1.629415e-01_rb, &
5996 1.470934e-01_rb,1.340183e-01_rb,1.230935e-01_rb,1.138049e-01_rb, &
5997 1.058201e-01_rb,9.888245e-02_rb,9.279878e-02_rb,8.742053e-02_rb, &
5998 8.263175e-02_rb,7.834058e-02_rb,7.447327e-02_rb,7.097000e-02_rb, &
5999 6.778167e-02_rb,6.486765e-02_rb,6.219400e-02_rb,5.973215e-02_rb, &
6000 5.745790e-02_rb,5.535059e-02_rb,5.339250e-02_rb,5.156831e-02_rb, &
6001 4.975308e-02_rb,4.821235e-02_rb,4.675596e-02_rb,4.537727e-02_rb, &
6002 4.407030e-02_rb,4.282968e-02_rb,4.165053e-02_rb,4.052845e-02_rb, &
6003 3.945941e-02_rb,3.843980e-02_rb,3.746628e-02_rb,3.653583e-02_rb, &
6004 3.564567e-02_rb,3.479326e-02_rb,3.397626e-02_rb,3.319253e-02_rb, &
6005 3.244008e-02_rb,3.171711e-02_rb,3.102189e-02_rb,3.035289e-02_rb, &
6006 2.970866e-02_rb,2.908784e-02_rb,2.848920e-02_rb,2.791156e-02_rb, &
6007 2.735385e-02_rb,2.681507e-02_rb,2.629425e-02_rb,2.579053e-02_rb, &
6008 2.530308e-02_rb,2.4831e-02_rb /)
6009 extliq1(:, 29) = (/ &
6010 4.614710e-01_rb,4.556116e-01_rb,4.056568e-01_rb,3.529833e-01_rb, &
6011 3.060334e-01_rb,2.658127e-01_rb,2.316095e-01_rb,2.024325e-01_rb, &
6012 1.773749e-01_rb,1.556867e-01_rb,1.455558e-01_rb,1.332882e-01_rb, &
6013 1.229052e-01_rb,1.140067e-01_rb,1.062981e-01_rb,9.955703e-02_rb, &
6014 9.361333e-02_rb,8.833420e-02_rb,8.361467e-02_rb,7.937071e-02_rb, &
6015 7.553420e-02_rb,7.204942e-02_rb,6.887031e-02_rb,6.595851e-02_rb, &
6016 6.328178e-02_rb,6.081286e-02_rb,5.852854e-02_rb,5.640892e-02_rb, &
6017 5.431269e-02_rb,5.252561e-02_rb,5.084345e-02_rb,4.925727e-02_rb, &
6018 4.775910e-02_rb,4.634182e-02_rb,4.499907e-02_rb,4.372512e-02_rb, &
6019 4.251484e-02_rb,4.136357e-02_rb,4.026710e-02_rb,3.922162e-02_rb, &
6020 3.822365e-02_rb,3.727004e-02_rb,3.635790e-02_rb,3.548457e-02_rb, &
6021 3.464764e-02_rb,3.384488e-02_rb,3.307424e-02_rb,3.233384e-02_rb, &
6022 3.162192e-02_rb,3.093688e-02_rb,3.027723e-02_rb,2.964158e-02_rb, &
6023 2.902864e-02_rb,2.843722e-02_rb,2.786621e-02_rb,2.731457e-02_rb, &
6024 2.678133e-02_rb,2.6266e-02_rb /)
6025 !
6026 ! Single scattering albedo
6027 !
6028 ssaliq1(:, 16) = (/ &
6029 8.143821e-01_rb,7.836739e-01_rb,7.550722e-01_rb,7.306269e-01_rb, &
6030 7.105612e-01_rb,6.946649e-01_rb,6.825556e-01_rb,6.737762e-01_rb, &
6031 6.678448e-01_rb,6.642830e-01_rb,6.679741e-01_rb,6.584607e-01_rb, &
6032 6.505598e-01_rb,6.440951e-01_rb,6.388901e-01_rb,6.347689e-01_rb, &
6033 6.315549e-01_rb,6.290718e-01_rb,6.271432e-01_rb,6.255928e-01_rb, &
6034 6.242441e-01_rb,6.229207e-01_rb,6.214464e-01_rb,6.196445e-01_rb, &
6035 6.173388e-01_rb,6.143527e-01_rb,6.105099e-01_rb,6.056339e-01_rb, &
6036 6.108290e-01_rb,6.073939e-01_rb,6.043073e-01_rb,6.015473e-01_rb, &
6037 5.990913e-01_rb,5.969173e-01_rb,5.950028e-01_rb,5.933257e-01_rb, &
6038 5.918636e-01_rb,5.905944e-01_rb,5.894957e-01_rb,5.885453e-01_rb, &
6039 5.877209e-01_rb,5.870003e-01_rb,5.863611e-01_rb,5.857811e-01_rb, &
6040 5.852381e-01_rb,5.847098e-01_rb,5.841738e-01_rb,5.836081e-01_rb, &
6041 5.829901e-01_rb,5.822979e-01_rb,5.815089e-01_rb,5.806011e-01_rb, &
6042 5.795521e-01_rb,5.783396e-01_rb,5.769413e-01_rb,5.753351e-01_rb, &
6043 5.734986e-01_rb,5.7141e-01_rb /)
6044 ssaliq1(:, 17) = (/ &
6045 8.165821e-01_rb,8.002015e-01_rb,7.816921e-01_rb,7.634131e-01_rb, &
6046 7.463721e-01_rb,7.312469e-01_rb,7.185883e-01_rb,7.088975e-01_rb, &
6047 7.026671e-01_rb,7.004020e-01_rb,7.042138e-01_rb,6.960930e-01_rb, &
6048 6.894243e-01_rb,6.840459e-01_rb,6.797957e-01_rb,6.765119e-01_rb, &
6049 6.740325e-01_rb,6.721955e-01_rb,6.708391e-01_rb,6.698013e-01_rb, &
6050 6.689201e-01_rb,6.680339e-01_rb,6.669805e-01_rb,6.655982e-01_rb, &
6051 6.637250e-01_rb,6.611992e-01_rb,6.578588e-01_rb,6.535420e-01_rb, &
6052 6.584449e-01_rb,6.553992e-01_rb,6.526547e-01_rb,6.501917e-01_rb, &
6053 6.479905e-01_rb,6.460313e-01_rb,6.442945e-01_rb,6.427605e-01_rb, &
6054 6.414094e-01_rb,6.402217e-01_rb,6.391775e-01_rb,6.382573e-01_rb, &
6055 6.374413e-01_rb,6.367099e-01_rb,6.360433e-01_rb,6.354218e-01_rb, &
6056 6.348257e-01_rb,6.342355e-01_rb,6.336313e-01_rb,6.329935e-01_rb, &
6057 6.323023e-01_rb,6.315383e-01_rb,6.306814e-01_rb,6.297122e-01_rb, &
6058 6.286110e-01_rb,6.273579e-01_rb,6.259333e-01_rb,6.243176e-01_rb, &
6059 6.224910e-01_rb,6.2043e-01_rb /)
6060 ssaliq1(:, 18) = (/ &
6061 9.900163e-01_rb,9.854307e-01_rb,9.797730e-01_rb,9.733113e-01_rb, &
6062 9.664245e-01_rb,9.594976e-01_rb,9.529055e-01_rb,9.470112e-01_rb, &
6063 9.421695e-01_rb,9.387304e-01_rb,9.344918e-01_rb,9.305302e-01_rb, &
6064 9.267048e-01_rb,9.230072e-01_rb,9.194289e-01_rb,9.159616e-01_rb, &
6065 9.125968e-01_rb,9.093260e-01_rb,9.061409e-01_rb,9.030330e-01_rb, &
6066 8.999940e-01_rb,8.970154e-01_rb,8.940888e-01_rb,8.912058e-01_rb, &
6067 8.883579e-01_rb,8.855368e-01_rb,8.827341e-01_rb,8.799413e-01_rb, &
6068 8.777423e-01_rb,8.749566e-01_rb,8.722298e-01_rb,8.695605e-01_rb, &
6069 8.669469e-01_rb,8.643875e-01_rb,8.618806e-01_rb,8.594246e-01_rb, &
6070 8.570179e-01_rb,8.546589e-01_rb,8.523459e-01_rb,8.500773e-01_rb, &
6071 8.478516e-01_rb,8.456670e-01_rb,8.435219e-01_rb,8.414148e-01_rb, &
6072 8.393439e-01_rb,8.373078e-01_rb,8.353047e-01_rb,8.333330e-01_rb, &
6073 8.313911e-01_rb,8.294774e-01_rb,8.275904e-01_rb,8.257282e-01_rb, &
6074 8.238893e-01_rb,8.220721e-01_rb,8.202751e-01_rb,8.184965e-01_rb, &
6075 8.167346e-01_rb,8.1499e-01_rb /)
6076 ssaliq1(:, 19) = (/ &
6077 9.999916e-01_rb,9.987396e-01_rb,9.966900e-01_rb,9.950738e-01_rb, &
6078 9.937531e-01_rb,9.925912e-01_rb,9.914525e-01_rb,9.902018e-01_rb, &
6079 9.887046e-01_rb,9.868263e-01_rb,9.849039e-01_rb,9.832372e-01_rb, &
6080 9.815265e-01_rb,9.797770e-01_rb,9.779940e-01_rb,9.761827e-01_rb, &
6081 9.743481e-01_rb,9.724955e-01_rb,9.706303e-01_rb,9.687575e-01_rb, &
6082 9.668823e-01_rb,9.650100e-01_rb,9.631457e-01_rb,9.612947e-01_rb, &
6083 9.594622e-01_rb,9.576534e-01_rb,9.558734e-01_rb,9.541275e-01_rb, &
6084 9.522059e-01_rb,9.504258e-01_rb,9.486459e-01_rb,9.468676e-01_rb, &
6085 9.450921e-01_rb,9.433208e-01_rb,9.415548e-01_rb,9.397955e-01_rb, &
6086 9.380441e-01_rb,9.363022e-01_rb,9.345706e-01_rb,9.328510e-01_rb, &
6087 9.311445e-01_rb,9.294524e-01_rb,9.277761e-01_rb,9.261167e-01_rb, &
6088 9.244755e-01_rb,9.228540e-01_rb,9.212534e-01_rb,9.196748e-01_rb, &
6089 9.181197e-01_rb,9.165894e-01_rb,9.150851e-01_rb,9.136080e-01_rb, &
6090 9.121596e-01_rb,9.107410e-01_rb,9.093536e-01_rb,9.079987e-01_rb, &
6091 9.066775e-01_rb,9.0539e-01_rb /)
6092 ssaliq1(:, 20) = (/ &
6093 9.979493e-01_rb,9.964113e-01_rb,9.950014e-01_rb,9.937045e-01_rb, &
6094 9.924964e-01_rb,9.913546e-01_rb,9.902575e-01_rb,9.891843e-01_rb, &
6095 9.881136e-01_rb,9.870238e-01_rb,9.859934e-01_rb,9.849372e-01_rb, &
6096 9.838873e-01_rb,9.828434e-01_rb,9.818052e-01_rb,9.807725e-01_rb, &
6097 9.797450e-01_rb,9.787225e-01_rb,9.777047e-01_rb,9.766914e-01_rb, &
6098 9.756823e-01_rb,9.746771e-01_rb,9.736756e-01_rb,9.726775e-01_rb, &
6099 9.716827e-01_rb,9.706907e-01_rb,9.697014e-01_rb,9.687145e-01_rb, &
6100 9.678060e-01_rb,9.668108e-01_rb,9.658218e-01_rb,9.648391e-01_rb, &
6101 9.638629e-01_rb,9.628936e-01_rb,9.619313e-01_rb,9.609763e-01_rb, &
6102 9.600287e-01_rb,9.590888e-01_rb,9.581569e-01_rb,9.572330e-01_rb, &
6103 9.563176e-01_rb,9.554108e-01_rb,9.545128e-01_rb,9.536239e-01_rb, &
6104 9.527443e-01_rb,9.518741e-01_rb,9.510137e-01_rb,9.501633e-01_rb, &
6105 9.493230e-01_rb,9.484931e-01_rb,9.476740e-01_rb,9.468656e-01_rb, &
6106 9.460683e-01_rb,9.452824e-01_rb,9.445080e-01_rb,9.437454e-01_rb, &
6107 9.429948e-01_rb,9.4226e-01_rb /)
6108 ssaliq1(:, 21) = (/ &
6109 9.988742e-01_rb,9.982668e-01_rb,9.976935e-01_rb,9.971497e-01_rb, &
6110 9.966314e-01_rb,9.961344e-01_rb,9.956545e-01_rb,9.951873e-01_rb, &
6111 9.947286e-01_rb,9.942741e-01_rb,9.938457e-01_rb,9.933947e-01_rb, &
6112 9.929473e-01_rb,9.925032e-01_rb,9.920621e-01_rb,9.916237e-01_rb, &
6113 9.911875e-01_rb,9.907534e-01_rb,9.903209e-01_rb,9.898898e-01_rb, &
6114 9.894597e-01_rb,9.890304e-01_rb,9.886015e-01_rb,9.881726e-01_rb, &
6115 9.877435e-01_rb,9.873138e-01_rb,9.868833e-01_rb,9.864516e-01_rb, &
6116 9.860698e-01_rb,9.856317e-01_rb,9.851957e-01_rb,9.847618e-01_rb, &
6117 9.843302e-01_rb,9.839008e-01_rb,9.834739e-01_rb,9.830494e-01_rb, &
6118 9.826275e-01_rb,9.822083e-01_rb,9.817918e-01_rb,9.813782e-01_rb, &
6119 9.809675e-01_rb,9.805598e-01_rb,9.801552e-01_rb,9.797538e-01_rb, &
6120 9.793556e-01_rb,9.789608e-01_rb,9.785695e-01_rb,9.781817e-01_rb, &
6121 9.777975e-01_rb,9.774171e-01_rb,9.770404e-01_rb,9.766676e-01_rb, &
6122 9.762988e-01_rb,9.759340e-01_rb,9.755733e-01_rb,9.752169e-01_rb, &
6123 9.748649e-01_rb,9.7452e-01_rb /)
6124 ssaliq1(:, 22) = (/ &
6125 9.994441e-01_rb,9.991608e-01_rb,9.988949e-01_rb,9.986439e-01_rb, &
6126 9.984054e-01_rb,9.981768e-01_rb,9.979557e-01_rb,9.977396e-01_rb, &
6127 9.975258e-01_rb,9.973120e-01_rb,9.971011e-01_rb,9.968852e-01_rb, &
6128 9.966708e-01_rb,9.964578e-01_rb,9.962462e-01_rb,9.960357e-01_rb, &
6129 9.958264e-01_rb,9.956181e-01_rb,9.954108e-01_rb,9.952043e-01_rb, &
6130 9.949987e-01_rb,9.947937e-01_rb,9.945892e-01_rb,9.943853e-01_rb, &
6131 9.941818e-01_rb,9.939786e-01_rb,9.937757e-01_rb,9.935728e-01_rb, &
6132 9.933922e-01_rb,9.931825e-01_rb,9.929739e-01_rb,9.927661e-01_rb, &
6133 9.925592e-01_rb,9.923534e-01_rb,9.921485e-01_rb,9.919447e-01_rb, &
6134 9.917421e-01_rb,9.915406e-01_rb,9.913403e-01_rb,9.911412e-01_rb, &
6135 9.909435e-01_rb,9.907470e-01_rb,9.905519e-01_rb,9.903581e-01_rb, &
6136 9.901659e-01_rb,9.899751e-01_rb,9.897858e-01_rb,9.895981e-01_rb, &
6137 9.894120e-01_rb,9.892276e-01_rb,9.890447e-01_rb,9.888637e-01_rb, &
6138 9.886845e-01_rb,9.885070e-01_rb,9.883314e-01_rb,9.881576e-01_rb, &
6139 9.879859e-01_rb,9.8782e-01_rb /)
6140 ssaliq1(:, 23) = (/ &
6141 9.999138e-01_rb,9.998730e-01_rb,9.998338e-01_rb,9.997965e-01_rb, &
6142 9.997609e-01_rb,9.997270e-01_rb,9.996944e-01_rb,9.996629e-01_rb, &
6143 9.996321e-01_rb,9.996016e-01_rb,9.995690e-01_rb,9.995372e-01_rb, &
6144 9.995057e-01_rb,9.994744e-01_rb,9.994433e-01_rb,9.994124e-01_rb, &
6145 9.993817e-01_rb,9.993510e-01_rb,9.993206e-01_rb,9.992903e-01_rb, &
6146 9.992600e-01_rb,9.992299e-01_rb,9.991998e-01_rb,9.991698e-01_rb, &
6147 9.991398e-01_rb,9.991098e-01_rb,9.990799e-01_rb,9.990499e-01_rb, &
6148 9.990231e-01_rb,9.989920e-01_rb,9.989611e-01_rb,9.989302e-01_rb, &
6149 9.988996e-01_rb,9.988690e-01_rb,9.988386e-01_rb,9.988084e-01_rb, &
6150 9.987783e-01_rb,9.987485e-01_rb,9.987187e-01_rb,9.986891e-01_rb, &
6151 9.986598e-01_rb,9.986306e-01_rb,9.986017e-01_rb,9.985729e-01_rb, &
6152 9.985443e-01_rb,9.985160e-01_rb,9.984879e-01_rb,9.984600e-01_rb, &
6153 9.984324e-01_rb,9.984050e-01_rb,9.983778e-01_rb,9.983509e-01_rb, &
6154 9.983243e-01_rb,9.982980e-01_rb,9.982719e-01_rb,9.982461e-01_rb, &
6155 9.982206e-01_rb,9.9820e-01_rb /)
6156 ssaliq1(:, 24) = (/ &
6157 9.999985e-01_rb,9.999979e-01_rb,9.999972e-01_rb,9.999966e-01_rb, &
6158 9.999961e-01_rb,9.999955e-01_rb,9.999950e-01_rb,9.999944e-01_rb, &
6159 9.999938e-01_rb,9.999933e-01_rb,9.999927e-01_rb,9.999921e-01_rb, &
6160 9.999915e-01_rb,9.999910e-01_rb,9.999904e-01_rb,9.999899e-01_rb, &
6161 9.999893e-01_rb,9.999888e-01_rb,9.999882e-01_rb,9.999877e-01_rb, &
6162 9.999871e-01_rb,9.999866e-01_rb,9.999861e-01_rb,9.999855e-01_rb, &
6163 9.999850e-01_rb,9.999844e-01_rb,9.999839e-01_rb,9.999833e-01_rb, &
6164 9.999828e-01_rb,9.999823e-01_rb,9.999817e-01_rb,9.999812e-01_rb, &
6165 9.999807e-01_rb,9.999801e-01_rb,9.999796e-01_rb,9.999791e-01_rb, &
6166 9.999786e-01_rb,9.999781e-01_rb,9.999776e-01_rb,9.999770e-01_rb, &
6167 9.999765e-01_rb,9.999761e-01_rb,9.999756e-01_rb,9.999751e-01_rb, &
6168 9.999746e-01_rb,9.999741e-01_rb,9.999736e-01_rb,9.999732e-01_rb, &
6169 9.999727e-01_rb,9.999722e-01_rb,9.999718e-01_rb,9.999713e-01_rb, &
6170 9.999709e-01_rb,9.999705e-01_rb,9.999701e-01_rb,9.999697e-01_rb, &
6171 9.999692e-01_rb,9.9997e-01_rb /)
6172 ssaliq1(:, 25) = (/ &
6173 9.999999e-01_rb,9.999998e-01_rb,9.999997e-01_rb,9.999997e-01_rb, &
6174 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb, &
6175 9.999995e-01_rb,9.999994e-01_rb,9.999994e-01_rb,9.999993e-01_rb, &
6176 9.999993e-01_rb,9.999992e-01_rb,9.999992e-01_rb,9.999991e-01_rb, &
6177 9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb, &
6178 9.999989e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb, &
6179 9.999987e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999986e-01_rb, &
6180 9.999985e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999984e-01_rb, &
6181 9.999984e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999982e-01_rb, &
6182 9.999982e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb, &
6183 9.999980e-01_rb,9.999980e-01_rb,9.999979e-01_rb,9.999979e-01_rb, &
6184 9.999978e-01_rb,9.999978e-01_rb,9.999977e-01_rb,9.999977e-01_rb, &
6185 9.999977e-01_rb,9.999976e-01_rb,9.999976e-01_rb,9.999975e-01_rb, &
6186 9.999975e-01_rb,9.999974e-01_rb,9.999974e-01_rb,9.999974e-01_rb, &
6187 9.999973e-01_rb,1.0000e+00_rb /)
6188 ssaliq1(:, 26) = (/ &
6189 9.999997e-01_rb,9.999995e-01_rb,9.999993e-01_rb,9.999992e-01_rb, &
6190 9.999990e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb, &
6191 9.999986e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999983e-01_rb, &
6192 9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb, &
6193 9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999974e-01_rb, &
6194 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb, &
6195 9.999968e-01_rb,9.999967e-01_rb,9.999966e-01_rb,9.999965e-01_rb, &
6196 9.999964e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999961e-01_rb, &
6197 9.999959e-01_rb,9.999958e-01_rb,9.999957e-01_rb,9.999956e-01_rb, &
6198 9.999955e-01_rb,9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb, &
6199 9.999951e-01_rb,9.999949e-01_rb,9.999949e-01_rb,9.999947e-01_rb, &
6200 9.999946e-01_rb,9.999945e-01_rb,9.999944e-01_rb,9.999943e-01_rb, &
6201 9.999942e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb, &
6202 9.999938e-01_rb,9.999937e-01_rb,9.999936e-01_rb,9.999935e-01_rb, &
6203 9.999934e-01_rb,9.9999e-01_rb /)
6204 ssaliq1(:, 27) = (/ &
6205 9.999984e-01_rb,9.999976e-01_rb,9.999969e-01_rb,9.999962e-01_rb, &
6206 9.999956e-01_rb,9.999950e-01_rb,9.999945e-01_rb,9.999940e-01_rb, &
6207 9.999935e-01_rb,9.999931e-01_rb,9.999926e-01_rb,9.999920e-01_rb, &
6208 9.999914e-01_rb,9.999908e-01_rb,9.999903e-01_rb,9.999897e-01_rb, &
6209 9.999891e-01_rb,9.999886e-01_rb,9.999880e-01_rb,9.999874e-01_rb, &
6210 9.999868e-01_rb,9.999863e-01_rb,9.999857e-01_rb,9.999851e-01_rb, &
6211 9.999846e-01_rb,9.999840e-01_rb,9.999835e-01_rb,9.999829e-01_rb, &
6212 9.999824e-01_rb,9.999818e-01_rb,9.999812e-01_rb,9.999806e-01_rb, &
6213 9.999800e-01_rb,9.999795e-01_rb,9.999789e-01_rb,9.999783e-01_rb, &
6214 9.999778e-01_rb,9.999773e-01_rb,9.999767e-01_rb,9.999761e-01_rb, &
6215 9.999756e-01_rb,9.999750e-01_rb,9.999745e-01_rb,9.999739e-01_rb, &
6216 9.999734e-01_rb,9.999729e-01_rb,9.999723e-01_rb,9.999718e-01_rb, &
6217 9.999713e-01_rb,9.999708e-01_rb,9.999703e-01_rb,9.999697e-01_rb, &
6218 9.999692e-01_rb,9.999687e-01_rb,9.999683e-01_rb,9.999678e-01_rb, &
6219 9.999673e-01_rb,9.9997e-01_rb /)
6220 ssaliq1(:, 28) = (/ &
6221 9.999981e-01_rb,9.999973e-01_rb,9.999965e-01_rb,9.999958e-01_rb, &
6222 9.999951e-01_rb,9.999943e-01_rb,9.999937e-01_rb,9.999930e-01_rb, &
6223 9.999924e-01_rb,9.999918e-01_rb,9.999912e-01_rb,9.999905e-01_rb, &
6224 9.999897e-01_rb,9.999890e-01_rb,9.999883e-01_rb,9.999876e-01_rb, &
6225 9.999869e-01_rb,9.999862e-01_rb,9.999855e-01_rb,9.999847e-01_rb, &
6226 9.999840e-01_rb,9.999834e-01_rb,9.999827e-01_rb,9.999819e-01_rb, &
6227 9.999812e-01_rb,9.999805e-01_rb,9.999799e-01_rb,9.999791e-01_rb, &
6228 9.999785e-01_rb,9.999778e-01_rb,9.999771e-01_rb,9.999764e-01_rb, &
6229 9.999757e-01_rb,9.999750e-01_rb,9.999743e-01_rb,9.999736e-01_rb, &
6230 9.999729e-01_rb,9.999722e-01_rb,9.999715e-01_rb,9.999709e-01_rb, &
6231 9.999701e-01_rb,9.999695e-01_rb,9.999688e-01_rb,9.999682e-01_rb, &
6232 9.999675e-01_rb,9.999669e-01_rb,9.999662e-01_rb,9.999655e-01_rb, &
6233 9.999649e-01_rb,9.999642e-01_rb,9.999636e-01_rb,9.999630e-01_rb, &
6234 9.999624e-01_rb,9.999618e-01_rb,9.999612e-01_rb,9.999606e-01_rb, &
6235 9.999600e-01_rb,9.9996e-01_rb /)
6236 ssaliq1(:, 29) = (/ &
6237 8.505737e-01_rb,8.465102e-01_rb,8.394829e-01_rb,8.279508e-01_rb, &
6238 8.110806e-01_rb,7.900397e-01_rb,7.669615e-01_rb,7.444422e-01_rb, &
6239 7.253055e-01_rb,7.124831e-01_rb,7.016434e-01_rb,6.885485e-01_rb, &
6240 6.767340e-01_rb,6.661029e-01_rb,6.565577e-01_rb,6.480013e-01_rb, &
6241 6.403373e-01_rb,6.334697e-01_rb,6.273034e-01_rb,6.217440e-01_rb, &
6242 6.166983e-01_rb,6.120740e-01_rb,6.077796e-01_rb,6.037249e-01_rb, &
6243 5.998207e-01_rb,5.959788e-01_rb,5.921123e-01_rb,5.881354e-01_rb, &
6244 5.891285e-01_rb,5.851143e-01_rb,5.814653e-01_rb,5.781606e-01_rb, &
6245 5.751792e-01_rb,5.724998e-01_rb,5.701016e-01_rb,5.679634e-01_rb, &
6246 5.660642e-01_rb,5.643829e-01_rb,5.628984e-01_rb,5.615898e-01_rb, &
6247 5.604359e-01_rb,5.594158e-01_rb,5.585083e-01_rb,5.576924e-01_rb, &
6248 5.569470e-01_rb,5.562512e-01_rb,5.555838e-01_rb,5.549239e-01_rb, &
6249 5.542503e-01_rb,5.535420e-01_rb,5.527781e-01_rb,5.519374e-01_rb, &
6250 5.509989e-01_rb,5.499417e-01_rb,5.487445e-01_rb,5.473865e-01_rb, &
6251 5.458466e-01_rb,5.4410e-01_rb /)
6252 !
6253 ! asymmetry parameter
6254 !
6255 asyliq1(:, 16) = (/ &
6256 8.133297e-01_rb,8.133528e-01_rb,8.173865e-01_rb,8.243205e-01_rb, &
6257 8.333063e-01_rb,8.436317e-01_rb,8.546611e-01_rb,8.657934e-01_rb, &
6258 8.764345e-01_rb,8.859837e-01_rb,8.627394e-01_rb,8.824569e-01_rb, &
6259 8.976887e-01_rb,9.089541e-01_rb,9.167699e-01_rb,9.216517e-01_rb, &
6260 9.241147e-01_rb,9.246743e-01_rb,9.238469e-01_rb,9.221504e-01_rb, &
6261 9.201045e-01_rb,9.182299e-01_rb,9.170491e-01_rb,9.170862e-01_rb, &
6262 9.188653e-01_rb,9.229111e-01_rb,9.297468e-01_rb,9.398950e-01_rb, &
6263 9.203269e-01_rb,9.260693e-01_rb,9.309373e-01_rb,9.349918e-01_rb, &
6264 9.382935e-01_rb,9.409030e-01_rb,9.428809e-01_rb,9.442881e-01_rb, &
6265 9.451851e-01_rb,9.456331e-01_rb,9.456926e-01_rb,9.454247e-01_rb, &
6266 9.448902e-01_rb,9.441503e-01_rb,9.432661e-01_rb,9.422987e-01_rb, &
6267 9.413094e-01_rb,9.403594e-01_rb,9.395102e-01_rb,9.388230e-01_rb, &
6268 9.383594e-01_rb,9.381810e-01_rb,9.383489e-01_rb,9.389251e-01_rb, &
6269 9.399707e-01_rb,9.415475e-01_rb,9.437167e-01_rb,9.465399e-01_rb, &
6270 9.500786e-01_rb,9.5439e-01_rb /)
6271 asyliq1(:, 17) = (/ &
6272 8.794448e-01_rb,8.819306e-01_rb,8.837667e-01_rb,8.853832e-01_rb, &
6273 8.871010e-01_rb,8.892675e-01_rb,8.922584e-01_rb,8.964666e-01_rb, &
6274 9.022940e-01_rb,9.101456e-01_rb,8.839999e-01_rb,9.035610e-01_rb, &
6275 9.184568e-01_rb,9.292315e-01_rb,9.364282e-01_rb,9.405887e-01_rb, &
6276 9.422554e-01_rb,9.419703e-01_rb,9.402759e-01_rb,9.377159e-01_rb, &
6277 9.348345e-01_rb,9.321769e-01_rb,9.302888e-01_rb,9.297166e-01_rb, &
6278 9.310075e-01_rb,9.347080e-01_rb,9.413643e-01_rb,9.515216e-01_rb, &
6279 9.306286e-01_rb,9.361781e-01_rb,9.408374e-01_rb,9.446692e-01_rb, &
6280 9.477363e-01_rb,9.501013e-01_rb,9.518268e-01_rb,9.529756e-01_rb, &
6281 9.536105e-01_rb,9.537938e-01_rb,9.535886e-01_rb,9.530574e-01_rb, &
6282 9.522633e-01_rb,9.512688e-01_rb,9.501370e-01_rb,9.489306e-01_rb, &
6283 9.477126e-01_rb,9.465459e-01_rb,9.454934e-01_rb,9.446183e-01_rb, &
6284 9.439833e-01_rb,9.436519e-01_rb,9.436866e-01_rb,9.441508e-01_rb, &
6285 9.451073e-01_rb,9.466195e-01_rb,9.487501e-01_rb,9.515621e-01_rb, &
6286 9.551185e-01_rb,9.5948e-01_rb /)
6287 asyliq1(:, 18) = (/ &
6288 8.478817e-01_rb,8.269312e-01_rb,8.161352e-01_rb,8.135960e-01_rb, &
6289 8.173586e-01_rb,8.254167e-01_rb,8.357072e-01_rb,8.461167e-01_rb, &
6290 8.544952e-01_rb,8.586776e-01_rb,8.335562e-01_rb,8.524273e-01_rb, &
6291 8.669052e-01_rb,8.775014e-01_rb,8.847277e-01_rb,8.890958e-01_rb, &
6292 8.911173e-01_rb,8.913038e-01_rb,8.901669e-01_rb,8.882182e-01_rb, &
6293 8.859692e-01_rb,8.839315e-01_rb,8.826164e-01_rb,8.825356e-01_rb, &
6294 8.842004e-01_rb,8.881223e-01_rb,8.948131e-01_rb,9.047837e-01_rb, &
6295 8.855951e-01_rb,8.911796e-01_rb,8.959229e-01_rb,8.998837e-01_rb, &
6296 9.031209e-01_rb,9.056939e-01_rb,9.076609e-01_rb,9.090812e-01_rb, &
6297 9.100134e-01_rb,9.105167e-01_rb,9.106496e-01_rb,9.104712e-01_rb, &
6298 9.100404e-01_rb,9.094159e-01_rb,9.086568e-01_rb,9.078218e-01_rb, &
6299 9.069697e-01_rb,9.061595e-01_rb,9.054499e-01_rb,9.048999e-01_rb, &
6300 9.045683e-01_rb,9.045142e-01_rb,9.047962e-01_rb,9.054730e-01_rb, &
6301 9.066037e-01_rb,9.082472e-01_rb,9.104623e-01_rb,9.133079e-01_rb, &
6302 9.168427e-01_rb,9.2113e-01_rb /)
6303 asyliq1(:, 19) = (/ &
6304 8.216697e-01_rb,7.982871e-01_rb,7.891147e-01_rb,7.909083e-01_rb, &
6305 8.003833e-01_rb,8.142516e-01_rb,8.292290e-01_rb,8.420356e-01_rb, &
6306 8.493945e-01_rb,8.480316e-01_rb,8.212381e-01_rb,8.394984e-01_rb, &
6307 8.534095e-01_rb,8.634813e-01_rb,8.702242e-01_rb,8.741483e-01_rb, &
6308 8.757638e-01_rb,8.755808e-01_rb,8.741095e-01_rb,8.718604e-01_rb, &
6309 8.693433e-01_rb,8.670686e-01_rb,8.655464e-01_rb,8.652872e-01_rb, &
6310 8.668006e-01_rb,8.705973e-01_rb,8.771874e-01_rb,8.870809e-01_rb, &
6311 8.678284e-01_rb,8.732315e-01_rb,8.778084e-01_rb,8.816166e-01_rb, &
6312 8.847146e-01_rb,8.871603e-01_rb,8.890116e-01_rb,8.903266e-01_rb, &
6313 8.911632e-01_rb,8.915796e-01_rb,8.916337e-01_rb,8.913834e-01_rb, &
6314 8.908869e-01_rb,8.902022e-01_rb,8.893873e-01_rb,8.885001e-01_rb, &
6315 8.875986e-01_rb,8.867411e-01_rb,8.859852e-01_rb,8.853891e-01_rb, &
6316 8.850111e-01_rb,8.849089e-01_rb,8.851405e-01_rb,8.857639e-01_rb, &
6317 8.868372e-01_rb,8.884185e-01_rb,8.905656e-01_rb,8.933368e-01_rb, &
6318 8.967899e-01_rb,9.0098e-01_rb /)
6319 asyliq1(:, 20) = (/ &
6320 8.063610e-01_rb,7.938147e-01_rb,7.921304e-01_rb,7.985092e-01_rb, &
6321 8.101339e-01_rb,8.242175e-01_rb,8.379913e-01_rb,8.486920e-01_rb, &
6322 8.535547e-01_rb,8.498083e-01_rb,8.224849e-01_rb,8.405509e-01_rb, &
6323 8.542436e-01_rb,8.640770e-01_rb,8.705653e-01_rb,8.742227e-01_rb, &
6324 8.755630e-01_rb,8.751004e-01_rb,8.733491e-01_rb,8.708231e-01_rb, &
6325 8.680365e-01_rb,8.655035e-01_rb,8.637381e-01_rb,8.632544e-01_rb, &
6326 8.645665e-01_rb,8.681885e-01_rb,8.746346e-01_rb,8.844188e-01_rb, &
6327 8.648180e-01_rb,8.700563e-01_rb,8.744672e-01_rb,8.781087e-01_rb, &
6328 8.810393e-01_rb,8.833174e-01_rb,8.850011e-01_rb,8.861485e-01_rb, &
6329 8.868183e-01_rb,8.870687e-01_rb,8.869579e-01_rb,8.865441e-01_rb, &
6330 8.858857e-01_rb,8.850412e-01_rb,8.840686e-01_rb,8.830263e-01_rb, &
6331 8.819726e-01_rb,8.809658e-01_rb,8.800642e-01_rb,8.793260e-01_rb, &
6332 8.788099e-01_rb,8.785737e-01_rb,8.786758e-01_rb,8.791746e-01_rb, &
6333 8.801283e-01_rb,8.815955e-01_rb,8.836340e-01_rb,8.863024e-01_rb, &
6334 8.896592e-01_rb,8.9376e-01_rb /)
6335 asyliq1(:, 21) = (/ &
6336 7.885899e-01_rb,7.937172e-01_rb,8.020658e-01_rb,8.123971e-01_rb, &
6337 8.235502e-01_rb,8.343776e-01_rb,8.437336e-01_rb,8.504711e-01_rb, &
6338 8.534421e-01_rb,8.514978e-01_rb,8.238888e-01_rb,8.417463e-01_rb, &
6339 8.552057e-01_rb,8.647853e-01_rb,8.710038e-01_rb,8.743798e-01_rb, &
6340 8.754319e-01_rb,8.746786e-01_rb,8.726386e-01_rb,8.698303e-01_rb, &
6341 8.667724e-01_rb,8.639836e-01_rb,8.619823e-01_rb,8.612870e-01_rb, &
6342 8.624165e-01_rb,8.658893e-01_rb,8.722241e-01_rb,8.819394e-01_rb, &
6343 8.620216e-01_rb,8.671239e-01_rb,8.713983e-01_rb,8.749032e-01_rb, &
6344 8.776970e-01_rb,8.798385e-01_rb,8.813860e-01_rb,8.823980e-01_rb, &
6345 8.829332e-01_rb,8.830500e-01_rb,8.828068e-01_rb,8.822623e-01_rb, &
6346 8.814750e-01_rb,8.805031e-01_rb,8.794056e-01_rb,8.782407e-01_rb, &
6347 8.770672e-01_rb,8.759432e-01_rb,8.749275e-01_rb,8.740784e-01_rb, &
6348 8.734547e-01_rb,8.731146e-01_rb,8.731170e-01_rb,8.735199e-01_rb, &
6349 8.743823e-01_rb,8.757625e-01_rb,8.777191e-01_rb,8.803105e-01_rb, &
6350 8.835953e-01_rb,8.8763e-01_rb /)
6351 asyliq1(:, 22) = (/ &
6352 7.811516e-01_rb,7.962229e-01_rb,8.096199e-01_rb,8.212996e-01_rb, &
6353 8.312212e-01_rb,8.393430e-01_rb,8.456236e-01_rb,8.500214e-01_rb, &
6354 8.524950e-01_rb,8.530031e-01_rb,8.251485e-01_rb,8.429043e-01_rb, &
6355 8.562461e-01_rb,8.656954e-01_rb,8.717737e-01_rb,8.750020e-01_rb, &
6356 8.759022e-01_rb,8.749953e-01_rb,8.728027e-01_rb,8.698461e-01_rb, &
6357 8.666466e-01_rb,8.637257e-01_rb,8.616047e-01_rb,8.608051e-01_rb, &
6358 8.618483e-01_rb,8.652557e-01_rb,8.715487e-01_rb,8.812485e-01_rb, &
6359 8.611645e-01_rb,8.662052e-01_rb,8.704173e-01_rb,8.738594e-01_rb, &
6360 8.765901e-01_rb,8.786678e-01_rb,8.801517e-01_rb,8.810999e-01_rb, &
6361 8.815713e-01_rb,8.816246e-01_rb,8.813185e-01_rb,8.807114e-01_rb, &
6362 8.798621e-01_rb,8.788290e-01_rb,8.776713e-01_rb,8.764470e-01_rb, &
6363 8.752152e-01_rb,8.740343e-01_rb,8.729631e-01_rb,8.720602e-01_rb, &
6364 8.713842e-01_rb,8.709936e-01_rb,8.709475e-01_rb,8.713041e-01_rb, &
6365 8.721221e-01_rb,8.734602e-01_rb,8.753774e-01_rb,8.779319e-01_rb, &
6366 8.811825e-01_rb,8.8519e-01_rb /)
6367 asyliq1(:, 23) = (/ &
6368 7.865744e-01_rb,8.093340e-01_rb,8.257596e-01_rb,8.369940e-01_rb, &
6369 8.441574e-01_rb,8.483602e-01_rb,8.507096e-01_rb,8.523139e-01_rb, &
6370 8.542834e-01_rb,8.577321e-01_rb,8.288960e-01_rb,8.465308e-01_rb, &
6371 8.597175e-01_rb,8.689830e-01_rb,8.748542e-01_rb,8.778584e-01_rb, &
6372 8.785222e-01_rb,8.773728e-01_rb,8.749370e-01_rb,8.717419e-01_rb, &
6373 8.683145e-01_rb,8.651816e-01_rb,8.628704e-01_rb,8.619077e-01_rb, &
6374 8.628205e-01_rb,8.661356e-01_rb,8.723803e-01_rb,8.820815e-01_rb, &
6375 8.616715e-01_rb,8.666389e-01_rb,8.707753e-01_rb,8.741398e-01_rb, &
6376 8.767912e-01_rb,8.787885e-01_rb,8.801908e-01_rb,8.810570e-01_rb, &
6377 8.814460e-01_rb,8.814167e-01_rb,8.810283e-01_rb,8.803395e-01_rb, &
6378 8.794095e-01_rb,8.782971e-01_rb,8.770613e-01_rb,8.757610e-01_rb, &
6379 8.744553e-01_rb,8.732031e-01_rb,8.720634e-01_rb,8.710951e-01_rb, &
6380 8.703572e-01_rb,8.699086e-01_rb,8.698084e-01_rb,8.701155e-01_rb, &
6381 8.708887e-01_rb,8.721872e-01_rb,8.740698e-01_rb,8.765957e-01_rb, &
6382 8.798235e-01_rb,8.8381e-01_rb /)
6383 asyliq1(:, 24) = (/ &
6384 8.069513e-01_rb,8.262939e-01_rb,8.398241e-01_rb,8.486352e-01_rb, &
6385 8.538213e-01_rb,8.564743e-01_rb,8.576854e-01_rb,8.585455e-01_rb, &
6386 8.601452e-01_rb,8.635755e-01_rb,8.337383e-01_rb,8.512655e-01_rb, &
6387 8.643049e-01_rb,8.733896e-01_rb,8.790535e-01_rb,8.818295e-01_rb, &
6388 8.822518e-01_rb,8.808533e-01_rb,8.781676e-01_rb,8.747284e-01_rb, &
6389 8.710690e-01_rb,8.677229e-01_rb,8.652236e-01_rb,8.641047e-01_rb, &
6390 8.648993e-01_rb,8.681413e-01_rb,8.743640e-01_rb,8.841007e-01_rb, &
6391 8.633558e-01_rb,8.682719e-01_rb,8.723543e-01_rb,8.756621e-01_rb, &
6392 8.782547e-01_rb,8.801915e-01_rb,8.815318e-01_rb,8.823347e-01_rb, &
6393 8.826598e-01_rb,8.825663e-01_rb,8.821135e-01_rb,8.813608e-01_rb, &
6394 8.803674e-01_rb,8.791928e-01_rb,8.778960e-01_rb,8.765366e-01_rb, &
6395 8.751738e-01_rb,8.738670e-01_rb,8.726755e-01_rb,8.716585e-01_rb, &
6396 8.708755e-01_rb,8.703856e-01_rb,8.702483e-01_rb,8.705229e-01_rb, &
6397 8.712687e-01_rb,8.725448e-01_rb,8.744109e-01_rb,8.769260e-01_rb, &
6398 8.801496e-01_rb,8.8414e-01_rb /)
6399 asyliq1(:, 25) = (/ &
6400 8.252182e-01_rb,8.379244e-01_rb,8.471709e-01_rb,8.535760e-01_rb, &
6401 8.577540e-01_rb,8.603183e-01_rb,8.618820e-01_rb,8.630578e-01_rb, &
6402 8.644587e-01_rb,8.666970e-01_rb,8.362159e-01_rb,8.536817e-01_rb, &
6403 8.666387e-01_rb,8.756240e-01_rb,8.811746e-01_rb,8.838273e-01_rb, &
6404 8.841191e-01_rb,8.825871e-01_rb,8.797681e-01_rb,8.761992e-01_rb, &
6405 8.724174e-01_rb,8.689593e-01_rb,8.663623e-01_rb,8.651632e-01_rb, &
6406 8.658988e-01_rb,8.691064e-01_rb,8.753226e-01_rb,8.850847e-01_rb, &
6407 8.641620e-01_rb,8.690500e-01_rb,8.731026e-01_rb,8.763795e-01_rb, &
6408 8.789400e-01_rb,8.808438e-01_rb,8.821503e-01_rb,8.829191e-01_rb, &
6409 8.832095e-01_rb,8.830813e-01_rb,8.825938e-01_rb,8.818064e-01_rb, &
6410 8.807787e-01_rb,8.795704e-01_rb,8.782408e-01_rb,8.768493e-01_rb, &
6411 8.754557e-01_rb,8.741193e-01_rb,8.728995e-01_rb,8.718561e-01_rb, &
6412 8.710484e-01_rb,8.705360e-01_rb,8.703782e-01_rb,8.706347e-01_rb, &
6413 8.713650e-01_rb,8.726285e-01_rb,8.744849e-01_rb,8.769933e-01_rb, &
6414 8.802136e-01_rb,8.8421e-01_rb /)
6415 asyliq1(:, 26) = (/ &
6416 8.370583e-01_rb,8.467920e-01_rb,8.537769e-01_rb,8.585136e-01_rb, &
6417 8.615034e-01_rb,8.632474e-01_rb,8.642468e-01_rb,8.650026e-01_rb, &
6418 8.660161e-01_rb,8.677882e-01_rb,8.369760e-01_rb,8.543821e-01_rb, &
6419 8.672699e-01_rb,8.761782e-01_rb,8.816454e-01_rb,8.842103e-01_rb, &
6420 8.844114e-01_rb,8.827872e-01_rb,8.798766e-01_rb,8.762179e-01_rb, &
6421 8.723500e-01_rb,8.688112e-01_rb,8.661403e-01_rb,8.648758e-01_rb, &
6422 8.655563e-01_rb,8.687206e-01_rb,8.749072e-01_rb,8.846546e-01_rb, &
6423 8.636289e-01_rb,8.684849e-01_rb,8.725054e-01_rb,8.757501e-01_rb, &
6424 8.782785e-01_rb,8.801503e-01_rb,8.814249e-01_rb,8.821620e-01_rb, &
6425 8.824211e-01_rb,8.822620e-01_rb,8.817440e-01_rb,8.809268e-01_rb, &
6426 8.798699e-01_rb,8.786330e-01_rb,8.772756e-01_rb,8.758572e-01_rb, &
6427 8.744374e-01_rb,8.730760e-01_rb,8.718323e-01_rb,8.707660e-01_rb, &
6428 8.699366e-01_rb,8.694039e-01_rb,8.692271e-01_rb,8.694661e-01_rb, &
6429 8.701803e-01_rb,8.714293e-01_rb,8.732727e-01_rb,8.757702e-01_rb, &
6430 8.789811e-01_rb,8.8297e-01_rb /)
6431 asyliq1(:, 27) = (/ &
6432 8.430819e-01_rb,8.510060e-01_rb,8.567270e-01_rb,8.606533e-01_rb, &
6433 8.631934e-01_rb,8.647554e-01_rb,8.657471e-01_rb,8.665760e-01_rb, &
6434 8.676496e-01_rb,8.693754e-01_rb,8.384298e-01_rb,8.557913e-01_rb, &
6435 8.686214e-01_rb,8.774605e-01_rb,8.828495e-01_rb,8.853287e-01_rb, &
6436 8.854393e-01_rb,8.837215e-01_rb,8.807161e-01_rb,8.769639e-01_rb, &
6437 8.730053e-01_rb,8.693812e-01_rb,8.666321e-01_rb,8.652988e-01_rb, &
6438 8.659219e-01_rb,8.690419e-01_rb,8.751999e-01_rb,8.849360e-01_rb, &
6439 8.638013e-01_rb,8.686371e-01_rb,8.726369e-01_rb,8.758605e-01_rb, &
6440 8.783674e-01_rb,8.802176e-01_rb,8.814705e-01_rb,8.821859e-01_rb, &
6441 8.824234e-01_rb,8.822429e-01_rb,8.817038e-01_rb,8.808658e-01_rb, &
6442 8.797887e-01_rb,8.785323e-01_rb,8.771560e-01_rb,8.757196e-01_rb, &
6443 8.742828e-01_rb,8.729052e-01_rb,8.716467e-01_rb,8.705666e-01_rb, &
6444 8.697250e-01_rb,8.691812e-01_rb,8.689950e-01_rb,8.692264e-01_rb, &
6445 8.699346e-01_rb,8.711795e-01_rb,8.730209e-01_rb,8.755181e-01_rb, &
6446 8.787312e-01_rb,8.8272e-01_rb /)
6447 asyliq1(:, 28) = (/ &
6448 8.452284e-01_rb,8.522700e-01_rb,8.572973e-01_rb,8.607031e-01_rb, &
6449 8.628802e-01_rb,8.642215e-01_rb,8.651198e-01_rb,8.659679e-01_rb, &
6450 8.671588e-01_rb,8.690853e-01_rb,8.383803e-01_rb,8.557485e-01_rb, &
6451 8.685851e-01_rb,8.774303e-01_rb,8.828245e-01_rb,8.853077e-01_rb, &
6452 8.854207e-01_rb,8.837034e-01_rb,8.806962e-01_rb,8.769398e-01_rb, &
6453 8.729740e-01_rb,8.693393e-01_rb,8.665761e-01_rb,8.652247e-01_rb, &
6454 8.658253e-01_rb,8.689182e-01_rb,8.750438e-01_rb,8.847424e-01_rb, &
6455 8.636140e-01_rb,8.684449e-01_rb,8.724400e-01_rb,8.756589e-01_rb, &
6456 8.781613e-01_rb,8.800072e-01_rb,8.812559e-01_rb,8.819671e-01_rb, &
6457 8.822007e-01_rb,8.820165e-01_rb,8.814737e-01_rb,8.806322e-01_rb, &
6458 8.795518e-01_rb,8.782923e-01_rb,8.769129e-01_rb,8.754737e-01_rb, &
6459 8.740342e-01_rb,8.726542e-01_rb,8.713934e-01_rb,8.703111e-01_rb, &
6460 8.694677e-01_rb,8.689222e-01_rb,8.687344e-01_rb,8.689646e-01_rb, &
6461 8.696715e-01_rb,8.709156e-01_rb,8.727563e-01_rb,8.752531e-01_rb, &
6462 8.784659e-01_rb,8.8245e-01_rb /)
6463 asyliq1(:, 29) = (/ &
6464 7.800869e-01_rb,8.091120e-01_rb,8.325369e-01_rb,8.466266e-01_rb, &
6465 8.515495e-01_rb,8.499371e-01_rb,8.456203e-01_rb,8.430521e-01_rb, &
6466 8.470286e-01_rb,8.625431e-01_rb,8.402261e-01_rb,8.610822e-01_rb, &
6467 8.776608e-01_rb,8.904485e-01_rb,8.999294e-01_rb,9.065860e-01_rb, &
6468 9.108995e-01_rb,9.133503e-01_rb,9.144187e-01_rb,9.145855e-01_rb, &
6469 9.143320e-01_rb,9.141402e-01_rb,9.144933e-01_rb,9.158754e-01_rb, &
6470 9.187716e-01_rb,9.236677e-01_rb,9.310503e-01_rb,9.414058e-01_rb, &
6471 9.239108e-01_rb,9.300719e-01_rb,9.353612e-01_rb,9.398378e-01_rb, &
6472 9.435609e-01_rb,9.465895e-01_rb,9.489829e-01_rb,9.508000e-01_rb, &
6473 9.521002e-01_rb,9.529424e-01_rb,9.533860e-01_rb,9.534902e-01_rb, &
6474 9.533143e-01_rb,9.529177e-01_rb,9.523596e-01_rb,9.516997e-01_rb, &
6475 9.509973e-01_rb,9.503121e-01_rb,9.497037e-01_rb,9.492317e-01_rb, &
6476 9.489558e-01_rb,9.489356e-01_rb,9.492311e-01_rb,9.499019e-01_rb, &
6477 9.510077e-01_rb,9.526084e-01_rb,9.547636e-01_rb,9.575331e-01_rb, &
6478 9.609766e-01_rb,9.6515e-01_rb /)
6479 !
6480 ! Spherical Ice Particle Parameterization
6481 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
6482 !
6483 extice2(:, 16) = (/ &
6484 ! band 16
6485 4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb, &
6486 1.063406e-01_rb,8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb, &
6487 5.970353e-02_rb,5.375249e-02_rb,4.887577e-02_rb,4.481025e-02_rb, &
6488 4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,3.365396e-02_rb, &
6489 3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb, &
6490 2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb, &
6491 2.175276e-02_rb,2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb, &
6492 1.888412e-02_rb,1.829018e-02_rb,1.773586e-02_rb,1.721738e-02_rb, &
6493 1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,1.544122e-02_rb, &
6494 1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb, &
6495 1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /)
6496 extice2(:, 17) = (/ &
6497 ! band 17
6498 3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb, &
6499 1.031602e-01_rb,8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb, &
6500 5.900909e-02_rb,5.328833e-02_rb,4.857728e-02_rb,4.463133e-02_rb, &
6501 4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,3.369280e-02_rb, &
6502 3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb, &
6503 2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb, &
6504 2.175571e-02_rb,2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb, &
6505 1.881278e-02_rb,1.819901e-02_rb,1.762463e-02_rb,1.708598e-02_rb, &
6506 1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,1.522937e-02_rb, &
6507 1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb, &
6508 1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /)
6509 extice2(:, 18) = (/ &
6510 ! band 18
6511 4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb, &
6512 1.047528e-01_rb,8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb, &
6513 5.844616e-02_rb,5.259609e-02_rb,4.781531e-02_rb,4.383980e-02_rb, &
6514 4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,3.298525e-02_rb, &
6515 3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb, &
6516 2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb, &
6517 2.152164e-02_rb,2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb, &
6518 1.878296e-02_rb,1.821744e-02_rb,1.769015e-02_rb,1.719741e-02_rb, &
6519 1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,1.551298e-02_rb, &
6520 1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb, &
6521 1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /)
6522 extice2(:, 19) = (/ &
6523 ! band 19
6524 3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb, &
6525 1.038247e-01_rb,8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb, &
6526 5.892850e-02_rb,5.313885e-02_rb,4.838068e-02_rb,4.440356e-02_rb, &
6527 4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,3.343269e-02_rb, &
6528 3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb, &
6529 2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb, &
6530 2.160789e-02_rb,2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb, &
6531 1.873177e-02_rb,1.813469e-02_rb,1.757689e-02_rb,1.705468e-02_rb, &
6532 1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,1.526192e-02_rb, &
6533 1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb, &
6534 1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /)
6535 extice2(:, 20) = (/ &
6536 ! band 20
6537 3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb, &
6538 1.028944e-01_rb,8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb, &
6539 5.866714e-02_rb,5.293694e-02_rb,4.822153e-02_rb,4.427547e-02_rb, &
6540 4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,3.336440e-02_rb, &
6541 3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb, &
6542 2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb, &
6543 2.154821e-02_rb,2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb, &
6544 1.866212e-02_rb,1.806221e-02_rb,1.750152e-02_rb,1.697637e-02_rb, &
6545 1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,1.517172e-02_rb, &
6546 1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb, &
6547 1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /)
6548 extice2(:, 21) = (/ &
6549 ! band 21
6550 3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb, &
6551 1.019462e-01_rb,8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb, &
6552 5.830218e-02_rb,5.263421e-02_rb,4.796697e-02_rb,4.405891e-02_rb, &
6553 4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,3.324008e-02_rb, &
6554 3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb, &
6555 2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb, &
6556 2.149614e-02_rb,2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb, &
6557 1.862174e-02_rb,1.802389e-02_rb,1.746500e-02_rb,1.694142e-02_rb, &
6558 1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,1.514129e-02_rb, &
6559 1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb, &
6560 1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /)
6561 extice2(:, 22) = (/ &
6562 ! band 22
6563 3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb, &
6564 1.016109e-01_rb,8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb, &
6565 5.810290e-02_rb,5.245608e-02_rb,4.780702e-02_rb,4.391478e-02_rb, &
6566 4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,3.314296e-02_rb, &
6567 3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb, &
6568 2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb, &
6569 2.145688e-02_rb,2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb, &
6570 1.859808e-02_rb,1.800356e-02_rb,1.744782e-02_rb,1.692721e-02_rb, &
6571 1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,1.513751e-02_rb, &
6572 1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb, &
6573 1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /)
6574 extice2(:, 23) = (/ &
6575 ! band 23
6576 3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb, &
6577 1.004203e-01_rb,8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb, &
6578 5.776176e-02_rb,5.219398e-02_rb,4.760288e-02_rb,4.375369e-02_rb, &
6579 4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,3.307079e-02_rb, &
6580 3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb, &
6581 2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb, &
6582 2.141556e-02_rb,2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb, &
6583 1.855009e-02_rb,1.795330e-02_rb,1.739514e-02_rb,1.687199e-02_rb, &
6584 1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,1.507143e-02_rb, &
6585 1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb, &
6586 1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /)
6587 extice2(:, 24) = (/ &
6588 ! band 24
6589 3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb, &
6590 9.955787e-02_rb,8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb, &
6591 5.751081e-02_rb,5.199888e-02_rb,4.744835e-02_rb,4.362899e-02_rb, &
6592 4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,3.300546e-02_rb, &
6593 3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb, &
6594 2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb, &
6595 2.136402e-02_rb,2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb, &
6596 1.849087e-02_rb,1.789178e-02_rb,1.733124e-02_rb,1.680565e-02_rb, &
6597 1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,1.499502e-02_rb, &
6598 1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb, &
6599 1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /)
6600 extice2(:, 25) = (/ &
6601 ! band 25
6602 3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb, &
6603 9.881779e-02_rb,8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb, &
6604 5.723183e-02_rb,5.176908e-02_rb,4.725658e-02_rb,4.346715e-02_rb, &
6605 4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,3.291583e-02_rb, &
6606 3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb, &
6607 2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb, &
6608 2.132934e-02_rb,2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb, &
6609 1.846448e-02_rb,1.786680e-02_rb,1.730745e-02_rb,1.678289e-02_rb, &
6610 1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,1.497499e-02_rb, &
6611 1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb, &
6612 1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /)
6613 extice2(:, 26) = (/ &
6614 ! band 26
6615 3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb, &
6616 9.838078e-02_rb,8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb, &
6617 5.703770e-02_rb,5.160290e-02_rb,4.711259e-02_rb,4.334110e-02_rb, &
6618 4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,3.283589e-02_rb, &
6619 3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb, &
6620 2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb, &
6621 2.129165e-02_rb,2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb, &
6622 1.843542e-02_rb,1.783943e-02_rb,1.728162e-02_rb,1.675847e-02_rb, &
6623 1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,1.495515e-02_rb, &
6624 1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb, &
6625 1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /)
6626 extice2(:, 27) = (/ &
6627 ! band 27
6628 3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb, &
6629 9.790253e-02_rb,8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb, &
6630 5.687024e-02_rb,5.146670e-02_rb,4.700001e-02_rb,4.324667e-02_rb, &
6631 4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,3.278257e-02_rb, &
6632 3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb, &
6633 2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb, &
6634 2.126273e-02_rb,2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb, &
6635 1.840801e-02_rb,1.781204e-02_rb,1.725417e-02_rb,1.673086e-02_rb, &
6636 1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,1.492634e-02_rb, &
6637 1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb, &
6638 1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /)
6639 extice2(:, 28) = (/ &
6640 ! band 28
6641 3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb, &
6642 9.804612e-02_rb,8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb, &
6643 5.697710e-02_rb,5.156460e-02_rb,4.708957e-02_rb,4.332850e-02_rb, &
6644 4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,3.283879e-02_rb, &
6645 3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb, &
6646 2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb, &
6647 2.128195e-02_rb,2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb, &
6648 1.841614e-02_rb,1.781774e-02_rb,1.725754e-02_rb,1.673203e-02_rb, &
6649 1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,1.491958e-02_rb, &
6650 1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb, &
6651 1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /)
6652 extice2(:, 29) = (/ &
6653 ! band 29
6654 4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb, &
6655 1.102161e-01_rb,9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb, &
6656 6.260168e-02_rb,5.645603e-02_rb,5.139732e-02_rb,4.716088e-02_rb, &
6657 4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,3.541094e-02_rb, &
6658 3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb, &
6659 2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb, &
6660 2.253072e-02_rb,2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb, &
6661 1.933015e-02_rb,1.866041e-02_rb,1.803283e-02_rb,1.744348e-02_rb, &
6662 1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,1.540539e-02_rb, &
6663 1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb, &
6664 1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /)
6665 !
6666 ! single-scattering albedo: unitless
6667 !
6668 ssaice2(:, 16) = (/ &
6669 ! band 16
6670 6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb, &
6671 6.178420e-01_rb,6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb, &
6672 5.995830e-01_rb,5.963030e-01_rb,5.933372e-01_rb,5.906311e-01_rb, &
6673 5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,5.816896e-01_rb, &
6674 5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb, &
6675 5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb, &
6676 5.677571e-01_rb,5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb, &
6677 5.630643e-01_rb,5.619850e-01_rb,5.609381e-01_rb,5.599214e-01_rb, &
6678 5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,5.561193e-01_rb, &
6679 5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb, &
6680 5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /)
6681 ssaice2(:, 17) = (/ &
6682 ! band 17
6683 7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb, &
6684 6.956928e-01_rb,6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb, &
6685 6.679838e-01_rb,6.632742e-01_rb,6.591036e-01_rb,6.553766e-01_rb, &
6686 6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,6.436531e-01_rb, &
6687 6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb, &
6688 6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb, &
6689 6.274512e-01_rb,6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb, &
6690 6.225953e-01_rb,6.215201e-01_rb,6.204914e-01_rb,6.195055e-01_rb, &
6691 6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,6.159280e-01_rb, &
6692 6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb, &
6693 6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /)
6694 ssaice2(:, 18) = (/ &
6695 ! band 18
6696 9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb, &
6697 9.577179e-01_rb,9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb, &
6698 9.399467e-01_rb,9.365708e-01_rb,9.334672e-01_rb,9.305921e-01_rb, &
6699 9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,9.207954e-01_rb, &
6700 9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb, &
6701 9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb, &
6702 9.046406e-01_rb,9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb, &
6703 8.989804e-01_rb,8.976655e-01_rb,8.963857e-01_rb,8.951389e-01_rb, &
6704 8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,8.904464e-01_rb, &
6705 8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb, &
6706 8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /)
6707 ssaice2(:, 19) = (/ &
6708 ! band 19
6709 9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb, &
6710 9.014238e-01_rb,8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb, &
6711 8.701736e-01_rb,8.643950e-01_rb,8.591299e-01_rb,8.542942e-01_rb, &
6712 8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,8.381324e-01_rb, &
6713 8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb, &
6714 8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb, &
6715 8.126403e-01_rb,8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb, &
6716 8.040765e-01_rb,8.021156e-01_rb,8.002174e-01_rb,7.983781e-01_rb, &
6717 7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,7.915432e-01_rb, &
6718 7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb, &
6719 7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /)
6720 ssaice2(:, 20) = (/ &
6721 ! band 20
6722 9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb, &
6723 9.743652e-01_rb,9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb, &
6724 9.659531e-01_rb,9.643915e-01_rb,9.629667e-01_rb,9.616561e-01_rb, &
6725 9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,9.572607e-01_rb, &
6726 9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb, &
6727 9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb, &
6728 9.502643e-01_rb,9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb, &
6729 9.478910e-01_rb,9.473456e-01_rb,9.468169e-01_rb,9.463039e-01_rb, &
6730 9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,9.443910e-01_rb, &
6731 9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb, &
6732 9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /)
6733 ssaice2(:, 21) = (/ &
6734 ! band 21
6735 9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb, &
6736 9.710184e-01_rb,9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb, &
6737 9.623352e-01_rb,9.607083e-01_rb,9.592198e-01_rb,9.578474e-01_rb, &
6738 9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,9.532226e-01_rb, &
6739 9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb, &
6740 9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb, &
6741 9.457985e-01_rb,9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb, &
6742 9.432656e-01_rb,9.426826e-01_rb,9.421173e-01_rb,9.415684e-01_rb, &
6743 9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,9.395198e-01_rb, &
6744 9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb, &
6745 9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /)
6746 ssaice2(:, 22) = (/ &
6747 ! band 22
6748 9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb, &
6749 9.981606e-01_rb,9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb, &
6750 9.977691e-01_rb,9.976798e-01_rb,9.975929e-01_rb,9.975081e-01_rb, &
6751 9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,9.971855e-01_rb, &
6752 9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb, &
6753 9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb, &
6754 9.965250e-01_rb,9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb, &
6755 9.962508e-01_rb,9.961836e-01_rb,9.961170e-01_rb,9.960508e-01_rb, &
6756 9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,9.957906e-01_rb, &
6757 9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb, &
6758 9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /)
6759 ssaice2(:, 23) = (/ &
6760 ! band 23
6761 9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb, &
6762 9.997436e-01_rb,9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb, &
6763 9.996999e-01_rb,9.996886e-01_rb,9.996771e-01_rb,9.996653e-01_rb, &
6764 9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,9.996152e-01_rb, &
6765 9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb, &
6766 9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb, &
6767 9.994831e-01_rb,9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb, &
6768 9.994154e-01_rb,9.993976e-01_rb,9.993795e-01_rb,9.993610e-01_rb, &
6769 9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,9.992837e-01_rb, &
6770 9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb, &
6771 9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /)
6772 ssaice2(:, 24) = (/ &
6773 ! band 24
6774 9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb, &
6775 9.999934e-01_rb,9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb, &
6776 9.999904e-01_rb,9.999895e-01_rb,9.999885e-01_rb,9.999874e-01_rb, &
6777 9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,9.999824e-01_rb, &
6778 9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb, &
6779 9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb, &
6780 9.999673e-01_rb,9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb, &
6781 9.999589e-01_rb,9.999566e-01_rb,9.999543e-01_rb,9.999519e-01_rb, &
6782 9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,9.999418e-01_rb, &
6783 9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb, &
6784 9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /)
6785 ssaice2(:, 25) = (/ &
6786 ! band 25
6787 9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb, &
6788 9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb, &
6789 9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999989e-01_rb, &
6790 9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb, &
6791 9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb, &
6792 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb, &
6793 9.999969e-01_rb,9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb, &
6794 9.999960e-01_rb,9.999957e-01_rb,9.999955e-01_rb,9.999953e-01_rb, &
6795 9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,9.999942e-01_rb, &
6796 9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb, &
6797 9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /)
6798 ssaice2(:, 26) = (/ &
6799 ! band 26
6800 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb, &
6801 9.999994e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb, &
6802 9.999990e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb, &
6803 9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb, &
6804 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb, &
6805 9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb, &
6806 9.999956e-01_rb,9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb, &
6807 9.999944e-01_rb,9.999941e-01_rb,9.999938e-01_rb,9.999934e-01_rb, &
6808 9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,9.999920e-01_rb, &
6809 9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb, &
6810 9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /)
6811 ssaice2(:, 27) = (/ &
6812 ! band 27
6813 9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb, &
6814 9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb, &
6815 9.999973e-01_rb,9.999970e-01_rb,9.999967e-01_rb,9.999964e-01_rb, &
6816 9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,9.999948e-01_rb, &
6817 9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb, &
6818 9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb, &
6819 9.999901e-01_rb,9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb, &
6820 9.999874e-01_rb,9.999867e-01_rb,9.999860e-01_rb,9.999853e-01_rb, &
6821 9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,9.999821e-01_rb, &
6822 9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb, &
6823 9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /)
6824 ssaice2(:, 28) = (/ &
6825 ! band 28
6826 9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb, &
6827 9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb, &
6828 9.999975e-01_rb,9.999972e-01_rb,9.999969e-01_rb,9.999966e-01_rb, &
6829 9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,9.999950e-01_rb, &
6830 9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb, &
6831 9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb, &
6832 9.999902e-01_rb,9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb, &
6833 9.999876e-01_rb,9.999869e-01_rb,9.999861e-01_rb,9.999854e-01_rb, &
6834 9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,9.999822e-01_rb, &
6835 9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb, &
6836 9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /)
6837 ssaice2(:, 29) = (/ &
6838 ! band 29
6839 7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb, &
6840 6.166381e-01_rb,6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb, &
6841 5.826968e-01_rb,5.767343e-01_rb,5.713804e-01_rb,5.665256e-01_rb, &
6842 5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,5.506794e-01_rb, &
6843 5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb, &
6844 5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb, &
6845 5.263988e-01_rb,5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb, &
6846 5.182280e-01_rb,5.163410e-01_rb,5.145062e-01_rb,5.127197e-01_rb, &
6847 5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,5.059860e-01_rb, &
6848 5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb, &
6849 4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /)
6850 !
6851 ! asymmetry factor: unitless
6852 !
6853 asyice2(:, 16) = (/ &
6854 ! band 16
6855 7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb, &
6856 9.041676e-01_rb,9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb, &
6857 9.216573e-01_rb,9.239620e-01_rb,9.258695e-01_rb,9.274745e-01_rb, &
6858 9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,9.319665e-01_rb, &
6859 9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb, &
6860 9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb, &
6861 9.369722e-01_rb,9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb, &
6862 9.382352e-01_rb,9.385010e-01_rb,9.387505e-01_rb,9.389854e-01_rb, &
6863 9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,9.398024e-01_rb, &
6864 9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb, &
6865 9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /)
6866 asyice2(:, 17) = (/ &
6867 ! band 17
6868 9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb, &
6869 9.354632e-01_rb,9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb, &
6870 9.446301e-01_rb,9.461351e-01_rb,9.474555e-01_rb,9.486259e-01_rb, &
6871 9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,9.522476e-01_rb, &
6872 9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb, &
6873 9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb, &
6874 9.570953e-01_rb,9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb, &
6875 9.585054e-01_rb,9.588142e-01_rb,9.591083e-01_rb,9.593888e-01_rb, &
6876 9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,9.603952e-01_rb, &
6877 9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb, &
6878 9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /)
6879 asyice2(:, 18) = (/ &
6880 ! band 18
6881 8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb, &
6882 8.789054e-01_rb,8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb, &
6883 8.932532e-01_rb,8.955965e-01_rb,8.976567e-01_rb,8.994887e-01_rb, &
6884 9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,9.052237e-01_rb, &
6885 9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb, &
6886 9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb, &
6887 9.132140e-01_rb,9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb, &
6888 9.156524e-01_rb,9.161955e-01_rb,9.167160e-01_rb,9.172157e-01_rb, &
6889 9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,9.190330e-01_rb, &
6890 9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb, &
6891 9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /)
6892 asyice2(:, 19) = (/ &
6893 ! band 19
6894 8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb, &
6895 8.865810e-01_rb,8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb, &
6896 9.028980e-01_rb,9.052513e-01_rb,9.072468e-01_rb,9.089632e-01_rb, &
6897 9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,9.139793e-01_rb, &
6898 9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb, &
6899 9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb, &
6900 9.200455e-01_rb,9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb, &
6901 9.216771e-01_rb,9.220262e-01_rb,9.223560e-01_rb,9.226680e-01_rb, &
6902 9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,9.237652e-01_rb, &
6903 9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb, &
6904 9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /)
6905 asyice2(:, 20) = (/ &
6906 ! band 20
6907 8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb, &
6908 8.733206e-01_rb,8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb, &
6909 8.862225e-01_rb,8.879904e-01_rb,8.894682e-01_rb,8.907228e-01_rb, &
6910 8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,8.942943e-01_rb, &
6911 8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb, &
6912 8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb, &
6913 8.983966e-01_rb,8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb, &
6914 8.994533e-01_rb,8.996766e-01_rb,8.998865e-01_rb,9.000843e-01_rb, &
6915 9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,9.007731e-01_rb, &
6916 9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb, &
6917 9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /)
6918 asyice2(:, 21) = (/ &
6919 ! band 21
6920 8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb, &
6921 8.758555e-01_rb,8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb, &
6922 8.865939e-01_rb,8.880564e-01_rb,8.892765e-01_rb,8.903105e-01_rb, &
6923 8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,8.932419e-01_rb, &
6924 8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb, &
6925 8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb, &
6926 8.965762e-01_rb,8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb, &
6927 8.974255e-01_rb,8.976042e-01_rb,8.977720e-01_rb,8.979298e-01_rb, &
6928 8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,8.984771e-01_rb, &
6929 8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb, &
6930 8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /)
6931 asyice2(:, 22) = (/ &
6932 ! band 22
6933 8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb, &
6934 8.713217e-01_rb,8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb, &
6935 8.811370e-01_rb,8.824649e-01_rb,8.835711e-01_rb,8.845073e-01_rb, &
6936 8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,8.871560e-01_rb, &
6937 8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb, &
6938 8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb, &
6939 8.901612e-01_rb,8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb, &
6940 8.909265e-01_rb,8.910876e-01_rb,8.912388e-01_rb,8.913812e-01_rb, &
6941 8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,8.918752e-01_rb, &
6942 8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb, &
6943 8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /)
6944 asyice2(:, 23) = (/ &
6945 ! band 23
6946 8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb, &
6947 8.747605e-01_rb,8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb, &
6948 8.821179e-01_rb,8.831583e-01_rb,8.840361e-01_rb,8.847875e-01_rb, &
6949 8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,8.869634e-01_rb, &
6950 8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb, &
6951 8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb, &
6952 8.895504e-01_rb,8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb, &
6953 8.902370e-01_rb,8.903833e-01_rb,8.905214e-01_rb,8.906518e-01_rb, &
6954 8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,8.911094e-01_rb, &
6955 8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb, &
6956 8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /)
6957 asyice2(:, 24) = (/ &
6958 ! band 24
6959 8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb, &
6960 8.776354e-01_rb,8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb, &
6961 8.832225e-01_rb,8.840333e-01_rb,8.847224e-01_rb,8.853162e-01_rb, &
6962 8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,8.870595e-01_rb, &
6963 8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb, &
6964 8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb, &
6965 8.891895e-01_rb,8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb, &
6966 8.897683e-01_rb,8.898926e-01_rb,8.900102e-01_rb,8.901215e-01_rb, &
6967 8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,8.905144e-01_rb, &
6968 8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb, &
6969 8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /)
6970 asyice2(:, 25) = (/ &
6971 ! band 25
6972 8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb, &
6973 8.789378e-01_rb,8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb, &
6974 8.835480e-01_rb,8.842152e-01_rb,8.847817e-01_rb,8.852696e-01_rb, &
6975 8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,8.866997e-01_rb, &
6976 8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb, &
6977 8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb, &
6978 8.884418e-01_rb,8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb, &
6979 8.889139e-01_rb,8.890152e-01_rb,8.891110e-01_rb,8.892017e-01_rb, &
6980 8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,8.895214e-01_rb, &
6981 8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb, &
6982 8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /)
6983 asyice2(:, 26) = (/ &
6984 ! band 26
6985 8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb, &
6986 8.796983e-01_rb,8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb, &
6987 8.829953e-01_rb,8.834501e-01_rb,8.838310e-01_rb,8.841549e-01_rb, &
6988 8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,8.850795e-01_rb, &
6989 8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb, &
6990 8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb, &
6991 8.861464e-01_rb,8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb, &
6992 8.864218e-01_rb,8.864800e-01_rb,8.865347e-01_rb,8.865863e-01_rb, &
6993 8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,8.867658e-01_rb, &
6994 8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb, &
6995 8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /)
6996 asyice2(:, 27) = (/ &
6997 ! band 27
6998 8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb, &
6999 8.768846e-01_rb,8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb, &
7000 8.799960e-01_rb,8.804159e-01_rb,8.807660e-01_rb,8.810626e-01_rb, &
7001 8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,8.819057e-01_rb, &
7002 8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb, &
7003 8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb, &
7004 8.828764e-01_rb,8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb, &
7005 8.831283e-01_rb,8.831817e-01_rb,8.832320e-01_rb,8.832795e-01_rb, &
7006 8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,8.834454e-01_rb, &
7007 8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb, &
7008 8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /)
7009 asyice2(:, 28) = (/ &
7010 ! band 28
7011 8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb, &
7012 8.770154e-01_rb,8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb, &
7013 8.799348e-01_rb,8.802952e-01_rb,8.805880e-01_rb,8.808300e-01_rb, &
7014 8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,8.814832e-01_rb, &
7015 8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb, &
7016 8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb, &
7017 8.821573e-01_rb,8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb, &
7018 8.823150e-01_rb,8.823474e-01_rb,8.823775e-01_rb,8.824056e-01_rb, &
7019 8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,8.825011e-01_rb, &
7020 8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb, &
7021 8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /)
7022 asyice2(:, 29) = (/ &
7023 ! band 29
7024 8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb, &
7025 9.142334e-01_rb,9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb, &
7026 9.375689e-01_rb,9.412085e-01_rb,9.443604e-01_rb,9.471230e-01_rb, &
7027 9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,9.555057e-01_rb, &
7028 9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb, &
7029 9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb, &
7030 9.664513e-01_rb,9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb, &
7031 9.696256e-01_rb,9.703237e-01_rb,9.709903e-01_rb,9.716280e-01_rb, &
7032 9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,9.739336e-01_rb, &
7033 9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb, &
7034 9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /)
7035 !
7036 ! Hexagonal Ice Particle Parameterization
7037 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
7038 !
7039 extice3(:, 16) = (/ &
7040 ! band 16
7041 5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb, &
7042 1.499977e-01_rb,1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb, &
7043 8.764435e-02_rb,7.939266e-02_rb,7.256081e-02_rb,6.681137e-02_rb, &
7044 6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,5.073102e-02_rb, &
7045 4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb, &
7046 3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb, &
7047 3.290694e-02_rb,3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb, &
7048 2.846172e-02_rb,2.753188e-02_rb,2.666085e-02_rb,2.584322e-02_rb, &
7049 2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,2.301926e-02_rb, &
7050 2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb, &
7051 2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb, &
7052 1.847607e-02_rb,1.807956e-02_rb /)
7053 extice3(:, 17) = (/ &
7054 ! band 17
7055 4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb, &
7056 1.445402e-01_rb,1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb, &
7057 8.495824e-02_rb,7.704501e-02_rb,7.048834e-02_rb,6.496693e-02_rb, &
7058 6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,4.950698e-02_rb, &
7059 4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb, &
7060 3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb, &
7061 3.234041e-02_rb,3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb, &
7062 2.805413e-02_rb,2.715727e-02_rb,2.631705e-02_rb,2.552828e-02_rb, &
7063 2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,2.280343e-02_rb, &
7064 2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb, &
7065 2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb, &
7066 1.841781e-02_rb,1.803494e-02_rb /)
7067 extice3(:, 18) = (/ &
7068 ! band 18
7069 5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb, &
7070 1.487318e-01_rb,1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb, &
7071 8.719819e-02_rb,7.902576e-02_rb,7.225433e-02_rb,6.655206e-02_rb, &
7072 6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,5.058572e-02_rb, &
7073 4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb, &
7074 3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb, &
7075 3.285686e-02_rb,3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb, &
7076 2.843018e-02_rb,2.750395e-02_rb,2.663621e-02_rb,2.582160e-02_rb, &
7077 2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,2.300750e-02_rb, &
7078 2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb, &
7079 2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb, &
7080 1.847823e-02_rb,1.808281e-02_rb /)
7081 extice3(:, 19) = (/ &
7082 ! band 19
7083 4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb, &
7084 1.443736e-01_rb,1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb, &
7085 8.509997e-02_rb,7.722769e-02_rb,7.070495e-02_rb,6.521211e-02_rb, &
7086 6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,4.983217e-02_rb, &
7087 4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb, &
7088 3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb, &
7089 3.275444e-02_rb,3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb, &
7090 2.849034e-02_rb,2.759812e-02_rb,2.676226e-02_rb,2.597757e-02_rb, &
7091 2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,2.326682e-02_rb, &
7092 2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb, &
7093 2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb, &
7094 1.890389e-02_rb,1.852300e-02_rb /)
7095 extice3(:, 20) = (/ &
7096 ! band 20
7097 5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb, &
7098 1.497944e-01_rb,1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb, &
7099 8.762610e-02_rb,7.936938e-02_rb,7.252809e-02_rb,6.676701e-02_rb, &
7100 6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,5.063598e-02_rb, &
7101 4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb, &
7102 3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb, &
7103 3.272425e-02_rb,3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb, &
7104 2.825191e-02_rb,2.731612e-02_rb,2.643943e-02_rb,2.561642e-02_rb, &
7105 2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,2.277329e-02_rb, &
7106 2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb, &
7107 1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb, &
7108 1.819730e-02_rb,1.779781e-02_rb /)
7109 extice3(:, 21) = (/ &
7110 ! band 21
7111 5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb, &
7112 1.479819e-01_rb,1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb, &
7113 8.675183e-02_rb,7.861971e-02_rb,7.188168e-02_rb,6.620754e-02_rb, &
7114 6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,5.031995e-02_rb, &
7115 4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb, &
7116 3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb, &
7117 3.267854e-02_rb,3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb, &
7118 2.827370e-02_rb,2.735203e-02_rb,2.648858e-02_rb,2.567798e-02_rb, &
7119 2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,2.287776e-02_rb, &
7120 2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb, &
7121 2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb, &
7122 1.837083e-02_rb,1.797737e-02_rb /)
7123 extice3(:, 22) = (/ &
7124 ! band 22
7125 4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb, &
7126 1.460446e-01_rb,1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb, &
7127 8.588928e-02_rb,7.789990e-02_rb,7.128013e-02_rb,6.570559e-02_rb, &
7128 6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,5.009688e-02_rb, &
7129 4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb, &
7130 3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb, &
7131 3.276512e-02_rb,3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb, &
7132 2.843759e-02_rb,2.753211e-02_rb,2.668381e-02_rb,2.588744e-02_rb, &
7133 2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,2.313637e-02_rb, &
7134 2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb, &
7135 2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb, &
7136 1.870855e-02_rb,1.832199e-02_rb /)
7137 extice3(:, 23) = (/ &
7138 ! band 23
7139 5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb, &
7140 1.485473e-01_rb,1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb, &
7141 8.704139e-02_rb,7.887264e-02_rb,7.210424e-02_rb,6.640454e-02_rb, &
7142 6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,5.044537e-02_rb, &
7143 4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb, &
7144 3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb, &
7145 3.272448e-02_rb,3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb, &
7146 2.829979e-02_rb,2.737397e-02_rb,2.650663e-02_rb,2.569238e-02_rb, &
7147 2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,2.287954e-02_rb, &
7148 2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb, &
7149 2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb, &
7150 1.835231e-02_rb,1.795707e-02_rb /)
7151 extice3(:, 24) = (/ &
7152 ! band 24
7153 5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb, &
7154 1.482779e-01_rb,1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb, &
7155 8.691087e-02_rb,7.876056e-02_rb,7.200745e-02_rb,6.632062e-02_rb, &
7156 6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,5.039749e-02_rb, &
7157 4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb, &
7158 3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb, &
7159 3.271661e-02_rb,3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb, &
7160 2.830191e-02_rb,2.737818e-02_rb,2.651279e-02_rb,2.570039e-02_rb, &
7161 2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,2.289390e-02_rb, &
7162 2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb, &
7163 2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb, &
7164 1.837688e-02_rb,1.798254e-02_rb /)
7165 extice3(:, 25) = (/ &
7166 ! band 25
7167 5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb, &
7168 1.477544e-01_rb,1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb, &
7169 8.663439e-02_rb,7.851688e-02_rb,7.179095e-02_rb,6.612700e-02_rb, &
7170 6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,5.026796e-02_rb, &
7171 4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb, &
7172 3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb, &
7173 3.265824e-02_rb,3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb, &
7174 2.826131e-02_rb,2.734130e-02_rb,2.647939e-02_rb,2.567026e-02_rb, &
7175 2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,2.287507e-02_rb, &
7176 2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb, &
7177 2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb, &
7178 1.837623e-02_rb,1.798348e-02_rb /)
7179 extice3(:, 26) = (/ &
7180 ! band 26
7181 5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb, &
7182 1.489122e-01_rb,1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb, &
7183 8.720201e-02_rb,7.900612e-02_rb,7.221524e-02_rb,6.649660e-02_rb, &
7184 6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,5.048442e-02_rb, &
7185 4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb, &
7186 3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb, &
7187 3.270466e-02_rb,3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb, &
7188 2.826527e-02_rb,2.733638e-02_rb,2.646615e-02_rb,2.564920e-02_rb, &
7189 2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,2.282702e-02_rb, &
7190 2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb, &
7191 2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb, &
7192 1.828474e-02_rb,1.788819e-02_rb /)
7193 extice3(:, 27) = (/ &
7194 ! band 27
7195 5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb, &
7196 1.491691e-01_rb,1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb, &
7197 8.734125e-02_rb,7.912973e-02_rb,7.232591e-02_rb,6.659637e-02_rb, &
7198 6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,5.055367e-02_rb, &
7199 4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb, &
7200 3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb, &
7201 3.274002e-02_rb,3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb, &
7202 2.829216e-02_rb,2.736150e-02_rb,2.648961e-02_rb,2.567111e-02_rb, &
7203 2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,2.284354e-02_rb, &
7204 2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb, &
7205 2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb, &
7206 1.829261e-02_rb,1.789531e-02_rb /)
7207 extice3(:, 28) = (/ &
7208 ! band 28
7209 5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb, &
7210 1.487921e-01_rb,1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb, &
7211 8.716516e-02_rb,7.898034e-02_rb,7.219863e-02_rb,6.648771e-02_rb, &
7212 6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,5.049716e-02_rb, &
7213 4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb, &
7214 3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb, &
7215 3.274141e-02_rb,3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb, &
7216 2.830801e-02_rb,2.738037e-02_rb,2.651132e-02_rb,2.569547e-02_rb, &
7217 2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,2.287710e-02_rb, &
7218 2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb, &
7219 2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb, &
7220 1.834096e-02_rb,1.794495e-02_rb /)
7221 extice3(:, 29) = (/ &
7222 ! band 29
7223 1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb, &
7224 1.343937e-01_rb,1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb, &
7225 8.685880e-02_rb,7.948698e-02_rb,7.319086e-02_rb,6.775669e-02_rb, &
7226 6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,5.189810e-02_rb, &
7227 4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb, &
7228 3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb, &
7229 3.317880e-02_rb,3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb, &
7230 2.832256e-02_rb,2.729724e-02_rb,2.633377e-02_rb,2.542675e-02_rb, &
7231 2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,2.227443e-02_rb, &
7232 2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb, &
7233 1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb, &
7234 1.713899e-02_rb,1.668704e-02_rb /)
7235 !
7236 ! single-scattering albedo: unitless
7237 !
7238 ssaice3(:, 16) = (/ &
7239 ! band 16
7240 6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb, &
7241 6.420046e-01_rb,6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb, &
7242 6.186783e-01_rb,6.138395e-01_rb,6.093543e-01_rb,6.052049e-01_rb, &
7243 6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,5.916302e-01_rb, &
7244 5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb, &
7245 5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb, &
7246 5.744262e-01_rb,5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb, &
7247 5.704097e-01_rb,5.695739e-01_rb,5.687747e-01_rb,5.679964e-01_rb, &
7248 5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,5.647860e-01_rb, &
7249 5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb, &
7250 5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb, &
7251 5.527976e-01_rb,5.507005e-01_rb /)
7252 ssaice3(:, 17) = (/ &
7253 ! band 17
7254 7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb, &
7255 7.397745e-01_rb,7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb, &
7256 7.201945e-01_rb,7.157894e-01_rb,7.115652e-01_rb,7.075145e-01_rb, &
7257 7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,6.929007e-01_rb, &
7258 6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb, &
7259 6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb, &
7260 6.673637e-01_rb,6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb, &
7261 6.582561e-01_rb,6.561163e-01_rb,6.540182e-01_rb,6.519554e-01_rb, &
7262 6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,6.439289e-01_rb, &
7263 6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb, &
7264 6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb, &
7265 6.254825e-01_rb,6.232583e-01_rb /)
7266 ssaice3(:, 18) = (/ &
7267 ! band 18
7268 9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb, &
7269 9.763566e-01_rb,9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb, &
7270 9.615104e-01_rb,9.579725e-01_rb,9.544997e-01_rb,9.510901e-01_rb, &
7271 9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,9.380415e-01_rb, &
7272 9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb, &
7273 9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb, &
7274 9.115688e-01_rb,9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb, &
7275 9.007846e-01_rb,8.981592e-01_rb,8.955581e-01_rb,8.929792e-01_rb, &
7276 8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,8.828464e-01_rb, &
7277 8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb, &
7278 8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb, &
7279 8.605744e-01_rb,8.580989e-01_rb /)
7280 ssaice3(:, 19) = (/ &
7281 ! band 19
7282 9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb, &
7283 9.205529e-01_rb,9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb, &
7284 8.843699e-01_rb,8.761992e-01_rb,8.683536e-01_rb,8.608204e-01_rb, &
7285 8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,8.335635e-01_rb, &
7286 8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb, &
7287 8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb, &
7288 7.856825e-01_rb,7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb, &
7289 7.685711e-01_rb,7.645522e-01_rb,7.606126e-01_rb,7.567404e-01_rb, &
7290 7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,7.416844e-01_rb, &
7291 7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb, &
7292 7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb, &
7293 7.070811e-01_rb,7.028972e-01_rb /)
7294 ssaice3(:, 20) = (/ &
7295 ! band 20
7296 9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb, &
7297 9.813746e-01_rb,9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb, &
7298 9.694553e-01_rb,9.666088e-01_rb,9.638123e-01_rb,9.610641e-01_rb, &
7299 9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,9.505211e-01_rb, &
7300 9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb, &
7301 9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb, &
7302 9.289731e-01_rb,9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb, &
7303 9.201147e-01_rb,9.179496e-01_rb,9.158008e-01_rb,9.136667e-01_rb, &
7304 9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,9.052436e-01_rb, &
7305 9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb, &
7306 8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb, &
7307 8.864907e-01_rb,8.843843e-01_rb /)
7308 ssaice3(:, 21) = (/ &
7309 ! band 21
7310 9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb, &
7311 9.800523e-01_rb,9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb, &
7312 9.680106e-01_rb,9.651862e-01_rb,9.624315e-01_rb,9.597439e-01_rb, &
7313 9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,9.496177e-01_rb, &
7314 9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb, &
7315 9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb, &
7316 9.298313e-01_rb,9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb, &
7317 9.220198e-01_rb,9.201338e-01_rb,9.182700e-01_rb,9.164258e-01_rb, &
7318 9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,9.091999e-01_rb, &
7319 9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb, &
7320 9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb, &
7321 8.931888e-01_rb,8.913770e-01_rb /)
7322 ssaice3(:, 22) = (/ &
7323 ! band 22
7324 9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb, &
7325 9.983724e-01_rb,9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb, &
7326 9.972623e-01_rb,9.969849e-01_rb,9.967077e-01_rb,9.964305e-01_rb, &
7327 9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,9.953230e-01_rb, &
7328 9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb, &
7329 9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb, &
7330 9.928390e-01_rb,9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb, &
7331 9.917396e-01_rb,9.914652e-01_rb,9.911911e-01_rb,9.909171e-01_rb, &
7332 9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,9.898237e-01_rb, &
7333 9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb, &
7334 9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb, &
7335 9.873784e-01_rb,9.871081e-01_rb /)
7336 ssaice3(:, 23) = (/ &
7337 ! band 23
7338 9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb, &
7339 9.997642e-01_rb,9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb, &
7340 9.995949e-01_rb,9.995528e-01_rb,9.995106e-01_rb,9.994686e-01_rb, &
7341 9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,9.993007e-01_rb, &
7342 9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb, &
7343 9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb, &
7344 9.989260e-01_rb,9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb, &
7345 9.987606e-01_rb,9.987194e-01_rb,9.986782e-01_rb,9.986370e-01_rb, &
7346 9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,9.984729e-01_rb, &
7347 9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb, &
7348 9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb, &
7349 9.981059e-01_rb,9.980653e-01_rb /)
7350 ssaice3(:, 24) = (/ &
7351 ! band 24
7352 9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb, &
7353 9.999926e-01_rb,9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb, &
7354 9.999873e-01_rb,9.999860e-01_rb,9.999847e-01_rb,9.999834e-01_rb, &
7355 9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,9.999782e-01_rb, &
7356 9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb, &
7357 9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb, &
7358 9.999665e-01_rb,9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb, &
7359 9.999613e-01_rb,9.999600e-01_rb,9.999587e-01_rb,9.999574e-01_rb, &
7360 9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,9.999522e-01_rb, &
7361 9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb, &
7362 9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb, &
7363 9.999405e-01_rb,9.999392e-01_rb /)
7364 ssaice3(:, 25) = (/ &
7365 ! band 25
7366 9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb, &
7367 9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb, &
7368 9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999979e-01_rb, &
7369 9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999973e-01_rb, &
7370 9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb, &
7371 9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb, &
7372 9.999960e-01_rb,9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb, &
7373 9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,9.999950e-01_rb, &
7374 9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,9.999944e-01_rb, &
7375 9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb, &
7376 9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb, &
7377 9.999931e-01_rb,9.999930e-01_rb /)
7378 ssaice3(:, 26) = (/ &
7379 ! band 26
7380 9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb, &
7381 9.999987e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb, &
7382 9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999971e-01_rb, &
7383 9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,9.999963e-01_rb, &
7384 9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb, &
7385 9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb, &
7386 9.999944e-01_rb,9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb, &
7387 9.999935e-01_rb,9.999933e-01_rb,9.999931e-01_rb,9.999929e-01_rb, &
7388 9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,9.999920e-01_rb, &
7389 9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb, &
7390 9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb, &
7391 9.999900e-01_rb,9.999897e-01_rb /)
7392 ssaice3(:, 27) = (/ &
7393 ! band 27
7394 9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb, &
7395 9.999968e-01_rb,9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb, &
7396 9.999946e-01_rb,9.999940e-01_rb,9.999934e-01_rb,9.999929e-01_rb, &
7397 9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,9.999907e-01_rb, &
7398 9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb, &
7399 9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb, &
7400 9.999858e-01_rb,9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb, &
7401 9.999836e-01_rb,9.999831e-01_rb,9.999826e-01_rb,9.999820e-01_rb, &
7402 9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,9.999798e-01_rb, &
7403 9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb, &
7404 9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb, &
7405 9.999748e-01_rb,9.999742e-01_rb /)
7406 ssaice3(:, 28) = (/ &
7407 ! band 28
7408 9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb, &
7409 9.999917e-01_rb,9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb, &
7410 9.999859e-01_rb,9.999845e-01_rb,9.999831e-01_rb,9.999816e-01_rb, &
7411 9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,9.999759e-01_rb, &
7412 9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb, &
7413 9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb, &
7414 9.999631e-01_rb,9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb, &
7415 9.999574e-01_rb,9.999560e-01_rb,9.999546e-01_rb,9.999532e-01_rb, &
7416 9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,9.999474e-01_rb, &
7417 9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb, &
7418 9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb, &
7419 9.999345e-01_rb,9.999330e-01_rb /)
7420 ssaice3(:, 29) = (/ &
7421 ! band 29
7422 4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb, &
7423 5.485149e-01_rb,5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb, &
7424 5.507364e-01_rb,5.503793e-01_rb,5.498090e-01_rb,5.490612e-01_rb, &
7425 5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,5.447878e-01_rb, &
7426 5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb, &
7427 5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb, &
7428 5.323140e-01_rb,5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb, &
7429 5.276704e-01_rb,5.267680e-01_rb,5.260000e-01_rb,5.253823e-01_rb, &
7430 5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,5.247434e-01_rb, &
7431 5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb, &
7432 5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb, &
7433 5.388676e-01_rb,5.422146e-01_rb /)
7434 !
7435 ! asymmetry factor: unitless
7436 !
7437 asyice3(:, 16) = (/ &
7438 ! band 16
7439 8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb, &
7440 8.660387e-01_rb,8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb, &
7441 8.882934e-01_rb,8.927662e-01_rb,8.968577e-01_rb,9.005914e-01_rb, &
7442 9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,9.123836e-01_rb, &
7443 9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb, &
7444 9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb, &
7445 9.256727e-01_rb,9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb, &
7446 9.281156e-01_rb,9.285662e-01_rb,9.289806e-01_rb,9.293726e-01_rb, &
7447 9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,9.309859e-01_rb, &
7448 9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb, &
7449 9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb, &
7450 9.384329e-01_rb,9.398744e-01_rb /)
7451 asyice3(:, 17) = (/ &
7452 ! band 17
7453 8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb, &
7454 8.908785e-01_rb,8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb, &
7455 9.050582e-01_rb,9.080739e-01_rb,9.108976e-01_rb,9.135388e-01_rb, &
7456 9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,9.224620e-01_rb, &
7457 9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb, &
7458 9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb, &
7459 9.353013e-01_rb,9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb, &
7460 9.389939e-01_rb,9.398145e-01_rb,9.406092e-01_rb,9.413856e-01_rb, &
7461 9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,9.444561e-01_rb, &
7462 9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb, &
7463 9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb, &
7464 9.531294e-01_rb,9.544055e-01_rb /)
7465 asyice3(:, 18) = (/ &
7466 ! band 18
7467 7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb, &
7468 8.091495e-01_rb,8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb, &
7469 8.258790e-01_rb,8.296792e-01_rb,8.333355e-01_rb,8.368524e-01_rb, &
7470 8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,8.496143e-01_rb, &
7471 8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb, &
7472 8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb, &
7473 8.718916e-01_rb,8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb, &
7474 8.795734e-01_rb,8.813308e-01_rb,8.830315e-01_rb,8.846799e-01_rb, &
7475 8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,8.908350e-01_rb, &
7476 8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb, &
7477 8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb, &
7478 9.032765e-01_rb,9.046369e-01_rb /)
7479 asyice3(:, 19) = (/ &
7480 ! band 19
7481 7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb, &
7482 8.094109e-01_rb,8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb, &
7483 8.328294e-01_rb,8.380166e-01_rb,8.429556e-01_rb,8.476556e-01_rb, &
7484 8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,8.642481e-01_rb, &
7485 8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb, &
7486 8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb, &
7487 8.910897e-01_rb,8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb, &
7488 8.996311e-01_rb,9.015398e-01_rb,9.033745e-01_rb,9.051436e-01_rb, &
7489 9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,9.117311e-01_rb, &
7490 9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb, &
7491 9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb, &
7492 9.259476e-01_rb,9.276661e-01_rb /)
7493 asyice3(:, 20) = (/ &
7494 ! band 20
7495 7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb, &
7496 7.832998e-01_rb,7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb, &
7497 8.001765e-01_rb,8.040551e-01_rb,8.078044e-01_rb,8.114280e-01_rb, &
7498 8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,8.247344e-01_rb, &
7499 8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb, &
7500 8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb, &
7501 8.486568e-01_rb,8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb, &
7502 8.571122e-01_rb,8.590558e-01_rb,8.609378e-01_rb,8.627618e-01_rb, &
7503 8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,8.695423e-01_rb, &
7504 8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb, &
7505 8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb, &
7506 8.826854e-01_rb,8.840419e-01_rb /)
7507 asyice3(:, 21) = (/ &
7508 ! band 21
7509 7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb, &
7510 7.789452e-01_rb,7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb, &
7511 7.953555e-01_rb,7.991290e-01_rb,8.027777e-01_rb,8.063049e-01_rb, &
7512 8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,8.192645e-01_rb, &
7513 8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb, &
7514 8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb, &
7515 8.425553e-01_rb,8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb, &
7516 8.507412e-01_rb,8.526132e-01_rb,8.544210e-01_rb,8.561675e-01_rb, &
7517 8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,8.625951e-01_rb, &
7518 8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb, &
7519 8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb, &
7520 8.745255e-01_rb,8.756961e-01_rb /)
7521 asyice3(:, 22) = (/ &
7522 ! band 22
7523 7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb, &
7524 7.715402e-01_rb,7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb, &
7525 7.847148e-01_rb,7.877892e-01_rb,7.907786e-01_rb,7.936846e-01_rb, &
7526 7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,8.045011e-01_rb, &
7527 8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb, &
7528 8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb, &
7529 8.244958e-01_rb,8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb, &
7530 8.316580e-01_rb,8.332991e-01_rb,8.348831e-01_rb,8.364115e-01_rb, &
7531 8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,8.419969e-01_rb, &
7532 8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb, &
7533 8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb, &
7534 8.518561e-01_rb,8.527528e-01_rb /)
7535 asyice3(:, 23) = (/ &
7536 ! band 23
7537 7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb, &
7538 7.699306e-01_rb,7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb, &
7539 7.815060e-01_rb,7.842654e-01_rb,7.869705e-01_rb,7.896211e-01_rb, &
7540 7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,7.996726e-01_rb, &
7541 8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb, &
7542 8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb, &
7543 8.190001e-01_rb,8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb, &
7544 8.260924e-01_rb,8.277186e-01_rb,8.292856e-01_rb,8.307932e-01_rb, &
7545 8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,8.362244e-01_rb, &
7546 8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb, &
7547 8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb, &
7548 8.448755e-01_rb,8.455263e-01_rb /)
7549 asyice3(:, 24) = (/ &
7550 ! band 24
7551 7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb, &
7552 7.683337e-01_rb,7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb, &
7553 7.792225e-01_rb,7.818494e-01_rb,7.844362e-01_rb,7.869819e-01_rb, &
7554 7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,7.967337e-01_rb, &
7555 7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb, &
7556 8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb, &
7557 8.158862e-01_rb,8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb, &
7558 8.230149e-01_rb,8.246527e-01_rb,8.262308e-01_rb,8.277483e-01_rb, &
7559 8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,8.331929e-01_rb, &
7560 8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb, &
7561 8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb, &
7562 8.415240e-01_rb,8.420926e-01_rb /)
7563 asyice3(:, 25) = (/ &
7564 ! band 25
7565 7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb, &
7566 7.655067e-01_rb,7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb, &
7567 7.758492e-01_rb,7.783750e-01_rb,7.808735e-01_rb,7.833430e-01_rb, &
7568 7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,7.928983e-01_rb, &
7569 7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb, &
7570 8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb, &
7571 8.120527e-01_rb,8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb, &
7572 8.192776e-01_rb,8.209405e-01_rb,8.225427e-01_rb,8.240826e-01_rb, &
7573 8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,8.295856e-01_rb, &
7574 8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb, &
7575 8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb, &
7576 8.376710e-01_rb,8.381633e-01_rb /)
7577 asyice3(:, 26) = (/ &
7578 ! band 26
7579 7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb, &
7580 7.597839e-01_rb,7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb, &
7581 7.701303e-01_rb,7.726639e-01_rb,7.751727e-01_rb,7.776548e-01_rb, &
7582 7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,7.872804e-01_rb, &
7583 7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb, &
7584 7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb, &
7585 8.066715e-01_rb,8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb, &
7586 8.140150e-01_rb,8.157072e-01_rb,8.173382e-01_rb,8.189063e-01_rb, &
7587 8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,8.245130e-01_rb, &
7588 8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb, &
7589 8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb, &
7590 8.327385e-01_rb,8.332350e-01_rb /)
7591 asyice3(:, 27) = (/ &
7592 ! band 27
7593 7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb, &
7594 7.504362e-01_rb,7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb, &
7595 7.609199e-01_rb,7.634888e-01_rb,7.660332e-01_rb,7.685512e-01_rb, &
7596 7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,7.783229e-01_rb, &
7597 7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb, &
7598 7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb, &
7599 7.980449e-01_rb,7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb, &
7600 8.055311e-01_rb,8.072581e-01_rb,8.089235e-01_rb,8.105255e-01_rb, &
7601 8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,8.162626e-01_rb, &
7602 8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb, &
7603 8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb, &
7604 8.247399e-01_rb,8.252599e-01_rb /)
7605 asyice3(:, 28) = (/ &
7606 ! band 28
7607 7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb, &
7608 7.332444e-01_rb,7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb, &
7609 7.437869e-01_rb,7.463702e-01_rb,7.489291e-01_rb,7.514616e-01_rb, &
7610 7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,7.612933e-01_rb, &
7611 7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb, &
7612 7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb, &
7613 7.811789e-01_rb,7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb, &
7614 7.887597e-01_rb,7.905131e-01_rb,7.922062e-01_rb,7.938372e-01_rb, &
7615 7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,7.997047e-01_rb, &
7616 8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb, &
7617 8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb, &
7618 8.085768e-01_rb,8.091507e-01_rb /)
7619 asyice3(:, 29) = (/ &
7620 ! band 29
7621 8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb, &
7622 9.168987e-01_rb,9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb, &
7623 9.323000e-01_rb,9.354235e-01_rb,9.382858e-01_rb,9.408985e-01_rb, &
7624 9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,9.490871e-01_rb, &
7625 9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb, &
7626 9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb, &
7627 9.576692e-01_rb,9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb, &
7628 9.590851e-01_rb,9.593729e-01_rb,9.596632e-01_rb,9.599705e-01_rb, &
7629 9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,9.616667e-01_rb, &
7630 9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb, &
7631 9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb, &
7632 9.724337e-01_rb,9.746084e-01_rb /)
7633 !
7634 ! fdelta: unitless
7635 !
7636 fdlice3(:, 16) = (/ &
7637 ! band 16
7638 4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb, &
7639 3.950191e-02_rb,3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb, &
7640 3.154697e-02_rb,2.985578e-02_rb,2.827395e-02_rb,2.679666e-02_rb, &
7641 2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,2.183639e-02_rb, &
7642 2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb, &
7643 1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb, &
7644 1.490917e-02_rb,1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb, &
7645 1.300089e-02_rb,1.258006e-02_rb,1.217208e-02_rb,1.177212e-02_rb, &
7646 1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,1.015596e-02_rb, &
7647 9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb, &
7648 7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb, &
7649 5.106597e-03_rb,4.312183e-03_rb /)
7650 fdlice3(:, 17) = (/ &
7651 ! band 17
7652 5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb, &
7653 4.814380e-02_rb,4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb, &
7654 4.622662e-02_rb,4.583426e-02_rb,4.547274e-02_rb,4.514007e-02_rb, &
7655 4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,4.405844e-02_rb, &
7656 4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb, &
7657 4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb, &
7658 4.254248e-02_rb,4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb, &
7659 4.198564e-02_rb,4.183462e-02_rb,4.167494e-02_rb,4.150462e-02_rb, &
7660 4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,4.067737e-02_rb, &
7661 4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb, &
7662 3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb, &
7663 3.742316e-02_rb,3.689645e-02_rb /)
7664 fdlice3(:, 18) = (/ &
7665 ! band 18
7666 1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb, &
7667 1.073793e-01_rb,1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb, &
7668 1.088364e-01_rb,1.092439e-01_rb,1.096647e-01_rb,1.100970e-01_rb, &
7669 1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,1.119004e-01_rb, &
7670 1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb, &
7671 1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb, &
7672 1.158540e-01_rb,1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb, &
7673 1.172741e-01_rb,1.175738e-01_rb,1.178472e-01_rb,1.180926e-01_rb, &
7674 1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,1.187538e-01_rb, &
7675 1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb, &
7676 1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb, &
7677 1.178282e-01_rb,1.174731e-01_rb /)
7678 fdlice3(:, 19) = (/ &
7679 ! band 19
7680 1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb, &
7681 1.035099e-01_rb,1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb, &
7682 1.000808e-01_rb,9.931116e-02_rb,9.857151e-02_rb,9.785939e-02_rb, &
7683 9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,9.523623e-02_rb, &
7684 9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb, &
7685 9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb, &
7686 8.996974e-02_rb,8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb, &
7687 8.754323e-02_rb,8.689919e-02_rb,8.623517e-02_rb,8.554869e-02_rb, &
7688 8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,8.252807e-02_rb, &
7689 8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb, &
7690 7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb, &
7691 7.344227e-02_rb,7.217872e-02_rb /)
7692 fdlice3(:, 20) = (/ &
7693 ! band 20
7694 1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb, &
7695 1.135456e-01_rb,1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb, &
7696 1.155623e-01_rb,1.161096e-01_rb,1.166703e-01_rb,1.172422e-01_rb, &
7697 1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,1.196025e-01_rb, &
7698 1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb, &
7699 1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb, &
7700 1.247926e-01_rb,1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb, &
7701 1.267509e-01_rb,1.271836e-01_rb,1.275896e-01_rb,1.279669e-01_rb, &
7702 1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,1.291486e-01_rb, &
7703 1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb, &
7704 1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb, &
7705 1.293460e-01_rb,1.291109e-01_rb /)
7706 fdlice3(:, 21) = (/ &
7707 ! band 21
7708 1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb, &
7709 1.148934e-01_rb,1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb, &
7710 1.168396e-01_rb,1.173706e-01_rb,1.179152e-01_rb,1.184715e-01_rb, &
7711 1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,1.207720e-01_rb, &
7712 1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb, &
7713 1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb, &
7714 1.258309e-01_rb,1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb, &
7715 1.277257e-01_rb,1.281415e-01_rb,1.285300e-01_rb,1.288893e-01_rb, &
7716 1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,1.299927e-01_rb, &
7717 1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb, &
7718 1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb, &
7719 1.299638e-01_rb,1.296983e-01_rb /)
7720 fdlice3(:, 22) = (/ &
7721 ! band 22
7722 1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb, &
7723 1.178666e-01_rb,1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb, &
7724 1.215796e-01_rb,1.225522e-01_rb,1.235383e-01_rb,1.245361e-01_rb, &
7725 1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,1.286011e-01_rb, &
7726 1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb, &
7727 1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb, &
7728 1.376198e-01_rb,1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb, &
7729 1.412678e-01_rb,1.421212e-01_rb,1.429469e-01_rb,1.437430e-01_rb, &
7730 1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,1.465899e-01_rb, &
7731 1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb, &
7732 1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb, &
7733 1.504579e-01_rb,1.506227e-01_rb /)
7734 fdlice3(:, 23) = (/ &
7735 ! band 23
7736 1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb, &
7737 1.187738e-01_rb,1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb, &
7738 1.226099e-01_rb,1.236141e-01_rb,1.246322e-01_rb,1.256621e-01_rb, &
7739 1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,1.298584e-01_rb, &
7740 1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb, &
7741 1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb, &
7742 1.391820e-01_rb,1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb, &
7743 1.429671e-01_rb,1.438547e-01_rb,1.447146e-01_rb,1.455449e-01_rb, &
7744 1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,1.485270e-01_rb, &
7745 1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb, &
7746 1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb, &
7747 1.526880e-01_rb,1.528840e-01_rb /)
7748 fdlice3(:, 24) = (/ &
7749 ! band 24
7750 1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb, &
7751 1.195676e-01_rb,1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb, &
7752 1.234349e-01_rb,1.244463e-01_rb,1.254712e-01_rb,1.265078e-01_rb, &
7753 1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,1.307287e-01_rb, &
7754 1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb, &
7755 1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb, &
7756 1.400984e-01_rb,1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb, &
7757 1.439016e-01_rb,1.447936e-01_rb,1.456579e-01_rb,1.464925e-01_rb, &
7758 1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,1.494923e-01_rb, &
7759 1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb, &
7760 1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb, &
7761 1.536969e-01_rb,1.538984e-01_rb /)
7762 fdlice3(:, 25) = (/ &
7763 ! band 25
7764 1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb, &
7765 1.203867e-01_rb,1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb, &
7766 1.242750e-01_rb,1.252903e-01_rb,1.263187e-01_rb,1.273583e-01_rb, &
7767 1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,1.315870e-01_rb, &
7768 1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb, &
7769 1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb, &
7770 1.409577e-01_rb,1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb, &
7771 1.447577e-01_rb,1.456488e-01_rb,1.465123e-01_rb,1.473461e-01_rb, &
7772 1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,1.503439e-01_rb, &
7773 1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb, &
7774 1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb, &
7775 1.545575e-01_rb,1.547617e-01_rb /)
7776 fdlice3(:, 26) = (/ &
7777 ! band 26
7778 1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb, &
7779 1.216171e-01_rb,1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb, &
7780 1.255363e-01_rb,1.265564e-01_rb,1.275888e-01_rb,1.286313e-01_rb, &
7781 1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,1.328643e-01_rb, &
7782 1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb, &
7783 1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb, &
7784 1.422165e-01_rb,1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb, &
7785 1.460058e-01_rb,1.468947e-01_rb,1.477564e-01_rb,1.485888e-01_rb, &
7786 1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,1.515864e-01_rb, &
7787 1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb, &
7788 1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb, &
7789 1.558490e-01_rb,1.560645e-01_rb /)
7790 fdlice3(:, 27) = (/ &
7791 ! band 27
7792 1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb, &
7793 1.237059e-01_rb,1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb, &
7794 1.276765e-01_rb,1.287041e-01_rb,1.297420e-01_rb,1.307883e-01_rb, &
7795 1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,1.350207e-01_rb, &
7796 1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb, &
7797 1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb, &
7798 1.443134e-01_rb,1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb, &
7799 1.480681e-01_rb,1.489490e-01_rb,1.498032e-01_rb,1.506286e-01_rb, &
7800 1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,1.536070e-01_rb, &
7801 1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb, &
7802 1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb, &
7803 1.579093e-01_rb,1.581390e-01_rb /)
7804 fdlice3(:, 28) = (/ &
7805 ! band 28
7806 1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb, &
7807 1.283905e-01_rb,1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb, &
7808 1.322964e-01_rb,1.333060e-01_rb,1.343252e-01_rb,1.353523e-01_rb, &
7809 1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,1.395042e-01_rb, &
7810 1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb, &
7811 1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb, &
7812 1.486157e-01_rb,1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb, &
7813 1.523016e-01_rb,1.531673e-01_rb,1.540073e-01_rb,1.548197e-01_rb, &
7814 1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,1.577576e-01_rb, &
7815 1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb, &
7816 1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb, &
7817 1.620614e-01_rb,1.623011e-01_rb /)
7818 fdlice3(:, 29) = (/ &
7819 ! band 29
7820 1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb, &
7821 8.165612e-02_rb,7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb, &
7822 6.638412e-02_rb,6.308156e-02_rb,5.996942e-02_rb,5.703979e-02_rb, &
7823 5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,4.698880e-02_rb, &
7824 4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb, &
7825 3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb, &
7826 3.197604e-02_rb,3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb, &
7827 2.752050e-02_rb,2.652776e-02_rb,2.556772e-02_rb,2.463247e-02_rb, &
7828 2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,2.098180e-02_rb, &
7829 2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb, &
7830 1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb, &
7831 1.114319e-02_rb,9.727157e-03_rb /)
7832 !
7833 end subroutine swcldpr
7834 !-------------------------------------------------------------------------------
7835 !
7836 !
7837 !-------------------------------------------------------------------------------
7838 end module rrtmg_sw_init_k
7839 !-------------------------------------------------------------------------------
7840 !
7841 !
7842 !-------------------------------------------------------------------------------
7843 module rrtmg_sw_vrtqdr_k
7844 !-------------------------------------------------------------------------------
7845 ! --------------------------------------------------------------------------
7846 ! | |
7847 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
7848 ! | This software may be used, copied, or redistributed as long as it is |
7849 ! | not sold and this copyright notice is reproduced on each copy made. |
7850 ! | This model is provided as is without any express or implied warranties. |
7851 ! | (http://www.rtweb.aer.com/) |
7852 ! | |
7853 ! --------------------------------------------------------------------------
7854 ! ------- Modules -------
7855 !
7856 use parkind_k, only: im => kind_im, rb => kind_rb
7857 ! use parrrsw, only: ngptsw
7858 !
7859 implicit none
7860 !
7861 contains
7862 !-------------------------------------------------------------------------------
7863 !
7864 !
7865 !-------------------------------------------------------------------------------
7866 subroutine vrtqdr_sw(klev, kw, &
7867 pref, prefd, ptra, ptrad, &
7868 pdbt, prdnd, prup, prupd, ptdbt, &
7869 pfd, pfu)
7870 !-------------------------------------------------------------------------------
7871 !
7872 ! abstract:
7873 ! This routine performs the vertical quadrature integration
7874 !
7875 ! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
7876 !
7877 ! history log
7878 !
7879 ! H. Barker Original
7880 ! 2002-10 J.-J. Morcrette, ECMWF Integrated with rrtmg_sw
7881 ! 2006-06 MJIacono, AER Reformatted for consistency with rrtmg_lw
7882 !
7883 ! Input :
7884 ! klev : number of model layers
7885 ! kw : g-point index
7886 ! pref(nlayers+1) : direct beam reflectivity
7887 ! prefd(nlayers+1) : diffuse beam reflectivity
7888 ! ptra(nlayers+1) : direct beam transmissivity
7889 ! ptrad(nlayers+1) : diffuse beam transmissivity
7890 ! pdbt(nlayers+1) : layer mean direct beam transmittance
7891 ! ptdbt(nlayers+1) : total direct beam transmittance at levels
7892 ! prdnd(nlayers+1)
7893 ! prup(nlayers+1)
7894 ! prupd(nlayers+1)
7895 !
7896 ! Output :
7897 ! pfd(nlayers+1,ngptsw) : downwelling flux (W/m2),
7898 ! unadjusted for earth/sun distance or zenith angle
7899 ! pfu(nlayers+1,ngptsw) : upwelling flux (W/m2)
7900 ! unadjusted for earth/sun distance or zenith angle
7901 !
7902 !-------------------------------------------------------------------------------
7903 !
7904 ! ------- Declarations -------
7905 !
7906 ! Input
7907 !
7908 integer(kind=im), intent(in ) :: klev
7909 integer(kind=im), intent(in ) :: kw
7910 real(kind=rb), dimension(:), intent(in ) :: pref
7911 real(kind=rb), dimension(:), intent(in ) :: prefd
7912 real(kind=rb), dimension(:), intent(in ) :: ptra
7913 real(kind=rb), dimension(:), intent(in ) :: ptrad
7914 real(kind=rb), dimension(:), intent(in ) :: pdbt
7915 real(kind=rb), dimension(:), intent(in ) :: ptdbt
7916 real(kind=rb), dimension(:), intent(inout) :: prdnd
7917 real(kind=rb), dimension(:), intent(inout) :: prup
7918 real(kind=rb), dimension(:), intent(inout) :: prupd
7919 !
7920 ! Output
7921 !
7922 real(kind=rb), dimension(:,:), intent( out) :: pfd
7923 real(kind=rb), dimension(:,:), intent( out) :: pfu
7924 !
7925 ! Local
7926 !
7927 integer(kind=im) :: ikp, ikx, jk
7928 !
7929 real(kind=rb) :: zreflect
7930 real(kind=rb),dimension(klev+1) :: ztdn
7931 !
7932 !-----------------------------------------------------------------------------
7933 !
7934 ! Link lowest layer with surface
7935 !
7936 zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
7937 prup(klev) = pref(klev) + (ptrad(klev) * &
7938 ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + &
7939 pdbt(klev) * pref(klev+1))) * zreflect
7940 prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * &
7941 prefd(klev+1) * zreflect
7942 !
7943 ! Pass from bottom to top
7944 !
7945 do jk = 1,klev-1
7946 ikp = klev+1-jk
7947 ikx = ikp-1
7948 zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
7949 prup(ikx) = pref(ikx) + (ptrad(ikx) * &
7950 ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + &
7951 pdbt(ikx) * prup(ikp))) * zreflect
7952 prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * &
7953 prupd(ikp) * zreflect
7954 enddo
7955 !
7956 ! Upper boundary conditions
7957 !
7958 ztdn(1) = 1._rb
7959 prdnd(1) = 0._rb
7960 ztdn(2) = ptra(1)
7961 prdnd(2) = prefd(1)
7962 !
7963 ! Pass from top to bottom
7964 !
7965 do jk = 2,klev
7966 ikp = jk+1
7967 zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
7968 ztdn(ikp) = ptdbt(jk) * ptra(jk) + &
7969 (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + &
7970 ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
7971 prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * &
7972 prdnd(jk) * zreflect
7973 enddo
7974 !
7975 ! Up and down-welling fluxes at levels
7976 !
7977 do jk = 1,klev+1
7978 zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
7979 pfu(jk,kw) = (ptdbt(jk) * prup(jk) + &
7980 (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
7981 pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ &
7982 ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
7983 enddo
7984 !
7985 end subroutine vrtqdr_sw
7986 !-------------------------------------------------------------------------------
7987 !
7988 !
7989 !-------------------------------------------------------------------------------
7990 end module rrtmg_sw_vrtqdr_k
7991 !-------------------------------------------------------------------------------
7992 !
7993 !
7994 !-------------------------------------------------------------------------------
7995 module rrtmg_sw_spcvmc_k
7996 !-------------------------------------------------------------------------------
7997 ! --------------------------------------------------------------------------
7998 ! | |
7999 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
8000 ! | This software may be used, copied, or redistributed as long as it is |
8001 ! | not sold and this copyright notice is reproduced on each copy made. |
8002 ! | This model is provided as is without any express or implied warranties. |
8003 ! | (http://www.rtweb.aer.com/) |
8004 ! | |
8005 ! --------------------------------------------------------------------------
8006 ! ------- Modules -------
8007 !
8008 use parkind_k, only : im => kind_im, rb => kind_rb
8009 use parrrsw_k, only : nbndsw, ngptsw, mxmol, jpband
8010 use rrsw_tbl_k, only : tblint, bpade, od_lo, exp_tbl
8011 use rrsw_vsn_k, only : hvrspc, hnamspc
8012 use rrsw_wvn_k, only : ngc, ngs
8013 use rrtmg_sw_reftra_k, only: reftra_sw
8014 use rrtmg_sw_taumol_k, only: taumol_sw
8015 use rrtmg_sw_vrtqdr_k, only: vrtqdr_sw
8016 !
8017 implicit none
8018 !
8019 contains
8020 !-------------------------------------------------------------------------------
8021 !
8022 !
8023 !-------------------------------------------------------------------------------
8024 subroutine spcvmc_sw &
8025 (nlayers, istart, iend, icpr, iout, &
8026 pavel, tavel, pz, tz, tbound, palbd, palbp, &
8027 pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
8028 ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, &
8029 laytrop, layswtch, laylow, jp, jt, jt1, &
8030 co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
8031 fac00, fac01, fac10, fac11, &
8032 selffac, selffrac, indself, forfac, forfrac, indfor, &
8033 dtliq,dtice,dtsno,dwliq,dwice,dwsno,daliq,daice,dasno, &
8034 pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
8035 pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir)
8036 !-------------------------------------------------------------------------------
8037 !
8038 ! abstract:
8039 ! Contains spectral loop to compute the shortwave radiative fluxes,
8040 ! using the two-stream method of H. Barker and McICA, the Monte-Carlo
8041 ! Independent Column Approximation, for the representation of
8042 ! sub-grid cloud variability (i.e. cloud overlap).
8043 !
8044 ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
8045 !
8046 ! Method:
8047 ! Adapted from two-stream model of H. Barker;
8048 ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
8049 ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
8050 !
8051 ! history log :
8052 !
8053 ! H. Barker Original
8054 ! 2003-12 J.-J.Morcrette Merge with RRTMG_SW
8055 ! 2003-10 MJIacono, AER Add adjustment for Earth/Sun distance
8056 ! 2003-11 MJIacono, AER Bug fix for use of PALBP and PALBD
8057 ! 2004-12 MJIacono, AER Bug fix to apply delta scaling to clear sky
8058 ! 2005-01 MJIacono, AER Code modified so that delta scaling is not done in
8059 ! cloudy profiles if routine cldprop is used; delta
8060 ! scaling can be applied by swithcing code below if
8061 ! cldprop is used; delta scaling can be applied by
8062 ! swithcing code below if cldprop is not used to get
8063 ! cloud properties.
8064 ! 2005-11 MJIacono, AER Modified to use McICA
8065 ! 2006-07 MJIacono, AER Uniform formatting for RRTMG
8066 ! 2007-08 MJIacono, AER se exponential lookup table for transmittance
8067 ! 2016-10 Sungghye Baek Revised Two Stream Approximaiton (TSA)
8068 ! Input :
8069 ! indfor(nlayers)
8070 ! indself(nlayers)
8071 ! jp(nlayers)
8072 ! jt(nlayers)
8073 ! jt1(nlayers)
8074 !
8075 ! pavel(nlayers) : layer pressure (hPa, mb)
8076 ! tavel(nlayers) : layer temperature (K)
8077 ! pz(0:nlayers) : level (interface) pressure (hPa, mb)
8078 ! tz(0:nlayers) : level temperatures (hPa, mb)
8079 ! tbound : surface temperature (K)
8080 ! wkl(mxmol,nlayers) : molecular amounts (mol/cm2)
8081 ! coldry(nlayers) : dry air column density (mol/cm2)
8082 ! colmol(nlayers)
8083 ! adjflux(jpband) : Earth/Sun distance adjustment
8084 !
8085 ! palbd(nbndsw) : surface albedo (diffuse)
8086 ! palbp(nbndsw) : surface albedo (direct)
8087 ! prmu0 : cosine of solar zenith angle
8088 ! pcldfmc(nlayers,ngptsw) : cloud fraction [mcica]
8089 ! ptaucmc(nlayers,ngptsw) : cloud optical depth [mcica]
8090 ! pasycmc(nlayers,ngptsw) : cloud asymmetry parameter [mcica]
8091 ! pomgcmc(nlayers,ngptsw) : cloud single scattering albedo [mcica]
8092 ! ptaormc(nlayers,ngptsw) : cloud optical depth, non-delta scaled [mcica]
8093 ! ptaua(nlayers,nbndsw) : aerosol optical depth
8094 ! pasya(nlayers,nbndsw) : aerosol asymmetry parameter
8095 ! pomga(nlayers,nbndsw) : aerosol single scattering albedo
8096 !
8097 ! colh2o(nlayers)
8098 ! colco2(nlayers)
8099 ! colch4(nlayers)
8100 ! co2mult(nlayers)
8101 ! colo3(nlayers)
8102 ! colo2(nlayers)
8103 ! coln2o(nlayers)
8104 !
8105 ! forfac(nlayers)
8106 ! forfrac(nlayers)
8107 ! selffac(nlayers)
8108 ! selffrac(nlayers)
8109 ! fac00(nlayers)
8110 ! fac01(nlayers)
8111 ! fac10(nlayers)
8112 ! fac11(nlayers)
8113 !
8114 ! dtliq (ngptsw,nlayers) : delta-scaled liquid cloud optical depth
8115 ! dtice (ngptsw,nlayers) : delta-scaled ice cloud optical depth
8116 ! dtsno (ngptsw,nlayers) : delta-scaled snow cloud optical depth
8117 ! dwliq (ngptsw,nlayers) : delta-scaled liquid cloud single scattering albedo
8118 ! dwice (ngptsw,nlayers) : delta-scaled ice cloud single scattering albedo
8119 ! dwsno (ngptsw,nlayers) : delta-scaled snow cloud single scattering albedo
8120 ! daliq (ngptsw,nlayers) : delta-scaled liquid cloud asymmetry factor
8121 ! daice (ngptsw,nlayers) : delta-scaled ice cloud asymmetry factor
8122 ! dasno (ngptsw,nlayers) : delta-scaled snow cloud asymmetry factor
8123 ! Output :
8124 ! pbbcd(nlayers+1)
8125 ! pbbcu(nlayers+1)
8126 ! pbbfd(nlayers+1)
8127 ! pbbfddir(nlayers+1)
8128 ! pbbcddir(nlayers+1)
8129 ! puvcd(nlayers+1)
8130 ! puvfd(nlayers+1)
8131 ! puvcddir(nlayers+1)
8132 ! puvfddir(nlayers+1)
8133 ! pnicd(nlayers+1)
8134 ! pnifd(nlayers+1)
8135 ! pnicddir(nlayers+1)
8136 ! pnifddir(nlayers+1)
8137 !-------------------------------------------------------------------------------
8138 ! ------- Declarations ------
8139 !
8140 ! ------- Input -------
8141 !
8142 integer(kind=im), intent(in ) :: nlayers
8143 integer(kind=im), intent(in ) :: istart
8144 integer(kind=im), intent(in ) :: iend
8145 integer(kind=im), intent(in ) :: icpr
8146 integer(kind=im), intent(in ) :: iout
8147 integer(kind=im), intent(in ) :: laytrop
8148 integer(kind=im), intent(in ) :: layswtch
8149 integer(kind=im), intent(in ) :: laylow
8150 !
8151 integer(kind=im), dimension(:), intent(in ) :: indfor
8152 integer(kind=im), dimension(:), intent(in ) :: indself
8153 integer(kind=im), dimension(:), intent(in ) :: jp
8154 integer(kind=im), dimension(:), intent(in ) :: jt
8155 integer(kind=im), dimension(:), intent(in ) :: jt1
8156 !
8157 real(kind=rb), dimension(:), intent(in ) :: pavel
8158 real(kind=rb), dimension(:), intent(in ) :: tavel
8159 real(kind=rb), dimension(0:), intent(in ) :: pz
8160 real(kind=rb), dimension(0:), intent(in ) :: tz
8161 real(kind=rb), intent(in ) :: tbound
8162 real(kind=rb), dimension(:,:),intent(in ) :: wkl
8163 real(kind=rb), dimension(:), intent(in ) :: coldry
8164 real(kind=rb), dimension(:), intent(in ) :: colmol
8165 real(kind=rb), dimension(:), intent(in ) :: adjflux
8166 !
8167 real(kind=rb), dimension(:), intent(in ) :: palbd
8168 real(kind=rb), dimension(:), intent(in ) :: palbp
8169 real(kind=rb), intent(in ) :: prmu0
8170 real(kind=rb), dimension(:,:), intent(in ) :: pcldfmc
8171 real(kind=rb), dimension(:,:), intent(in ) :: ptaucmc
8172 real(kind=rb), dimension(:,:), intent(in ) :: pasycmc
8173 real(kind=rb), dimension(:,:), intent(in ) :: pomgcmc
8174 real(kind=rb), dimension(:,:), intent(in ) :: ptaormc
8175 real(kind=rb), dimension(:,:), intent(in ) :: ptaua
8176 real(kind=rb), dimension(:,:), intent(in ) :: pasya
8177 real(kind=rb), dimension(:,:), intent(in ) :: pomga
8178 !
8179 real(kind=rb), dimension(:), intent(in ) :: colh2o
8180 real(kind=rb), dimension(:), intent(in ) :: colco2
8181 real(kind=rb), dimension(:), intent(in ) :: colch4
8182 real(kind=rb), dimension(:), intent(in ) :: co2mult
8183 real(kind=rb), dimension(:), intent(in ) :: colo3
8184 real(kind=rb), dimension(:), intent(in ) :: colo2
8185 real(kind=rb), dimension(:), intent(in ) :: coln2o
8186 !
8187 real(kind=rb), dimension(:), intent(in ) :: forfac
8188 real(kind=rb), dimension(:), intent(in ) :: forfrac
8189 real(kind=rb), dimension(:), intent(in ) :: selffac
8190 real(kind=rb), dimension(:), intent(in ) :: selffrac
8191 real(kind=rb), dimension(:), intent(in ) :: fac00
8192 real(kind=rb), dimension(:), intent(in ) :: fac01
8193 real(kind=rb), dimension(:), intent(in ) :: fac10
8194 real(kind=rb), dimension(:), intent(in ) :: fac11
8195 !
8196 real(kind=rb), dimension(:,:), intent(in ) :: dtliq, dtice, dtsno
8197 real(kind=rb), dimension(:,:), intent(in ) :: dwliq, dwice, dwsno
8198 real(kind=rb), dimension(:,:), intent(in ) :: daliq, daice, dasno
8199 !
8200 ! ------- Output -------
8201 ! All Dimensions: (nlayers+1)
8202 !
8203 real(kind=rb), dimension(:), intent( out) :: pbbcd
8204 real(kind=rb), dimension(:), intent( out) :: pbbcu
8205 real(kind=rb), dimension(:), intent( out) :: pbbfd
8206 real(kind=rb), dimension(:), intent( out) :: pbbfu
8207 real(kind=rb), dimension(:), intent( out) :: pbbfddir
8208 real(kind=rb), dimension(:), intent( out) :: pbbcddir
8209 !
8210 real(kind=rb), dimension(:), intent( out) :: puvcd
8211 real(kind=rb), dimension(:), intent( out) :: puvfd
8212 real(kind=rb), dimension(:), intent( out) :: puvcddir
8213 real(kind=rb), dimension(:), intent( out) :: puvfddir
8214 !
8215 real(kind=rb), dimension(:), intent( out) :: pnicd
8216 real(kind=rb), dimension(:), intent( out) :: pnifd
8217 real(kind=rb), dimension(:), intent( out) :: pnicddir
8218 real(kind=rb), dimension(:), intent( out) :: pnifddir
8219 !
8220 ! Output - inactive All Dimensions: (nlayers+1)
8221 ! real(kind=rb), intent(out) :: puvcu(:)
8222 ! real(kind=rb), intent(out) :: puvfu(:)
8223 ! real(kind=rb), intent(out) :: pnicu(:)
8224 ! real(kind=rb), intent(out) :: pnifu(:)
8225 ! real(kind=rb), intent(out) :: pvscd(:)
8226 ! real(kind=rb), intent(out) :: pvscu(:)
8227 ! real(kind=rb), intent(out) :: pvsfd(:)
8228 ! real(kind=rb), intent(out) :: pvsfu(:)
8229 !
8230 ! ------- Local -------
8231 !
8232 logical, dimension(nlayers) :: lrtchkclr,lrtchkcld
8233 !
8234 integer(kind=im) :: klev
8235 integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx
8236 integer(kind=im) :: iw, jb, jg, jl, jk
8237 ! integer(kind=im), parameter :: nuv = ??
8238 ! integer(kind=im), parameter :: nvs = ??
8239 integer(kind=im) :: itind
8240 !
8241 real(kind=rb) :: tblind, ze1
8242 real(kind=rb) :: zclear, zcloud
8243 real(kind=rb), dimension(nlayers+1) :: zdbt, zdbt_nodel
8244 real(kind=rb), dimension(nlayers ) :: zgc, zgcc, zgco
8245 real(kind=rb), dimension(nlayers ) :: zomc, zomcc, zomco
8246 real(kind=rb), dimension(nlayers+1) :: zrdnd, zrdndc
8247 real(kind=rb), dimension(nlayers+1) :: zref, zrefc, zrefo
8248 real(kind=rb), dimension(nlayers+1) :: zrefd, zrefdc, zrefdo
8249 real(kind=rb), dimension(nlayers+1) :: zrup, zrupd
8250 real(kind=rb), dimension(nlayers+1) :: zrupc, zrupdc
8251 real(kind=rb), dimension(nlayers+1) :: zs1
8252 real(kind=rb), dimension(nlayers ) :: ztauc, ztauo
8253 real(kind=rb), dimension(nlayers+1) :: ztdn, ztdnd, ztdbt
8254 real(kind=rb), dimension(nlayers ) :: ztoc, ztor
8255 real(kind=rb), dimension(nlayers+1) :: ztra, ztrac, ztrao
8256 real(kind=rb), dimension(nlayers+1) :: ztrad, ztradc, ztrado
8257 real(kind=rb), dimension(nlayers+1) :: zdbtc, ztdbtc, zdbtc_nodel
8258 real(kind=rb), dimension(ngptsw ) :: zincflx
8259 real(kind=rb), dimension(nlayers+1) :: ztdbt_nodel, ztdbtc_nodel
8260 !
8261 real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect
8262 real(kind=rb) :: zwf, tauorig, repclc
8263 ! real(kind=rb) :: zincflux ! inactive
8264 !
8265 ! Arrays from rrtmg_sw_taumoln routines
8266 !
8267 ! real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16)
8268 ! real(kind=rb) :: zsflxzen(16)
8269 real(kind=rb), dimension(nlayers,ngptsw) :: ztaug, ztaur
8270 real(kind=rb), dimension(ngptsw) :: zsflxzen
8271 !
8272 ! Arrays from rrtmg_sw_vrtqdr routine
8273 !
8274 real(kind=rb), dimension(nlayers+1,ngptsw) :: zcd, zcu, zfd, zfu
8275 !
8276 ! Inactive arrays
8277 ! real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1)
8278 ! real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1)
8279 ! real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1)
8280 !
8281 real(kind=rb), dimension(nlayers) :: al1c, al2c, al3c
8282 real(kind=rb), dimension(nlayers) :: al1o, al2o, al3o
8283 !
8284 real(kind=rb), dimension(nlayers) :: f_ray, f_aer
8285 !
8286 real(kind=rb), dimension(nlayers) :: ts_ray, ts_aer
8287 real(kind=rb), dimension(nlayers) :: ts_liq, ts_ice, ts_sno
8288 real(kind=rb), dimension(nlayers) :: ta_ray, ta_gas, ta_aer(nlayers)
8289 real(kind=rb), dimension(nlayers) :: ta_liq, ta_ice, ta_sno
8290 real(kind=rb), dimension(nlayers) :: tt_ray, tt_aer
8291 !
8292 real(kind=rb), dimension(nlayers) :: w_ray, w_aer
8293 real(kind=rb), dimension(nlayers) :: g_ray, g_aer
8294 !
8295 real(kind=rb), dimension(nlayers) :: b0_ray, b0_aer
8296 real(kind=rb), dimension(nlayers) :: b0_liq, b0_ice, b0_sno
8297 !
8298 real(kind=rb), dimension(nlayers) :: b0mu_ray, b0mu_aer
8299 real(kind=rb), dimension(nlayers) :: b0mu_liq, b0mu_ice, b0mu_sno
8300 !
8301 real(kind=rb) :: ua_aer=2., ua_gas=2., ua_ray=2.
8302 real(kind=rb) :: ua_liq=2., ua_ice=2., ua_sno=2.
8303 !
8304 real(kind=rb) :: us_aer=2., us_gas=2., us_ray=2.
8305 real(kind=rb) :: us_liq=2., us_ice=2., us_sno=2.
8306 !
8307 real(kind=rb) :: tt
8308 logical :: kmodts_4 = .false.
8309 !
8310 ! ------------------------------------------------------------------------------
8311 !
8312 ! Initializations
8313 !
8314 ib1 = istart
8315 ib2 = iend
8316 klev = nlayers
8317 iw = 0
8318 repclc = 1.e-12_rb
8319 ! zincflux = 0.0_rb
8320 !
8321 do jk = 1,klev+1
8322 pbbcd(jk)=0._rb
8323 pbbcu(jk)=0._rb
8324 pbbfd(jk)=0._rb
8325 pbbfu(jk)=0._rb
8326 pbbcddir(jk)=0._rb
8327 pbbfddir(jk)=0._rb
8328 puvcd(jk)=0._rb
8329 puvfd(jk)=0._rb
8330 puvcddir(jk)=0._rb
8331 puvfddir(jk)=0._rb
8332 pnicd(jk)=0._rb
8333 pnifd(jk)=0._rb
8334 pnicddir(jk)=0._rb
8335 pnifddir(jk)=0._rb
8336 enddo
8337 !
8338 ! Calculate the optical depths for gaseous absorption and Rayleigh scattering
8339 !
8340 call taumol_sw(klev, &
8341 colh2o, colco2, colch4, colo2, colo3, colmol, &
8342 laytrop, jp, jt, jt1, &
8343 fac00, fac01, fac10, fac11, &
8344 selffac, selffrac, indself, forfac, forfrac, indfor, &
8345 zsflxzen, ztaug, ztaur)
8346 !
8347 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
8348 !
8349 do jb = ib1,ib2
8350 ibm = jb-15
8351 igt = ngc(ibm)
8352 !
8353 ! Reinitialize g-point counter for each band if output for each band is
8354 ! requested.
8355 !
8356 if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1)
8357 !
8358 ! do jk = 1,klev+1
8359 ! zbbcd(jk)=0.0_rb
8360 ! zbbcu(jk)=0.0_rb
8361 ! zbbfd(jk)=0.0_rb
8362 ! zbbfu(jk)=0.0_rb
8363 ! enddo
8364 !
8365 ! Top of g-point interval loop within each band (iw is cumulative counter)
8366 !
8367 do jg = 1,igt
8368 iw = iw+1
8369 !
8370 ! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming
8371 ! solar flux
8372 !
8373 zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0
8374 ! zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0 ! inactive
8375 !
8376 ! Compute layer reflectances and transmittances for direct and diffuse sources,
8377 ! first clear then cloudy
8378 !
8379 ! zrefc(jk) direct albedo for clear
8380 ! zrefo(jk) direct albedo for cloud
8381 ! zrefdc(jk) diffuse albedo for clear
8382 ! zrefdo(jk) diffuse albedo for cloud
8383 ! ztrac(jk) direct transmittance for clear
8384 ! ztrao(jk) direct transmittance for cloudy
8385 ! ztradc(jk) diffuse transmittance for clear
8386 ! ztrado(jk) diffuse transmittance for cloudy
8387 !
8388 ! zref(jk) direct reflectance
8389 ! zrefd(jk) diffuse reflectance
8390 ! ztra(jk) direct transmittance
8391 ! ztrad(jk) diffuse transmittance
8392 !
8393 ! zdbtc(jk) clear direct beam transmittance
8394 ! zdbto(jk) cloudy direct beam transmittance
8395 ! zdbt(jk) layer mean direct beam transmittance
8396 ! ztdbt(jk) total direct beam transmittance at levels
8397 !
8398 ! Clear-sky
8399 !
8400 ! TOA direct beam
8401 !
8402 ztdbtc(1)=1.0_rb
8403 ztdbtc_nodel(1)=1.0_rb
8404 !
8405 ! Surface values
8406 !
8407 zdbtc(klev+1) =0.0_rb
8408 ztrac(klev+1) =0.0_rb
8409 ztradc(klev+1)=0.0_rb
8410 zrefc(klev+1) =palbp(ibm)
8411 zrefdc(klev+1)=palbd(ibm)
8412 zrupc(klev+1) =palbp(ibm)
8413 zrupdc(klev+1)=palbd(ibm)
8414 !
8415 ! Total sky
8416 ! TOA direct beam
8417 !
8418 ztdbt(1)=1.0_rb
8419 ztdbt_nodel(1)=1.0_rb
8420 !
8421 ! Surface values
8422 !
8423 zdbt(klev+1) =0.0_rb
8424 ztra(klev+1) =0.0_rb
8425 ztrad(klev+1)=0.0_rb
8426 zref(klev+1) =palbp(ibm)
8427 zrefd(klev+1)=palbd(ibm)
8428 zrup(klev+1) =palbp(ibm)
8429 zrupd(klev+1)=palbd(ibm)
8430 !
8431 ! Top of layer loop
8432 !
8433 do jk = 1,klev
8434 !
8435 ! Note: two-stream calculations proceed from top to bottom;
8436 ! RRTMG_SW quantities are given bottom to top and are reversed here
8437 !
8438 ikl=klev+1-jk
8439 !
8440 ! Set logical flag to do REFTRA calculation
8441 ! Do REFTRA for all clear layers
8442 !
8443 lrtchkclr(jk)=.true.
8444 !
8445 ! Do REFTRA only for cloudy layers in profile, since already done for clear
8446 ! layers
8447 !
8448 lrtchkcld(jk)=.false.
8449 lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc)
8450 !
8451 ! Clear-sky optical parameters - this section inactive
8452 ! Original
8453 ! ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw)
8454 ! zomcc(jk) = ztaur(ikl,iw) / ztauc(jk)
8455 ! zgcc(jk) = 0.0001_rb
8456 ! Total sky optical parameters
8457 ! ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw)
8458 ! zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw)
8459 ! zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8460 ! ztaur(ikl,iw) * 0.0001_rb) / zomco(jk)
8461 ! zomco(jk) = zomco(jk) / ztauo(jk)
8462 !
8463 ! Clear-sky optical parameters including aerosols
8464 !
8465 if(ztaug(ikl,iw)<=0.) ztaug(ikl,iw)=0.
8466 ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm)
8467 zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
8468 zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
8469 zomcc(jk) = zomcc(jk) / ztauc(jk)
8470 !
8471 zf = pasya(ikl,ibm)*pasya(ikl,ibm)
8472 if(prmu0<0.5) zf = pasya(ikl,ibm)**1.5
8473 zwf = pomga(ikl,ibm)*zf
8474 f_aer(jk) = zf
8475 !
8476 g_aer(jk) = (pasya(ikl,ibm)-zf)/(1.e0-zf)
8477 tt_aer(jk) = (1.e0-zwf)*ptaua(ikl,ibm)
8478 w_aer(jk) = (pomga(ikl,ibm)-zwf)/(1.e0-zwf)
8479 !
8480 ts_aer(jk) = tt_aer(jk)*w_aer(jk)
8481 ta_aer(jk) = tt_aer(jk)*(1.e0-w_aer(jk))
8482 b0mu_aer(jk) = 0.25e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8483 ! b0_aer(jk) = 0.375e0*(1.e0-g_aer(jk))
8484 !
8485 ts_liq(jk) = dtliq(iw,ikl)*dwliq(iw,ikl)
8486 ta_liq(jk) = dtliq(iw,ikl)*(1.e0-dwliq(iw,ikl))
8487 b0mu_liq(jk) = 0.25e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8488 b0_liq(jk) = 0.375e0*(1.e0-daliq(iw,ikl))
8489 !
8490 ts_ice(jk) = dtice(iw,ikl)*dwice(iw,ikl)
8491 ta_ice(jk) = dtice(iw,ikl)*(1.e0-dwice(iw,ikl))
8492 b0mu_ice(jk) = 0.25e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8493 b0_ice(jk) = 0.375e0*(1.e0-daice(iw,ikl))
8494 !
8495 ts_sno(jk) = dtsno(iw,ikl)*dwsno(iw,ikl)
8496 ta_sno(jk) = dtsno(iw,ikl)*(1.e0-dwsno(iw,ikl))
8497 b0mu_sno(jk) = 0.25e0*(2.e0-3.e0*dasno(iw,ikl)*prmu0)
8498 b0_sno(jk) = 0.375e0*(1.e0-dasno(iw,ikl))
8499 !
8500 !aerosol
8501 if(prmu0<0.3)then
8502 b0mu_aer(jk) = 0.35e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8503 elseif(prmu0<0.5)then
8504 b0mu_aer(jk) = 0.3e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8505 elseif(prmu0>0.7)then
8506 b0mu_aer(jk) = 0.22e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8507 endif
8508 b0_aer(jk) = 0.5e0*(1.e0-g_aer(jk))
8509 !liquid
8510 if(prmu0<0.5)then
8511 b0mu_liq(jk) = 0.3e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8512 elseif(prmu0<0.8)then
8513 b0mu_liq(jk) = 0.28e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8514 endif
8515 !ice
8516 if(prmu0<0.4)then
8517 b0mu_ice(jk) = 0.3e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8518 elseif(prmu0>0.9)then
8519 b0mu_ice(jk) = 0.18e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8520 endif
8521 !snow
8522 if(prmu0<0.4)then
8523 b0mu_sno(jk) = 0.3e0*(2.e0-3.e0*dasno(iw,ikl)*prmu0)
8524 endif
8525 !
8526 !
8527 ! Pre-delta-scaling clear and cloudy direct beam transmittance
8528 ! (must use 'orig', unscaled cloud OD)
8529 ! \/\/\/ This block of code is only needed for direct beam calculation
8530 !
8531 zclear = 1.0_rb - pcldfmc(ikl,iw)
8532 zcloud = pcldfmc(ikl,iw)
8533 !
8534 ! Clear
8535 ! zdbtmc = exp(-ztauc(jk) / prmu0)
8536 !
8537 ! Use exponential lookup table for transmittance, or expansion of
8538 ! exponential for low tau
8539 !
8540 ze1 = ztauc(jk) / prmu0
8541 if (ze1 .le. od_lo) then
8542 zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8543 else
8544 tblind = ze1 / (bpade + ze1)
8545 itind = tblint * tblind + 0.5_rb
8546 zdbtmc = exp_tbl(itind)
8547 endif
8548 !
8549 zdbtc_nodel(jk) = zdbtmc
8550 ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk)
8551 !
8552 ! Clear + Cloud
8553 !
8554 tauorig = ztauc(jk) + ptaormc(ikl,iw)
8555 ! zdbtmo = exp(-tauorig / prmu0)
8556 !
8557 ! Use exponential lookup table for transmittance, or expansion of
8558 ! exponential for low tau
8559 !
8560 ze1 = tauorig / prmu0
8561 if (ze1 .le. od_lo) then
8562 zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8563 else
8564 tblind = ze1 / (bpade + ze1)
8565 itind = tblint * tblind + 0.5_rb
8566 zdbtmo = exp_tbl(itind)
8567 endif
8568 zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo
8569 ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk)
8570 !
8571 ! /\/\/\ Above code only needed for direct beam calculation
8572 !
8573 ! Delta scaling - clear
8574 !
8575 ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + tt_aer(jk)
8576 zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + tt_aer(jk) * w_aer(jk)
8577 zgcc(jk) = g_aer(jk) * w_aer(jk) * tt_aer(jk) / zomcc(jk)
8578 zomcc(jk) = zomcc(jk) / ztauc(jk)
8579 !
8580 tt = 1.e0 / ztauc(jk)
8581 al1c(jk) = (ua_gas*ztaug(ikl,iw) &
8582 + ua_aer*ta_aer(jk) + us_ray*0.375e0*ztaur(ikl,iw) &
8583 + us_aer*b0_aer(jk)*ts_aer(jk)) * tt
8584 al2c(jk) = (us_ray*0.375e0*ztaur(ikl,iw) &
8585 + us_aer*b0_aer(jk)*ts_aer(jk)) * tt
8586 al3c(jk) = (0.5e0*ztaur(ikl,iw) + b0mu_aer(jk)*ts_aer(jk)) * tt
8587 !
8588 ! Total sky optical parameters (cloud properties already delta-scaled)
8589 ! Use this code if cloud properties are derived in rrtmg_sw_cldprop
8590 !
8591 if (icpr .ge. 1) then
8592 ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw)
8593 zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw)
8594 zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8595 ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk)
8596 zomco(jk) = zomco(jk) / ztauo(jk)
8597 tt = 1.e0/ztauo(jk)
8598 !
8599 al1o(jk) = (ua_gas*ztaug(ikl,iw) + ua_aer*ta_aer(jk) &
8600 + ua_liq*ta_liq(jk) + ua_ice*ta_ice(jk) &
8601 + ua_sno*ta_sno(jk) &
8602 !
8603 + us_ray*0.375e0*ztaur(ikl,iw) &
8604 + us_aer*b0_aer(jk)*ts_aer(jk) &
8605 + us_liq*b0_liq(jk)*ts_liq(jk) &
8606 + us_ice*b0_ice(jk)*ts_ice(jk) &
8607 + us_sno*b0_sno(jk)*ts_sno(jk)) * tt
8608 !
8609 al2o(jk) = (us_ray*0.375e0*ztaur(ikl,iw) &
8610 + us_aer*b0_aer(jk)*ts_aer(jk) &
8611 + us_liq*b0_liq(jk)*ts_liq(jk) &
8612 + us_ice*b0_ice(jk)*ts_ice(jk) &
8613 + us_sno*b0_sno(jk)*ts_sno(jk)) * tt
8614 !
8615 al3o(jk) = (0.5e0*ztaur(ikl,iw) + b0mu_aer(jk)*ts_aer(jk) &
8616 + b0mu_liq(jk)*ts_liq(jk) + b0mu_ice(jk)*ts_ice(jk) &
8617 + b0mu_sno(jk)*ts_sno(jk) ) * tt
8618 !
8619 ! Total sky optical parameters (if cloud properties not delta scaled)
8620 ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop
8621 !
8622 elseif (icpr .eq. 0) then
8623 ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + &
8624 ptaua(ikl,ibm) + ptaucmc(ikl,iw)
8625 zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + &
8626 ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + &
8627 ztaur(ikl,iw) * 1.0_rb
8628 zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8629 ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk)
8630 zomco(jk) = zomco(jk) / ztauo(jk)
8631 !
8632 ! Delta scaling - clouds
8633 ! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties
8634 ! and to apply delta scaling
8635 !
8636 zf = zgco(jk) * zgco(jk)
8637 zwf = zomco(jk) * zf
8638 ztauo(jk) = (1._rb - zwf) * ztauo(jk)
8639 zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf)
8640 zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf)
8641 endif
8642 !
8643 ! End of layer loop
8644 !
8645 enddo
8646 !
8647 ! Clear sky reflectivities
8648 !
8649 call reftra_sw (klev, &
8650 lrtchkclr, zgcc, prmu0, ztauc, zomcc, &
8651 al1c, al2c, al3c, &
8652 zrefc, zrefdc, ztrac, ztradc)
8653 !
8654 ! Total sky reflectivities
8655 !
8656 call reftra_sw (klev, &
8657 lrtchkcld, zgco, prmu0, ztauo, zomco, &
8658 al1o, al2o, al3o, &
8659 zrefo, zrefdo, ztrao, ztrado)
8660 !
8661 do jk = 1,klev
8662 !
8663 ! Combine clear and cloudy contributions for total sky
8664 !
8665 ikl = klev+1-jk
8666 zclear = 1.0_rb - pcldfmc(ikl,iw)
8667 zcloud = pcldfmc(ikl,iw)
8668 !
8669 zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk)
8670 zrefd(jk) = zclear*zrefdc(jk) + zcloud*zrefdo(jk)
8671 ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk)
8672 ztrad(jk) = zclear*ztradc(jk) + zcloud*ztrado(jk)
8673 !
8674 ! Direct beam transmittance
8675 !
8676 ! Clear
8677 ! zdbtmc = exp(-ztauc(jk) / prmu0)
8678 !
8679 ! Use exponential lookup table for transmittance, or expansion of
8680 ! exponential for low tau
8681 !
8682 ze1 = ztauc(jk) / prmu0
8683 if (ze1 .le. od_lo) then
8684 zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8685 else
8686 tblind = ze1 / (bpade + ze1)
8687 itind = tblint * tblind + 0.5_rb
8688 zdbtmc = exp_tbl(itind)
8689 endif
8690 !
8691 zdbtc(jk) = zdbtmc
8692 ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk)
8693 !
8694 ! Clear + Cloud
8695 ! zdbtmo = exp(-ztauo(jk) / prmu0)
8696 ! Use exponential lookup table for transmittance, or expansion of
8697 ! exponential for low tau
8698 !
8699 ze1 = ztauo(jk) / prmu0
8700 if (ze1 .le. od_lo) then
8701 zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8702 else
8703 tblind = ze1 / (bpade + ze1)
8704 itind = tblint * tblind + 0.5_rb
8705 zdbtmo = exp_tbl(itind)
8706 endif
8707 zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo
8708 ztdbt(jk+1) = zdbt(jk)*ztdbt(jk)
8709 enddo
8710 !
8711 ! Vertical quadrature for clear-sky fluxes
8712 !
8713 call vrtqdr_sw(klev, iw, &
8714 zrefc, zrefdc, ztrac, ztradc, &
8715 zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, &
8716 zcd, zcu)
8717 !
8718 ! Vertical quadrature for cloudy fluxes
8719 !
8720 call vrtqdr_sw(klev, iw, &
8721 zref, zrefd, ztra, ztrad, &
8722 zdbt, zrdnd, zrup, zrupd, ztdbt, &
8723 zfd, zfu)
8724 !
8725 ! Upwelling and downwelling fluxes at levels
8726 ! Two-stream calculations go from top to bottom;
8727 ! layer indexing is reversed to go bottom to top for output arrays
8728 !
8729 do jk = 1,klev+1
8730 ikl = klev+2-jk
8731 !
8732 ! Accumulate spectral fluxes over bands - inactive
8733 ! zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8734 ! zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8735 ! zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8736 ! zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8737 ! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8738 ! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8739 !
8740 ! Accumulate spectral fluxes over whole spectrum
8741 !
8742 pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8743 pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8744 pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8745 pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8746 pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8747 pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8748 !
8749 ! Accumulate direct fluxes for UV/visible bands
8750 !
8751 if (ibm >= 10 .and. ibm <= 13) then
8752 puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw)
8753 puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw)
8754 puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8755 puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8756 !
8757 ! Accumulate direct fluxes for near-IR bands
8758 !
8759 else if (ibm == 14 .or. ibm <= 9) then
8760 pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw)
8761 pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw)
8762 pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8763 pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8764 endif
8765 enddo
8766 !
8767 ! End loop on jg, g-point interval
8768 !
8769 enddo
8770 !
8771 ! End loop on jb, spectral band
8772 !
8773 enddo
8774 !
8775 end subroutine spcvmc_sw
8776 !-------------------------------------------------------------------------------
8777 !
8778 !
8779 !-------------------------------------------------------------------------------
8780 end module rrtmg_sw_spcvmc_k
8781 !-------------------------------------------------------------------------------
8782 !
8783 !
8784 !-------------------------------------------------------------------------------
8785 module rrtmg_sw_rad_k
8786 !-------------------------------------------------------------------------------
8787 ! --------------------------------------------------------------------------
8788 ! | |
8789 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
8790 ! | This software may be used, copied, or redistributed as long as it is |
8791 ! | not sold and this copyright notice is reproduced on each copy made. |
8792 ! | This model is provided as is without any express or implied warranties. |
8793 ! | (http://www.rtweb.aer.com/) |
8794 ! | |
8795 ! --------------------------------------------------------------------------
8796 !
8797 ! ****************************************************************************
8798 ! * *
8799 ! * RRTMG_SW *
8800 ! * *
8801 ! * *
8802 ! * *
8803 ! * a rapid radiative transfer model *
8804 ! * for the solar spectral region *
8805 ! * for application to general circulation models *
8806 ! * *
8807 ! * *
8808 ! * Atmospheric and Environmental Research, Inc. *
8809 ! * 131 Hartwell Avenue *
8810 ! * Lexington, MA 02421 *
8811 ! * *
8812 ! * *
8813 ! * Eli J. Mlawer *
8814 ! * Jennifer S. Delamere *
8815 ! * Michael J. Iacono *
8816 ! * Shepard A. Clough *
8817 ! * *
8818 ! * *
8819 ! * *
8820 ! * *
8821 ! * *
8822 ! * *
8823 ! * email: miacono@aer.com *
8824 ! * email: emlawer@aer.com *
8825 ! * email: jdelamer@aer.com *
8826 ! * *
8827 ! * The authors wish to acknowledge the contributions of the *
8828 ! * following people: Steven J. Taubman, Patrick D. Brown, *
8829 ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
8830 ! * *
8831 ! ****************************************************************************
8832 !
8833 ! --------- Modules ---------
8834 !
8835 use parkind_k, only : im => kind_im, rb => kind_rb
8836 use rrsw_vsn_k
8837 use rrtmg_sw_cldprmc_k, only: cldprmc_sw
8838 !
8839 ! *** Move the required call to rrtmg_sw_ini below and the following
8840 ! use association to GCM initialization area ***
8841 ! use rrtmg_sw_init, only: rrtmg_sw_ini
8842 !
8843 use rrtmg_sw_setcoef_k, only: setcoef_sw
8844 use rrtmg_sw_spcvmc_k, only: spcvmc_sw
8845 !
8846 implicit none
8847 !
8848 ! public interfaces/functions/subroutines
8849 !
8850 public :: rrtmg_sw, inatm_sw, earth_sun
8851 !
8852 contains
8853 !-------------------------------------------------------------------------------
8854 !
8855 !
8856 !-------------------------------------------------------------------------------
8857 ! Public subroutines
8858 !-------------------------------------------------------------------------------
8859 subroutine rrtmg_sw &
8860 ( ncol ,nlay ,icld , &
8861 play ,plev ,tlay ,tlev ,tsfc , &
8862 h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
8863 asdir ,asdif ,aldir ,aldif , &
8864 coszen ,adjes ,dyofyr ,scon , &
8865 inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
8866 taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
8867 ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
8868 cswpmcl, resnmcl, &
8869 tauaer ,ssaaer ,asmaer ,ecaer , &
8870 swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
8871 visdir ,visdif ,nirdir ,nirdif &
8872 )
8873 !-------------------------------------------------------------------------------
8874 !
8875 ! ------- Description -------
8876 ! This program is the driver for RRTMG_SW, the AER SW radiation model for
8877 ! application to GCMs, that has been adapted from RRTM_SW for improved
8878 ! efficiency and to provide fractional cloudiness and cloud overlap
8879 ! capability using McICA.
8880 !
8881 ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization
8882 ! area, since this has to be called only once.
8883 !
8884 ! This routine
8885 ! b) calls INATM_SW to read in the atmospheric profile;
8886 ! all layering in RRTMG is ordered from surface to toa.
8887 ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based
8888 ! on input cloud properties
8889 ! d) calls SETCOEF_SW to calculate various quantities needed for
8890 ! the radiative transfer algorithm
8891 ! e) calls SPCVMC to call the two-stream model that in turn
8892 ! calls TAUMOL to calculate gaseous optical depths for each
8893 ! of the 16 spectral bands and to perform the radiative transfer
8894 ! using McICA, the Monte-Carlo Independent Column Approximation,
8895 ! to represent sub-grid scale cloud variability
8896 ! f) passes the calculated fluxes and cooling rates back to GCM
8897 !
8898 ! Two modes of operation are possible:
8899 ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use
8900 ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM.
8901 !
8902 ! 1) Standard, single forward model calculation (imca = 0); this is
8903 ! valid only for clear sky or fully overcast clouds
8904 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
8905 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
8906 ! This method is valid for clear sky or partial cloud conditions.
8907 !
8908 ! This call to RRTMG_SW must be preceeded by a call to the module
8909 ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator,
8910 ! which will provide the cloud physical or cloud optical properties
8911 ! on the RRTMG quadrature point (ngptsw) dimension.
8912 !
8913 ! Two methods of cloud property input are possible:
8914 ! Cloud properties can be input in one of two ways (controlled by input
8915 ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions
8916 ! and subroutine rrtmg_sw_cldprop.f90 for further details):
8917 !
8918 ! 1) Input cloud fraction, cloud optical depth, single scattering albedo
8919 ! and asymmetry parameter directly (inflgsw = 0)
8920 ! 2) Input cloud fraction and cloud physical properties: ice fracion,
8921 ! ice and liquid particle sizes (inflgsw = 1 or 2);
8922 ! cloud optical properties are calculated by cldprop or cldprmc based
8923 ! on input settings of iceflgsw and liqflgsw
8924 !
8925 ! Two methods of aerosol property input are possible:
8926 ! Aerosol properties can be input in one of two ways (controlled by input
8927 ! flag iaer, see text file rrtmg_sw_instructions for further details):
8928 !
8929 ! 1) Input aerosol optical depth, single scattering albedo and asymmetry
8930 ! parameter directly by layer and spectral band (iaer=10)
8931 ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use
8932 ! one or more of six ECMWF aerosol types (iaer=6)
8933 !
8934 !
8935 ! ------- Modifications -------
8936 !
8937 ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced
8938 ! set of g-point intervals and a two-stream model for application to GCMs.
8939 !
8940 !-- Original version (derived from RRTM_SW)
8941 ! 2002: AER. Inc.
8942 !-- Conversion to F90 formatting; addition of 2-stream radiative transfer
8943 ! Feb 2003: J.-J. Morcrette, ECMWF
8944 !-- Additional modifications for GCM application
8945 ! Aug 2003: M. J. Iacono, AER Inc.
8946 !-- Total number of g-points reduced from 224 to 112. Original
8947 ! set of 224 can be restored by exchanging code in module parrrsw.f90
8948 ! and in file rrtmg_sw_init.f90.
8949 ! Apr 2004: M. J. Iacono, AER, Inc.
8950 !-- Modifications to include output for direct and diffuse
8951 ! downward fluxes. There are output as "true" fluxes without
8952 ! any delta scaling applied. Code can be commented to exclude
8953 ! this calculation in source file rrtmg_sw_spcvrt.f90.
8954 ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc.
8955 !-- Revised to add McICA capability.
8956 ! Nov 2005: M. J. Iacono, AER, Inc.
8957 !-- Reformatted for consistency with rrtmg_lw.
8958 ! Feb 2007: M. J. Iacono, AER, Inc.
8959 !-- Modifications to formatting to use assumed-shape arrays.
8960 ! Aug 2007: M. J. Iacono, AER, Inc.
8961 !
8962 ! Input :
8963 ! ncol - Number of horizontal columns
8964 ! nlay - Number of model layers
8965 ! icld - Cloud overlap method
8966 ! 0: Clear only 1: Random 2: Maximum/random 3: Maximum
8967 ! play(ncol,nlay) - Layer pressures (hPa, mb)
8968 ! plev(ncol,nlay+1) - Interface pressures (hPa, mb)
8969 ! tlay(ncol,nlay) - Layer temperatures (K)
8970 ! tlev(ncol,nlay+1) - Interface temperatures (K)
8971 ! tsfc(ncol) - Surface temperature (K)
8972 ! h2ovmr(ncol,nlay) - H2O volume mixing ratio
8973 ! o3vmr(ncol,nlay) - O3 volume mixing ratio
8974 ! co2vmr(ncol,nlay) - co2 volume mixing ratio
8975 ! ch4vmr(ncol,nlay) - ch4 volume mixing ratio
8976 ! n2ovmr(ncol,nlay) - n2o volume mixing ratio
8977 ! o2vmr(ncol,nlay) - o2 volume mixing ratio
8978 ! asdir(ncol) - UV/vis surface albedo direct rad
8979 ! aldir(ncol) - Near-IR surface albedo direct rad
8980 ! asdif(ncol) - UV/vis surface albedo diffuse rad
8981 ! aldif(ncol) - Near-IR surface albedo diffuse rad
8982 ! dyofyr - Day of the year (used to get Earth/Sun distance if
8983 ! adjflx not provided)
8984 !
8985 ! adjes - Flux adjustment for Earth/Sun distance
8986 ! coszen(ncol) - Cosine of solar zenith angle
8987 ! scon - Solar constant (W/m2)
8988 ! inflgsw - Flag for cloud optical properties
8989 ! iceflgsw - Flag for ice particle specification
8990 ! liqflgsw - Flag for liquid droplet specification
8991 !
8992 ! cldfmcl(ngptsw,ncol,nlay) - Cloud fraction
8993 ! taucmcl(ngptsw,ncol,nlay) - In-cloud optical depth
8994 ! ssacmcl(ngptsw,ncol,nlay) - In-cloud single scattering albedo
8995 ! asmcmcl(ngptsw,ncol,nlay) - In-cloud asymmetry parameter
8996 ! fsfcmcl(ngptsw,ncol,nlay) - In-cloud forward scattering fraction
8997 ! ciwpmcl(ngptsw,ncol,nlay) - In-cloud water path (g/m2)
8998 ! clwpmcl(ngptsw,ncol,nlay) - In-cloud liquid water path (g/m2)
8999 ! cswpmcl(ngptsw,ncol,nlay) - In-cloud snow water path (g/m2)
9000 ! reicmcl(ncol,nlay) - Cloud ice effective radius (microns)
9001 !
9002 ! specific definition of reicmcl depends on setting of iceflglw:
9003 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
9004 ! r_ec must be >= 10.0 microns
9005 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
9006 ! r_ec range is limited to 13.0 to 130.0 microns
9007 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
9008 ! r_k range is limited to 5.0 to 131.0 microns
9009 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
9010 ! dge range is limited to 5.0 to 140.0 microns
9011 ! [dge = 1.0315 * r_ec]
9012 !
9013 ! relqmcl(ncol,nlay) - Cloud water drop effective radius (microns)
9014 ! resnmcl(ncol,nlay) - Cloud snow effective radius (microns)
9015 ! tauaer(ncol,nlay,nbndsw) - Aerosol optical depth (iaer=10 only)
9016 ! (non-delta scaled)
9017 ! ssaaer(ncol,nlay,nbndsw) - Aerosol Aerosol single scattering albedo
9018 ! (iaer=10 only) (non-delta scaled)
9019 ! asmaer(ncol,nlay,nbndsw) - Aerosol Aerosol asymmetry parameters
9020 ! (iaer=10 only) (non-delta scaled)
9021 ! ecaer(ncol,nlay,naerec) - Aerosol optical depth at 0.55 micron
9022 ! (iaer=6 only) (non-delta scaled)
9023 !
9024 ! output :
9025 ! swuflx(ncol,nlay+1) - Total sky shortwave upward flux (W/m2)
9026 ! swdflx(ncol,nlay+1) - Total sky shortwave downward flux (W/m2)
9027 ! swhr(ncol,nlay) - Total sky shortwave radiative heating rate (K/d)
9028 ! swuflxc(ncol,nlay+1) - Clear sky shortwave upward flux (W/m2)
9029 ! swdflxc(ncol,nlay+1) - Clear sky shortwave downward flux (W/m2)
9030 ! swhrc(ncol,nlay) - Clear sky shortwave radiative heating rate (K/d)
9031 ! sibvisdir(ncol,nlay+1) - visible direct downward flux (W/m2)
9032 ! sibvisdif(ncol,nlay+1) - visible diffusion downward flux (W/m2)
9033 ! sibnirdir(ncol,nlay+1) - Near IR direct downward flux (W/m2)
9034 ! sibnirdif(ncol,nlay+1) - Near IR diffusion downward flux (W/m2)
9035 ! swdkdir(ncol,nlay) - Total shortwave downward direct flux (W/m2)
9036 ! swdkdif(ncol,nlay) - Total shortwave downward diffuse flux (W/m2)
9037 ! visdir(ncol) - Direct downward surface shortwave flux, UV/vis
9038 ! visdif(ncol) - Diffuse downward surface shortwave flux, UV/vis
9039 ! nirdir(ncol) - Direct downward surface shortwave flux, Near-IR
9040 ! nirdif(ncol) - Diffuse downward surface shortwave flux, Near-IR
9041 !
9042 ! local :
9043 ! nlayers - total number of layers
9044 ! istart - beginning band of calculation
9045 ! iend - ending band of calculation
9046 ! icpr - cldprop/cldprmc use flag
9047 ! iout - output option flag (inactive)
9048 ! iaer - aerosol option flag
9049 ! idelm - delta-m scaling flag (inactive)
9050 ! isccos - instrumental cosine response flag (inactive)
9051 ! iplon - column loop index
9052 ! i - layer loop index ! jk
9053 ! ib - band loop index ! jsw
9054 ! ia, ig - indices
9055 ! k - layer loop index
9056 ! ims - value for changing mcica permute seed
9057 ! imca - flag for mcica [0=off, 1=on]
9058 ! zepsec, zepzen- epsilon
9059 ! zdpgcp - flux to heating conversion ratio
9060 !
9061 ! pavel(nlay+1) - layer pressures (mb)
9062 ! tavel(nlay+1) - layer temperatures (K)
9063 ! pz(0:nlay+1) - level (interface) pressures (hPa, mb)
9064 ! tz(0:nlay+1) - level (interface) temperatures (K)
9065 ! tbound - surface temperature (K)
9066 ! pdp(nlay+1) - layer pressure thickness (hPa, mb)
9067 ! coldry(nlay+1) - dry air column amount
9068 ! wkl(mxmol,nlay+1)- molecular amounts (mol/cm-2)
9069 ! cossza - Cosine of solar zenith angle
9070 ! adjflux(jpband) - adjustment for current Earth/Sun distance
9071 ! solvar(jpband) - solar constant scaling factor from rrtmg_sw
9072 ! - default value of 1368.22 Wm-2 at 1 AU
9073 ! albdir(nbndsw) - surface albedo, direct ! zalbp
9074 ! albdif(nbndsw) - surface albedo, diffuse ! zalbd
9075 !
9076 ! taua(nlay+1,nbndsw) - Aerosol optical depth
9077 ! ssaa(nlay+1,nbndsw) - Aerosol single scattering albedo
9078 ! asma(nlay+1,nbndsw) - Aerosol asymmetry parameter
9079 !
9080 ! laytrop - tropopause layer index
9081 ! layswtch - tropopause layer index
9082 ! laylow - tropopause layer index
9083 ! jp(nlay+1)
9084 ! jt(nlay+1)
9085 ! jt1(nlay+1)
9086 !
9087 ! colh2o(nlay+1) - column amount (h2o)
9088 ! colco2(nlay+1) - column amount (co2)
9089 ! colo3(nlay+1) - column amount (o3)
9090 ! coln2o(nlay+1) - column amount (n2o)
9091 ! colch4(nlay+1) - column amount (ch4)
9092 ! colo2(nlay+1) - column amount (o2)
9093 ! colmol(nlay+1) - column amount
9094 ! co2mult(nlay+1) - column amount
9095 !
9096 ! ncbands - number of cloud spectral bands
9097 ! inflag - flag for cloud property method
9098 ! iceflag - flag for ice cloud properties
9099 ! liqflag - flag for liquid cloud properties
9100 !
9101 ! cldfrac(nlay+1) - layer cloud fraction
9102 ! tauc(nlay+1) - in-cloud optical depth (non-delta scaled)
9103 ! ssac(nlay+1) - in-cloud single scattering albedo (non-delta scaled)
9104 ! asmc(nlay+1) - in-cloud asymmetry parameter (non-delta scaled)
9105 ! fsfc(nlay+1) - in-cloud forward scattering fraction (non-delta scaled)
9106 ! ciwp(nlay+1) - in-cloud ice water path
9107 ! clwp(nlay+1) - in-cloud liquid water path
9108 ! rei(nlay+1) - cloud ice particle size
9109 ! rel(nlay+1) - cloud liquid particle size
9110 !
9111 ! taucloud(nlay+1,jpband) - in-cloud optical depth
9112 ! taucldorig(nlay+1,jpband)- in-cloud optical depth (non-delta scaled)
9113 ! ssacloud(nlay+1,jpband) - in-cloud single scattering albedo
9114 ! asmcloud(nlay+1,jpband) - in-cloud asymmetry parameter
9115 !
9116 ! cldfmc(ngptsw,nlay+1) - cloud fraction [mcica]
9117 ! ciwpmc(ngptsw,nlay+1) - in-cloud ice water path [mcica]
9118 ! clwpmc(ngptsw,nlay+1) - in-cloud liquid water path [mcica]
9119 ! cswpmc(ngptsw,nlay+1) - in-cloud snow water path [mcica]
9120 ! relqmc(nlay+1) - liquid particle effective radius (microns)
9121 ! reicmc(nlay+1) - ice particle effective size (microns)
9122 ! resnmc(nlay+1) - snow particle effective size (microns)
9123 ! taucmc(ngptsw,nlay+1) - in-cloud optical depth [mcica]
9124 ! taormc(ngptsw,nlay+1) - unscaled in-cloud optical depth [mcica]
9125 ! ssacmc(ngptsw,nlay+1) - in-cloud single scattering albedo [mcica]
9126 ! asmcmc(ngptsw,nlay+1) - in-cloud asymmetry parameter [mcica]
9127 ! fsfcmc(ngptsw,nlay+1) - in-cloud forward scattering fraction [mcica]
9128 !
9129 ! ztauc(nlay+1,nbndsw) - cloud optical depth
9130 ! ztaucorig(nlay+1,nbndsw) - unscaled cloud optical depth
9131 ! zasyc(nlay+1,nbndsw) - cloud asymmetry parameter
9132 ! (first moment of phase function)
9133 ! zomgc(nlay+1,nbndsw) - cloud single scattering albedo
9134 ! ztaua(nlay+1,nbndsw) - total aerosol optical depth
9135 ! zasya(nlay+1,nbndsw) - total aerosol asymmetry parameter
9136 ! zomga(nlay+1,nbndsw) - total aerosol single scattering albedo
9137 !
9138 ! zcldfmc(nlay+1,ngptsw) -cloud fraction [mcica]
9139 ! ztaucmc(nlay+1,ngptsw) -cloud optical depth [mcica]
9140 ! ztaormc(nlay+1,ngptsw) -unscaled cloud optical depth [mcica]
9141 ! zasycmc(nlay+1,ngptsw) -cloud asymmetry parameter [mcica]
9142 ! zomgcmc(nlay+1,ngptsw) -cloud single scattering albedo [mcica]
9143 !
9144 ! zbbfu(nlay+2) - temporary upward shortwave flux (w/m2)
9145 ! zbbfd(nlay+2) - temporary downward shortwave flux (w/m2)
9146 ! zbbcu(nlay+2) - temporary clear sky upward shortwave flux (w/m2)
9147 ! zbbcd(nlay+2) - temporary clear sky downward shortwave flux (w/m2)
9148 ! zbbfddir(nlay+2)- temporary downward direct shortwave flux (w/m2)
9149 ! zbbcddir(nlay+2)- temporary clear sky downward direct shortwave flux (w/m2)
9150 ! zuvfd(nlay+2) - temporary UV downward shortwave flux (w/m2)
9151 ! zuvcd(nlay+2) - temporary clear sky UV downward shortwave flux (w/m2)
9152 ! zuvfddir(nlay+2)- temporary UV downward direct shortwave flux (w/m2)
9153 ! zuvcddir(nlay+2)- temporary clear sky UV downward direct shortwave flux
9154 ! znifd(nlay+2) - temporary near-IR downward shortwave flux (w/m2)
9155 ! znicd(nlay+2) - temporary clear sky near-IR downward shortwave flux (w/m2)
9156 ! znifddir(nlay+2)- temporary near-IR downward direct shortwave flux (w/m2)
9157 ! znicddir(nlay+2)- temporary clear sky near-IR downward direct shortwave flux
9158 !
9159 ! swnflx(nlay+2) - Total sky shortwave net flux (W/m2)
9160 ! swnflxc(nlay+2) - Clear sky shortwave net flux (W/m2)
9161 ! dirdflux(nlay+2) - Direct downward shortwave surface flux
9162 ! difdflux(nlay+2) - Diffuse downward shortwave surface flux
9163 ! uvdflx(nlay+2) - Total sky downward shortwave flux, UV/vis
9164 ! nidflx(nlay+2) - Total sky downward shortwave flux, near-IR
9165 ! dirdnuv(nlay+2) - Direct downward shortwave flux, UV/vis
9166 ! difdnuv(nlay+2) - Diffuse downward shortwave flux, UV/vis
9167 ! dirdnir(nlay+2) - Direct downward shortwave flux, near-IR
9168 ! difdnir(nlay+2) - Diffuse downward shortwave flux, near-IR
9169 !
9170 ! zuvfu(nlay+2) - temporary upward UV shortwave flux (w/m2)
9171 ! zuvfd(nlay+2) - temporary downward UV shortwave flux (w/m2)
9172 ! zuvcu(nlay+2) - temporary clear sky upward UV shortwave flux (w/m2)
9173 ! zuvcd(nlay+2) - temporary clear sky downward UV shortwave flux (w/m2)
9174 ! zvsfu(nlay+2) - temporary upward visible shortwave flux (w/m2)
9175 ! zvsfd(nlay+2) - temporary downward visible shortwave flux (w/m2)
9176 ! zvscu(nlay+2) - temporary clear sky upward visible shortwave flux (w/m2)
9177 ! zvscd(nlay+2) - temporary clear sky downward visible shortwave flux (w/m2)
9178 ! znifu(nlay+2) - temporary upward near-IR shortwave flux (w/m2)
9179 ! znifd(nlay+2) - temporary downward near-IR shortwave flux (w/m2)
9180 ! znicu(nlay+2) - temporary clear sky upward near-IR shortwave flux (w/m2)
9181 ! znicd(nlay+2) - temporary clear sky downward near-IR shortwave flux (w/m2)
9182 !
9183 !-------------------------------------------------------------------------------
9184 ! --------- Modules ---------
9185 !
9186 use parrrsw_k, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
9187 jpband, jpb1, jpb2
9188 use rrsw_aer_k, only : rsrtaua, rsrpiza, rsrasya
9189 use rrsw_con_k, only : heatfac, oneminus, pi
9190 use rrsw_wvn_k, only : wavenum1, wavenum2
9191 !
9192 ! ------- Declarations
9193 !
9194 ! ----- Input -----
9195 !
9196 integer(kind=im), intent(in ) :: ncol
9197 integer(kind=im), intent(in ) :: nlay
9198 integer(kind=im), intent(inout) :: icld
9199 real(kind=rb), dimension(:,:), intent(in ) :: play
9200 real(kind=rb), dimension(:,:), intent(in ) :: plev
9201 real(kind=rb), dimension(:,:), intent(in ) :: tlay
9202 real(kind=rb), dimension(:,:), intent(in ) :: tlev
9203 real(kind=rb), dimension(:), intent(in ) :: tsfc
9204 real(kind=rb), dimension(:,:), intent(in ) :: h2ovmr
9205 real(kind=rb), dimension(:,:), intent(in ) :: o3vmr
9206 real(kind=rb), dimension(:,:), intent(in ) :: co2vmr
9207 real(kind=rb), dimension(:,:), intent(in ) :: ch4vmr
9208 real(kind=rb), dimension(:,:), intent(in ) :: n2ovmr
9209 real(kind=rb), dimension(:,:), intent(in ) :: o2vmr
9210 real(kind=rb), dimension(:), intent(in ) :: asdir
9211 real(kind=rb), dimension(:), intent(in ) :: aldir
9212 real(kind=rb), dimension(:), intent(in ) :: asdif
9213 real(kind=rb), dimension(:), intent(in ) :: aldif
9214 integer(kind=im), intent(in ) :: dyofyr
9215 real(kind=rb), intent(in ) :: adjes
9216 real(kind=rb), dimension(:), intent(in ) :: coszen
9217 real(kind=rb), intent(in ) :: scon
9218 integer(kind=im), intent(in ) :: inflgsw
9219 integer(kind=im), intent(in ) :: iceflgsw
9220 integer(kind=im), intent(in ) :: liqflgsw
9221 real(kind=rb), dimension(:,:,:), intent(in ) :: cldfmcl
9222 real(kind=rb), dimension(:,:,:), intent(in ) :: taucmcl
9223 real(kind=rb), dimension(:,:,:), intent(in ) :: ssacmcl
9224 real(kind=rb), dimension(:,:,:), intent(in ) :: asmcmcl
9225 real(kind=rb), dimension(:,:,:), intent(in ) :: fsfcmcl
9226 real(kind=rb), dimension(:,:,:), intent(in ) :: ciwpmcl
9227 real(kind=rb), dimension(:,:,:), intent(in ) :: clwpmcl
9228 real(kind=rb), dimension(:,:,:), intent(in ) :: cswpmcl
9229 real(kind=rb), dimension(:,:), intent(in ) :: reicmcl
9230 real(kind=rb), dimension(:,:), intent(in ) :: relqmcl
9231 real(kind=rb), dimension(:,:), intent(in ) :: resnmcl
9232 real(kind=rb), dimension(:,:,:), intent(in ) :: tauaer
9233 real(kind=rb), dimension(:,:,:), intent(in ) :: ssaaer
9234 real(kind=rb), dimension(:,:,:), intent(in ) :: asmaer
9235 real(kind=rb), dimension(:,:,:), intent(in ) :: ecaer
9236 !
9237 ! ----- Output -----
9238 !
9239 real(kind=rb), dimension(:,:), intent( out) :: swuflx
9240 real(kind=rb), dimension(:,:), intent( out) :: swdflx
9241 real(kind=rb), dimension(:,:), intent( out) :: swhr
9242 real(kind=rb), dimension(:,:), intent( out) :: swuflxc
9243 real(kind=rb), dimension(:,:), intent( out) :: swdflxc
9244 real(kind=rb), dimension(:,:), intent( out) :: swhrc
9245 real(kind=rb), dimension(:), intent( out) :: visdir
9246 real(kind=rb), dimension(:), intent( out) :: visdif
9247 real(kind=rb), dimension(:), intent( out) :: nirdir
9248 real(kind=rb), dimension(:), intent( out) :: nirdif
9249 !
9250 ! ----- Local -----
9251 !
9252 ! Control
9253 !
9254 integer(kind=im) :: nlayers
9255 integer(kind=im) :: istart
9256 integer(kind=im) :: iend
9257 integer(kind=im) :: icpr
9258 integer(kind=im) :: iout
9259 integer(kind=im) :: iaer
9260 integer(kind=im) :: idelm
9261 integer(kind=im) :: isccos
9262 integer(kind=im) :: iplon
9263 integer(kind=im) :: i
9264 integer(kind=im) :: ib
9265 integer(kind=im) :: ia, ig
9266 integer(kind=im) :: k
9267 integer(kind=im) :: ims
9268 integer(kind=im) :: imca
9269 real(kind=rb) :: zepsec, zepzen
9270 real(kind=rb) :: zdpgcp
9271 !
9272 ! Atmosphere
9273 !
9274 real(kind=rb), dimension(nlay+1) :: pavel
9275 real(kind=rb), dimension(nlay+1) :: tavel
9276 real(kind=rb), dimension(0:nlay+1) :: pz
9277 real(kind=rb), dimension(0:nlay+1) :: tz
9278 real(kind=rb) :: tbound
9279 real(kind=rb), dimension(nlay+1) :: pdp
9280 real(kind=rb), dimension(nlay+1) :: coldry
9281 real(kind=rb), dimension(mxmol,nlay+1) :: wkl
9282 !
9283 ! real(kind=rb) :: earth_sun
9284 real(kind=rb) :: cossza
9285 real(kind=rb), dimension(jpband) :: adjflux
9286 real(kind=rb), dimension(jpband) :: solvar
9287 real(kind=rb), dimension(nbndsw) :: albdir
9288 real(kind=rb), dimension(nbndsw) :: albdif
9289 !
9290 real(kind=rb), dimension(nlay+1,nbndsw) :: taua
9291 real(kind=rb), dimension(nlay+1,nbndsw) :: ssaa
9292 real(kind=rb), dimension(nlay+1,nbndsw) :: asma
9293 !
9294 ! Atmosphere - setcoef
9295 !
9296 integer(kind=im) :: laytrop
9297 integer(kind=im) :: layswtch
9298 integer(kind=im) :: laylow
9299 integer(kind=im), dimension(nlay+1) :: jp
9300 integer(kind=im), dimension(nlay+1) :: jt
9301 integer(kind=im), dimension(nlay+1) :: jt1
9302 !
9303 real(kind=rb), dimension(nlay+1) :: colh2o
9304 real(kind=rb), dimension(nlay+1) :: colco2
9305 real(kind=rb), dimension(nlay+1) :: colo3
9306 real(kind=rb), dimension(nlay+1) :: coln2o
9307 real(kind=rb), dimension(nlay+1) :: colch4
9308 real(kind=rb), dimension(nlay+1) :: colo2
9309 real(kind=rb), dimension(nlay+1) :: colmol
9310 real(kind=rb), dimension(nlay+1) :: co2mult
9311 !
9312 integer(kind=im), dimension(nlay+1) :: indself
9313 integer(kind=im), dimension(nlay+1) :: indfor
9314 real(kind=rb), dimension(nlay+1) :: selffac
9315 real(kind=rb), dimension(nlay+1) :: selffrac
9316 real(kind=rb), dimension(nlay+1) :: forfac
9317 real(kind=rb), dimension(nlay+1):: forfrac
9318 real(kind=rb), dimension(nlay+1) :: fac00, fac01, fac10, fac11
9319 !
9320 ! Atmosphere/clouds - cldprop
9321 !
9322 integer(kind=im) :: ncbands
9323 integer(kind=im) :: inflag
9324 integer(kind=im) :: iceflag
9325 integer(kind=im) :: liqflag
9326 !
9327 ! real(kind=rb) :: cldfrac(nlay+1)
9328 ! real(kind=rb) :: tauc(nlay+1)
9329 ! real(kind=rb) :: ssac(nlay+1)
9330 ! real(kind=rb) :: asmc(nlay+1)
9331 ! real(kind=rb) :: fsfc(nlay+1)
9332 ! real(kind=rb) :: ciwp(nlay+1)
9333 ! real(kind=rb) :: clwp(nlay+1)
9334 ! real(kind=rb) :: rei(nlay+1)
9335 ! real(kind=rb) :: rel(nlay+1)
9336 !
9337 ! real(kind=rb) :: taucloud(nlay+1,jpband)
9338 ! real(kind=rb) :: taucldorig(nlay+1,jpband)
9339 ! real(kind=rb) :: ssacloud(nlay+1,jpband)
9340 ! real(kind=rb) :: asmcloud(nlay+1,jpband)
9341 !
9342 ! Atmosphere/clouds - cldprmc [mcica]
9343 !
9344 real(kind=rb), dimension(ngptsw,nlay+1) :: cldfmc
9345 real(kind=rb), dimension(ngptsw,nlay+1) :: ciwpmc
9346 real(kind=rb), dimension(ngptsw,nlay+1) :: clwpmc
9347 real(kind=rb), dimension(ngptsw,nlay+1) :: cswpmc
9348 real(kind=rb), dimension(nlay+1) :: relqmc
9349 real(kind=rb), dimension(nlay+1) :: reicmc
9350 real(kind=rb), dimension(nlay+1) :: resnmc
9351 real(kind=rb), dimension(ngptsw,nlay+1) :: taucmc
9352 real(kind=rb), dimension(ngptsw,nlay+1) :: taormc
9353 real(kind=rb), dimension(ngptsw,nlay+1) :: ssacmc
9354 real(kind=rb), dimension(ngptsw,nlay+1) :: asmcmc
9355 real(kind=rb), dimension(ngptsw,nlay+1) :: fsfcmc
9356 real(kind=rb), dimension(ngptsw,nlay+1) :: dtliq
9357 real(kind=rb), dimension(ngptsw,nlay+1) :: dtice
9358 real(kind=rb), dimension(ngptsw,nlay+1) :: dtsno
9359 real(kind=rb), dimension(ngptsw,nlay+1) :: dwliq
9360 real(kind=rb), dimension(ngptsw,nlay+1) :: dwice
9361 real(kind=rb), dimension(ngptsw,nlay+1) :: dwsno
9362 real(kind=rb), dimension(ngptsw,nlay+1) :: daliq
9363 real(kind=rb), dimension(ngptsw,nlay+1) :: daice
9364 real(kind=rb), dimension(ngptsw,nlay+1) :: dasno
9365 !
9366 ! Atmosphere/clouds/aerosol - spcvrt,spcvmc
9367 !
9368 real(kind=rb), dimension(nlay+1,nbndsw) :: ztauc
9369 real(kind=rb), dimension(nlay+1,nbndsw) :: ztaucorig
9370 real(kind=rb), dimension(nlay+1,nbndsw) :: zasyc
9371 real(kind=rb), dimension(nlay+1,nbndsw) :: zomgc
9372 real(kind=rb), dimension(nlay+1,nbndsw) :: ztaua
9373 real(kind=rb), dimension(nlay+1,nbndsw) :: zasya
9374 real(kind=rb), dimension(nlay+1,nbndsw) :: zomga
9375 !
9376 real(kind=rb), dimension(nlay+1,ngptsw) :: zcldfmc
9377 real(kind=rb), dimension(nlay+1,ngptsw) :: ztaucmc
9378 real(kind=rb), dimension(nlay+1,ngptsw) :: ztaormc
9379 real(kind=rb), dimension(nlay+1,ngptsw) :: zasycmc
9380 real(kind=rb), dimension(nlay+1,ngptsw) :: zomgcmc
9381 !
9382 real(kind=rb), dimension(nlay+2) :: zbbfu
9383 real(kind=rb), dimension(nlay+2) :: zbbfd
9384 real(kind=rb), dimension(nlay+2) :: zbbcu
9385 real(kind=rb), dimension(nlay+2) :: zbbcd
9386 real(kind=rb), dimension(nlay+2) :: zbbfddir
9387 real(kind=rb), dimension(nlay+2) :: zbbcddir
9388 real(kind=rb), dimension(nlay+2) :: zuvfd
9389 real(kind=rb), dimension(nlay+2) :: zuvcd
9390 real(kind=rb), dimension(nlay+2) :: zuvfddir
9391 real(kind=rb), dimension(nlay+2) :: zuvcddir
9392 real(kind=rb), dimension(nlay+2) :: znifd
9393 real(kind=rb), dimension(nlay+2) :: znicd
9394 real(kind=rb), dimension(nlay+2) :: znifddir
9395 real(kind=rb), dimension(nlay+2) :: znicddir
9396 !
9397 ! Optional output fields
9398 !
9399 real(kind=rb), dimension(nlay+2) :: swnflx
9400 real(kind=rb), dimension(nlay+2) :: swnflxc
9401 real(kind=rb), dimension(nlay+2) :: dirdflux
9402 real(kind=rb), dimension(nlay+2) :: difdflux
9403 real(kind=rb), dimension(nlay+2) :: uvdflx
9404 real(kind=rb), dimension(nlay+2) :: nidflx
9405 real(kind=rb), dimension(nlay+2) :: dirdnuv
9406 real(kind=rb), dimension(nlay+2) :: difdnuv
9407 real(kind=rb), dimension(nlay+2) :: dirdnir
9408 real(kind=rb), dimension(nlay+2) :: difdnir
9409 !
9410 ! Output - inactive
9411 !
9412 ! real(kind=rb) :: zuvfu(nlay+2)
9413 ! real(kind=rb) :: zuvfd(nlay+2)
9414 ! real(kind=rb) :: zuvcu(nlay+2)
9415 ! real(kind=rb) :: zuvcd(nlay+2)
9416 ! real(kind=rb) :: zvsfu(nlay+2)
9417 ! real(kind=rb) :: zvsfd(nlay+2)
9418 ! real(kind=rb) :: zvscu(nlay+2)
9419 ! real(kind=rb) :: zvscd(nlay+2)
9420 ! real(kind=rb) :: znifu(nlay+2)
9421 ! real(kind=rb) :: znifd(nlay+2)
9422 ! real(kind=rb) :: znicu(nlay+2)
9423 ! real(kind=rb) :: znicd(nlay+2)
9424 !
9425 !
9426 ! Initializations
9427 !
9428 zepsec = 1.e-06_rb
9429 zepzen = 1.e-10_rb
9430 oneminus = 1.0_rb - zepsec
9431 pi = 2._rb * asin(1._rb)
9432 !
9433 istart = jpb1
9434 iend = jpb2
9435 icpr = 0
9436 ims = 2
9437 !
9438 ! In a GCM with or without McICA, set nlon to the longitude dimension
9439 !
9440 ! Set imca to select calculation type:
9441 ! imca = 0, use standard forward model calculation (clear and overcast only)
9442 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
9443 ! (clear, overcast or partial cloud conditions)
9444 !
9445 ! *** This version uses McICA (imca = 1) ***
9446 !
9447 ! Set icld to select of clear or cloud calculation and cloud
9448 ! overlap method (read by subroutine readprof from input file INPUT_RRTM):
9449 ! icld = 0, clear only
9450 ! icld = 1, with clouds using random cloud overlap (McICA only)
9451 ! icld = 2, with clouds using maximum/random cloud overlap (McICA only)
9452 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
9453 if (icld.lt.0.or.icld.gt.3) icld = 2
9454 !
9455 ! Set iaer to select aerosol option
9456 ! iaer = 0, no aerosols
9457 ! iaer = 6, use six ECMWF aerosol types
9458 ! input aerosol optical depth at 0.55 microns for each
9459 ! aerosol type (ecaer)
9460 ! iaer = 10, input total aerosol optical depth, single scattering albedo
9461 ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly
9462 iaer = 6
9463 !
9464 ! Call model and data initialization, compute lookup tables, perform
9465 ! reduction of g-points from 224 to 112 for input absorption
9466 ! coefficient data and other arrays.
9467 !
9468 ! In a GCM this call should be placed in the model initialization
9469 ! area, since this has to be called only once.
9470 ! call rrtmg_sw_ini(cpdair)
9471 !
9472 ! This is the main longitude/column loop in RRTMG.
9473 ! Modify to loop over all columns (nlon) or over daylight columns
9474 !
9475 do iplon = 1,ncol
9476 if(coszen(iplon).gt.0.0)then
9477 !
9478 ! Prepare atmosphere profile from GCM for use in RRTMG, and define
9479 ! other input parameters
9480 !
9481 call inatm_sw (iplon, nlay, icld, iaer, &
9482 play, plev, tlay, tlev, tsfc, h2ovmr, &
9483 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
9484 adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
9485 cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, &
9486 ciwpmcl, clwpmcl, reicmcl, relqmcl, &
9487 cswpmcl, resnmcl, &
9488 tauaer, ssaaer, asmaer, &
9489 nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
9490 adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
9491 ssacmc, asmcmc, fsfcmc, &
9492 ciwpmc, clwpmc, reicmc, relqmc, &
9493 cswpmc, resnmc, &
9494 taua, ssaa, asma)
9495 !
9496 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
9497 ! input cloud physical properties. Select method based on choices described
9498 ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
9499 ! effective radius must be passed in cldprop. Cloud fraction and cloud
9500 ! optical properties are transferred to rrtmg_sw arrays in cldprop.
9501 !
9502 dtliq=0._rb ; dtice=0._rb ; dtsno=0._rb
9503 dwliq=1._rb ; dwice=1._rb ; dwsno=1._rb
9504 daliq=0._rb ; daice=0._rb ; dasno=0._rb
9505 call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
9506 ciwpmc, clwpmc, reicmc, relqmc, &
9507 cswpmc, resnmc, &
9508 dtliq, dtice, dtsno, dwliq, dwice, dwsno, &
9509 daliq, daice, dasno, &
9510 taormc, taucmc, ssacmc, asmcmc, fsfcmc)
9511 icpr = 1
9512 !
9513 ! Calculate coefficients for the temperature and pressure dependence of the
9514 ! molecular absorption coefficients by interpolating data from stored
9515 ! reference atmospheres.
9516 !
9517 call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
9518 laytrop, layswtch, laylow, jp, jt, jt1, &
9519 co2mult, colch4, colco2, colh2o, colmol, coln2o, &
9520 colo2, colo3, fac00, fac01, fac10, fac11, &
9521 selffac, selffrac, indself, forfac, forfrac, indfor)
9522 !
9523 ! Cosine of the solar zenith angle
9524 ! Prevent using value of zero; ideally,
9525 ! SW model is not called from host model when sun
9526 ! is below horizon
9527 !
9528 cossza = coszen(iplon)
9529 if (cossza .le. zepzen) cossza = zepzen
9530 !
9531 ! Transfer albedo, cloud and aerosol properties into arrays for
9532 ! 2-stream radiative transfer
9533 !
9534 ! Surface albedo
9535 ! Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns
9536 !
9537 do ib = 1,9
9538 albdir(ib) = aldir(iplon)
9539 albdif(ib) = aldif(iplon)
9540 enddo
9541 albdir(nbndsw) = aldir(iplon)
9542 albdif(nbndsw) = aldif(iplon)
9543 !
9544 ! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
9545 !
9546 do ib = 10,13
9547 albdir(ib) = asdir(iplon)
9548 albdif(ib) = asdif(iplon)
9549 enddo
9550 !
9551 ! Clouds
9552 !
9553 if (icld.eq.0) then
9554 zcldfmc(:,:) = 0._rb
9555 ztaucmc(:,:) = 0._rb
9556 ztaormc(:,:) = 0._rb
9557 zasycmc(:,:) = 0._rb
9558 zomgcmc(:,:) = 1._rb
9559 elseif (icld.ge.1) then
9560 do i = 1,nlayers
9561 do ig = 1,ngptsw
9562 zcldfmc(i,ig) = cldfmc(ig,i)
9563 ztaucmc(i,ig) = taucmc(ig,i)
9564 ztaormc(i,ig) = taormc(ig,i)
9565 zasycmc(i,ig) = asmcmc(ig,i)
9566 zomgcmc(i,ig) = ssacmc(ig,i)
9567 enddo
9568 enddo
9569 endif
9570 !
9571 ! Aerosol
9572 ! IAER = 0: no aerosols
9573 !
9574 if(iaer.eq.0) then
9575 ztaua(:,:) = 0._rb
9576 zasya(:,:) = 0._rb
9577 zomga(:,:) = 1._rb
9578 !
9579 ! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details.
9580 ! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer),
9581 ! or set manually here for each aerosol and layer.
9582 !
9583 elseif(iaer.eq.6) then
9584 ! do i = 1,nlayers
9585 ! do ia = 1,naerec
9586 ! ecaer(iplon,i,ia) = 1.0e-15_rb
9587 ! enddo
9588 ! enddo
9589 do i = 1,nlayers
9590 do ib = 1,nbndsw
9591 ztaua(i,ib) = 0._rb
9592 zasya(i,ib) = 0._rb
9593 zomga(i,ib) = 0._rb
9594 do ia = 1,naerec
9595 ztaua(i,ib) = ztaua(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)
9596 zomga(i,ib) = zomga(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)* &
9597 rsrpiza(ib,ia)
9598 zasya(i,ib) = zasya(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)* &
9599 rsrpiza(ib,ia) * rsrasya(ib,ia)
9600 enddo
9601 if(zomga(i,ib).ne.0._rb) then
9602 zasya(i,ib) = zasya(i,ib)/zomga(i,ib)
9603 endif
9604 if(ztaua(i,ib).ne.0._rb) then
9605 zomga(i,ib) = zomga(i,ib)/ztaua(i,ib)
9606 endif
9607 enddo
9608 enddo
9609 !
9610 ! IAER=10: Direct specification of aerosol optical properties from GCM
9611 !
9612 elseif(iaer.eq.10) then
9613 do i = 1,nlayers
9614 do ib = 1,nbndsw
9615 ztaua(i,ib) = taua(i,ib)
9616 zasya(i,ib) = asma(i,ib)
9617 zomga(i,ib) = ssaa(i,ib)
9618 enddo
9619 enddo
9620 endif
9621 !
9622 ! Call the 2-stream radiation transfer model
9623 !
9624 do i = 1,nlayers+1
9625 zbbcu(i) = 0._rb
9626 zbbcd(i) = 0._rb
9627 zbbfu(i) = 0._rb
9628 zbbfd(i) = 0._rb
9629 zbbcddir(i) = 0._rb
9630 zbbfddir(i) = 0._rb
9631 zuvcd(i) = 0._rb
9632 zuvfd(i) = 0._rb
9633 zuvcddir(i) = 0._rb
9634 zuvfddir(i) = 0._rb
9635 znicd(i) = 0._rb
9636 znifd(i) = 0._rb
9637 znicddir(i) = 0._rb
9638 znifddir(i) = 0._rb
9639 enddo
9640 !
9641 call spcvmc_sw &
9642 (nlayers, istart, iend, icpr, iout, &
9643 pavel, tavel, pz, tz, tbound, albdif, albdir, &
9644 zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
9645 ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, &
9646 laytrop, layswtch, laylow, jp, jt, jt1, &
9647 co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
9648 fac00, fac01, fac10, fac11, &
9649 selffac, selffrac, indself, forfac, forfrac, indfor, &
9650 dtliq,dtice,dtsno,dwliq,dwice,dwsno,daliq,daice,dasno, &
9651 zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, &
9652 zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir)
9653 !
9654 ! Transfer up and down, clear and total sky fluxes to output arrays.
9655 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
9656 !
9657 do i = 1,nlayers+1
9658 swuflxc(iplon,i) = zbbcu(i)
9659 swdflxc(iplon,i) = zbbcd(i)
9660 swuflx(iplon,i) = zbbfu(i)
9661 swdflx(iplon,i) = zbbfd(i)
9662 uvdflx(i) = zuvfd(i)
9663 nidflx(i) = znifd(i)
9664 !
9665 ! Direct/diffuse fluxes
9666 !
9667 dirdflux(i) = zbbfddir(i)
9668 difdflux(i) = swdflx(iplon,i) - dirdflux(i)
9669 !
9670 ! UV/visible direct/diffuse fluxes
9671 !
9672 dirdnuv(i) = zuvfddir(i)
9673 difdnuv(i) = zuvfd(i) - dirdnuv(i)
9674 !
9675 ! Near-IR direct/diffuse fluxes
9676 !
9677 dirdnir(i) = znifddir(i)
9678 difdnir(i) = znifd(i) - dirdnir(i)
9679 enddo
9680 !
9681 ! Total and clear sky net fluxes
9682 !
9683 do i = 1,nlayers+1
9684 swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i)
9685 swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i)
9686 enddo
9687 !
9688 ! Total and clear sky heating rates
9689 !
9690 do i = 1,nlayers
9691 zdpgcp = heatfac / pdp(i)
9692 swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp
9693 swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp
9694 enddo
9695 swhrc(iplon,nlayers) = 0._rb
9696 swhr(iplon,nlayers) = 0._rb
9697 !
9698 ! End longitude loop
9699 !
9700 endif
9701 enddo
9702 !
9703 end subroutine rrtmg_sw
9704 !-------------------------------------------------------------------------------
9705 !
9706 !
9707 !-------------------------------------------------------------------------------
9708 real(kind=rb) function earth_sun(idn)
9709 !-------------------------------------------------------------------------------
9710 !
9711 ! abstract:
9712 ! Function to calculate the correction factor of Earth's orbit
9713 ! for current day of the year
9714 !
9715 ! idn : Day of the year
9716 ! earth_sun : square of the ratio of mean to actual Earth-Sun distance
9717 !
9718 !-------------------------------------------------------------------------------
9719 ! ------- Modules -------
9720 !
9721 use rrsw_con_k, only : pi
9722 !
9723 integer(kind=im), intent(in) :: idn
9724 real(kind=rb) :: gamma
9725 !-------------------------------------------------------------------------------
9726 gamma = 2._rb*pi*(idn-1)/365._rb
9727 !
9728 ! Use Iqbal's equation 1.2.1
9729 !
9730 earth_sun = 1.000110_rb+.034221_rb*cos(gamma) + &
9731 .001289_rb*sin(gamma) + &
9732 .000719_rb*cos(2._rb*gamma)+.000077_rb*sin(2._rb*gamma)
9733 !
9734 end function earth_sun
9735 !-------------------------------------------------------------------------------
9736 !
9737 !
9738 !-------------------------------------------------------------------------------
9739 subroutine inatm_sw (iplon, nlay, icld, iaer, &
9740 play, plev, tlay, tlev, tsfc, h2ovmr, &
9741 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
9742 adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
9743 cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, &
9744 ciwpmcl, clwpmcl, reicmcl, relqmcl, &
9745 cswpmcl, resnmcl, &
9746 tauaer, ssaaer, asmaer, &
9747 nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
9748 adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
9749 ssacmc, asmcmc, fsfcmc, &
9750 ciwpmc, clwpmc, reicmc, relqmc, &
9751 cswpmc, resnmc, &
9752 taua, ssaa, asma)
9753 !-------------------------------------------------------------------------------
9754 !
9755 ! abstract :
9756 ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
9757 ! Set other RRTMG_SW input parameters.
9758 !
9759 ! history log :
9760 !
9761 ! input :
9762 ! iplon - column loop index
9763 ! nlay - number of model layers
9764 ! icld - clear/cloud and cloud overlap flag
9765 ! iaer - aerosol option flag
9766 ! play(ncol,nlay) - Layer pressures (hPa, mb)
9767 ! plev(ncol,nlay+1) - Interface pressures (hPa, mb)
9768 ! tlay(ncol,nlay) - Layer temperatures (K)
9769 ! tlev(ncol,nlay+1) - Interface temperatures (K)
9770 ! tsfc(ncol) - Surface temperature (K)
9771 ! h2ovmr(ncol,nlay) - H2O volume mixing ratio
9772 ! o3vmr(ncol,nlay) - o3 volume mixing ratio
9773 ! co2vmr(ncol,nlay) - co2 volume mixing ratio
9774 ! ch4vmr(ncol,nlay) - ch4 volume mixing ratio
9775 ! n2ovmr(ncol,nlay) - n2o volume mixing ratio
9776 ! o2vmr(ncol,nlay) - o2 volume mixing ratio
9777 !
9778 ! dyofyr - Day of the year (used to get Earth/Sun distance
9779 ! if adjflx not provided)
9780 ! adjes - Flux adjustment for Earth/Sun distance
9781 ! scon - Solar constant (W/m2)
9782 !
9783 ! inflgsw - Flag for cloud optical properties
9784 ! iceflgsw - Flag for ice particle specification
9785 ! liqflgsw - Flag for liquid droplet specification
9786 !
9787 ! cldfmcl(ngptsw,ncol,nlay) - cloud fraction
9788 ! taucmcl(ngptsw,ncol,nlay) - In-cloud optical depth (optional)
9789 ! ssacmcl(ngptsw,ncol,nlay) - In-cloud single scattering albedo (optional)
9790 ! asmcmcl(ngptsw,ncol,nlay) - In-cloud asymmetry parameter (optional)
9791 ! fsfcmcl(ngptsw,ncol,nlay) - In-cloud forward scattering fraction (optional)
9792 ! ciwpmcl(ngptsw,ncol,nlay) - In-cloud ice water path (g/m2)
9793 ! clwpmcl(ngptsw,ncol,nlay) - In-cloud liquid water path (g/m2)
9794 ! cswpmcl(ngptsw,ncol,nlay) - In-cloud snow water path (g/m2)
9795 ! reicmcl(ncol,nlay) - Cloud ice effective size (microns)
9796 ! relqmcl(ncol,nlay) - Cloud water drop effective radius (microns)
9797 ! resnmcl(ncol,nlay) - Cloud snow effective radius (microns)
9798 !
9799 ! tauaer(ncol,nlay,nbndsw) - Aerosol optical depth
9800 ! ssaaer(ncol,nlay,nbndsw) - Aerosol single scattering albedo
9801 ! asmaer(ncol,nlay,nbndsw) - Aerosol asymmetry parameters
9802 !
9803 ! nlayers - number of layers
9804 ! pavel(nlay) - layer pressures (mb)
9805 ! tavel(nlay) layer temperatures (K)
9806 ! pz(0:) - level (interface) pressures (hPa, mb)
9807 ! tz(0:) - level (interface) temperatures (K)
9808 ! tbound - surface temperature(K)
9809 ! pdp(nlay) - layer pressure thickness (hPa, mb)
9810 ! coldry(nlay) - dry air column density (mol/cm2)
9811 ! wkl(mxmol,nlay) - molecular amounts (mol/cm-2)
9812 ! adjflux(jpband) - adjustment for current Earth/Sun distance
9813 ! solvar(jpband) - solar constant scaling factor from rrtmg_sw
9814 ! default value of 1368.22 Wm-2 at 1 AU
9815 ! taua(nlay,nbndsw) - Aerosol optical depth
9816 ! ssaa(nlay,nbndsw) - Aerosol single scattering albedo
9817 ! asma(nlay,nbndsw) - Aerosol asymmtry parameter
9818 !
9819 ! inflag - flag for cloud property method
9820 ! iceflag - flag for ice cloud properties
9821 ! liqflag - flag for liquid cloud properties
9822 !
9823 ! cldfmc(ngptsw,nlay) - layer cloud fraction
9824 ! taucmc(ngptsw,nlay) - in-cloud optical depth (non-delta scaled)
9825 ! ssacmc(ngptsw,nlay) - in-cloud single scattering albedo (non-delta scaled)
9826 ! asmcmc(ngptsw,nlay) - in-cloud asymmetry parameter (non-delta scaled)
9827 ! fsfcmc(ngptsw,nlay) - in-cloud forward scattering fraction
9828 ! (non-delta scaled)
9829 ! ciwpmc(ngptsw,nlay) - in-cloud ice water path
9830 ! clwpmc(ngptsw,nlay) - in-cloud liquid water path
9831 ! cswpmc(ngptsw,nlay) - in-cloud snow water path
9832 ! relqmc(nlay) - liquid particle effective radius (microns)
9833 ! reicmc(nlay) - ice particle effective radius (microns)
9834 ! rescmc(nlay) - snow particle effective radius (microns)
9835 !
9836 ! local :
9837 ! amd - Effective molecular weight of dry air (g/mol)
9838 ! amw - Molecular weight of water vapor (g/mol)
9839 ! amc - Molecular weight of carbon dioxide (g/mol)
9840 ! amo - Molecular weight of ozone (g/mol)
9841 ! amo2 - Molecular weight of oxygen (g/mol)
9842 ! amch4 - Molecular weight of methane (g/mol)
9843 ! amn2o - Molecular weight of nitrous oxide (g/mol)
9844 ! amdw - Molecular weight of dry air / water vapor
9845 ! amdc - Molecular weight of dry air / carbon dioxide
9846 ! amdo - Molecular weight of dry air / ozone
9847 ! amdm - Molecular weight of dry air / methane
9848 ! amdn - Molecular weight of dry air / nitrous oxide
9849 ! amdo2 - Molecular weight of dry air / oxygen
9850 ! sbc - Stefan-Boltzmann constant (W/m2K4)
9851 ! isp, l, ix, n, imol, ib, ig - Loop indices
9852 ! adjflx - flux adjustment for Earth/Sun distance
9853 ! earth_sun - function for Earth/Sun distance adjustment
9854 !
9855 !-------------------------------------------------------------------------------
9856 use parrrsw_k, only : nbndsw, ngptsw, nstr, nmol, mxmol, &
9857 jpband, jpb1, jpb2, rrsw_scon
9858 use rrsw_con_k, only : heatfac, oneminus, pi, grav, avogad
9859 use rrsw_wvn_k, only : ng, nspa, nspb, wavenum1, wavenum2, delwave
9860 !
9861 ! ------- Declarations -------
9862 !
9863 ! ----- Input -----
9864 integer(kind=im), intent(in ) :: iplon
9865 integer(kind=im), intent(in ) :: nlay
9866 integer(kind=im), intent(in ) :: icld
9867 integer(kind=im), intent(in ) :: iaer
9868 real(kind=rb), dimension(:,:), intent(in ) :: play
9869 real(kind=rb), dimension(:,:), intent(in ) :: plev
9870 real(kind=rb), dimension(:,:), intent(in ) :: tlay
9871 real(kind=rb), dimension(:,:), intent(in ) :: tlev
9872 real(kind=rb), dimension(:), intent(in ) :: tsfc
9873 real(kind=rb), dimension(:,:), intent(in ) :: h2ovmr
9874 real(kind=rb), dimension(:,:), intent(in ) :: o3vmr
9875 real(kind=rb), dimension(:,:), intent(in ) :: co2vmr
9876 real(kind=rb), dimension(:,:), intent(in ) :: ch4vmr
9877 real(kind=rb), dimension(:,:), intent(in ) :: n2ovmr
9878 real(kind=rb), dimension(:,:), intent(in ) :: o2vmr
9879 integer(kind=im), intent(in ) :: dyofyr
9880 real(kind=rb), intent(in ) :: adjes
9881 real(kind=rb), intent(in ) :: scon
9882 !
9883 integer(kind=im), intent(in ) :: inflgsw
9884 integer(kind=im), intent(in ) :: iceflgsw
9885 integer(kind=im), intent(in ) :: liqflgsw
9886 !
9887 real(kind=rb), dimension(:,:,:), intent(in ) :: cldfmcl
9888 real(kind=rb), dimension(:,:,:), intent(in ) :: taucmcl
9889 real(kind=rb), dimension(:,:,:), intent(in ) :: ssacmcl
9890 real(kind=rb), dimension(:,:,:), intent(in ) :: asmcmcl
9891 real(kind=rb), dimension(:,:,:), intent(in ) :: fsfcmcl
9892 real(kind=rb), dimension(:,:,:), intent(in ) :: ciwpmcl
9893 real(kind=rb), dimension(:,:,:), intent(in ) :: clwpmcl
9894 real(kind=rb), dimension(:,:,:), intent(in ) :: cswpmcl
9895 real(kind=rb), dimension(:,:), intent(in ) :: reicmcl
9896 real(kind=rb), dimension(:,:), intent(in ) :: relqmcl
9897 real(kind=rb), dimension(:,:), intent(in ) :: resnmcl
9898 !
9899 real(kind=rb), dimension(:,:,:), intent(in ) :: tauaer
9900 real(kind=rb), dimension(:,:,:), intent(in ) :: ssaaer
9901 real(kind=rb), dimension(:,:,:), intent(in ) :: asmaer
9902 !
9903 ! Atmosphere
9904 !
9905 integer(kind=im), intent( out) :: nlayers
9906 real(kind=rb), dimension(:), intent( out) :: pavel
9907 real(kind=rb), dimension(:), intent( out) :: tavel
9908 real(kind=rb), dimension(0:), intent( out) :: pz
9909 real(kind=rb), dimension(0:), intent( out) :: tz
9910 real(kind=rb), intent( out) :: tbound
9911 real(kind=rb), dimension(:), intent( out) :: pdp
9912 real(kind=rb), dimension(:), intent( out) :: coldry
9913 real(kind=rb), dimension(:,:), intent( out) :: wkl
9914 real(kind=rb), dimension(:), intent( out) :: adjflux
9915 real(kind=rb), dimension(:), intent( out) :: solvar
9916 real(kind=rb), dimension(:,:), intent( out) :: taua
9917 real(kind=rb), dimension(:,:), intent( out) :: ssaa
9918 real(kind=rb), dimension(:,:), intent( out) :: asma
9919 !
9920 ! Atmosphere/clouds - cldprop
9921 !
9922 integer(kind=im), intent( out) :: inflag
9923 integer(kind=im), intent( out) :: iceflag
9924 integer(kind=im), intent( out) :: liqflag
9925 !
9926 real(kind=rb), dimension(:,:), intent( out) :: cldfmc
9927 real(kind=rb), dimension(:,:), intent( out) :: taucmc
9928 real(kind=rb), dimension(:,:), intent( out) :: ssacmc
9929 real(kind=rb), dimension(:,:), intent( out) :: asmcmc
9930 real(kind=rb), dimension(:,:), intent( out) :: fsfcmc
9931 real(kind=rb), dimension(:,:), intent( out) :: ciwpmc
9932 real(kind=rb), dimension(:,:), intent( out) :: clwpmc
9933 real(kind=rb), dimension(:,:), intent( out) :: cswpmc
9934 real(kind=rb), dimension(:), intent( out) :: relqmc
9935 real(kind=rb), dimension(:), intent( out) :: reicmc
9936 real(kind=rb), dimension(:), intent( out) :: resnmc
9937 !
9938 ! ----- Local -----
9939 !
9940 real(kind=rb), parameter :: amd = 28.9660_rb
9941 real(kind=rb), parameter :: amw = 18.0160_rb
9942 ! real(kind=rb), parameter :: amc = 44.0098_rb
9943 ! real(kind=rb), parameter :: amo = 47.9998_rb
9944 ! real(kind=rb), parameter :: amo2 = 31.9999_rb
9945 ! real(kind=rb), parameter :: amch4 = 16.0430_rb
9946 ! real(kind=rb), parameter :: amn2o = 44.0128_rb
9947 !
9948 ! Set molecular weight ratios (for converting mmr to vmr)
9949 ! e.g. h2ovmr = h2ommr * amdw)
9950 !
9951 real(kind=rb), parameter :: amdw = 1.607793_rb
9952 real(kind=rb), parameter :: amdc = 0.658114_rb
9953 real(kind=rb), parameter :: amdo = 0.603428_rb
9954 real(kind=rb), parameter :: amdm = 1.805423_rb
9955 real(kind=rb), parameter :: amdn = 0.658090_rb
9956 real(kind=rb), parameter :: amdo2 = 0.905140_rb
9957 !
9958 real(kind=rb), parameter :: sbc = 5.67e-08_rb
9959 !
9960 integer(kind=im) :: isp, l, ix, n, imol, ib, ig
9961 real(kind=rb) :: amm, summol
9962 real(kind=rb) :: adjflx
9963 ! real(kind=rb) :: earth_sun
9964 !-------------------------------------------------------------------------------
9965 nlayers = nlay
9966 !
9967 ! Initialize all molecular amounts to zero here, then pass input amounts
9968 ! into RRTM array WKL below.
9969 !
9970 wkl(:,:) = 0.0_rb
9971 cldfmc(:,:) = 0.0_rb
9972 taucmc(:,:) = 0.0_rb
9973 ssacmc(:,:) = 1.0_rb
9974 asmcmc(:,:) = 0.0_rb
9975 fsfcmc(:,:) = 0.0_rb
9976 ciwpmc(:,:) = 0.0_rb
9977 clwpmc(:,:) = 0.0_rb
9978 cswpmc(:,:) = 0.0_rb
9979 reicmc(:) = 0.0_rb
9980 relqmc(:) = 0.0_rb
9981 resnmc(:) = 0.0_rb
9982 taua(:,:) = 0.0_rb
9983 ssaa(:,:) = 1.0_rb
9984 asma(:,:) = 0.0_rb
9985 !
9986 ! Set flux adjustment for current Earth/Sun distance (two options).
9987 ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes);
9988 !
9989 adjflx = adjes
9990 !
9991 ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year.
9992 ! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU).
9993 !
9994 if (dyofyr .gt. 0) then
9995 adjflx = earth_sun(dyofyr)
9996 endif
9997 !
9998 ! Set incoming solar flux adjustment to include adjustment for
9999 ! current Earth/Sun distance (ADJFLX) and scaling of default internal
10000 ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set
10001 ! to a single scaling factor as needed, or to a different value in each
10002 ! band, which may be necessary for paleoclimate simulations.
10003 !
10004 do ib = jpb1,jpb2
10005 ! solvar(ib) = 1._rb
10006 solvar(ib) = scon / rrsw_scon
10007 adjflux(ib) = adjflx * solvar(ib)
10008 enddo
10009 !
10010 ! Set surface temperature.
10011 !
10012 tbound = tsfc(iplon)
10013 !
10014 ! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature,
10015 ! and molecular amounts.
10016 ! Pressures are input in mb, or are converted to mb here.
10017 ! Molecular amounts are input in volume mixing ratio, or are converted from
10018 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
10019 ! here. These are then converted to molecular amount (molec/cm2) below.
10020 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
10021 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
10022 ! correction to account for h2o in the layer. The molecular weight of moist
10023 ! air (amm) is calculated for each layer.
10024 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
10025 ! assumes GCM input fields are also bottom to top. Input layer indexing
10026 ! from GCM fields should be reversed here if necessary.
10027 !
10028 pz(0) = plev(iplon,1)
10029 tz(0) = tlev(iplon,1)
10030 do l = 1,nlayers
10031 pavel(l) = play(iplon,l)
10032 tavel(l) = tlay(iplon,l)
10033 pz(l) = plev(iplon,l+1)
10034 tz(l) = tlev(iplon,l+1)
10035 pdp(l) = pz(l-1) - pz(l)
10036 !
10037 ! For h2o input in vmr:
10038 wkl(1,l) = h2ovmr(iplon,l)
10039 ! For h2o input in mmr:
10040 ! wkl(1,l) = h2o(iplon,l)*amdw
10041 ! For h2o input in specific humidity;
10042 ! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
10043 !
10044 wkl(2,l) = co2vmr(iplon,l)
10045 wkl(3,l) = o3vmr(iplon,l)
10046 wkl(4,l) = n2ovmr(iplon,l)
10047 wkl(6,l) = ch4vmr(iplon,l)
10048 wkl(7,l) = o2vmr(iplon,l)
10049 amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
10050 coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
10051 (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
10052 enddo
10053 !
10054 ! The following section can be used to set values for an additional layer (from
10055 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
10056 ! Temperature and molecular amounts in the extra model layer are set to
10057 ! their values in the top GCM model layer, though these can be modified
10058 ! here if necessary.
10059 ! If this feature is utilized, increase nlayers by one above, limit the two
10060 ! loops above to (nlayers-1), and set the top most (nlayers) layer values here.
10061 !
10062 ! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
10063 ! tavel(nlayers) = tavel(nlayers-1)
10064 ! pz(nlayers) = 1.e-4_rb
10065 ! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
10066 ! tz(nlayers) = tz(nlayers-1)
10067 ! pdp(nlayers) = pz(nlayers-1) - pz(nlayers)
10068 ! wkl(1,nlayers) = wkl(1,nlayers-1)
10069 ! wkl(2,nlayers) = wkl(2,nlayers-1)
10070 ! wkl(3,nlayers) = wkl(3,nlayers-1)
10071 ! wkl(4,nlayers) = wkl(4,nlayers-1)
10072 ! wkl(6,nlayers) = wkl(6,nlayers-1)
10073 ! wkl(7,nlayers) = wkl(7,nlayers-1)
10074 ! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
10075 ! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
10076 ! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
10077 !
10078 ! At this point all molecular amounts in wkl are in volume mixing ratio;
10079 ! convert to molec/cm2 based on coldry for use in rrtm.
10080 !
10081 do l = 1,nlayers
10082 do imol = 1,nmol
10083 wkl(imol,l) = coldry(l) * wkl(imol,l)
10084 enddo
10085 enddo
10086 !
10087 ! Transfer aerosol optical properties to RRTM variables;
10088 ! modify to reverse layer indexing here if necessary.
10089 !
10090 if (iaer .ge. 1) then
10091 do l = 1,nlayers
10092 do ib = 1,nbndsw
10093 taua(l,ib) = tauaer(iplon,l,ib)
10094 ssaa(l,ib) = ssaaer(iplon,l,ib)
10095 asma(l,ib) = asmaer(iplon,l,ib)
10096 enddo
10097 enddo
10098 endif
10099 !
10100 ! Transfer cloud fraction and cloud optical properties to RRTM variables;
10101 ! modify to reverse layer indexing here if necessary.
10102 !
10103 if (icld .ge. 1) then
10104 inflag = inflgsw
10105 iceflag = iceflgsw
10106 liqflag = liqflgsw
10107 !
10108 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
10109 ! For GCM input, incoming reicmcl is defined based on selected ice
10110 ! parameterization (inflgsw)
10111 !
10112 do l = 1,nlayers
10113 do ig = 1,ngptsw
10114 cldfmc(ig,l) = cldfmcl(ig,iplon,l)
10115 taucmc(ig,l) = taucmcl(ig,iplon,l)
10116 ssacmc(ig,l) = ssacmcl(ig,iplon,l)
10117 asmcmc(ig,l) = asmcmcl(ig,iplon,l)
10118 fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
10119 ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
10120 clwpmc(ig,l) = clwpmcl(ig,iplon,l)
10121 if(iceflag.eq.5) then
10122 cswpmc(ig,l) = cswpmcl(ig,iplon,l)
10123 endif
10124 enddo
10125 reicmc(l) = reicmcl(iplon,l)
10126 relqmc(l) = relqmcl(iplon,l)
10127 if(iceflag.eq.5) then
10128 resnmc(l) = resnmcl(iplon,l)
10129 endif
10130 enddo
10131 !
10132 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in
10133 ! the extra layer.
10134 !
10135 ! cldfmc(:,nlayers) = 0.0_rb
10136 ! taucmc(:,nlayers) = 0.0_rb
10137 ! ssacmc(:,nlayers) = 1.0_rb
10138 ! asmcmc(:,nlayers) = 0.0_rb
10139 ! fsfcmc(:,nlayers) = 0.0_rb
10140 ! ciwpmc(:,nlayers) = 0.0_rb
10141 ! clwpmc(:,nlayers) = 0.0_rb
10142 ! reicmc(nlayers) = 0.0_rb
10143 ! relqmc(nlayers) = 0.0_rb
10144 !
10145 endif
10146 !
10147 end subroutine inatm_sw
10148 !-------------------------------------------------------------------------------
10149 !
10150 !
10151 !-------------------------------------------------------------------------------
10152 end module rrtmg_sw_rad_k
10153 !-------------------------------------------------------------------------------
10154 !
10155 !
10156 !-------------------------------------------------------------------------------
10157 module module_ra_rrtmg_swk
10158 !-------------------------------------------------------------------------------
10159 use module_model_constants, only: cp, rd=>r_d, t0c=>SVPT0
10160 use parrrsw_k, only : nbndsw, ngptsw, naerec
10161 use parrrtm_k, only : nbndlw, ngptlw
10162 use rrtmg_sw_init_k, only: rrtmg_sw_ini
10163 use rrtmg_sw_rad_k, only: rrtmg_sw
10164 use rrtmg_lw_rad_k, only :rrtmg_lw
10165 use mcica_subcol_gen_k, only: mcica_subcol
10166 use module_ra_rrtmg_lwk, only : inirad, relcalc, reicalc
10167 use module_ra_effective_radius
10168 !
10169 contains
10170 !-------------------------------------------------------------------------------
10171 !
10172 !
10173 !-------------------------------------------------------------------------------
10174 subroutine rad_rrtmg_driver( &
10175 rthratenlw,rthratensw, &
10176 rthratenlwc,rthratenswc, &
10177 lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
10178 swupflx, swupflxc, swdnflx, swdnflxc, &
10179 lwupt, lwuptc, lwdnt, lwdntc, &
10180 lwupb, lwupbc, lwdnb, lwdnbc, &
10181 glw, olr, lwcf, &
10182 swupt, swuptc, swdnt, swdntc, &
10183 swupb, swupbc, swdnb, swdnbc, &
10184 gsw, swcf, cosz, solcon, &
10185 albedo, &
10186 emiss, &
10187 t3d, t8w, tsk, &
10188 rho3d, &
10189 p3d, p8w, cldfra3d, r, g, &
10190 nc3d, xland, &
10191 f_qnc, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
10192 qv3d, qc3d, qr3d, qi3d, qs3d, qg3d, &
10193 !sh
10194 o3input, o33d, &
10195 aer_opt, aerod, no_src, &
10196 !sh
10197 ids,ide, jds,jde, kds,kde, &
10198 ims,ime, jms,jme, kms,kme, &
10199 its,ite, jts,jte, kts,kte )
10200 !-------------------------------------------------------------------------------
10201 ! abstract : unified rrtmg sw lw driver
10202 !
10203 ! history log :
10204 ! 2016-3-10 sunghye baek initial setup
10205 ! 2017-1-15 sunghye baek wrf format correction
10206 !-------------------------------------------------------------------------------
10207 !
10208 implicit none
10209 !
10210 integer, parameter :: natype=5
10211 real, parameter :: qmin=0.
10213 logical, intent(in ) :: f_qnc, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg
10214 integer, intent(in ) :: ids,ide, jds,jde, kds,kde
10215 integer, intent(in ) :: ims,ime, jms,jme, kms,kme
10216 integer, intent(in ) :: its,ite, jts,jte, kts,kte
10217 integer, intent(in ) :: no_src
10218 integer, optional, intent(in ) :: o3input, aer_opt
10220 real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratensw
10221 real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenlw
10222 real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenswc
10223 real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenlwc
10224 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwupflx
10225 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwupflxc
10226 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwdnflx
10227 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwdnflxc
10228 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swupflx
10229 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swupflxc
10230 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swdnflx
10231 real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swdnflxc
10232 real, dimension(ims:ime,jms:jme), intent(inout) :: lwupt, lwuptc
10233 real, dimension(ims:ime,jms:jme), intent(inout) :: lwdnt, lwdntc
10234 real, dimension(ims:ime,jms:jme), intent(inout) :: lwupb, lwupbc
10235 real, dimension(ims:ime,jms:jme), intent(inout) :: lwdnb, lwdnbc
10236 real, dimension(ims:ime,jms:jme), intent(inout) :: glw, olr, lwcf
10237 real, dimension(ims:ime,jms:jme), intent(inout) :: swupt, swuptc
10238 real, dimension(ims:ime,jms:jme), intent(inout) :: swdnt, swdntc
10239 real, dimension(ims:ime,jms:jme), intent(inout) :: swupb, swupbc
10240 real, dimension(ims:ime,jms:jme), intent(inout) :: swdnb, swdnbc
10241 real, dimension(ims:ime,jms:jme), intent(inout) :: gsw, swcf
10242 real, dimension(ims:ime,jms:jme), intent(in ) :: cosz
10243 real, intent(in ) :: solcon
10244 real, dimension(ims:ime,jms:jme), intent(in ) :: albedo, emiss
10245 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: t8w, p8w
10246 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: t3d, p3d
10247 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: rho3d
10248 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: nc3d
10249 real, dimension(ims:ime,jms:jme), intent(in ) :: xland, tsk
10250 real, intent(in ) :: r,g
10251 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: cldfra3d
10252 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: qv3d, qc3d, qr3d
10253 real, dimension(ims:ime,kms:kme,jms:jme), intent(in ) :: qi3d, qs3d, qg3d
10254 real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(in ) :: o33d
10255 real, dimension(ims:ime,kms:kme,jms:jme,1:no_src), optional, intent(in )&
10256 :: aerod
10259 ! xland 1 for land 2 for water
10261 ! real, dimension(ims:ime,jms:jme), intent(in ) :: aluvb, aluvd
10262 ! real, dimension(ims:ime,jms:jme), intent(in ) :: alnirb, alnird
10264 !
10265 ! Added local arrays for RRTMG
10266 !
10267 integer :: ncol, nlay, icld
10268 integer :: inflgsw, iceflgsw, liqflgsw
10269 integer :: inflglw, iceflglw, liqflglw
10270 !
10271 ! Dimension with extra layer from model top to TOA
10272 !
10273 real, dimension(1,kts:kte+2) :: plev
10274 real, dimension(1,kts:kte+2) :: tlev
10275 real, dimension(1,kts:kte+1) :: play
10276 real, dimension(1,kts:kte+1) :: tlay
10277 real, dimension(1,kts:kte+1) :: h2ovmr, o3vmr, co2vmr, o2vmr, ch4vmr, n2ovmr
10278 real, dimension(1,kts:kte+1) :: cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr
10279 real, dimension(kts:kte+1) :: o3mmr
10280 !
10281 ! Surface albedo (for UV/visible and near-IR spectral regions,
10282 ! and for direct and diffuse radiation)
10283 !`
10284 real, dimension(1) :: asdir, asdif, aldir, aldif
10285 real, dimension(1) :: visdir, visdif, nirdir, nirdif
10286 !
10287 ! Surface emissivity (for 16 LW spectral bands)
10288 !
10289 real, dimension(1,nbndlw) :: emis
10290 !
10291 ! Dimension with extra layer from model top to TOA,
10292 ! though no clouds are allowed in extra layer
10293 !
10294 real, dimension(1,kts:kte+1) :: cldfrac
10295 real, dimension(1,kts:kte+1) :: clwpth, ciwpth
10296 real, dimension(1,kts:kte+1) :: rel, rei
10297 real, dimension(1,kts:kte+1) :: cswpth, res
10298 real, dimension(ngptsw,1,kts:kte+1) :: staucmcl, sssacmcl
10299 real, dimension(ngptsw,1,kts:kte+1) :: sasmcmcl, sfsfcmcl
10300 real, dimension(ngptlw,1,kts:kte+1) :: lcldfmcl, ltaucmcl
10301 real, dimension(ngptlw,1,kts:kte+1) :: lclwpmcl, lciwpmcl
10302 real, dimension(ngptlw,1,kts:kte+1) :: lcswpmcl
10303 real, dimension(1,kts:kte+1,nbndsw) :: stauaer, ssaaer, asmaer
10304 real, dimension(1,kts:kte+1,nbndlw) :: ltauaer
10305 real, dimension(1,kts:kte+1) :: qo31d
10306 real, dimension(1,kts:kte+1,naerec) :: ecaer
10307 real, dimension(1,kts:kte+1) :: co2_t
10308 integer, parameter :: has_reqc = 1
10309 integer, parameter :: has_reqi = 1
10310 integer, parameter :: has_reqs = 1
10311 real :: pi,third,relconst,lwpmin,rhoh2o
10312 !
10313 ! Output arrays contain extra layer from model top to TOA
10314 !
10315 real, dimension(1,kts:kte+2) :: swuflx
10316 real, dimension(1,kts:kte+2) :: swdflx
10317 real, dimension(1,kts:kte+2) :: swuflxc
10318 real, dimension(1,kts:kte+2) :: swdflxc
10319 real, dimension(1,kts:kte+1) :: swhr
10320 real, dimension(1,kts:kte+1) :: swhrc
10321 real, dimension(1) :: tsfc, ps, coszen
10322 real, dimension(1,kts:kte+2) :: uflx
10323 real, dimension(1,kts:kte+2) :: dflx
10324 real, dimension(1,kts:kte+2) :: uflxc
10325 real, dimension(1,kts:kte+2) :: dflxc
10326 real, dimension(1,kts:kte+1) :: hr
10327 real, dimension(1,kts:kte+1) :: hrc
10328 real :: ro, dz, adjes
10329 real :: landf, icef, snowd, scon
10330 real, dimension(kts:kte) :: re_qc, re_qi, re_qs
10331 real, dimension(kts:kte) :: o31d
10332 real :: snow_mass_factor
10333 real, dimension(kts:kte) :: qsum1d, qccps
10334 real, dimension(its:ite) :: xice
10335 integer :: dyofyr
10338 !
10339 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
10340 ! carbon dioxide (379 ppmv)
10341 !
10342 real :: co2
10343 data co2 / 379.e-6 /
10344 !
10345 ! methane (1774 ppbv)
10346 !
10347 real :: ch4
10348 data ch4 / 1774.e-9 /
10349 !
10350 ! nitrous oxide (319 ppbv)
10351 !
10352 real :: n2o
10353 data n2o / 319.e-9 /
10354 !
10355 ! cfc-11 (251 ppt)
10356 !
10357 real :: cfc11
10358 data cfc11 / 0.251e-9 /
10359 !
10360 ! cfc-12 (538 ppt)
10361 real :: cfc12
10362 data cfc12 / 0.538e-9 /
10363 !
10364 ! cfc-22 (169 ppt)
10365 !
10366 real :: cfc22
10367 data cfc22 / 0.169e-9 /
10368 !
10369 ! ccl4 (93 ppt)
10370 !
10371 real :: ccl4
10372 data ccl4 / 0.093e-9 /
10373 !
10374 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
10375 !
10376 real :: o2
10377 data o2 / 0.209488 /
10378 !
10379 integer :: iplon, irng, permuteseed
10380 integer :: nb
10381 !
10382 ! For old cloud property specification for rrtm_lw
10383 ! Cloud and precipitation absorption coefficients
10384 !
10385 real :: abcw, abice, abrn, absn
10386 data abcw /0.144/
10387 data abice /0.0735/
10388 data abrn /0.330e-3/
10389 data absn /2.34e-3/
10390 real :: amdw ! Molecular weight of dry air / water vapor
10391 real :: amdo ! Molecular weight of dry air / ozone
10392 real :: amdo2 ! Molecular weight of dry air / oxygen
10393 data amdw / 1.607793 /
10394 data amdo / 0.603461 /
10395 data amdo2 / 0.905190 /
10396 !
10397 real, dimension(kts:kte) :: pdel ! mb
10398 real, dimension(kts:kte) :: cicewp, cliqwp
10399 real, dimension(kts:kte) :: csnowp
10400 real, dimension(kts:kte) :: cldfra1d
10401 real :: gsnowp, gliqwp, gicewp, gravmks, gravdvd
10402 real :: fp
10403 real :: coszrs
10404 logical, dimension(its:ite, jts:jte) :: dorrsw
10405 integer :: pver
10406 real :: xt24, tloctm, hrang, xxlat
10407 integer :: i, j, k, na
10408 logical :: predicate
10410 !-------------------------------------------------------------------------------
10411 !
10412 ! Zero out cloud optical properties here, calculated in radiation
10413 !
10414 staucmcl = 0.0
10415 sssacmcl = 1.0
10416 sasmcmcl = 0.0
10417 sfsfcmcl = 0.0
10419 !
10420 ! Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
10421 !
10422 stauaer = 0.
10423 ssaaer = 1.
10424 asmaer = 0.
10425 ltauaer =0.
10426 !
10427 ltaucmcl = 0.
10428 !
10429 qo31d = 0.
10430 co2_t = 0.0
10431 ecaer = 0.0
10432 o31d = 0.0
10433 !
10434 !
10435 !---------------------------------------------------------------------------------
10437 !
10438 !-----CALCULATE SHORT & LONG WAVE RADIATION
10439 !
10440 ! All fields are ordered vertically from bottom to top
10441 ! Pressures are in mb
10442 !
10443 !
10444 ! Set solar constant
10445 !
10446 scon = solcon
10447 !
10448 ! For Earth/Sun distance adjustment in RRTMG
10449 ! dyofyr = julday
10450 ! adjes = 0.0
10451 ! solar constant is already provided with eccentricity adjustment,
10452 ! so do not do this in RRTMG
10453 !
10454 dyofyr = 0
10455 adjes = 1.0
10456 ncol = 0
10457 pver = kte - kts + 1
10458 !SET CONST here for fast computation
10459 gravmks = g
10460 gravdvd = 1000./g
10461 dorrsw = .true.
10462 !
10463 do j = jts,jte
10464 do i = its,ite
10465 if(cosz(i,j).le.0.0) dorrsw(i,j) = .false.
10466 enddo
10467 enddo
10468 !
10469 ! Add extra layer from top of model to top of atmosphere
10470 !
10471 nlay = (kte - kts + 1) + 1
10472 !
10473 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
10474 !
10475 icld = 2
10476 inflgsw = 2
10477 iceflgsw = 3
10478 liqflgsw = 1
10479 !
10480 inflglw = 2
10481 iceflglw = 3
10482 liqflglw = 1
10483 !
10484 ! START LOOP FOR SETTING CLOUD PROPERTY
10485 !
10486 ncol=0
10487 do j = jts,jte
10488 do i = its,ite
10489 !
10490 !-------------------------------------------------
10491 ! 1. SET SURFACE PROPERTY
10492 !----------------- --------------------------------
10493 !
10495 !
10496 !-------------------------------------------------
10497 ! 2. SET AEROSOL PROPERTY
10498 !-------------------------------------------------
10499 !
10500 ! do na = 1,natype
10501 ! aod_t(1,kts:kte,na) = aod_t3d(i,kts:kte,na)
10502 ! aod_t(1,kte+1,na) = 0.
10503 ! enddo
10504 !
10505 !-------------------------------------------------
10506 ! 3. SET OZONE PROPERTY
10507 !-------------------------------------------------
10508 !
10509 ! do k = kts,kte
10510 ! qo31d(1,k) = qo3_3d(i,k,j)
10511 ! enddo
10512 !
10513 ! qo31d(1,kte+1) = qo31d(1,kte,j)
10514 !
10515 !-------------------------------------------------
10516 ! 4. SET CO2 PROPERTY
10517 !-------------------------------------------------
10518 !
10519 ! do k = kts,kte
10520 ! co2_t(1,k) = co2_3d(i,k)
10521 ! enddo
10522 !
10523 ! co2_t(1,kte+1) = co2_t(1,kte)
10524 !
10525 !-------------------------------------------------
10526 ! 5. SET OPTICAL CLOUD PROPERTY
10527 !-------------------------------------------------
10528 !
10529 !
10530 !
10531 !-------------------------------------------------
10532 ! 5-1. SET EFFECTIVE RADIUS
10533 !-------------------------------------------------
10534 !
10535 do k = kts,kte
10536 qsum1d(k) = qi3d(i,k,j)+qc3d(i,k,j)+qs3d(i,k,j)
10537 cldfra1d(k) = cldfra3d(i,k,j)
10538 enddo
10539 !
10540 re_qc = 5.0e-6
10541 re_qi = 10.0e-6
10542 re_qs = 25.0e-6
10543 !
10545 if(f_qc) then
10546 inflgsw = 3 ; inflglw = 3
10547 endif
10549 if(f_qi) then
10550 inflgsw = 4 ; iceflgsw = 4
10551 inflglw = 4 ; iceflglw = 4
10552 endif
10554 if(f_qs) then
10555 inflgsw = 5 ; iceflgsw = 5
10556 inflglw = 5 ; iceflglw = 5
10557 endif
10560 qccps = 0.e0
10562 call effectRad(t3d(i,kts:kte,j), qc3d(i,kts:kte,j), nc3d(i,kts:kte,j), &
10563 qi3d(i,kts:kte,j), qs3d(i,kts:kte,j), qg3d(i,kts:kte,j), &
10564 rho3d(i,kts:kte,j), qmin, t0c, qccps, f_qnc, &
10565 re_qc, re_qi, re_qs, kts, kte)
10567 re_qc = re_qc * 1.e+6
10568 re_qi = re_qi * 1.e+6
10569 re_qs = re_qs * 1.e+6
10571 re_qc(kts:kte) = max(2.51, min(re_qc(kts:kte), 50.))
10572 re_qi(kts:kte) = max(10.01, min(re_qi(kts:kte), 125.))
10573 re_qs(kts:kte) = max(25., min(re_qs(kts:kte), 999.))
10575 !-------------------------------------------------
10576 ! 5-2. SET CLOUD HYDROMETEOR PROPERTY
10577 !-------------------------------------------------
10578 !
10579 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
10580 ! Water paths are in units of g/m2
10581 ! snow added as ice cloud (JD 091022)
10582 !
10583 !
10584 ! pdel is in Pa here <==========
10585 !
10586 do k = kts,kte
10587 pdel(k) = p8w(i,k,j)-p8w(i,k+1,j)
10588 enddo
10589 !
10590 ! if (p8w(i,kte+1).eq.0.) pdel(kte) = p8w(i,kte) - 1.e-2
10591 !
10592 do k = kts,kte
10593 ! Grid box ice water path.
10594 gicewp = (qi3d(i,k,j)+qs3d(i,k,j)) * pdel(k) * gravdvd
10595 ! Grid box liquid water path.
10596 gliqwp = qc3d(i,k,j) * pdel(k) * gravdvd
10597 ! in-cloud ice water path.
10598 cicewp(k) = gicewp / max(0.01,cldfra1d(k))
10599 ! In-cloud liquid water path.
10600 cliqwp(k) = gliqwp / max(0.01,cldfra1d(k))
10601 if(cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10602 gliqwp = 1.e-9* pdel(k) * gravdvd
10603 cliqwp(k) = gliqwp ! In-cloud liquid water path.
10604 endif
10605 enddo
10606 ! The ice water path is already sum of cloud ice and snow, but when we have
10607 ! explicit ice effective radius, overwrite the ice path with only the cloud
10608 ! ice variable, leaving out the snow for its own effect.
10609 !
10610 if (iceflgsw .ge. 4) then
10611 do k = kts,kte
10612 gicewp = qi3d(i,k,j)*pdel(k)* gravdvd ! Grid box ice water path.
10613 cicewp(k) = gicewp/max(0.01,cldfra1d(k)) ! In-cloud ice water path.
10614 if(cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10615 gicewp = 1.e-9*pdel(k)* gravdvd
10616 cicewp(k) = gicewp ! In-cloud ice water path.
10617 endif
10618 enddo
10619 end if
10620 !
10621 !
10622 ! Here the snow path is adjusted if (radiation) effective radius of snow is
10623 ! larger than what we currently have in the lookup tables. Since mass goes
10624 ! rather close to diameter squared, adjust the mixing ratio of snow used
10625 ! to compute its water path in combination with the max diameter. Not a
10626 ! perfect fix, but certainly better than using all snow mass when diameter is
10627 ! far larger than table currently contains and crystal sizes much larger than
10628 ! about 140 microns have lesser impact than those much smaller sizes.
10629 !
10630 !
10631 if (iceflgsw.eq.5) then
10632 do k = kts,kte
10633 snow_mass_factor = 1.0
10634 if (re_qs(k).gt.130.)then
10635 snow_mass_factor =(130.0/re_qs(k))**2.
10636 re_qs(k)=130.
10637 endif
10638 ! Grid box snow water path.
10639 gsnowp = (qs3d(i,k,j)+qg3d(i,k,j))*snow_mass_factor*pdel(k)* gravdvd
10640 if (cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10641 gsnowp = 0.0
10642 endif
10643 csnowp(k) = gsnowp/max(0.01,cldfra1d(k))
10644 enddo
10645 endif
10646 !
10647 ! Limit upper bound of reice for Fu ice parameterization and convert
10648 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
10649 !
10650 if (iceflgsw.eq.3) then
10651 do k = kts,kte
10652 re_qi(k) = re_qi(k)*1.0315
10653 re_qi(k) = min(140.0,re_qi(k))
10654 enddo
10655 endif
10656 !
10657 !-------------------------------------------------
10658 ! 6. FILLING ARRAYS FOR RRTMG_SW and RRTMG_LW
10659 !-------------------------------------------------
10660 ncol=1
10661 play(ncol, kts:kte ) = p3d(i,kts:kte,j)*1.e-2
10662 plev(ncol, kts:kte+1 ) = p8w(i,kts:kte+1,j)*1.e-2
10663 tlay(ncol, kts:kte ) = t3d(i,kts:kte,j)
10664 tlev(ncol, kts:kte+1) = t8w(i,kts:kte+1,j)
10665 tsfc(ncol) = tsk(i,j)
10666 h2ovmr(ncol, kts:kte ) = amax1(max(0.,qv3d(i,kts:kte,j)),3.0e-6) * amdw
10667 co2vmr(ncol, kts:kte ) = co2
10668 o2vmr(ncol, kts:kte ) = o2
10669 ch4vmr(ncol, kts:kte ) = ch4
10670 n2ovmr(ncol, kts:kte ) = n2o
10671 cfc11vmr(ncol,kts:kte) = cfc11
10672 cfc12vmr(ncol,kts:kte) = cfc12
10673 cfc22vmr(ncol,kts:kte) = cfc22
10674 ccl4vmr(ncol,kts:kte) = ccl4
10675 ! Define profile values for extra layer from model top to top of atmosphere.
10676 ! The top layer temperature for all gridpoints is set to the top layer-1
10677 ! temperature plus a constant (0 K) that represents an isothermal layer
10678 ! above ptop. Top layer interface temperatures are linearly interpolated
10679 ! from the layer temperatures.
10680 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
10681 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
10682 plev(ncol,kte+2) = 1.0e-5
10683 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10684 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
10685 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10686 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
10687 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
10688 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
10689 cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte)
10690 cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte)
10691 cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte)
10692 ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte)
10693 !
10694 ! do k = kts,kte
10695 ! o3vmr(ncol,k) = qo31d(1,k)*amdo ! convert mmr to vmr
10696 ! enddo
10697 !
10698 ! o3vmr(ncol,kte+1) = o3vmr(ncol,kte)
10699 !
10700 call inirad(o3mmr,plev,kts,kte)
10701 do k = kts,kte+1
10702 o3vmr(ncol,k) = o3mmr(k)*amdo
10703 enddo
10705 if(present(o33d).and.o3input.eq.2) then
10706 do k = kts,kte
10707 o31d(k) = o33d(i,k,j)
10708 o3vmr(ncol,k) = o31d(k)
10709 enddo
10711 o3vmr(ncol,kte+1) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(kte+1)*amdo
10712 if(o3vmr(ncol,kte+1) .le. 0.) o3vmr(ncol,kte+1) = o3mmr(kte+1)*amdo
10713 endif
10716 ! do k = kts,kte
10717 ! co2vmr(ncol,k) = co2_t(1,k)
10718 ! enddo
10719 ! co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10721 !
10722 !
10723 ! Set surface albedo for direct and diffuse radiation in UV/visible and
10724 ! near-IR spectral regions
10725 !
10726 asdir(ncol) = albedo(i,j)
10727 asdif(ncol) = albedo(i,j)
10728 aldir(ncol) = albedo(i,j)
10729 aldif(ncol) = albedo(i,j)
10730 !
10731 ! Set surface emissivity in each RRTMG longwave band
10732 !
10733 emis(ncol,:) = emiss(i,j)
10734 !
10735 ! Set cloud physical property arrays
10736 !
10737 clwpth(ncol,kts:kte) = cliqwp(kts:kte)
10738 ciwpth(ncol,kts:kte) = cicewp(kts:kte)
10739 rel(ncol,kts:kte) = re_qc(kts:kte)
10740 rei(ncol,kts:kte) = re_qi(kts:kte)
10741 !
10742 if (inflgsw .eq. 5) then
10743 cswpth(ncol,kts:kte) = csnowp(kts:kte)
10744 res(ncol,kts:kte) = re_qs(kts:kte)
10745 else
10746 cswpth(ncol,kts:kte) = 0.0
10747 res(ncol,kts:kte) = 10.0
10748 endif
10749 ! Set cosine of solar zenith angle
10750 coszen(ncol) = cosz(i,j)
10751 ! Layer indexing goes bottom to top here for all fields.
10752 ! Water vapor and ozone are converted from mmr to vmr.
10753 ! Pressures are in units of mb here.
10754 cldfrac(ncol,kts:kte) = cldfra1d(kts:kte)
10755 !
10756 ! No clouds are allowed in the extra layer from model top to TOA
10757 !
10758 clwpth(ncol,kte+1) = 0.
10759 ciwpth(ncol,kte+1) = 0.
10760 cswpth(ncol,kte+1) = 0.
10761 rel(ncol,kte+1) = 10.
10762 rei(ncol,kte+1) = 10.
10763 res(ncol,kte+1) = 10.
10764 cldfrac(ncol,kte+1) = 0.
10765 ecaer = 0.e0
10766 iplon = ncol
10767 irng = 0
10769 permuteseed = 1
10770 call mcica_subcol (iplon, ncol, nlay, icld, permuteseed, irng, play, &
10771 cldfrac, ciwpth, clwpth, &
10772 lciwpmcl, lclwpmcl, &
10773 cswpth, lcswpmcl, &
10774 lcldfmcl)
10776 !
10777 if (dorrsw(i,j)) then
10779 if (present(aerod)) then
10780 if (aer_opt.eq.1) then
10781 do na = 1,naerec
10782 do k = kts, kte
10783 ecaer(ncol,k,na) = aerod(i,k,j,na)
10784 enddo
10785 enddo
10786 endif
10787 endif
10789 call rrtmg_sw &
10790 (ncol ,nlay ,icld , &
10791 play ,plev ,tlay ,tlev ,tsfc , &
10792 h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
10793 asdir ,asdif ,aldir ,aldif , &
10794 coszen ,adjes ,dyofyr ,scon , &
10795 inflgsw ,iceflgsw,liqflgsw,lcldfmcl(1:ngptsw,:,:) , &
10796 staucmcl ,sssacmcl ,sasmcmcl ,sfsfcmcl , &
10797 lciwpmcl(1:ngptsw,:,:) ,lclwpmcl(1:ngptsw,:,:), rei ,rel, &
10798 lcswpmcl(1:ngptsw,:,:), res, &
10799 stauaer ,ssaaer ,asmaer ,ecaer , &
10800 swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc , &
10801 visdir ,visdif ,nirdir ,nirdif )
10803 rthratensw(i,kts:kte,j) = swhr(1,kts:kte)/86400.
10804 rthratenswc(i,kts:kte,j) = swhrc(1,kts:kte)/86400.
10805 if(present(swupflx))then
10806 swupflx(i,kts:kte+2,j) = swuflx(1,kts:kte+2)
10807 swupflxc(i,kts:kte+2,j) = swuflxc(1,kts:kte+2)
10808 swdnflx(i,kts:kte+2,j) = swdflx(1,kts:kte+2)
10809 swdnflxc(i,kts:kte+2,j) = swdflxc(1,kts:kte+2)
10810 endif
10811 gsw(i,j) = swdflx(1,1) - swuflx(1,1)
10812 swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) &
10813 - swuflxc(1,kte+2))
10814 swupt(i,j) = swuflx(1,kte+2)
10815 swuptc(i,j) = swuflxc(1,kte+2)
10816 swdnt(i,j) = swdflx(1,kte+2)
10817 swdntc(i,j) = swdflxc(1,kte+2)
10818 swupb(i,j) = swuflx(1,1)
10819 swupbc(i,j) = swuflxc(1,1)
10820 swdnb(i,j) = swdflx(1,1)
10821 swdnbc(i,j) = swdflxc(1,1)
10822 endif ! do SW
10823 !
10824 ! Call RRTMG longwave radiation model
10825 !
10826 call rrtmg_lw &
10827 (ncol, nlay, icld, play, plev , tlay, &
10828 tlev ,tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr, &
10829 n2ovmr, o2vmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr, &
10830 emis, inflglw, iceflglw, liqflglw, lcldfmcl, &
10831 ltaucmcl, lciwpmcl, lclwpmcl, rei, rel, &
10832 lcswpmcl, res, &
10833 ltauaer, &
10834 uflx, dflx, hr, uflxc, dflxc, hrc)
10835 !
10836 rthratenlw(i,kts:kte,j) = hr(1,kts:kte)/86400.
10837 rthratenlwc(i,kts:kte,j) = hrc(1,kts:kte)/86400.
10838 if(present(lwupflx))then
10839 lwupflx(i,kts:kte+2,j) = uflx(1,kts:kte+2)
10840 lwupflxc(i,kts:kte+2,j) = uflxc(1,kts:kte+2)
10841 lwdnflx(i,kts:kte+2,j) = dflx(1,kts:kte+2)
10842 lwdnflxc(i,kts:kte+2,j) = dflxc(1,kts:kte+2)
10843 endif
10844 glw(i,j) = dflx(1,1)
10845 olr(i,j) = uflx(1,kte+2)
10846 lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
10847 lwupt(i,j) = uflx(1,kte+2)
10848 lwuptc(i,j) = uflxc(1,kte+2)
10849 lwdnt(i,j) = dflx(1,kte+2)
10850 lwdntc(i,j) = dflxc(1,kte+2)
10851 lwupb(i,j) = uflx(1,1)
10852 lwupbc(i,j) = uflxc(1,1)
10853 lwdnb(i,j) = dflx(1,1)
10854 lwdnbc(i,j) = dflxc(1,1)
10855 enddo ! jts:jte end j LOOP
10856 enddo ! its:ite end GRAND LOOP
10857 end subroutine rad_rrtmg_driver
10858 !-------------------------------------------------------------------------------
10859 !-------------------------------------------------------------------------------
10860 subroutine rrtmg_swinit_k( &
10861 allowed_to_read , &
10862 ids, ide, jds, jde, kds, kde, &
10863 ims, ime, jms, jme, kms, kme, &
10864 its, ite, jts, jte, kts, kte )
10865 !-------------------------------------------------------------------------------
10866 use rrtmg_sw_init_k
10867 !
10868 implicit none
10869 !
10870 logical, intent(in) :: allowed_to_read
10871 integer, intent(in) :: ids, ide, jds, jde, kds, kde, &
10872 ims, ime, jms, jme, kms, kme, &
10873 its, ite, jts, jte, kts, kte
10874 !-------------------------------------------------------------------------------
10875 !
10876 ! Read in absorption coefficients and other data
10877 !
10878 IF ( allowed_to_read ) then
10879 call rrtmg_swlookuptable
10880 endif
10881 !
10882 ! Perform g-point reduction and other initializations
10883 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
10884 !
10885 call rrtmg_sw_ini(cp)
10886 !
10887 end subroutine rrtmg_swinit_k
10888 !-------------------------------------------------------------------------------
10889 !
10890 !
10891 !-------------------------------------------------------------------------------
10892 subroutine rrtmg_swlookuptable
10893 !
10894 implicit none
10895 !
10896 ! Local
10897 !
10898 integer :: i
10899 logical :: opened
10900 logical , external :: wrf_dm_on_monitor
10901 character*80 errmess
10902 integer rrtmg_unit
10903 !-------------------------------------------------------------------------------
10904 if ( wrf_dm_on_monitor() ) then
10905 do i = 10,99
10906 inquire ( i , opened = opened )
10907 if ( .not. opened ) then
10908 rrtmg_unit = i
10909 goto 2010
10910 endif
10911 enddo
10912 rrtmg_unit = -1
10913 2010 continue
10914 endif
10915 call wrf_dm_bcast_bytes ( rrtmg_unit , 4 )
10918 if ( wrf_dm_on_monitor() ) then
10919 open(rrtmg_unit,file='RRTMG_SW_DATA', &
10920 form='UNFORMATTED',status='OLD',err=9009)
10921 endif
10922 call sw_kgb16(rrtmg_unit)
10923 call sw_kgb17(rrtmg_unit)
10924 call sw_kgb18(rrtmg_unit)
10925 call sw_kgb19(rrtmg_unit)
10926 call sw_kgb20(rrtmg_unit)
10927 call sw_kgb21(rrtmg_unit)
10928 call sw_kgb22(rrtmg_unit)
10929 call sw_kgb23(rrtmg_unit)
10930 call sw_kgb24(rrtmg_unit)
10931 call sw_kgb25(rrtmg_unit)
10932 call sw_kgb26(rrtmg_unit)
10933 call sw_kgb27(rrtmg_unit)
10934 call sw_kgb28(rrtmg_unit)
10935 call sw_kgb29(rrtmg_unit)
10936 !
10937 if ( wrf_dm_on_monitor() ) close (rrtmg_unit)
10938 !
10939 return
10940 9009 continue
10941 write( errmess , '(A,I4)' ) &
10942 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
10943 !
10944 end subroutine rrtmg_swlookuptable
10945 !-------------------------------------------------------------------------------
10946 !
10947 !
10948 !-------------------------------------------------------------------------------
10949 ! **************************************************************************
10950 ! RRTMG Shortwave Radiative Transfer Model
10951 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
10952 !
10953 ! Original by J.Delamere, Atmospheric & Environmental Research.
10954 ! Reformatted for F90: JJMorcrette, ECMWF
10955 ! Revision for GCMs: Michael J. Iacono, AER, July 2002
10956 ! Further F90 reformatting: Michael J. Iacono, AER, June 2006
10957 !
10958 ! This file contains 14 READ statements that include the
10959 ! absorption coefficients and other data for each of the 14 shortwave
10960 ! spectral bands used in RRTMG_SW. Here, the data are defined for 16
10961 ! g-points, or sub-intervals, per band. These data are combined and
10962 ! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
10963 ! the total number of g-points from 224 to 112 for use in the GCM.
10964 ! **************************************************************************
10965 !
10966 !-------------------------------------------------------------------------------
10967 subroutine sw_kgb16(rrtmg_unit)
10968 !-------------------------------------------------------------------------------
10969 ! Array sfluxrefo contains the Kurucz solar source function for this band.
10970 !
10971 ! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
10972 !
10973 ! The array KAO contains absorption coefs at the 16 chosen g-values
10974 ! for a range of pressure levels> ~100mb, temperatures, and binary
10975 ! species parameters (see taumol.f for definition). The first
10976 ! index in the array, JS, runs from 1 to 9, and corresponds to
10977 ! different values of the binary species parameter. For instance,
10978 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
10979 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
10980 ! in the array, JT, which runs from 1 to 5, corresponds to different
10981 ! temperatures. More specifically, JT = 3 means that the data are for
10982 ! the reference temperature TREF for this pressure level, JT = 2 refers
10983 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
10984 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
10985 ! to the JPth reference pressure level (see taumol.f for these levels
10986 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
10987 ! which g-interval the absorption coefficients are for.
10988 !
10989 ! The array KBO contains absorption coefs at the 16 chosen g-values
10990 ! for a range of pressure levels < ~100mb and temperatures. The first
10991 ! index in the array, JT, which runs from 1 to 5, corresponds to
10992 ! different temperatures. More specifically, JT = 3 means that the
10993 ! data are for the reference temperature TREF for this pressure
10994 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
10995 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
10996 ! The second index, JP, runs from 13 to 59 and refers to the JPth
10997 ! reference pressure level (see taumol.f for the value of these
10998 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
10999 ! and tells us which g-interval the absorption coefficients are for.
11000 !
11001 ! The array FORREFO contains the coefficient of the water vapor
11002 ! foreign-continuum (including the energy term). The first
11003 ! index refers to reference temperature (296,260,224,260) and
11004 ! pressure (970,475,219,3 mbar) levels. The second index
11005 ! runs over the g-channel (1 to 16).
11006 !
11007 ! The array SELFREFO contains the coefficient of the water vapor
11008 ! self-continuum (including the energy term). The first index
11009 ! refers to temperature in 7.2 degree increments. For instance,
11010 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11011 ! etc. The second index runs over the g-channel (1 to 16).
11012 !-------------------------------------------------------------------------------
11013 use rrsw_kg16_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11014 rayl, strrat1, layreffr
11015 !
11016 implicit none
11017 !
11018 save
11019 !
11020 ! Input
11021 !
11022 integer, intent(in) :: rrtmg_unit
11023 !
11024 ! Local
11025 !
11026 character*80 errmess
11027 logical, external :: wrf_dm_on_monitor
11028 !-------------------------------------------------------------------------------
11029 !
11030 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11031 rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11032 call wrf_dm_bcast_real ( rayl , 1 )
11033 call wrf_dm_bcast_real ( strrat1 , 1 )
11034 call wrf_dm_bcast_integer ( layreffr , 1 )
11035 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11036 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11037 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11038 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11039 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11040 !
11041 return
11042 9010 continue
11043 write( errmess , '(A,I4)' ) &
11044 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11045 !
11046 end subroutine sw_kgb16
11047 !-------------------------------------------------------------------------------
11048 !
11049 !
11050 !-------------------------------------------------------------------------------
11051 subroutine sw_kgb17(rrtmg_unit)
11052 !-------------------------------------------------------------------------------
11053 !
11054 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11055 !
11056 ! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
11057 !
11058 ! The array KAO contains absorption coefs at the 16 chosen g-values
11059 ! for a range of pressure levels> ~100mb, temperatures, and binary
11060 ! species parameters (see taumol.f for definition). The first
11061 ! index in the array, JS, runs from 1 to 9, and corresponds to
11062 ! different values of the binary species parameter. For instance,
11063 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11064 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11065 ! in the array, JT, which runs from 1 to 5, corresponds to different
11066 ! temperatures. More specifically, JT = 3 means that the data are for
11067 ! the reference temperature TREF for this pressure level, JT = 2 refers
11068 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11069 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11070 ! to the JPth reference pressure level (see taumol.f for these levels
11071 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11072 ! which g-interval the absorption coefficients are for.
11073 !
11074 ! The array KBO contains absorption coefs at the 16 chosen g-values
11075 ! for a range of pressure levels < ~100mb and temperatures. The first
11076 ! index in the array, JT, which runs from 1 to 5, corresponds to
11077 ! different temperatures. More specifically, JT = 3 means that the
11078 ! data are for the reference temperature TREF for this pressure
11079 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11080 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11081 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11082 ! reference pressure level (see taumol.f for the value of these
11083 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11084 ! and tells us which g-interval the absorption coefficients are for.
11085 !
11086 ! The array FORREFO contains the coefficient of the water vapor
11087 ! foreign-continuum (including the energy term). The first
11088 ! index refers to reference temperature (296,260,224,260) and
11089 ! pressure (970,475,219,3 mbar) levels. The second index
11090 ! runs over the g-channel (1 to 16).
11091 !
11092 ! The array SELFREFO contains the coefficient of the water vapor
11093 ! self-continuum (including the energy term). The first index
11094 ! refers to temperature in 7.2 degree increments. For instance,
11095 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11096 ! etc. The second index runs over the g-channel (1 to 16).
11097 !-------------------------------------------------------------------------------
11098 use rrsw_kg17_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11099 rayl, strrat, layreffr
11100 !
11101 implicit none
11102 !
11103 save
11104 !
11105 ! Input
11106 !
11107 integer, intent(in) :: rrtmg_unit
11108 !
11109 ! Local
11110 !
11111 character*80 errmess
11112 logical, external :: wrf_dm_on_monitor
11113 !-------------------------------------------------------------------------------
11114 !
11115 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11116 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11117 call wrf_dm_bcast_real ( rayl , 1 )
11118 call wrf_dm_bcast_real ( strrat , 1 )
11119 call wrf_dm_bcast_integer ( layreffr , 1 )
11120 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11121 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11122 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11123 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11124 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11125 !
11126 return
11127 9010 continue
11128 write( errmess , '(A,I4)' ) &
11129 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11130 !
11131 end subroutine sw_kgb17
11132 !-------------------------------------------------------------------------------
11133 !
11134 !
11135 !-------------------------------------------------------------------------------
11136 subroutine sw_kgb18(rrtmg_unit)
11137 !-------------------------------------------------------------------------------
11138 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11139 !
11140 ! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
11141 !
11142 ! The array KAO contains absorption coefs at the 16 chosen g-values
11143 ! for a range of pressure levels> ~100mb, temperatures, and binary
11144 ! species parameters (see taumol.f for definition). The first
11145 ! index in the array, JS, runs from 1 to 9, and corresponds to
11146 ! different values of the binary species parameter. For instance,
11147 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11148 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11149 ! in the array, JT, which runs from 1 to 5, corresponds to different
11150 ! temperatures. More specifically, JT = 3 means that the data are for
11151 ! the reference temperature TREF for this pressure level, JT = 2 refers
11152 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11153 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11154 ! to the JPth reference pressure level (see taumol.f for these levels
11155 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11156 ! which g-interval the absorption coefficients are for.
11157 !
11158 ! The array KBO contains absorption coefs at the 16 chosen g-values
11159 ! for a range of pressure levels < ~100mb and temperatures. The first
11160 ! index in the array, JT, which runs from 1 to 5, corresponds to
11161 ! different temperatures. More specifically, JT = 3 means that the
11162 ! data are for the reference temperature TREF for this pressure
11163 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11164 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11165 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11166 ! reference pressure level (see taumol.f for the value of these
11167 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11168 ! and tells us which g-interval the absorption coefficients are for.
11169 !
11170 ! The array FORREFO contains the coefficient of the water vapor
11171 ! foreign-continuum (including the energy term). The first
11172 ! index refers to reference temperature (296,260,224,260) and
11173 ! pressure (970,475,219,3 mbar) levels. The second index
11174 ! runs over the g-channel (1 to 16).
11175 !
11176 ! The array SELFREFO contains the coefficient of the water vapor
11177 ! self-continuum (including the energy term). The first index
11178 ! refers to temperature in 7.2 degree increments. For instance,
11179 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11180 ! etc. The second index runs over the g-channel (1 to 16).
11181 !-------------------------------------------------------------------------------
11182 use rrsw_kg18_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11183 rayl, strrat, layreffr
11184 !
11185 implicit none
11186 !
11187 save
11188 !
11189 ! Input
11190 !
11191 integer, intent(in) :: rrtmg_unit
11192 !
11193 ! Local
11194 !
11195 character*80 errmess
11196 logical, external :: wrf_dm_on_monitor
11197 !-------------------------------------------------------------------------------
11198 !
11199 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11200 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11201 call wrf_dm_bcast_real ( rayl , 1 )
11202 call wrf_dm_bcast_real ( strrat , 1 )
11203 call wrf_dm_bcast_integer ( layreffr , 1 )
11204 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11205 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11206 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11207 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11208 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11209 !
11210 return
11211 9010 continue
11212 write( errmess , '(A,I4)' ) &
11213 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11214 !
11215 end subroutine sw_kgb18
11216 !-------------------------------------------------------------------------------
11217 !
11218 !
11219 !-------------------------------------------------------------------------------
11220 subroutine sw_kgb19(rrtmg_unit)
11221 !-------------------------------------------------------------------------------
11222 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11223 !
11224 ! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
11225 !
11226 ! The array KAO contains absorption coefs at the 16 chosen g-values
11227 ! for a range of pressure levels> ~100mb, temperatures, and binary
11228 ! species parameters (see taumol.f for definition). The first
11229 ! index in the array, JS, runs from 1 to 9, and corresponds to
11230 ! different values of the binary species parameter. For instance,
11231 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11232 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11233 ! in the array, JT, which runs from 1 to 5, corresponds to different
11234 ! temperatures. More specifically, JT = 3 means that the data are for
11235 ! the reference temperature TREF for this pressure level, JT = 2 refers
11236 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11237 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11238 ! to the JPth reference pressure level (see taumol.f for these levels
11239 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11240 ! which g-interval the absorption coefficients are for.
11241 !
11242 ! The array KBO contains absorption coefs at the 16 chosen g-values
11243 ! for a range of pressure levels < ~100mb and temperatures. The first
11244 ! index in the array, JT, which runs from 1 to 5, corresponds to
11245 ! different temperatures. More specifically, JT = 3 means that the
11246 ! data are for the reference temperature TREF for this pressure
11247 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11248 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11249 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11250 ! reference pressure level (see taumol.f for the value of these
11251 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11252 ! and tells us which g-interval the absorption coefficients are for.
11253 !
11254 ! The array FORREFO contains the coefficient of the water vapor
11255 ! foreign-continuum (including the energy term). The first
11256 ! index refers to reference temperature (296,260,224,260) and
11257 ! pressure (970,475,219,3 mbar) levels. The second index
11258 ! runs over the g-channel (1 to 16).
11259 !
11260 ! The array SELFREFO contains the coefficient of the water vapor
11261 ! self-continuum (including the energy term). The first index
11262 ! refers to temperature in 7.2 degree increments. For instance,
11263 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11264 ! etc. The second index runs over the g-channel (1 to 16).
11265 !-------------------------------------------------------------------------------
11266 use rrsw_kg19_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11267 rayl, strrat, layreffr
11268 !
11269 implicit none
11270 !
11271 save
11272 !
11273 ! Input
11274 !
11275 integer, intent(in) :: rrtmg_unit
11276 !
11277 ! Local
11278 !
11279 character*80 errmess
11280 logical, external :: wrf_dm_on_monitor
11281 !-------------------------------------------------------------------------------
11282 !
11283 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11284 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11285 call wrf_dm_bcast_real ( rayl , 1 )
11286 call wrf_dm_bcast_real ( strrat , 1 )
11287 call wrf_dm_bcast_integer ( layreffr , 1 )
11288 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11289 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11290 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11291 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11292 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11293 !
11294 return
11295 9010 continue
11296 write( errmess , '(A,I4)' ) &
11297 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11298 !
11299 end subroutine sw_kgb19
11300 !-------------------------------------------------------------------------------
11301 !
11302 !
11303 !-------------------------------------------------------------------------------
11304 subroutine sw_kgb20(rrtmg_unit)
11305 !-------------------------------------------------------------------------------
11306 !
11307 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11308 !
11309 ! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
11310 !
11311 ! Array absch4o contains the absorption coefficients for methane.
11312 !
11313 ! The array KAO contains absorption coefs at the 16 chosen g-values
11314 ! for a range of pressure levels> ~100mb, temperatures, and binary
11315 ! species parameters (see taumol.f for definition). The first
11316 ! index in the array, JS, runs from 1 to 9, and corresponds to
11317 ! different values of the binary species parameter. For instance,
11318 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11319 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11320 ! in the array, JT, which runs from 1 to 5, corresponds to different
11321 ! temperatures. More specifically, JT = 3 means that the data are for
11322 ! the reference temperature TREF for this pressure level, JT = 2 refers
11323 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11324 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11325 ! to the JPth reference pressure level (see taumol.f for these levels
11326 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11327 ! which g-interval the absorption coefficients are for.
11328 !
11329 ! The array KBO contains absorption coefs at the 16 chosen g-values
11330 ! for a range of pressure levels < ~100mb and temperatures. The first
11331 ! index in the array, JT, which runs from 1 to 5, corresponds to
11332 ! different temperatures. More specifically, JT = 3 means that the
11333 ! data are for the reference temperature TREF for this pressure
11334 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11335 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11336 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11337 ! reference pressure level (see taumol.f for the value of these
11338 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11339 ! and tells us which g-interval the absorption coefficients are for.
11340 !
11341 ! The array FORREFO contains the coefficient of the water vapor
11342 ! foreign-continuum (including the energy term). The first
11343 ! index refers to reference temperature (296,260,224,260) and
11344 ! pressure (970,475,219,3 mbar) levels. The second index
11345 ! runs over the g-channel (1 to 16).
11346 !
11347 ! The array SELFREFO contains the coefficient of the water vapor
11348 ! self-continuum (including the energy term). The first index
11349 ! refers to temperature in 7.2 degree increments. For instance,
11350 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11351 ! etc. The second index runs over the g-channel (1 to 16).
11352 !-------------------------------------------------------------------------------
11353 use rrsw_kg20_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11354 absch4o, rayl, layreffr
11355 !
11356 implicit none
11357 !
11358 save
11359 !
11360 ! Input
11361 !
11362 integer, intent(in) :: rrtmg_unit
11363 !
11364 ! Local
11365 !
11366 character*80 errmess
11367 logical, external :: wrf_dm_on_monitor
11368 !-------------------------------------------------------------------------------
11369 !
11370 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11371 rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
11372 call wrf_dm_bcast_real ( rayl , 1 )
11373 call wrf_dm_bcast_integer ( layreffr , 1 )
11374 call wrf_dm_bcast_bytes ( absch4o , size ( absch4o ) * 4 )
11375 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11376 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11377 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11378 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11379 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11380 !
11381 return
11382 9010 continue
11383 write( errmess , '(A,I4)' ) &
11384 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11385 !
11386 end subroutine sw_kgb20
11387 !-------------------------------------------------------------------------------
11388 !
11389 !
11390 !-------------------------------------------------------------------------------
11391 subroutine sw_kgb21(rrtmg_unit)
11392 !-------------------------------------------------------------------------------
11393 !
11394 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11395 !
11396 ! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
11397 !
11398 ! The array KAO contains absorption coefs at the 16 chosen g-values
11399 ! for a range of pressure levels> ~100mb, temperatures, and binary
11400 ! species parameters (see taumol.f for definition). The first
11401 ! index in the array, JS, runs from 1 to 9, and corresponds to
11402 ! different values of the binary species parameter. For instance,
11403 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11404 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11405 ! in the array, JT, which runs from 1 to 5, corresponds to different
11406 ! temperatures. More specifically, JT = 3 means that the data are for
11407 ! the reference temperature TREF for this pressure level, JT = 2 refers
11408 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11409 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11410 ! to the JPth reference pressure level (see taumol.f for these levels
11411 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11412 ! which g-interval the absorption coefficients are for.
11413 !
11414 ! The array KBO contains absorption coefs at the 16 chosen g-values
11415 ! for a range of pressure levels < ~100mb and temperatures. The first
11416 ! index in the array, JT, which runs from 1 to 5, corresponds to
11417 ! different temperatures. More specifically, JT = 3 means that the
11418 ! data are for the reference temperature TREF for this pressure
11419 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11420 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11421 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11422 ! reference pressure level (see taumol.f for the value of these
11423 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11424 ! and tells us which g-interval the absorption coefficients are for.
11425 !
11426 ! The array FORREFO contains the coefficient of the water vapor
11427 ! foreign-continuum (including the energy term). The first
11428 ! index refers to reference temperature (296,260,224,260) and
11429 ! pressure (970,475,219,3 mbar) levels. The second index
11430 ! runs over the g-channel (1 to 16).
11431 !
11432 ! The array SELFREFO contains the coefficient of the water vapor
11433 ! self-continuum (including the energy term). The first index
11434 ! refers to temperature in 7.2 degree increments. For instance,
11435 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11436 ! etc. The second index runs over the g-channel (1 to 16).
11437 !
11438 !-------------------------------------------------------------------------------
11439 use rrsw_kg21_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11440 rayl, strrat, layreffr
11441 !
11442 implicit none
11443 !
11444 save
11445 !
11446 ! Input
11447 !
11448 integer, intent(in) :: rrtmg_unit
11449 !
11450 ! Local
11451 !
11452 character*80 errmess
11453 logical, external :: wrf_dm_on_monitor
11454 !-------------------------------------------------------------------------------
11455 !
11456 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11457 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11458 call wrf_dm_bcast_real ( rayl , 1 )
11459 call wrf_dm_bcast_real ( strrat , 1 )
11460 call wrf_dm_bcast_integer ( layreffr , 1 )
11461 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11462 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11463 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11464 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11465 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11466 !
11467 return
11468 9010 continue
11469 write( errmess , '(A,I4)' ) &
11470 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11471 !
11472 end subroutine sw_kgb21
11473 !-------------------------------------------------------------------------------
11474 !
11475 !
11476 !-------------------------------------------------------------------------------
11477 subroutine sw_kgb22(rrtmg_unit)
11478 !-------------------------------------------------------------------------------
11479 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11480 !
11481 ! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
11482 !
11483 ! The array KAO contains absorption coefs at the 16 chosen g-values
11484 ! for a range of pressure levels> ~100mb, temperatures, and binary
11485 ! species parameters (see taumol.f for definition). The first
11486 ! index in the array, JS, runs from 1 to 9, and corresponds to
11487 ! different values of the binary species parameter. For instance,
11488 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11489 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11490 ! in the array, JT, which runs from 1 to 5, corresponds to different
11491 ! temperatures. More specifically, JT = 3 means that the data are for
11492 ! the reference temperature TREF for this pressure level, JT = 2 refers
11493 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11494 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11495 ! to the JPth reference pressure level (see taumol.f for these levels
11496 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11497 ! which g-interval the absorption coefficients are for.
11498 !
11499 ! The array KBO contains absorption coefs at the 16 chosen g-values
11500 ! for a range of pressure levels < ~100mb and temperatures. The first
11501 ! index in the array, JT, which runs from 1 to 5, corresponds to
11502 ! different temperatures. More specifically, JT = 3 means that the
11503 ! data are for the reference temperature TREF for this pressure
11504 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11505 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11506 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11507 ! reference pressure level (see taumol.f for the value of these
11508 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11509 ! and tells us which g-interval the absorption coefficients are for.
11510 !
11511 ! The array FORREFO contains the coefficient of the water vapor
11512 ! foreign-continuum (including the energy term). The first
11513 ! index refers to reference temperature (296_rb,260_rb,224,260) and
11514 ! pressure (970,475,219,3 mbar) levels. The second index
11515 ! runs over the g-channel (1 to 16).
11516 !
11517 ! The array SELFREFO contains the coefficient of the water vapor
11518 ! self-continuum (including the energy term). The first index
11519 ! refers to temperature in 7.2 degree increments. For instance,
11520 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11521 ! etc. The second index runs over the g-channel (1 to 16).
11522 !-------------------------------------------------------------------------------
11523 use rrsw_kg22_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11524 rayl, strrat, layreffr
11525 !
11526 implicit none
11527 !
11528 save
11529 !
11530 ! Input
11531 !
11532 integer, intent(in) :: rrtmg_unit
11533 !
11534 ! Local
11535 !
11536 character*80 errmess
11537 logical, external :: wrf_dm_on_monitor
11538 !-------------------------------------------------------------------------------
11539 !
11540 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11541 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11542 call wrf_dm_bcast_real ( rayl , 1 )
11543 call wrf_dm_bcast_real ( strrat , 1 )
11544 call wrf_dm_bcast_integer ( layreffr , 1 )
11545 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11546 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11547 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11548 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11549 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11550 !
11551 return
11552 9010 continue
11553 write( errmess , '(A,I4)' ) &
11554 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11555 !
11556 end subroutine sw_kgb22
11557 !-------------------------------------------------------------------------------
11558 !
11559 !
11560 !-------------------------------------------------------------------------------
11561 subroutine sw_kgb23(rrtmg_unit)
11562 !-------------------------------------------------------------------------------
11563 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11564 !
11565 ! Array raylo contains the Rayleigh extinction coefficient at all v for
11566 ! this band
11567 !
11568 ! Array givfac is the average Giver et al. correction factor for this band.
11569 !
11570 ! The array KAO contains absorption coefs at the 16 chosen g-values
11571 ! for a range of pressure levels> ~100mb, temperatures, and binary
11572 ! species parameters (see taumol.f for definition). The first
11573 ! index in the array, JS, runs from 1 to 9, and corresponds to
11574 ! different values of the binary species parameter. For instance,
11575 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11576 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11577 ! in the array, JT, which runs from 1 to 5, corresponds to different
11578 ! temperatures. More specifically, JT = 3 means that the data are for
11579 ! the reference temperature TREF for this pressure level, JT = 2 refers
11580 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11581 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11582 ! to the JPth reference pressure level (see taumol.f for these levels
11583 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11584 ! which g-interval the absorption coefficients are for.
11585 !
11586 ! The array FORREFO contains the coefficient of the water vapor
11587 ! foreign-continuum (including the energy term). The first
11588 ! index refers to reference temperature (296,260,224,260) and
11589 ! pressure (970,475,219,3 mbar) levels. The second index
11590 ! runs over the g-channel (1 to 16).
11591 !
11592 ! The array SELFREFO contains the coefficient of the water vapor
11593 ! self-continuum (including the energy term). The first index
11594 ! refers to temperature in 7.2 degree increments. For instance,
11595 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11596 ! etc. The second index runs over the g-channel (1 to 16).
11597 !-------------------------------------------------------------------------------
11598 use rrsw_kg23_k, only : kao, selfrefo, forrefo, sfluxrefo, &
11599 raylo, givfac, layreffr
11600 !
11601 implicit none
11602 !
11603 save
11604 !
11605 ! Input
11606 !
11607 integer, intent(in) :: rrtmg_unit
11608 !
11609 ! Local
11610 !
11611 character*80 errmess
11612 logical, external :: wrf_dm_on_monitor
11613 !-------------------------------------------------------------------------------
11614 !
11615 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11616 raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
11617 call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11618 call wrf_dm_bcast_real ( givfac , 1 )
11619 call wrf_dm_bcast_integer ( layreffr , 1 )
11620 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11621 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11622 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11623 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11624 return
11625 9010 continue
11626 write( errmess , '(A,I4)' ) &
11627 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11628 !
11629 end subroutine sw_kgb23
11630 !-------------------------------------------------------------------------------
11631 !
11632 !
11633 !-------------------------------------------------------------------------------
11634 subroutine sw_kgb24(rrtmg_unit)
11635 !-------------------------------------------------------------------------------
11636 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11637 !
11638 ! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
11639 ! all v for this band for the upper and lower atmosphere.
11640 !
11641 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
11642 ! all v for this band for the upper and lower atmosphere.
11643 !
11644 ! The array KAO contains absorption coefs at the 16 chosen g-values
11645 ! for a range of pressure levels> ~100mb, temperatures, and binary
11646 ! species parameters (see taumol.f for definition). The first
11647 ! index in the array, JS, runs from 1 to 9, and corresponds to
11648 ! different values of the binary species parameter. For instance,
11649 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11650 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11651 ! in the array, JT, which runs from 1 to 5, corresponds to different
11652 ! temperatures. More specifically, JT = 3 means that the data are for
11653 ! the reference temperature TREF for this pressure level, JT = 2 refers
11654 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11655 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11656 ! to the JPth reference pressure level (see taumol.f for these levels
11657 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11658 ! which g-interval the absorption coefficients are for.
11659 !
11660 ! The array KBO contains absorption coefs at the 16 chosen g-values
11661 ! for a range of pressure levels < ~100mb and temperatures. The first
11662 ! index in the array, JT, which runs from 1 to 5, corresponds to
11663 ! different temperatures. More specifically, JT = 3 means that the
11664 ! data are for the reference temperature TREF for this pressure
11665 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11666 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11667 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11668 ! reference pressure level (see taumol.f for the value of these
11669 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11670 ! and tells us which g-interval the absorption coefficients are for.
11671 !
11672 ! The array FORREFO contains the coefficient of the water vapor
11673 ! foreign-continuum (including the energy term). The first
11674 ! index refers to reference temperature (296,260,224,260) and
11675 ! pressure (970,475,219,3 mbar) levels. The second index
11676 ! runs over the g-channel (1 to 16).
11677 !
11678 ! The array SELFREFO contains the coefficient of the water vapor
11679 ! self-continuum (including the energy term). The first index
11680 ! refers to temperature in 7.2 degree increments. For instance,
11681 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11682 ! etc. The second index runs over the g-channel (1 to 16).
11683 !-------------------------------------------------------------------------------
11684 use rrsw_kg24_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11685 raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
11686 !
11687 implicit none
11688 !
11689 save
11690 !
11691 ! Input
11692 !
11693 integer, intent(in) :: rrtmg_unit
11694 !
11695 ! Local
11696 !
11697 character*80 errmess
11698 logical, external :: wrf_dm_on_monitor
11699 !-------------------------------------------------------------------------------
11700 !
11701 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11702 raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
11703 forrefo, sfluxrefo
11704 call wrf_dm_bcast_bytes ( raylao , size ( raylao ) * 4 )
11705 call wrf_dm_bcast_bytes ( raylbo , size ( raylbo ) * 4 )
11706 call wrf_dm_bcast_real ( strrat , 1 )
11707 call wrf_dm_bcast_integer ( layreffr , 1 )
11708 call wrf_dm_bcast_bytes ( abso3ao , size ( abso3ao ) * 4 )
11709 call wrf_dm_bcast_bytes ( abso3bo , size ( abso3bo ) * 4 )
11710 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11711 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11712 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11713 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11714 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11715 !
11716 return
11717 9010 continue
11718 write( errmess , '(A,I4)' ) &
11719 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11720 !
11721 end subroutine sw_kgb24
11722 !-------------------------------------------------------------------------------
11723 !
11724 !
11725 !-------------------------------------------------------------------------------
11726 subroutine sw_kgb25(rrtmg_unit)
11727 !-------------------------------------------------------------------------------
11728 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11729 !
11730 ! Array raylo contains the Rayleigh extinction coefficient at all
11731 ! v = 2925 cm-1.
11732 !
11733 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
11734 ! all v for this band for the upper and lower atmosphere.
11735 !
11736 ! The array KAO contains absorption coefs at the 16 chosen g-values
11737 ! for a range of pressure levels> ~100mb, temperatures, and binary
11738 ! species parameters (see taumol.f for definition). The first
11739 ! index in the array, JS, runs from 1 to 9, and corresponds to
11740 ! different values of the binary species parameter. For instance,
11741 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11742 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11743 ! in the array, JT, which runs from 1 to 5, corresponds to different
11744 ! temperatures. More specifically, JT = 3 means that the data are for
11745 ! the reference temperature TREF for this pressure level, JT = 2 refers
11746 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11747 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11748 ! to the JPth reference pressure level (see taumol.f for these levels
11749 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11750 ! which g-interval the absorption coefficients are for.
11751 !-------------------------------------------------------------------------------
11752 use rrsw_kg25_k, only : kao, sfluxrefo, &
11753 raylo, abso3ao, abso3bo, layreffr
11754 !
11755 implicit none
11756 !
11757 save
11758 !
11759 ! Input
11760 !
11761 integer, intent(in) :: rrtmg_unit
11762 !
11763 ! Local
11764 !
11765 character*80 errmess
11766 logical, external :: wrf_dm_on_monitor
11767 !-------------------------------------------------------------------------------
11768 !
11769 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11770 raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
11771 call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11772 call wrf_dm_bcast_integer ( layreffr , 1 )
11773 call wrf_dm_bcast_bytes ( abso3ao , size ( abso3ao ) * 4 )
11774 call wrf_dm_bcast_bytes ( abso3bo , size ( abso3bo ) * 4 )
11775 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11776 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11777 !
11778 return
11779 9010 continue
11780 write( errmess , '(A,I4)' ) &
11781 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11782 !
11783 end subroutine sw_kgb25
11784 !-------------------------------------------------------------------------------
11785 !
11786 !
11787 !-------------------------------------------------------------------------------
11788 subroutine sw_kgb26(rrtmg_unit)
11789 !-------------------------------------------------------------------------------
11790 use rrsw_kg26_k, only : sfluxrefo, raylo
11791 !-------------------------------------------------------------------------------
11792 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11793 !
11794 ! Array raylo contains the Rayleigh extinction coefficient at all v for
11795 ! this band.
11796 !
11797 !-------------------------------------------------------------------------------
11798 !
11799 implicit none
11800 !
11801 save
11802 !
11803 ! Input
11804 !
11805 integer, intent(in) :: rrtmg_unit
11806 !
11807 ! Local
11808 !
11809 character*80 errmess
11810 logical, external :: wrf_dm_on_monitor
11811 !-------------------------------------------------------------------------------
11812 !
11813 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11814 raylo, sfluxrefo
11815 call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11816 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11817 !
11818 return
11819 9010 continue
11820 write( errmess , '(A,I4)' ) &
11821 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11822 !
11823 end subroutine sw_kgb26
11824 !-------------------------------------------------------------------------------
11825 !
11826 !
11827 !-------------------------------------------------------------------------------
11828 subroutine sw_kgb27(rrtmg_unit)
11829 !-------------------------------------------------------------------------------
11830 use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo, &
11831 scalekur, layreffr
11832 !-------------------------------------------------------------------------------
11833 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11834 ! The values in array sfluxrefo were obtained using the "low resolution"
11835 ! version of the Kurucz solar source function. For unknown reasons,
11836 ! the total irradiance in this band differs from the corresponding
11837 ! total in the "high-resolution" version of the Kurucz function.
11838 ! Therefore, these values are scaled by the factor SCALEKUR.
11839 !
11840 ! Array raylo contains the Rayleigh extinction coefficient at all v = 2925
11841 ! cm-1.
11842 !
11843 ! The array KAO contains absorption coefs at the 16 chosen g-values
11844 ! for a range of pressure levels> ~100mb, temperatures, and binary
11845 ! species parameters (see taumol.f for definition). The first
11846 ! index in the array, JS, runs from 1 to 9, and corresponds to
11847 ! different values of the binary species parameter. For instance,
11848 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11849 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11850 ! in the array, JT, which runs from 1 to 5, corresponds to different
11851 ! temperatures. More specifically, JT = 3 means that the data are for
11852 ! the reference temperature TREF for this pressure level, JT = 2 refers
11853 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11854 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11855 ! to the JPth reference pressure level (see taumol.f for these levels
11856 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11857 ! which g-interval the absorption coefficients are for.
11858 !
11859 ! The array KBO contains absorption coefs at the 16 chosen g-values
11860 ! for a range of pressure levels < ~100mb and temperatures. The first
11861 ! index in the array, JT, which runs from 1 to 5, corresponds to
11862 ! different temperatures. More specifically, JT = 3 means that the
11863 ! data are for the reference temperature TREF for this pressure
11864 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11865 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11866 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11867 ! reference pressure level (see taumol.f for the value of these
11868 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11869 ! and tells us which g-interval the absorption coefficients are for.
11870 !-------------------------------------------------------------------------------
11871 use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo, &
11872 scalekur, layreffr
11873 !
11874 implicit none
11875 !
11876 save
11877 !
11878 ! Input
11879 !
11880 integer, intent(in) :: rrtmg_unit
11881 !
11882 ! Local
11883 !
11884 character*80 errmess
11885 logical, external :: wrf_dm_on_monitor
11886 !-------------------------------------------------------------------------------
11887 !
11888 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11889 raylo, scalekur, layreffr, kao, kbo, sfluxrefo
11890 call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11891 call wrf_dm_bcast_real ( scalekur , 1 )
11892 call wrf_dm_bcast_integer ( layreffr , 1 )
11893 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11894 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11895 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11896 !
11897 return
11898 9010 continue
11899 write( errmess , '(A,I4)' ) &
11900 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11901 !
11902 end subroutine sw_kgb27
11903 !-------------------------------------------------------------------------------
11904 !
11905 !
11906 !-------------------------------------------------------------------------------
11907 subroutine sw_kgb28(rrtmg_unit)
11908 !-------------------------------------------------------------------------------
11909 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11910 !
11911 ! Array raylo contains the Rayleigh extinction coefficient at
11912 ! all v = ???? cm-1.
11913 !
11914 ! The array KAO contains absorption coefs at the 16 chosen g-values
11915 ! for a range of pressure levels> ~100mb, temperatures, and binary
11916 ! species parameters (see taumol.f for definition). The first
11917 ! index in the array, JS, runs from 1 to 9, and corresponds to
11918 ! different values of the binary species parameter. For instance,
11919 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11920 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11921 ! in the array, JT, which runs from 1 to 5, corresponds to different
11922 ! temperatures. More specifically, JT = 3 means that the data are for
11923 ! the reference temperature TREF for this pressure level, JT = 2 refers
11924 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11925 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11926 ! to the JPth reference pressure level (see taumol.f for these levels
11927 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11928 ! which g-interval the absorption coefficients are for.
11929 !
11930 ! The array KBO contains absorption coefs at the 16 chosen g-values
11931 ! for a range of pressure levels < ~100mb and temperatures. The first
11932 ! index in the array, JT, which runs from 1 to 5, corresponds to
11933 ! different temperatures. More specifically, JT = 3 means that the
11934 ! data are for the reference temperature TREF for this pressure
11935 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11936 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11937 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11938 ! reference pressure level (see taumol.f for the value of these
11939 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11940 ! and tells us which g-interval the absorption coefficients are for.
11941 !-------------------------------------------------------------------------------
11942 use rrsw_kg28_k, only : kao, kbo, sfluxrefo, &
11943 rayl, strrat, layreffr
11944 !
11945 implicit none
11946 !
11947 save
11948 !
11949 ! Input
11950 !
11951 integer, intent(in) :: rrtmg_unit
11952 !
11953 ! Local
11954 !
11955 character*80 errmess
11956 logical, external :: wrf_dm_on_monitor
11957 !-------------------------------------------------------------------------------
11958 !
11959 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
11960 rayl, strrat, layreffr, kao, kbo, sfluxrefo
11961 call wrf_dm_bcast_real ( rayl , 1 )
11962 call wrf_dm_bcast_real ( strrat , 1 )
11963 call wrf_dm_bcast_integer ( layreffr , 1 )
11964 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11965 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11966 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11967 !
11968 return
11969 9010 continue
11970 write( errmess , '(A,I4)' ) &
11971 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11972 !
11973 end subroutine sw_kgb28
11974 !-------------------------------------------------------------------------------
11975 !
11976 !
11977 !-------------------------------------------------------------------------------
11978 subroutine sw_kgb29(rrtmg_unit)
11979 !-------------------------------------------------------------------------------
11980 use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11981 absh2oo, absco2o, rayl, layreffr
11982 !-------------------------------------------------------------------------------
11983 !
11984 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11985 !
11986 ! Array rayl contains the Rayleigh extinction coefficient at all
11987 ! v = 2200 cm-1.
11988 !
11989 ! Array absh2oo contains the water vapor absorption coefficient for
11990 ! this band.
11991 !
11992 ! Array absco2o contains the carbon dioxide absorption coefficient for
11993 ! this band.
11994 !
11995 ! The array KAO contains absorption coefs at the 16 chosen g-values
11996 ! for a range of pressure levels> ~100mb, temperatures, and binary
11997 ! species parameters (see taumol.f for definition). The first
11998 ! index in the array, JS, runs from 1 to 9, and corresponds to
11999 ! different values of the binary species parameter. For instance,
12000 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12001 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12002 ! in the array, JT, which runs from 1 to 5, corresponds to different
12003 ! temperatures. More specifically, JT = 3 means that the data are for
12004 ! the reference temperature TREF for this pressure level, JT = 2 refers
12005 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12006 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12007 ! to the JPth reference pressure level (see taumol.f for these levels
12008 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12009 ! which g-interval the absorption coefficients are for.
12010 !
12011 ! The array KBO contains absorption coefs at the 16 chosen g-values
12012 ! for a range of pressure levels < ~100mb and temperatures. The first
12013 ! index in the array, JT, which runs from 1 to 5, corresponds to
12014 ! different temperatures. More specifically, JT = 3 means that the
12015 ! data are for the reference temperature TREF for this pressure
12016 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12017 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12018 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12019 ! reference pressure level (see taumol.f for the value of these
12020 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12021 ! and tells us which g-interval the absorption coefficients are for.
12022 !
12023 ! The array FORREFO contains the coefficient of the water vapor
12024 ! foreign-continuum (including the energy term). The first
12025 ! index refers to reference temperature (296,260,224,260) and
12026 ! pressure (970,475,219,3 mbar) levels. The second index
12027 ! runs over the g-channel (1 to 16).
12028 !
12029 ! The array SELFREFO contains the coefficient of the water vapor
12030 ! self-continuum (including the energy term). The first index
12031 ! refers to temperature in 7.2 degree increments. For instance,
12032 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12033 ! etc. The second index runs over the g-channel (1 to 16).
12034 !-------------------------------------------------------------------------------
12035 use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12036 absh2oo, absco2o, rayl, layreffr
12037 !
12038 implicit none
12039 !
12040 save
12041 !
12042 ! Input
12043 !
12044 integer, intent(in) :: rrtmg_unit
12045 !
12046 ! Local
12047 !
12048 character*80 errmess
12049 logical, external :: wrf_dm_on_monitor
12050 !-------------------------------------------------------------------------------
12051 !
12052 if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010) &
12053 rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
12054 call wrf_dm_bcast_real ( rayl , 1 )
12055 call wrf_dm_bcast_integer ( layreffr , 1 )
12056 call wrf_dm_bcast_bytes ( absh2oo , size ( absh2oo ) * 4 )
12057 call wrf_dm_bcast_bytes ( absco2o , size ( absco2o ) * 4 )
12058 call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12059 call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12060 call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12061 call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12062 call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
12063 !
12064 return
12065 9010 continue
12066 write( errmess , '(A,I4)' ) &
12067 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12068 !
12069 end subroutine sw_kgb29
12070 !-------------------------------------------------------------------------------
12071 !
12072 !
12073 !-------------------------------------------------------------------------------
12074 !-------------------------------------------------------------------------------
12075 !
12076 !
12077 !-------------------------------------------------------------------------------
12078 end module module_ra_rrtmg_swk
12079 !-------------------------------------------------------------------------------
12080 #endif