| blob | 1b0c2a8b8863b787c68f8f3a7ea109d0f4c2f731 |
1 !!MODULE module_ra_rrtmg_sw
3 module parrrsw
5 use parkind ,only : im => kind_im, rb => kind_rb
7 ! implicit none
8 save
10 !------------------------------------------------------------------
11 ! rrtmg_sw main parameters
12 !
13 ! Initial version: JJMorcrette, ECMWF, jul1998
14 ! Revised: MJIacono, AER, jun2006
15 ! Revised: MJIacono, AER, aug2008
16 !------------------------------------------------------------------
18 ! name type purpose
19 ! ----- : ---- : ----------------------------------------------
20 ! mxlay : integer: maximum number of layers
21 ! mg : integer: number of original g-intervals per spectral band
22 ! nbndsw : integer: number of spectral bands
23 ! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option)
24 ! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw
25 ! ngNN : integer: number of reduced g-intervals per spectral band
26 ! ngsNN : integer: cumulative number of g-intervals per band
27 !------------------------------------------------------------------
29 integer(kind=im), parameter :: mxlay = 203 !jplay, klev
30 integer(kind=im), parameter :: mg = 16 !jpg
31 integer(kind=im), parameter :: nbndsw = 14 !jpsw, ksw
32 integer(kind=im), parameter :: naerec = 6 !jpaer
33 integer(kind=im), parameter :: mxmol = 38
34 integer(kind=im), parameter :: nstr = 2
35 integer(kind=im), parameter :: nmol = 7
36 ! Use for 112 g-point model
37 integer(kind=im), parameter :: ngptsw = 112 !jpgpt
38 ! Use for 224 g-point model
39 ! integer(kind=im), parameter :: ngptsw = 224 !jpgpt
41 ! may need to rename these - from v2.6
42 integer(kind=im), parameter :: jpband = 29
43 integer(kind=im), parameter :: jpb1 = 16 !istart
44 integer(kind=im), parameter :: jpb2 = 29 !iend
46 integer(kind=im), parameter :: jmcmu = 32
47 integer(kind=im), parameter :: jmumu = 32
48 integer(kind=im), parameter :: jmphi = 3
49 integer(kind=im), parameter :: jmxang = 4
50 integer(kind=im), parameter :: jmxstr = 16
52 ! Use for 112 g-point model
53 integer(kind=im), parameter :: ng16 = 6
54 integer(kind=im), parameter :: ng17 = 12
55 integer(kind=im), parameter :: ng18 = 8
56 integer(kind=im), parameter :: ng19 = 8
57 integer(kind=im), parameter :: ng20 = 10
58 integer(kind=im), parameter :: ng21 = 10
59 integer(kind=im), parameter :: ng22 = 2
60 integer(kind=im), parameter :: ng23 = 10
61 integer(kind=im), parameter :: ng24 = 8
62 integer(kind=im), parameter :: ng25 = 6
63 integer(kind=im), parameter :: ng26 = 6
64 integer(kind=im), parameter :: ng27 = 8
65 integer(kind=im), parameter :: ng28 = 6
66 integer(kind=im), parameter :: ng29 = 12
68 integer(kind=im), parameter :: ngs16 = 6
69 integer(kind=im), parameter :: ngs17 = 18
70 integer(kind=im), parameter :: ngs18 = 26
71 integer(kind=im), parameter :: ngs19 = 34
72 integer(kind=im), parameter :: ngs20 = 44
73 integer(kind=im), parameter :: ngs21 = 54
74 integer(kind=im), parameter :: ngs22 = 56
75 integer(kind=im), parameter :: ngs23 = 66
76 integer(kind=im), parameter :: ngs24 = 74
77 integer(kind=im), parameter :: ngs25 = 80
78 integer(kind=im), parameter :: ngs26 = 86
79 integer(kind=im), parameter :: ngs27 = 94
80 integer(kind=im), parameter :: ngs28 = 100
81 integer(kind=im), parameter :: ngs29 = 112
83 ! Use for 224 g-point model
84 ! integer(kind=im), parameter :: ng16 = 16
85 ! integer(kind=im), parameter :: ng17 = 16
86 ! integer(kind=im), parameter :: ng18 = 16
87 ! integer(kind=im), parameter :: ng19 = 16
88 ! integer(kind=im), parameter :: ng20 = 16
89 ! integer(kind=im), parameter :: ng21 = 16
90 ! integer(kind=im), parameter :: ng22 = 16
91 ! integer(kind=im), parameter :: ng23 = 16
92 ! integer(kind=im), parameter :: ng24 = 16
93 ! integer(kind=im), parameter :: ng25 = 16
94 ! integer(kind=im), parameter :: ng26 = 16
95 ! integer(kind=im), parameter :: ng27 = 16
96 ! integer(kind=im), parameter :: ng28 = 16
97 ! integer(kind=im), parameter :: ng29 = 16
99 ! integer(kind=im), parameter :: ngs16 = 16
100 ! integer(kind=im), parameter :: ngs17 = 32
101 ! integer(kind=im), parameter :: ngs18 = 48
102 ! integer(kind=im), parameter :: ngs19 = 64
103 ! integer(kind=im), parameter :: ngs20 = 80
104 ! integer(kind=im), parameter :: ngs21 = 96
105 ! integer(kind=im), parameter :: ngs22 = 112
106 ! integer(kind=im), parameter :: ngs23 = 128
107 ! integer(kind=im), parameter :: ngs24 = 144
108 ! integer(kind=im), parameter :: ngs25 = 160
109 ! integer(kind=im), parameter :: ngs26 = 176
110 ! integer(kind=im), parameter :: ngs27 = 192
111 ! integer(kind=im), parameter :: ngs28 = 208
112 ! integer(kind=im), parameter :: ngs29 = 224
114 ! Source function solar constant
115 real(kind=rb), parameter :: rrsw_scon = 1.36822e+03 ! W/m2
117 end module parrrsw
119 module rrsw_aer
121 use parkind, only : im => kind_im, rb => kind_rb
122 use parrrsw, only : nbndsw, naerec
124 ! implicit none
125 save
127 !------------------------------------------------------------------
128 ! rrtmg_sw aerosol optical properties
129 !
130 ! Data derived from six ECMWF aerosol types and defined for
131 ! the rrtmg_sw spectral intervals
132 !
133 ! Initial: J.-J. Morcrette, ECMWF, mar2003
134 ! Revised: MJIacono, AER, jul2006
135 ! Revised: MJIacono, AER, aug2008
136 !------------------------------------------------------------------
137 !
138 !-- The six ECMWF aerosol types are respectively:
139 !
140 ! 1/ continental average 2/ maritime
141 ! 3/ desert 4/ urban
142 ! 5/ volcanic active 6/ stratospheric background
143 !
144 ! computed from Hess and Koepke (con, mar, des, urb)
145 ! from Bonnel et al. (vol, str)
146 !
147 ! rrtmg_sw 14 spectral intervals (microns):
148 ! 3.846 - 3.077
149 ! 3.077 - 2.500
150 ! 2.500 - 2.150
151 ! 2.150 - 1.942
152 ! 1.942 - 1.626
153 ! 1.626 - 1.299
154 ! 1.299 - 1.242
155 ! 1.242 - 0.7782
156 ! 0.7782- 0.6250
157 ! 0.6250- 0.4415
158 ! 0.4415- 0.3448
159 ! 0.3448- 0.2632
160 ! 0.2632- 0.2000
161 ! 12.195 - 3.846
162 !
163 !------------------------------------------------------------------
164 !
165 ! name type purpose
166 ! ----- : ---- : ----------------------------------------------
167 ! rsrtaua : real : ratio of average optical thickness in
168 ! spectral band to that at 0.55 micron
169 ! rsrpiza : real : average single scattering albedo (unitless)
170 ! rsrasya : real : average asymmetry parameter (unitless)
171 !------------------------------------------------------------------
173 real(kind=rb) :: rsrtaua(nbndsw,naerec)
174 real(kind=rb) :: rsrpiza(nbndsw,naerec)
175 real(kind=rb) :: rsrasya(nbndsw,naerec)
177 end module rrsw_aer
179 module rrsw_cld
181 use parkind, only : im => kind_im, rb => kind_rb
183 ! implicit none
184 save
186 !------------------------------------------------------------------
187 ! rrtmg_sw cloud property coefficients
188 !
189 ! Initial: J.-J. Morcrette, ECMWF, oct1999
190 ! Revised: J. Delamere/MJIacono, AER, aug2005
191 ! Revised: MJIacono, AER, nov2005
192 ! Revised: MJIacono, AER, jul2006
193 ! Revised: MJIacono, AER, aug2008
194 !------------------------------------------------------------------
195 !
196 ! name type purpose
197 ! ----- : ---- : ----------------------------------------------
198 ! xxxliq1 : real : optical properties (extinction coefficient, single
199 ! scattering albedo, assymetry factor) from
200 ! Hu & Stamnes, j. clim., 6, 728-742, 1993.
201 ! xxxice2 : real : optical properties (extinction coefficient, single
202 ! scattering albedo, assymetry factor) from streamer v3.0,
203 ! Key, streamer user's guide, cooperative institude
204 ! for meteorological studies, 95 pp., 2001.
205 ! xxxice3 : real : optical properties (extinction coefficient, single
206 ! scattering albedo, assymetry factor) from
207 ! Fu, j. clim., 9, 1996.
208 ! xbari : real : optical property coefficients for five spectral
209 ! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
210 ! and 14285-40000 wavenumbers) following
211 ! Ebert and Curry, jgr, 97, 3831-3836, 1992.
212 !------------------------------------------------------------------
214 real(kind=rb) :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29)
215 real(kind=rb) :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29)
216 real(kind=rb) :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29)
217 real(kind=rb) :: fdlice3(46,16:29)
218 real(kind=rb) :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5)
220 end module rrsw_cld
222 module rrsw_con
224 use parkind, only : im => kind_im, rb => kind_rb
226 ! implicit none
227 save
229 !------------------------------------------------------------------
230 ! rrtmg_sw constants
232 ! Initial version: MJIacono, AER, jun2006
233 ! Revised: MJIacono, AER, aug2008
234 !------------------------------------------------------------------
236 ! name type purpose
237 ! ----- : ---- : ----------------------------------------------
238 ! fluxfac: real : radiance to flux conversion factor
239 ! heatfac: real : flux to heating rate conversion factor
240 !oneminus: real : 1.-1.e-6
241 ! pi : real : pi
242 ! grav : real : acceleration of gravity
243 ! planck : real : planck constant
244 ! boltz : real : boltzmann constant
245 ! clight : real : speed of light
246 ! avogad : real : avogadro constant
247 ! alosmt : real : loschmidt constant
248 ! gascon : real : molar gas constant
249 ! radcn1 : real : first radiation constant
250 ! radcn2 : real : second radiation constant
251 ! sbcnst : real : stefan-boltzmann constant
252 ! secdy : real : seconds per day
253 !------------------------------------------------------------------
255 real(kind=rb) :: fluxfac, heatfac
256 real(kind=rb) :: oneminus, pi, grav
257 real(kind=rb) :: planck, boltz, clight
258 real(kind=rb) :: avogad, alosmt, gascon
259 real(kind=rb) :: radcn1, radcn2
260 real(kind=rb) :: sbcnst, secdy
262 end module rrsw_con
264 module rrsw_kg16
266 use parkind ,only : im => kind_im, rb => kind_rb
267 use parrrsw, only : ng16
269 ! implicit none
270 save
272 !-----------------------------------------------------------------
273 ! rrtmg_sw ORIGINAL abs. coefficients for interval 16
274 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
275 !
276 ! Initial version: JJMorcrette, ECMWF, oct1999
277 ! Revised: MJIacono, AER, jul2006
278 ! Revised: MJIacono, AER, aug2008
279 !-----------------------------------------------------------------
280 !
281 ! name type purpose
282 ! ---- : ---- : ---------------------------------------------
283 ! kao : real
284 ! kbo : real
285 ! selfrefo: real
286 ! forrefo : real
287 !sfluxrefo: real
288 !-----------------------------------------------------------------
290 integer(kind=im), parameter :: no16 = 16
292 real(kind=rb) :: kao(9,5,13,no16)
293 real(kind=rb) :: kbo(5,13:59,no16)
294 real(kind=rb) :: selfrefo(10,no16), forrefo(3,no16)
295 real(kind=rb) :: sfluxrefo(no16)
297 integer(kind=im) :: layreffr
298 real(kind=rb) :: rayl, strrat1
300 !-----------------------------------------------------------------
301 ! rrtmg_sw COMBINED abs. coefficients for interval 16
302 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
303 !
304 ! Initial version: JJMorcrette, ECMWF, oct1999
305 ! Revised: MJIacono, AER, jul2006
306 ! Revised: MJIacono, AER, aug2008
307 !-----------------------------------------------------------------
308 !
309 ! name type purpose
310 ! ---- : ---- : ---------------------------------------------
311 ! ka : real
312 ! kb : real
313 ! absa : real
314 ! absb : real
315 ! selfref : real
316 ! forref : real
317 ! sfluxref: real
318 !-----------------------------------------------------------------
320 real(kind=rb) :: ka(9,5,13,ng16) , absa(585,ng16)
321 real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
322 real(kind=rb) :: selfref(10,ng16), forref(3,ng16)
323 real(kind=rb) :: sfluxref(ng16)
325 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
327 end module rrsw_kg16
329 module rrsw_kg17
331 use parkind ,only : im => kind_im, rb => kind_rb
332 use parrrsw, only : ng17
334 ! implicit none
335 save
337 !-----------------------------------------------------------------
338 ! rrtmg_sw ORIGINAL abs. coefficients for interval 17
339 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
340 !
341 ! Initial version: JJMorcrette, ECMWF, oct1999
342 ! Revised: MJIacono, AER, jul2006
343 ! Revised: MJIacono, AER, aug2008
344 !-----------------------------------------------------------------
345 !
346 ! name type purpose
347 ! ---- : ---- : ---------------------------------------------
348 ! kao : real
349 ! kbo : real
350 ! selfrefo: real
351 ! forrefo : real
352 !sfluxrefo: real
353 !-----------------------------------------------------------------
355 integer(kind=im), parameter :: no17 = 16
357 real(kind=rb) :: kao(9,5,13,no17)
358 real(kind=rb) :: kbo(5,5,13:59,no17)
359 real(kind=rb) :: selfrefo(10,no17), forrefo(4,no17)
360 real(kind=rb) :: sfluxrefo(no17,5)
362 integer(kind=im) :: layreffr
363 real(kind=rb) :: rayl, strrat
365 !-----------------------------------------------------------------
366 ! rrtmg_sw COMBINED abs. coefficients for interval 17
367 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
368 !
369 ! Initial version: JJMorcrette, ECMWF, oct1999
370 ! Revised: MJIacono, AER, jul2006
371 ! Revised: MJIacono, AER, aug2008
372 !-----------------------------------------------------------------
373 !
374 ! name type purpose
375 ! ---- : ---- : ---------------------------------------------
376 ! ka : real
377 ! kb : real
378 ! absa : real
379 ! absb : real
380 ! selfref : real
381 ! forref : real
382 ! sfluxref: real
383 !-----------------------------------------------------------------
385 real(kind=rb) :: ka(9,5,13,ng17) , absa(585,ng17)
386 real(kind=rb) :: kb(5,5,13:59,ng17), absb(1175,ng17)
387 real(kind=rb) :: selfref(10,ng17), forref(4,ng17)
388 real(kind=rb) :: sfluxref(ng17,5)
390 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
392 end module rrsw_kg17
394 module rrsw_kg18
396 use parkind ,only : im => kind_im, rb => kind_rb
397 use parrrsw, only : ng18
399 ! implicit none
400 save
402 !-----------------------------------------------------------------
403 ! rrtmg_sw ORIGINAL abs. coefficients for interval 18
404 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
405 !
406 ! Initial version: JJMorcrette, ECMWF, oct1999
407 ! Revised: MJIacono, AER, jul2006
408 ! Revised: MJIacono, AER, aug2008
409 !-----------------------------------------------------------------
410 !
411 ! name type purpose
412 ! ---- : ---- : ---------------------------------------------
413 ! kao : real
414 ! kbo : real
415 ! selfrefo: real
416 ! forrefo : real
417 !sfluxrefo: real
418 !-----------------------------------------------------------------
420 integer(kind=im), parameter :: no18 = 16
422 real(kind=rb) :: kao(9,5,13,no18)
423 real(kind=rb) :: kbo(5,13:59,no18)
424 real(kind=rb) :: selfrefo(10,no18), forrefo(3,no18)
425 real(kind=rb) :: sfluxrefo(no18,9)
427 integer(kind=im) :: layreffr
428 real(kind=rb) :: rayl, strrat
430 !-----------------------------------------------------------------
431 ! rrtmg_sw COMBINED abs. coefficients for interval 18
432 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
433 !
434 ! Initial version: JJMorcrette, ECMWF, oct1999
435 ! Revised: MJIacono, AER, jul2006
436 ! Revised: MJIacono, AER, aug2008
437 !-----------------------------------------------------------------
438 !
439 ! name type purpose
440 ! ---- : ---- : ---------------------------------------------
441 ! ka : real
442 ! kb : real
443 ! absa : real
444 ! absb : real
445 ! selfref : real
446 ! forref : real
447 ! sfluxref: real
448 !-----------------------------------------------------------------
450 real(kind=rb) :: ka(9,5,13,ng18), absa(585,ng18)
451 real(kind=rb) :: kb(5,13:59,ng18), absb(235,ng18)
452 real(kind=rb) :: selfref(10,ng18), forref(3,ng18)
453 real(kind=rb) :: sfluxref(ng18,9)
455 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
457 end module rrsw_kg18
459 module rrsw_kg19
461 use parkind ,only : im => kind_im, rb => kind_rb
462 use parrrsw, only : ng19
464 ! implicit none
465 save
467 !-----------------------------------------------------------------
468 ! rrtmg_sw ORIGINAL abs. coefficients for interval 19
469 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
470 !
471 ! Initial version: JJMorcrette, ECMWF, oct1999
472 ! Revised: MJIacono, AER, jul2006
473 ! Revised: MJIacono, AER, aug2008
474 !-----------------------------------------------------------------
475 !
476 ! name type purpose
477 ! ---- : ---- : ---------------------------------------------
478 ! kao : real
479 ! kbo : real
480 ! selfrefo: real
481 ! forrefo : real
482 !sfluxrefo: real
483 !-----------------------------------------------------------------
485 integer(kind=im), parameter :: no19 = 16
487 real(kind=rb) :: kao(9,5,13,no19)
488 real(kind=rb) :: kbo(5,13:59,no19)
489 real(kind=rb) :: selfrefo(10,no19), forrefo(3,no19)
490 real(kind=rb) :: sfluxrefo(no19,9)
492 integer(kind=im) :: layreffr
493 real(kind=rb) :: rayl, strrat
495 !-----------------------------------------------------------------
496 ! rrtmg_sw COMBINED abs. coefficients for interval 19
497 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
498 !
499 ! Initial version: JJMorcrette, ECMWF, oct1999
500 ! Revised: MJIacono, AER, jul2006
501 ! Revised: MJIacono, AER, aug2008
502 !-----------------------------------------------------------------
503 !
504 ! name type purpose
505 ! ---- : ---- : ---------------------------------------------
506 ! ka : real
507 ! kb : real
508 ! absa : real
509 ! absb : real
510 ! selfref : real
511 ! forref : real
512 ! sfluxref: real
513 !-----------------------------------------------------------------
515 real(kind=rb) :: ka(9,5,13,ng19), absa(585,ng19)
516 real(kind=rb) :: kb(5,13:59,ng19), absb(235,ng19)
517 real(kind=rb) :: selfref(10,ng19), forref(3,ng19)
518 real(kind=rb) :: sfluxref(ng19,9)
520 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
522 end module rrsw_kg19
524 module rrsw_kg20
526 use parkind ,only : im => kind_im, rb => kind_rb
527 use parrrsw, only : ng20
529 ! implicit none
530 save
532 !-----------------------------------------------------------------
533 ! rrtmg_sw ORIGINAL abs. coefficients for interval 20
534 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
535 !
536 ! Initial version: JJMorcrette, ECMWF, oct1999
537 ! Revised: MJIacono, AER, jul2006
538 ! Revised: MJIacono, AER, aug2008
539 !-----------------------------------------------------------------
540 !
541 ! name type purpose
542 ! ---- : ---- : ---------------------------------------------
543 ! kao : real
544 ! kbo : real
545 ! selfrefo: real
546 ! forrefo : real
547 !sfluxrefo: real
548 ! absch4o : real
549 !-----------------------------------------------------------------
551 integer(kind=im), parameter :: no20 = 16
553 real(kind=rb) :: kao(5,13,no20)
554 real(kind=rb) :: kbo(5,13:59,no20)
555 real(kind=rb) :: selfrefo(10,no20), forrefo(4,no20)
556 real(kind=rb) :: sfluxrefo(no20)
557 real(kind=rb) :: absch4o(no20)
559 integer(kind=im) :: layreffr
560 real(kind=rb) :: rayl
562 !-----------------------------------------------------------------
563 ! rrtmg_sw COMBINED abs. coefficients for interval 20
564 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
565 !
566 ! Initial version: JJMorcrette, ECMWF, oct1999
567 ! Revised: MJIacono, AER, jul2006
568 ! Revised: MJIacono, AER, aug2008
569 !-----------------------------------------------------------------
570 !
571 ! name type purpose
572 ! ---- : ---- : ---------------------------------------------
573 ! ka : real
574 ! kb : real
575 ! absa : real
576 ! absb : real
577 ! selfref : real
578 ! forref : real
579 ! sfluxref: real
580 ! absch4 : real
581 !-----------------------------------------------------------------
583 real(kind=rb) :: ka(5,13,ng20), absa(65,ng20)
584 real(kind=rb) :: kb(5,13:59,ng20), absb(235,ng20)
585 real(kind=rb) :: selfref(10,ng20), forref(4,ng20)
586 real(kind=rb) :: sfluxref(ng20)
587 real(kind=rb) :: absch4(ng20)
589 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
591 end module rrsw_kg20
593 module rrsw_kg21
595 use parkind ,only : im => kind_im, rb => kind_rb
596 use parrrsw, only : ng21
598 ! implicit none
599 save
601 !-----------------------------------------------------------------
602 ! rrtmg_sw ORIGINAL abs. coefficients for interval 21
603 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
604 !
605 ! Initial version: JJMorcrette, ECMWF, oct1999
606 ! Revised: MJIacono, AER, jul2006
607 ! Revised: MJIacono, AER, aug2008
608 !-----------------------------------------------------------------
609 !
610 ! name type purpose
611 ! ---- : ---- : ---------------------------------------------
612 ! kao : real
613 ! kbo : real
614 ! selfrefo: real
615 ! forrefo : real
616 !sfluxrefo: real
617 !-----------------------------------------------------------------
619 integer(kind=im), parameter :: no21 = 16
621 real(kind=rb) :: kao(9,5,13,no21)
622 real(kind=rb) :: kbo(5,5,13:59,no21)
623 real(kind=rb) :: selfrefo(10,no21), forrefo(4,no21)
624 real(kind=rb) :: sfluxrefo(no21,9)
626 integer(kind=im) :: layreffr
627 real(kind=rb) :: rayl, strrat
629 !-----------------------------------------------------------------
630 ! rrtmg_sw COMBINED abs. coefficients for interval 21
631 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
632 !
633 ! Initial version: JJMorcrette, ECMWF, oct1999
634 ! Revised: MJIacono, AER, jul2006
635 ! Revised: MJIacono, AER, aug2008
636 !-----------------------------------------------------------------
637 !
638 ! name type purpose
639 ! ---- : ---- : ---------------------------------------------
640 ! ka : real
641 ! kb : real
642 ! absa : real
643 ! absb : real
644 ! selfref : real
645 ! forref : real
646 ! sfluxref: real
647 !-----------------------------------------------------------------
649 real(kind=rb) :: ka(9,5,13,ng21), absa(585,ng21)
650 real(kind=rb) :: kb(5,5,13:59,ng21), absb(1175,ng21)
651 real(kind=rb) :: selfref(10,ng21), forref(4,ng21)
652 real(kind=rb) :: sfluxref(ng21,9)
654 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
656 end module rrsw_kg21
658 module rrsw_kg22
660 use parkind ,only : im => kind_im, rb => kind_rb
661 use parrrsw, only : ng22
663 ! implicit none
664 save
666 !-----------------------------------------------------------------
667 ! rrtmg_sw ORIGINAL abs. coefficients for interval 22
668 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
669 !
670 ! Initial version: JJMorcrette, ECMWF, oct1999
671 ! Revised: MJIacono, AER, jul2006
672 ! Revised: MJIacono, AER, aug2008
673 !-----------------------------------------------------------------
674 !
675 ! name type purpose
676 ! ---- : ---- : ---------------------------------------------
677 ! kao : real
678 ! kbo : real
679 ! selfrefo: real
680 ! forrefo : real
681 !sfluxrefo: real
682 !-----------------------------------------------------------------
684 integer(kind=im), parameter :: no22 = 16
686 real(kind=rb) :: kao(9,5,13,no22)
687 real(kind=rb) :: kbo(5,13:59,no22)
688 real(kind=rb) :: selfrefo(10,no22), forrefo(3,no22)
689 real(kind=rb) :: sfluxrefo(no22,9)
691 integer(kind=im) :: layreffr
692 real(kind=rb) :: rayl, strrat
694 !-----------------------------------------------------------------
695 ! rrtmg_sw COMBINED abs. coefficients for interval 22
696 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
697 !
698 ! Initial version: JJMorcrette, ECMWF, oct1999
699 ! Revised: MJIacono, AER, jul2006
700 ! Revised: MJIacono, AER, aug2008
701 !-----------------------------------------------------------------
702 !
703 ! name type purpose
704 ! ---- : ---- : ---------------------------------------------
705 ! ka : real
706 ! kb : real
707 ! absa : real
708 ! absb : real
709 ! selfref : real
710 ! forref : real
711 ! sfluxref: real
712 !-----------------------------------------------------------------
714 real(kind=rb) :: ka(9,5,13,ng22), absa(585,ng22)
715 real(kind=rb) :: kb(5,13:59,ng22), absb(235,ng22)
716 real(kind=rb) :: selfref(10,ng22), forref(3,ng22)
717 real(kind=rb) :: sfluxref(ng22,9)
719 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
721 end module rrsw_kg22
723 module rrsw_kg23
725 use parkind ,only : im => kind_im, rb => kind_rb
726 use parrrsw, only : ng23
728 ! implicit none
729 save
731 !-----------------------------------------------------------------
732 ! rrtmg_sw ORIGINAL abs. coefficients for interval 23
733 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
734 !
735 ! Initial version: JJMorcrette, ECMWF, oct1999
736 ! Revised: MJIacono, AER, jul2006
737 ! Revised: MJIacono, AER, aug2008
738 !-----------------------------------------------------------------
739 !
740 ! name type purpose
741 ! ---- : ---- : ---------------------------------------------
742 ! kao : real
743 ! kbo : real
744 ! selfrefo: real
745 ! forrefo : real
746 !sfluxrefo: real
747 !-----------------------------------------------------------------
749 integer(kind=im), parameter :: no23 = 16
751 real(kind=rb) :: kao(5,13,no23)
752 real(kind=rb) :: selfrefo(10,no23), forrefo(3,no23)
753 real(kind=rb) :: sfluxrefo(no23)
754 real(kind=rb) :: raylo(no23)
756 integer(kind=im) :: layreffr
757 real(kind=rb) :: givfac
759 !-----------------------------------------------------------------
760 ! rrtmg_sw COMBINED abs. coefficients for interval 23
761 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
762 !
763 ! Initial version: JJMorcrette, ECMWF, oct1999
764 ! Revised: MJIacono, AER, jul2006
765 ! Revised: MJIacono, AER, aug2008
766 !-----------------------------------------------------------------
767 !
768 ! name type purpose
769 ! ---- : ---- : ---------------------------------------------
770 ! ka : real
771 ! kb : real
772 ! absa : real
773 ! absb : real
774 ! selfref : real
775 ! forref : real
776 ! sfluxref: real
777 !-----------------------------------------------------------------
779 real(kind=rb) :: ka(5,13,ng23), absa(65,ng23)
780 real(kind=rb) :: selfref(10,ng23), forref(3,ng23)
781 real(kind=rb) :: sfluxref(ng23), rayl(ng23)
783 equivalence (ka(1,1,1),absa(1,1))
785 end module rrsw_kg23
787 module rrsw_kg24
789 use parkind ,only : im => kind_im, rb => kind_rb
790 use parrrsw, only : ng24
792 ! implicit none
793 save
795 !-----------------------------------------------------------------
796 ! rrtmg_sw ORIGINAL abs. coefficients for interval 24
797 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
798 !
799 ! Initial version: JJMorcrette, ECMWF, oct1999
800 ! Revised: MJIacono, AER, jul2006
801 ! Revised: MJIacono, AER, aug2008
802 !-----------------------------------------------------------------
803 !
804 ! name type purpose
805 ! ---- : ---- : ---------------------------------------------
806 ! kao : real
807 ! kbo : real
808 ! selfrefo: real
809 ! forrefo : real
810 !sfluxrefo: real
811 ! abso3ao : real
812 ! abso3bo : real
813 ! raylao : real
814 ! raylbo : real
815 !-----------------------------------------------------------------
817 integer(kind=im), parameter :: no24 = 16
819 real(kind=rb) :: kao(9,5,13,no24)
820 real(kind=rb) :: kbo(5,13:59,no24)
821 real(kind=rb) :: selfrefo(10,no24), forrefo(3,no24)
822 real(kind=rb) :: sfluxrefo(no24,9)
823 real(kind=rb) :: abso3ao(no24), abso3bo(no24)
824 real(kind=rb) :: raylao(no24,9), raylbo(no24)
826 integer(kind=im) :: layreffr
827 real(kind=rb) :: strrat
829 !-----------------------------------------------------------------
830 ! rrtmg_sw COMBINED abs. coefficients for interval 24
831 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
832 !
833 ! Initial version: JJMorcrette, ECMWF, oct1999
834 ! Revised: MJIacono, AER, jul2006
835 ! Revised: MJIacono, AER, aug2008
836 !-----------------------------------------------------------------
837 !
838 ! name type purpose
839 ! ---- : ---- : ---------------------------------------------
840 ! ka : real
841 ! kb : real
842 ! absa : real
843 ! absb : real
844 ! selfref : real
845 ! forref : real
846 ! sfluxref: real
847 ! abso3a : real
848 ! abso3b : real
849 ! rayla : real
850 ! raylb : real
851 !-----------------------------------------------------------------
853 real(kind=rb) :: ka(9,5,13,ng24), absa(585,ng24)
854 real(kind=rb) :: kb(5,13:59,ng24), absb(235,ng24)
855 real(kind=rb) :: selfref(10,ng24), forref(3,ng24)
856 real(kind=rb) :: sfluxref(ng24,9)
857 real(kind=rb) :: abso3a(ng24), abso3b(ng24)
858 real(kind=rb) :: rayla(ng24,9), raylb(ng24)
860 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
862 end module rrsw_kg24
864 module rrsw_kg25
866 use parkind ,only : im => kind_im, rb => kind_rb
867 use parrrsw, only : ng25
869 ! implicit none
870 save
872 !-----------------------------------------------------------------
873 ! rrtmg_sw ORIGINAL abs. coefficients for interval 25
874 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
875 !
876 ! Initial version: JJMorcrette, ECMWF, oct1999
877 ! Revised: MJIacono, AER, jul2006
878 ! Revised: MJIacono, AER, aug2008
879 !-----------------------------------------------------------------
880 !
881 ! name type purpose
882 ! ---- : ---- : ---------------------------------------------
883 ! kao : real
884 !sfluxrefo: real
885 ! abso3ao : real
886 ! abso3bo : real
887 ! raylo : real
888 !-----------------------------------------------------------------
890 integer(kind=im), parameter :: no25 = 16
892 real(kind=rb) :: kao(5,13,no25)
893 real(kind=rb) :: sfluxrefo(no25)
894 real(kind=rb) :: abso3ao(no25), abso3bo(no25)
895 real(kind=rb) :: raylo(no25)
897 integer(kind=im) :: layreffr
899 !-----------------------------------------------------------------
900 ! rrtmg_sw COMBINED abs. coefficients for interval 25
901 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
902 !
903 ! Initial version: JJMorcrette, ECMWF, oct1999
904 ! Revised: MJIacono, AER, jul2006
905 ! Revised: MJIacono, AER, aug2008
906 !-----------------------------------------------------------------
907 !
908 ! name type purpose
909 ! ---- : ---- : ---------------------------------------------
910 ! ka : real
911 ! absa : real
912 ! sfluxref: real
913 ! abso3a : real
914 ! abso3b : real
915 ! rayl : real
916 !-----------------------------------------------------------------
918 real(kind=rb) :: ka(5,13,ng25), absa(65,ng25)
919 real(kind=rb) :: sfluxref(ng25)
920 real(kind=rb) :: abso3a(ng25), abso3b(ng25)
921 real(kind=rb) :: rayl(ng25)
923 equivalence (ka(1,1,1),absa(1,1))
925 end module rrsw_kg25
927 module rrsw_kg26
929 use parkind ,only : im => kind_im, rb => kind_rb
930 use parrrsw, only : ng26
932 ! implicit none
933 save
935 !-----------------------------------------------------------------
936 ! rrtmg_sw ORIGINAL abs. coefficients for interval 26
937 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
938 !
939 ! Initial version: JJMorcrette, ECMWF, oct1999
940 ! Revised: MJIacono, AER, jul2006
941 ! Revised: MJIacono, AER, aug2008
942 !-----------------------------------------------------------------
943 !
944 ! name type purpose
945 ! ---- : ---- : ---------------------------------------------
946 !sfluxrefo: real
947 ! raylo : real
948 !-----------------------------------------------------------------
950 integer(kind=im), parameter :: no26 = 16
952 real(kind=rb) :: sfluxrefo(no26)
953 real(kind=rb) :: raylo(no26)
955 !-----------------------------------------------------------------
956 ! rrtmg_sw COMBINED abs. coefficients for interval 26
957 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
958 !
959 ! Initial version: JJMorcrette, ECMWF, oct1999
960 ! Revised: MJIacono, AER, jul2006
961 ! Revised: MJIacono, AER, aug2008
962 !-----------------------------------------------------------------
963 !
964 ! name type purpose
965 ! ---- : ---- : ---------------------------------------------
966 ! sfluxref: real
967 ! rayl : real
968 !-----------------------------------------------------------------
970 real(kind=rb) :: sfluxref(ng26)
971 real(kind=rb) :: rayl(ng26)
973 end module rrsw_kg26
975 module rrsw_kg27
977 use parkind ,only : im => kind_im, rb => kind_rb
978 use parrrsw, only : ng27
980 ! implicit none
981 save
983 !-----------------------------------------------------------------
984 ! rrtmg_sw ORIGINAL abs. coefficients for interval 27
985 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
986 !
987 ! Initial version: JJMorcrette, ECMWF, oct1999
988 ! Revised: MJIacono, AER, jul2006
989 ! Revised: MJIacono, AER, aug2008
990 !-----------------------------------------------------------------
991 !
992 ! name type purpose
993 ! ---- : ---- : ---------------------------------------------
994 ! kao : real
995 ! kbo : real
996 !sfluxrefo: real
997 ! raylo : real
998 !-----------------------------------------------------------------
1000 integer(kind=im), parameter :: no27 = 16
1002 real(kind=rb) :: kao(5,13,no27)
1003 real(kind=rb) :: kbo(5,13:59,no27)
1004 real(kind=rb) :: sfluxrefo(no27)
1005 real(kind=rb) :: raylo(no27)
1007 integer(kind=im) :: layreffr
1008 real(kind=rb) :: scalekur
1010 !-----------------------------------------------------------------
1011 ! rrtmg_sw COMBINED abs. coefficients for interval 27
1012 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1013 !
1014 ! Initial version: JJMorcrette, ECMWF, oct1999
1015 ! Revised: MJIacono, AER, jul2006
1016 ! Revised: MJIacono, AER, aug2008
1017 !-----------------------------------------------------------------
1018 !
1019 ! name type purpose
1020 ! ---- : ---- : ---------------------------------------------
1021 ! ka : real
1022 ! kb : real
1023 ! absa : real
1024 ! absb : real
1025 ! sfluxref: real
1026 ! rayl : real
1027 !-----------------------------------------------------------------
1029 real(kind=rb) :: ka(5,13,ng27), absa(65,ng27)
1030 real(kind=rb) :: kb(5,13:59,ng27), absb(235,ng27)
1031 real(kind=rb) :: sfluxref(ng27)
1032 real(kind=rb) :: rayl(ng27)
1034 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1036 end module rrsw_kg27
1038 module rrsw_kg28
1040 use parkind ,only : im => kind_im, rb => kind_rb
1041 use parrrsw, only : ng28
1043 ! implicit none
1044 save
1046 !-----------------------------------------------------------------
1047 ! rrtmg_sw ORIGINAL abs. coefficients for interval 28
1048 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1049 !
1050 ! Initial version: JJMorcrette, ECMWF, oct1999
1051 ! Revised: MJIacono, AER, jul2006
1052 ! Revised: MJIacono, AER, aug2008
1053 !-----------------------------------------------------------------
1054 !
1055 ! name type purpose
1056 ! ---- : ---- : ---------------------------------------------
1057 ! kao : real
1058 ! kbo : real
1059 !sfluxrefo: real
1060 !-----------------------------------------------------------------
1062 integer(kind=im), parameter :: no28 = 16
1064 real(kind=rb) :: kao(9,5,13,no28)
1065 real(kind=rb) :: kbo(5,5,13:59,no28)
1066 real(kind=rb) :: sfluxrefo(no28,5)
1068 integer(kind=im) :: layreffr
1069 real(kind=rb) :: rayl, strrat
1071 !-----------------------------------------------------------------
1072 ! rrtmg_sw COMBINED abs. coefficients for interval 28
1073 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1074 !
1075 ! Initial version: JJMorcrette, ECMWF, oct1999
1076 ! Revised: MJIacono, AER, jul2006
1077 ! Revised: MJIacono, AER, aug2008
1078 !-----------------------------------------------------------------
1079 !
1080 ! name type purpose
1081 ! ---- : ---- : ---------------------------------------------
1082 ! ka : real
1083 ! kb : real
1084 ! sfluxref: real
1085 !-----------------------------------------------------------------
1087 real(kind=rb) :: ka(9,5,13,ng28), absa(585,ng28)
1088 real(kind=rb) :: kb(5,5,13:59,ng28), absb(1175,ng28)
1089 real(kind=rb) :: sfluxref(ng28,5)
1091 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
1093 end module rrsw_kg28
1095 module rrsw_kg29
1097 use parkind ,only : im => kind_im, rb => kind_rb
1098 use parrrsw, only : ng29
1100 ! implicit none
1101 save
1103 !-----------------------------------------------------------------
1104 ! rrtmg_sw ORIGINAL abs. coefficients for interval 29
1105 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1106 !
1107 ! Initial version: JJMorcrette, ECMWF, oct1999
1108 ! Revised: MJIacono, AER, jul2006
1109 ! Revised: MJIacono, AER, aug2008
1110 !-----------------------------------------------------------------
1111 !
1112 ! name type purpose
1113 ! ---- : ---- : ---------------------------------------------
1114 ! kao : real
1115 ! kbo : real
1116 ! selfrefo: real
1117 ! forrefo : real
1118 !sfluxrefo: real
1119 ! absh2oo : real
1120 ! absco2o : real
1121 !-----------------------------------------------------------------
1123 integer(kind=im), parameter :: no29 = 16
1125 real(kind=rb) :: kao(5,13,no29)
1126 real(kind=rb) :: kbo(5,13:59,no29)
1127 real(kind=rb) :: selfrefo(10,no29), forrefo(4,no29)
1128 real(kind=rb) :: sfluxrefo(no29)
1129 real(kind=rb) :: absh2oo(no29), absco2o(no29)
1131 integer(kind=im) :: layreffr
1132 real(kind=rb) :: rayl
1134 !-----------------------------------------------------------------
1135 ! rrtmg_sw COMBINED abs. coefficients for interval 29
1136 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
1137 !
1138 ! Initial version: JJMorcrette, ECMWF, oct1999
1139 ! Revised: MJIacono, AER, jul2006
1140 ! Revised: MJIacono, AER, aug2008
1141 !-----------------------------------------------------------------
1142 !
1143 ! name type purpose
1144 ! ---- : ---- : ---------------------------------------------
1145 ! ka : real
1146 ! kb : real
1147 ! selfref : real
1148 ! forref : real
1149 ! sfluxref: real
1150 ! absh2o : real
1151 ! absco2 : real
1152 !-----------------------------------------------------------------
1154 real(kind=rb) :: ka(5,13,ng29), absa(65,ng29)
1155 real(kind=rb) :: kb(5,13:59,ng29), absb(235,ng29)
1156 real(kind=rb) :: selfref(10,ng29), forref(4,ng29)
1157 real(kind=rb) :: sfluxref(ng29)
1158 real(kind=rb) :: absh2o(ng29), absco2(ng29)
1160 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1162 end module rrsw_kg29
1164 module rrsw_ref
1166 use parkind, only : im => kind_im, rb => kind_rb
1168 ! implicit none
1169 save
1171 !------------------------------------------------------------------
1172 ! rrtmg_sw reference atmosphere
1173 ! Based on standard mid-latitude summer profile
1174 !
1175 ! Initial version: JJMorcrette, ECMWF, jul1998
1176 ! Revised: MJIacono, AER, jun2006
1177 ! Revised: MJIacono, AER, aug2008
1178 !------------------------------------------------------------------
1180 ! name type purpose
1181 ! ----- : ---- : ----------------------------------------------
1182 ! pref : real : Reference pressure levels
1183 ! preflog: real : Reference pressure levels, ln(pref)
1184 ! tref : real : Reference temperature levels for MLS profile
1185 !------------------------------------------------------------------
1187 real(kind=rb) , dimension(59) :: pref
1188 real(kind=rb) , dimension(59) :: preflog
1189 real(kind=rb) , dimension(59) :: tref
1191 end module rrsw_ref
1193 module rrsw_tbl
1195 use parkind, only : im => kind_im, rb => kind_rb
1197 ! implicit none
1198 save
1200 !------------------------------------------------------------------
1201 ! rrtmg_sw lookup table arrays
1203 ! Initial version: MJIacono, AER, may2007
1204 ! Revised: MJIacono, AER, aug2007
1205 ! Revised: MJIacono, AER, aug2008
1206 !------------------------------------------------------------------
1208 ! name type purpose
1209 ! ----- : ---- : ----------------------------------------------
1210 ! ntbl : integer: Lookup table dimension
1211 ! tblint : real : Lookup table conversion factor
1212 ! tau_tbl: real : Clear-sky optical depth
1213 ! exp_tbl: real : Exponential lookup table for transmittance
1214 ! od_lo : real : Value of tau below which expansion is used
1215 ! : in place of lookup table
1216 ! pade : real : Pade approximation constant
1217 ! bpade : real : Inverse of Pade constant
1218 !------------------------------------------------------------------
1220 integer(kind=im), parameter :: ntbl = 10000
1222 real(kind=rb), parameter :: tblint = 10000.0_rb
1224 real(kind=rb), parameter :: od_lo = 0.06_rb
1226 real(kind=rb) :: tau_tbl
1227 real(kind=rb) , dimension(0:ntbl) :: exp_tbl
1229 real(kind=rb), parameter :: pade = 0.278_rb
1230 real(kind=rb) :: bpade
1232 end module rrsw_tbl
1234 module rrsw_vsn
1236 ! implicit none
1237 save
1239 !------------------------------------------------------------------
1240 ! rrtmg_sw version information
1242 ! Initial version: JJMorcrette, ECMWF, jul1998
1243 ! Revised: MJIacono, AER, jul2006
1244 ! Revised: MJIacono, AER, aug2008
1245 !------------------------------------------------------------------
1247 ! name type purpose
1248 ! ----- : ---- : ----------------------------------------------
1249 !hnamrtm :character:
1250 !hnamini :character:
1251 !hnamcld :character:
1252 !hnamclc :character:
1253 !hnamrft :character:
1254 !hnamspv :character:
1255 !hnamspc :character:
1256 !hnamset :character:
1257 !hnamtau :character:
1258 !hnamvqd :character:
1259 !hnamatm :character:
1260 !hnamutl :character:
1261 !hnamext :character:
1262 !hnamkg :character:
1263 !
1264 ! hvrrtm :character:
1265 ! hvrini :character:
1266 ! hvrcld :character:
1267 ! hvrclc :character:
1268 ! hvrrft :character:
1269 ! hvrspv :character:
1270 ! hvrspc :character:
1271 ! hvrset :character:
1272 ! hvrtau :character:
1273 ! hvrvqd :character:
1274 ! hvratm :character:
1275 ! hvrutl :character:
1276 ! hvrext :character:
1277 ! hvrkg :character:
1278 !------------------------------------------------------------------
1280 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
1281 hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
1282 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
1283 hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
1285 character*18 hvrkg
1286 character*20 hnamkg
1288 end module rrsw_vsn
1290 module rrsw_wvn
1292 use parkind, only : im => kind_im, rb => kind_rb
1293 use parrrsw, only : nbndsw, mg, ngptsw, jpb1, jpb2
1295 ! implicit none
1296 save
1298 !------------------------------------------------------------------
1299 ! rrtmg_sw spectral information
1301 ! Initial version: JJMorcrette, ECMWF, jul1998
1302 ! Revised: MJIacono, AER, jul2006
1303 ! Revised: MJIacono, AER, aug2008
1304 !------------------------------------------------------------------
1306 ! name type purpose
1307 ! ----- : ---- : ----------------------------------------------
1308 ! ng : integer: Number of original g-intervals in each spectral band
1309 ! nspa : integer:
1310 ! nspb : integer:
1311 !wavenum1: real : Spectral band lower boundary in wavenumbers
1312 !wavenum2: real : Spectral band upper boundary in wavenumbers
1313 ! delwave: real : Spectral band width in wavenumbers
1314 !
1315 ! ngc : integer: The number of new g-intervals in each band
1316 ! ngs : integer: The cumulative sum of new g-intervals for each band
1317 ! ngm : integer: The index of each new g-interval relative to the
1318 ! original 16 g-intervals in each band
1319 ! ngn : integer: The number of original g-intervals that are
1320 ! combined to make each new g-intervals in each band
1321 ! ngb : integer: The band index for each new g-interval
1322 ! wt : real : RRTM weights for the original 16 g-intervals
1323 ! rwgt : real : Weights for combining original 16 g-intervals
1324 ! (224 total) into reduced set of g-intervals
1325 ! (112 total)
1326 !------------------------------------------------------------------
1328 integer(kind=im) :: ng(jpb1:jpb2)
1329 integer(kind=im) :: nspa(jpb1:jpb2)
1330 integer(kind=im) :: nspb(jpb1:jpb2)
1332 real(kind=rb) :: wavenum1(jpb1:jpb2)
1333 real(kind=rb) :: wavenum2(jpb1:jpb2)
1334 real(kind=rb) :: delwave(jpb1:jpb2)
1336 integer(kind=im) :: ngc(nbndsw)
1337 integer(kind=im) :: ngs(nbndsw)
1338 integer(kind=im) :: ngn(ngptsw)
1339 integer(kind=im) :: ngb(ngptsw)
1340 integer(kind=im) :: ngm(nbndsw*mg)
1342 real(kind=rb) :: wt(mg)
1343 real(kind=rb) :: rwgt(nbndsw*mg)
1345 end module rrsw_wvn
1347 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
1348 ! author: $Author: trn $
1349 ! revision: $Revision: 1.3 $
1350 ! created: $Date: 2009/04/16 19:54:22 $
1351 !
1352 module mcica_subcol_gen_sw
1354 ! --------------------------------------------------------------------------
1355 ! | |
1356 ! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). |
1357 ! | This software may be used, copied, or redistributed as long as it is |
1358 ! | not sold and this copyright notice is reproduced on each copy made. |
1359 ! | This model is provided as is without any express or implied warranties. |
1360 ! | (http://www.rtweb.aer.com/) |
1361 ! | |
1362 ! --------------------------------------------------------------------------
1364 ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
1365 ! Two options are possible:
1366 ! 1) Input cloud physical properties: cloud fraction, ice and liquid water
1367 ! paths, ice fraction, and particle sizes. Output will be stochastic
1368 ! arrays of these variables. (inflag = 1)
1369 ! 2) Input cloud optical properties directly: cloud optical depth, single
1370 ! scattering albedo and asymmetry parameter. Output will be stochastic
1371 ! arrays of these variables. (inflag = 0)
1373 ! --------- Modules ----------
1375 use parkind, only : im => kind_im, rb => kind_rb
1376 use parrrsw, only : nbndsw, ngptsw
1377 use rrsw_con, only: grav, pi
1378 use rrsw_wvn, only: ngb
1379 use rrsw_vsn
1381 implicit none
1383 ! public interfaces/functions/subroutines
1384 public :: mcica_subcol_sw, generate_stochastic_clouds_sw
1386 contains
1388 !------------------------------------------------------------------
1389 ! Public subroutines
1390 !------------------------------------------------------------------
1392 ! mji - Add height needed for exponential and exponential-random cloud overlap methods
1393 ! (icld=4 and 5, respectively) along with idcor, juldat and lat used to specify
1394 ! the decorrelation length for these methods
1395 subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
1396 cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, ssac, asmc, fsfc, &
1397 hgt, idcor, juldat, lat, &
1398 cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
1399 taucmcl, ssacmcl, asmcmcl, fsfcmcl)
1401 ! ----- Input -----
1402 ! Control
1403 integer(kind=im), intent(in) :: iplon ! column/longitude dimension
1404 integer(kind=im), intent(in) :: ncol ! number of columns
1405 integer(kind=im), intent(in) :: nlay ! number of model layers
1406 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
1407 integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times,
1408 ! permute the seed between each call;
1409 ! between calls for LW and SW, recommended
1410 ! permuteseed differs by 'ngpt'
1411 integer(kind=im), intent(inout) :: irng ! flag for random number generator
1412 ! 0 = kissvec
1413 ! 1 = Mersenne Twister
1415 ! Atmosphere
1416 real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb)
1417 ! Dimensions: (ncol,nlay)
1418 ! mji - Add height
1419 real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
1420 ! Dimensions: (ncol,nlay)
1421 ! Atmosphere/clouds - cldprop
1422 real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction
1423 ! Dimensions: (ncol,nlay)
1424 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
1425 ! Dimensions: (nbndsw,ncol,nlay)
1426 real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled)
1427 ! Dimensions: (nbndsw,ncol,nlay)
1428 real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled)
1429 ! Dimensions: (nbndsw,ncol,nlay)
1430 real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled)
1431 ! Dimensions: (nbndsw,ncol,nlay)
1432 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
1433 ! Dimensions: (ncol,nlay)
1434 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
1435 ! Dimensions: (ncol,nlay)
1436 real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path
1437 ! Dimensions: (ncol,nlay)
1438 real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size
1439 ! Dimensions: (ncol,nlay)
1440 real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size
1441 ! Dimensions: (ncol,nlay)
1442 real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size
1443 ! Dimensions: (ncol,nlay)
1444 integer(kind=im), intent(in) :: idcor ! Decorrelation length type
1445 integer(kind=im), intent(in) :: juldat ! Julian date (day of year, 1-365)
1446 real(kind=rb), intent(in) :: lat ! latitude (degrees, -90 to 90)
1448 ! ----- Output -----
1449 ! Atmosphere/clouds - cldprmc [mcica]
1450 real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
1451 ! Dimensions: (ngptsw,ncol,nlay)
1452 real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
1453 ! Dimensions: (ngptsw,ncol,nlay)
1454 real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
1455 ! Dimensions: (ngptsw,ncol,nlay)
1456 real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica]
1457 ! Dimensions: (ngptsw,ncol,nlay)
1458 real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns)
1459 ! Dimensions: (ncol,nlay)
1460 real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns)
1461 ! Dimensions: (ncol,nlay)
1462 real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns)
1463 ! Dimensions: (ncol,nlay)
1464 real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
1465 ! Dimensions: (ngptsw,ncol,nlay)
1466 real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica]
1467 ! Dimensions: (ngptsw,ncol,nlay)
1468 real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica]
1469 ! Dimensions: (ngptsw,ncol,nlay)
1470 real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica]
1471 ! Dimensions: (ngptsw,ncol,nlay)
1473 ! ----- Local -----
1475 ! Stochastic cloud generator variables [mcica]
1476 integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals)
1477 integer(kind=im) :: ilev ! loop index
1479 real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa)
1480 ! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa)
1481 ! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity)
1482 ! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity)
1484 ! MJI - For latitude dependent decorrelation length
1485 real(kind=rb), parameter :: am1 = 1.4315_rb
1486 real(kind=rb), parameter :: am2 = 2.1219_rb
1487 real(kind=rb), parameter :: am4 = -25.584_rb
1488 real(kind=rb), parameter :: amr = 7._rb
1489 real(kind=rb) :: am3
1490 real(kind=rb) :: decorr_len(ncol) ! decorrelation length (meters)
1491 real(kind=rb), parameter :: Zo_default = 2500._rb ! default constant decorrelation length (m)
1493 ! Return if clear sky
1494 if (icld.eq.0) return
1496 ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns
1499 ! Pass particle sizes to new arrays, no subcolumns for these properties yet
1500 ! Convert pressures from mb to Pa
1502 reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
1503 relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
1504 resnmcl(:ncol,:nlay) = res(:ncol,:nlay)
1505 pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
1507 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components
1509 ! cwp = (q * pdel * 1000.) / gravit)
1510 ! = (kg/kg * kg m-1 s-2 *1000.) / m s-2
1511 ! = (g m-2)
1512 !
1513 ! q = (cwp * gravit) / (pdel *1000.)
1514 ! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
1515 ! = kg/kg
1517 ! do ilev = 1, nlay
1518 ! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
1519 ! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
1520 ! enddo
1522 ! MJI - Latitude and day of year dependent decorrelation length
1523 if (idcor .eq. 1) then
1524 ! Derive decorrelation length based on day of year and latitude (from NASA GMAO method)
1525 ! Result is in meters
1526 if (juldat .gt. 181) then
1527 am3 = -4._rb * amr / 365._rb * (juldat-272)
1528 else
1529 am3 = 4._rb * amr / 365._rb * (juldat-91)
1530 endif
1531 ! Latitude in radians, decorrelation length in meters
1532 ! decorr_len(:) = ( am1 + am2 * exp(-(lat*180._rb/pi - am3)**2 / (am4*am4)) ) * 1.e3_rb
1533 ! Latitude in degrees, decorrelation length in meters
1534 decorr_len(:) = ( am1 + am2 * exp(-(lat - am3)**2 / (am4*am4)) ) * 1.e3_rb
1535 else
1536 ! Spatially and temporally constant decorrelation length
1537 decorr_len(:) = Zo_default
1538 endif
1540 ! Generate the stochastic subcolumns of cloud optical properties for the shortwave;
1541 call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, cldfrac, clwp, ciwp, cswp, &
1542 tauc, ssac, asmc, fsfc, &
1543 hgt, decorr_len, &
1544 cldfmcl, clwpmcl, ciwpmcl, cswpmcl, &
1545 taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed)
1547 end subroutine mcica_subcol_sw
1550 !-------------------------------------------------------------------------------------------------
1551 subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, cswp, &
1552 tauc, ssac, asmc, fsfc, &
1553 hgt, decorr_len, &
1554 cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, &
1555 tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed)
1556 !-------------------------------------------------------------------------------------------------
1558 !----------------------------------------------------------------------------------------------------------------
1559 ! ---------------------
1560 ! Contact: Cecile Hannay (hannay@ucar.edu)
1561 !
1562 ! Original code: Based on Raisanen et al., QJRMS, 2004.
1563 !
1564 ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
1565 ! random number generator, which can be changed to the optional kissvec random number generator
1566 ! with flag 'irng'. Some extra functionality has been commented or removed.
1567 ! Michael J. Iacono, AER, Inc., February 2007
1568 !
1569 ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
1570 ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
1571 ! and uniform cloud liquid and cloud ice concentration.
1572 ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
1573 ! and obeys an overlap assumption in the vertical.
1574 !
1575 ! Overlap assumption:
1576 ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
1577 ! The default option is maximum-random (option 3)
1578 ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
1579 ! This is set with the variable "overlap"
1580 !mji - Exponential overlap option (overlap=4) has been deactivated in this version
1581 ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
1582 !
1583 ! Seed:
1584 ! If the stochastic cloud generator is called several times during the same timestep,
1585 ! one should change the seed between the call to insure that the subcolumns are different.
1586 ! This is done by changing the argument 'changeSeed'
1587 ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
1588 ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
1589 !
1590 ! PDF assumption:
1591 ! We can use arbitrary complicated PDFS.
1592 ! In the present version, we produce homogeneuous clouds (the simplest case).
1593 ! Future developments include using the PDF scheme of Ben Johnson.
1594 !
1595 ! History file:
1596 ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
1597 ! nsubcol = number of subcolumns
1598 ! overlap = overlap type (1-3)
1599 ! Zo = length scale
1600 ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
1601 ! CLDLIQ_S = mean of the subcolumn cloud water
1602 ! CLDICE_S = mean of the subcolumn cloud ice
1603 !
1604 ! Note:
1605 ! Here: we force that the cloud condensate to be consistent with the cloud fraction
1606 ! i.e we only have cloud condensate when the cell is cloudy.
1607 ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
1608 ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
1609 ! without cloud condensate or the opposite).
1610 !---------------------------------------------------------------------------------------------------------------
1612 use mcica_random_numbers
1613 ! The Mersenne Twister random number engine
1614 use MersenneTwister, only: randomNumberSequence, &
1615 new_RandomNumberSequence, getRandomReal
1617 type(randomNumberSequence) :: randomNumbers
1619 ! -- Arguments
1621 integer(kind=im), intent(in) :: ncol ! number of layers
1622 integer(kind=im), intent(in) :: nlay ! number of layers
1623 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
1624 integer(kind=im), intent(inout) :: irng ! flag for random number generator
1625 ! 0 = kissvec
1626 ! 1 = Mersenne Twister
1627 integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
1628 integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed
1630 ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
1631 real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa)
1632 ! Dimensions: (ncol,nlay)
1633 real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
1634 ! Dimensions: (ncol,nlay)
1635 real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction
1636 ! Dimensions: (ncol,nlay)
1637 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2)
1638 ! Dimensions: (ncol,nlay)
1639 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2)
1640 ! Dimensions: (ncol,nlay)
1641 real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2)
1642 ! Dimensions: (ncol,nlay)
1643 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled)
1644 ! Dimensions: (nbndsw,ncol,nlay)
1645 real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled)
1646 ! Dimensions: (nbndsw,ncol,nlay)
1647 real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled)
1648 ! Dimensions: (nbndsw,ncol,nlay)
1649 real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled)
1650 ! Dimensions: (nbndsw,ncol,nlay)
1651 real(kind=rb), intent(in) :: decorr_len(:) ! decorrelation length (meters)
1652 ! Dimensions: (ncol)
1654 real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
1655 ! Dimensions: (ngptsw,ncol,nlay)
1656 real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
1657 ! Dimensions: (ngptsw,ncol,nlay)
1658 real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
1659 ! Dimensions: (ngptsw,ncol,nlay)
1660 real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
1661 ! Dimensions: (ngptsw,ncol,nlay)
1662 real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
1663 ! Dimensions: (ngptsw,ncol,nlay)
1664 real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
1665 ! Dimensions: (ngptsw,ncol,nlay)
1666 real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter
1667 ! Dimensions: (ngptsw,ncol,nlay)
1668 real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction
1669 ! Dimensions: (ngptsw,ncol,nlay)
1671 ! -- Local variables
1672 real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction
1673 ! Dimensions: (ncol,nlay)
1675 ! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
1676 ! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction
1677 ! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water
1678 ! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice
1679 ! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth
1680 ! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo
1681 ! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter
1682 ! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction
1684 ! Set overlap
1685 integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random,
1686 ! 3 = maximum overlap, 4 = exponential,
1687 ! 5 = exponential-random
1688 real(kind=rb) :: Zo_inv(ncol) ! inverse of decorrelation length scale (m)
1689 real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter
1691 ! Constants (min value for cloud fraction and cloud water and ice)
1692 real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
1693 ! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used)
1695 ! Variables related to random number and seed
1696 real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers
1697 integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number
1698 real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec)
1699 integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister)
1700 real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister)
1702 ! Flag to identify cloud fraction in subcolumns
1703 logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy
1705 ! Indices
1706 integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices
1708 !------------------------------------------------------------------------------------------
1710 ! Check that irng is in bounds; if not, set to default
1711 if (irng .ne. 0) irng = 1
1713 ! Pass input cloud overlap setting to local variable
1714 overlap = icld
1715 Zo_inv(:) = 1._rb / decorr_len(:)
1717 ! Ensure that cloud fractions are in bounds
1718 do ilev = 1, nlay
1719 do i = 1, ncol
1720 cldf(i,ilev) = cld(i,ilev)
1721 if (cldf(i,ilev) < cldmin) then
1722 cldf(i,ilev) = 0._rb
1723 endif
1724 enddo
1725 enddo
1727 ! ----- Create seed --------
1729 ! Advance randum number generator by changeseed values
1730 if (irng.eq.0) then
1731 ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
1732 ! Must use pmid from bottom four layers.
1733 do i=1,ncol
1734 if (pmid(i,1).lt.pmid(i,2)) then
1735 stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
1736 endif
1737 seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im
1738 seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im
1739 seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im
1740 seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im
1741 enddo
1742 do i=1,changeSeed
1743 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1744 enddo
1745 elseif (irng.eq.1) then
1746 randomNumbers = new_RandomNumberSequence(seed = changeSeed)
1747 endif
1750 ! ------ Apply overlap assumption --------
1752 ! generate the random numbers
1754 select case (overlap)
1756 case(1)
1757 ! Random overlap
1758 ! i) pick a random value at every level
1760 if (irng.eq.0) then
1761 do isubcol = 1,nsubcol
1762 do ilev = 1,nlay
1763 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1764 CDF(isubcol,:,ilev) = rand_num
1765 enddo
1766 enddo
1767 elseif (irng.eq.1) then
1768 do isubcol = 1, nsubcol
1769 do i = 1, ncol
1770 do ilev = 1, nlay
1771 rand_num_mt = getRandomReal(randomNumbers)
1772 CDF(isubcol,i,ilev) = rand_num_mt
1773 enddo
1774 enddo
1775 enddo
1776 endif
1778 case(2)
1779 ! Maximum-Random overlap
1780 ! i) pick a random number for top layer.
1781 ! ii) walk down the column:
1782 ! - if the layer above is cloudy, we use the same random number than in the layer above
1783 ! - if the layer above is clear, we use a new random number
1785 if (irng.eq.0) then
1786 do isubcol = 1,nsubcol
1787 do ilev = 1,nlay
1788 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1789 CDF(isubcol,:,ilev) = rand_num
1790 enddo
1791 enddo
1792 elseif (irng.eq.1) then
1793 do isubcol = 1, nsubcol
1794 do i = 1, ncol
1795 do ilev = 1, nlay
1796 rand_num_mt = getRandomReal(randomNumbers)
1797 CDF(isubcol,i,ilev) = rand_num_mt
1798 enddo
1799 enddo
1800 enddo
1801 endif
1803 do ilev = 2,nlay
1804 do i = 1, ncol
1805 do isubcol = 1, nsubcol
1806 if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
1807 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1)
1808 else
1809 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1))
1810 endif
1811 enddo
1812 enddo
1813 enddo
1815 case(3)
1816 ! Maximum overlap
1817 ! i) pick same random numebr at every level
1819 if (irng.eq.0) then
1820 do isubcol = 1,nsubcol
1821 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1822 do ilev = 1,nlay
1823 CDF(isubcol,:,ilev) = rand_num
1824 enddo
1825 enddo
1826 elseif (irng.eq.1) then
1827 do isubcol = 1, nsubcol
1828 do i = 1, ncol
1829 rand_num_mt = getRandomReal(randomNumbers)
1830 do ilev = 1, nlay
1831 CDF(isubcol,i,ilev) = rand_num_mt
1832 enddo
1833 enddo
1834 enddo
1835 endif
1837 ! mji - Activate exponential cloud overlap option
1838 case(4)
1839 ! Exponential overlap: transition from maximum to random cloud overlap increases
1840 ! exponentially with layer thickness and distance through layers
1841 ! j=1 RAN(j)=RND1
1842 ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
1843 ! RAN(j) = RND2
1844 ! alpha is obtained from the equation
1845 ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale
1847 ! compute alpha
1848 do i = 1, ncol
1849 alpha(i, 1) = 0._rb
1850 do ilev = 2,nlay
1851 alpha(i, ilev) = exp( -(hgt(i,ilev) - hgt(i,ilev-1)) * Zo_inv(i))
1852 enddo
1853 enddo
1855 ! generate 2 streams of random numbers
1856 if (irng.eq.0) then
1857 do isubcol = 1,nsubcol
1858 do ilev = 1,nlay
1859 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1860 CDF(isubcol, :, ilev) = rand_num
1861 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1862 CDF2(isubcol, :, ilev) = rand_num
1863 enddo
1864 enddo
1865 elseif (irng.eq.1) then
1866 do isubcol = 1, nsubcol
1867 do i = 1, ncol
1868 do ilev = 1, nlay
1869 rand_num_mt = getRandomReal(randomNumbers)
1870 CDF(isubcol,i,ilev) = rand_num_mt
1871 rand_num_mt = getRandomReal(randomNumbers)
1872 CDF2(isubcol,i,ilev) = rand_num_mt
1873 enddo
1874 enddo
1875 enddo
1876 endif
1878 ! generate random numbers
1879 do ilev = 2,nlay
1880 where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
1881 CDF(:,:,ilev) = CDF(:,:,ilev-1)
1882 end where
1883 end do
1885 ! mji - Exponential-random cloud overlap option
1886 case(5)
1887 ! Exponential_Random overlap: transition from maximum to random cloud overlap increases
1888 ! exponentially with layer thickness and with distance through adjacent cloudy layers.
1889 ! Non-adjacent blocks of clouds are treated randomly, and each block begins a new
1890 ! exponential transition from maximum to random.
1891 !
1892 ! compute alpha: bottom to top
1893 ! - set alpha to 0 in bottom layer (no layer below for correlation)
1894 do i = 1, ncol
1895 alpha(i, 1) = 0._rb
1896 do ilev = 2,nlay
1897 alpha(i, ilev) = exp( -(hgt(i,ilev) - hgt(i,ilev-1) ) * Zo_inv(i))
1898 ! Decorrelate layers when clear layer follows a cloudy layer to enforce
1899 ! random correlation between non-adjacent cloudy layers
1900 if (cldf(i,ilev) .eq. 0.0_rb .and. cldf(i,ilev-1) .gt. 0.0_rb) then
1901 alpha(i,ilev) = 0.0_rb
1902 endif
1903 end do
1904 end do
1906 ! generate 2 streams of random numbers
1907 ! CDF2 is used to select which sub-columns are vertically correlated relative to alpha
1908 ! CDF is used to select which sub-columns are treated as cloudy relative to cloud fraction
1909 if (irng.eq.0) then
1910 do isubcol = 1,nsubcol
1911 do ilev = 1,nlay
1912 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1913 CDF(isubcol, :, ilev) = rand_num
1914 call kissvec(seed1, seed2, seed3, seed4, rand_num)
1915 CDF2(isubcol, :, ilev) = rand_num
1916 end do
1917 end do
1918 elseif (irng.eq.1) then
1919 do isubcol = 1, nsubcol
1920 do i = 1, ncol
1921 do ilev = 1,nlay
1922 rand_num_mt = getRandomReal(randomNumbers)
1923 CDF(isubcol,i,ilev) = rand_num_mt
1924 rand_num_mt = getRandomReal(randomNumbers)
1925 CDF2(isubcol,i,ilev) = rand_num_mt
1926 enddo
1927 enddo
1928 enddo
1929 endif
1930 ! generate vertical correlations in random number arrays - bottom to top
1931 do ilev = 2,nlay
1932 where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
1933 CDF(:,:,ilev) = CDF(:,:,ilev-1)
1934 end where
1935 end do
1937 end select
1940 ! -- generate subcolumns for homogeneous clouds -----
1941 do ilev = 1, nlay
1942 isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
1943 enddo
1945 ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
1946 ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
1947 ! where there is a cloud, define the subcolumn cloud properties,
1948 ! otherwise set these to zero
1950 ngbm = ngb(1) - 1
1951 do ilev = 1,nlay
1952 do i = 1, ncol
1953 do isubcol = 1, nsubcol
1954 if ( iscloudy(isubcol,i,ilev) ) then
1955 cld_stoch(isubcol,i,ilev) = 1._rb
1956 clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
1957 ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
1958 cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
1959 n = ngb(isubcol) - ngbm
1960 tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
1961 ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
1962 asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
1963 fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev)
1964 else
1965 cld_stoch(isubcol,i,ilev) = 0._rb
1966 clwp_stoch(isubcol,i,ilev) = 0._rb
1967 ciwp_stoch(isubcol,i,ilev) = 0._rb
1968 cswp_stoch(isubcol,i,ilev) = 0._rb
1969 tauc_stoch(isubcol,i,ilev) = 0._rb
1970 ssac_stoch(isubcol,i,ilev) = 1._rb
1971 asmc_stoch(isubcol,i,ilev) = 0._rb
1972 fsfc_stoch(isubcol,i,ilev) = 0._rb
1973 endif
1974 enddo
1975 enddo
1976 enddo
1978 ! -- compute the means of the subcolumns ---
1979 ! mean_cld_stoch(:,:) = 0._rb
1980 ! mean_clwp_stoch(:,:) = 0._rb
1981 ! mean_ciwp_stoch(:,:) = 0._rb
1982 ! mean_tauc_stoch(:,:) = 0._rb
1983 ! mean_ssac_stoch(:,:) = 0._rb
1984 ! mean_asmc_stoch(:,:) = 0._rb
1985 ! mean_fsfc_stoch(:,:) = 0._rb
1986 ! do i = 1, nsubcol
1987 ! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:)
1988 ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:)
1989 ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:)
1990 ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:)
1991 ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:)
1992 ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:)
1993 ! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:)
1994 ! end do
1995 ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
1996 ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
1997 ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
1998 ! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
1999 ! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
2000 ! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
2001 ! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol
2003 end subroutine generate_stochastic_clouds_sw
2006 !--------------------------------------------------------------------------------------------------
2007 subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
2008 !--------------------------------------------------------------------------------------------------
2010 ! public domain code
2011 ! made available from http://www.fortran.com/
2012 ! downloaded by pjr on 03/16/04 for NCAR CAM
2013 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
2015 ! The KISS (Keep It Simple Stupid) random number generator. Combines:
2016 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
2017 ! (2) A 3-shift shift-register generator, period 2^32-1,
2018 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
2019 ! Overall period>2^123;
2020 !
2021 real(kind=rb), dimension(:), intent(inout) :: ran_arr
2022 integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
2023 integer(kind=im) :: i,sz,kiss
2024 integer(kind=im) :: m, k, n
2026 ! inline function
2027 m(k, n) = ieor (k, ishft (k, n) )
2029 sz = size(ran_arr)
2030 do i = 1, sz
2031 seed1(i) = 69069_im * seed1(i) + 1327217885_im
2032 seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
2033 seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
2034 seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
2035 kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
2036 ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
2037 end do
2039 end subroutine kissvec
2041 end module mcica_subcol_gen_sw
2043 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
2044 ! author: $Author: trn $
2045 ! revision: $Revision: 1.3 $
2046 ! created: $Date: 2009/04/16 19:54:22 $
2048 module rrtmg_sw_cldprmc
2050 ! --------------------------------------------------------------------------
2051 ! | |
2052 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2053 ! | This software may be used, copied, or redistributed as long as it is |
2054 ! | not sold and this copyright notice is reproduced on each copy made. |
2055 ! | This model is provided as is without any express or implied warranties. |
2056 ! | (http://www.rtweb.aer.com/) |
2057 ! | |
2058 ! --------------------------------------------------------------------------
2060 ! ------- Modules -------
2062 use parkind, only : im => kind_im, rb => kind_rb
2063 use parrrsw, only : ngptsw, jpband, jpb1, jpb2
2064 use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
2065 extice2, ssaice2, asyice2, &
2066 extice3, ssaice3, asyice3, fdlice3, &
2067 abari, bbari, cbari, dbari, ebari, fbari
2068 use rrsw_wvn, only : wavenum1, wavenum2, ngb
2069 use rrsw_vsn, only : hvrclc, hnamclc
2071 implicit none
2073 contains
2075 ! ----------------------------------------------------------------------------
2076 subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
2077 ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
2078 taormc, taucmc, ssacmc, asmcmc, fsfcmc)
2079 ! ----------------------------------------------------------------------------
2081 ! Purpose: Compute the cloud optical properties for each cloudy layer
2082 ! and g-point interval for use by the McICA method.
2083 ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available;
2084 ! (Hu & Stamnes, Key, and Fu) are implemented.
2086 ! ------- Input -------
2088 integer(kind=im), intent(in) :: nlayers ! total number of layers
2089 integer(kind=im), intent(in) :: inflag ! see definitions
2090 integer(kind=im), intent(in) :: iceflag ! see definitions
2091 integer(kind=im), intent(in) :: liqflag ! see definitions
2093 real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica]
2094 ! Dimensions: (ngptsw,nlayers)
2095 real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica]
2096 ! Dimensions: (ngptsw,nlayers)
2097 real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica]
2098 ! Dimensions: (ngptsw,nlayers)
2099 real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow water path [mcica]
2100 ! Dimensions: (ngptsw,nlayers)
2101 real(kind=rb), intent(in) :: resnmc(:) ! cloud snow particle effective radius (microns)
2102 ! Dimensions: (nlayers)
2103 real(kind=rb), intent(in) :: relqmc(:) ! cloud liquid particle effective radius (microns)
2104 ! Dimensions: (nlayers)
2105 real(kind=rb), intent(in) :: reicmc(:) ! cloud ice particle effective radius (microns)
2106 ! Dimensions: (nlayers)
2107 ! specific definition of reicmc depends on setting of iceflag:
2108 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
2109 ! r_ec range is limited to 13.0 to 130.0 microns
2110 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
2111 ! r_k range is limited to 5.0 to 131.0 microns
2112 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
2113 ! dge range is limited to 5.0 to 140.0 microns
2114 ! [dge = 1.0315 * r_ec]
2115 real(kind=rb), intent(in) :: fsfcmc(:,:) ! cloud forward scattering fraction
2116 ! Dimensions: (ngptsw,nlayers)
2118 ! ------- Output -------
2120 real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth (delta scaled)
2121 ! Dimensions: (ngptsw,nlayers)
2122 real(kind=rb), intent(inout) :: ssacmc(:,:) ! single scattering albedo (delta scaled)
2123 ! Dimensions: (ngptsw,nlayers)
2124 real(kind=rb), intent(inout) :: asmcmc(:,:) ! asymmetry parameter (delta scaled)
2125 ! Dimensions: (ngptsw,nlayers)
2126 real(kind=rb), intent(out) :: taormc(:,:) ! cloud optical depth (non-delta scaled)
2127 ! Dimensions: (ngptsw,nlayers)
2129 ! ------- Local -------
2131 ! integer(kind=im) :: ncbands
2132 integer(kind=im) :: ib, lay, istr, index, icx, ig
2134 real(kind=rb), parameter :: eps = 1.e-06_rb ! epsilon
2135 real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities
2136 real(kind=rb) :: cwp ! total cloud water path
2137 real(kind=rb) :: radliq ! cloud liquid droplet radius (microns)
2138 real(kind=rb) :: radice ! cloud ice effective size (microns)
2139 real(kind=rb) :: radsno ! cloud snow effective size (microns)
2140 real(kind=rb) :: factor
2141 real(kind=rb) :: fint
2143 real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
2144 real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
2145 real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno
2147 real(kind=rb) :: fdelta(ngptsw)
2148 real(kind=rb) :: extcoice(ngptsw), gice(ngptsw)
2149 real(kind=rb) :: ssacoice(ngptsw), forwice(ngptsw)
2150 real(kind=rb) :: extcoliq(ngptsw), gliq(ngptsw)
2151 real(kind=rb) :: ssacoliq(ngptsw), forwliq(ngptsw)
2152 real(kind=rb) :: extcosno(ngptsw), gsno(ngptsw)
2153 real(kind=rb) :: ssacosno(ngptsw), forwsno(ngptsw)
2155 CHARACTER*80 errmess
2157 ! Initialize
2159 !jm not thread safe hvrclc = '$Revision: 1.3 $'
2161 ! Some of these initializations are done elsewhere
2162 do lay = 1, nlayers
2163 do ig = 1, ngptsw
2164 taormc(ig,lay) = taucmc(ig,lay)
2165 ! taucmc(ig,lay) = 0.0_rb
2166 ! ssacmc(ig,lay) = 1.0_rb
2167 ! asmcmc(ig,lay) = 0.0_rb
2168 enddo
2169 enddo
2171 ! Main layer loop
2172 do lay = 1, nlayers
2174 ! Main g-point interval loop
2175 do ig = 1, ngptsw
2176 cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
2178 if (cldfmc(ig,lay) .ge. cldmin .and. &
2179 (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
2181 ! (inflag=0): Cloud optical properties input directly
2182 if (inflag .eq. 0) then
2183 ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled;
2184 ! Apply delta-M scaling here (using Henyey-Greenstein approximation)
2185 taucldorig_a = taucmc(ig,lay)
2186 ffp = fsfcmc(ig,lay)
2187 ffp1 = 1.0_rb - ffp
2188 ffpssa = 1.0_rb - ffp * ssacmc(ig,lay)
2189 ssacloud_a = ffp1 * ssacmc(ig,lay) / ffpssa
2190 taucloud_a = ffpssa * taucldorig_a
2192 taormc(ig,lay) = taucldorig_a
2193 ssacmc(ig,lay) = ssacloud_a
2194 taucmc(ig,lay) = taucloud_a
2195 asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1)
2197 elseif (inflag .eq. 1) then
2198 stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
2200 ! (inflag=2): Separate treatement of ice clouds and water clouds.
2201 elseif (inflag .ge. 2) then
2202 radice = reicmc(lay)
2204 ! Calculation of absorption coefficients due to ice clouds.
2205 if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then
2206 extcoice(ig) = 0.0_rb
2207 ssacoice(ig) = 0.0_rb
2208 gice(ig) = 0.0_rb
2209 forwice(ig) = 0.0_rb
2211 extcosno(ig) = 0.0_rb
2212 ssacosno(ig) = 0.0_rb
2213 gsno(ig) = 0.0_rb
2214 forwsno(ig) = 0.0_rb
2216 ! (iceflag = 1):
2217 ! Note: This option uses Ebert and Curry approach for all particle sizes similar to
2218 ! CAM3 implementation, though this is somewhat unjustified for large ice particles
2219 elseif (iceflag .eq. 1) then
2220 ib = ngb(ig)
2221 if (wavenum2(ib) .gt. 1.43e04_rb) then
2222 icx = 1
2223 elseif (wavenum2(ib) .gt. 7.7e03_rb) then
2224 icx = 2
2225 elseif (wavenum2(ib) .gt. 5.3e03_rb) then
2226 icx = 3
2227 elseif (wavenum2(ib) .gt. 4.0e03_rb) then
2228 icx = 4
2229 elseif (wavenum2(ib) .ge. 2.5e03_rb) then
2230 icx = 5
2231 endif
2232 extcoice(ig) = (abari(icx) + bbari(icx)/radice)
2233 ssacoice(ig) = 1._rb - cbari(icx) - dbari(icx) * radice
2234 gice(ig) = ebari(icx) + fbari(icx) * radice
2235 ! Check to ensure upper limit of gice is within physical limits for large particles
2236 if (gice(ig).ge.1._rb) gice(ig) = 1._rb - eps
2237 forwice(ig) = gice(ig)*gice(ig)
2238 ! Check to ensure all calculated quantities are within physical limits.
2239 if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
2240 if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
2241 if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
2242 if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
2243 if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
2245 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
2247 elseif (iceflag .eq. 2) then
2248 if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
2249 factor = (radice - 2._rb)/3._rb
2250 index = int(factor)
2251 if (index .eq. 43) index = 42
2252 fint = factor - float(index)
2253 ib = ngb(ig)
2254 extcoice(ig) = extice2(index,ib) + fint * &
2255 (extice2(index+1,ib) - extice2(index,ib))
2256 ssacoice(ig) = ssaice2(index,ib) + fint * &
2257 (ssaice2(index+1,ib) - ssaice2(index,ib))
2258 gice(ig) = asyice2(index,ib) + fint * &
2259 (asyice2(index+1,ib) - asyice2(index,ib))
2260 forwice(ig) = gice(ig)*gice(ig)
2261 ! Check to ensure all calculated quantities are within physical limits.
2262 if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
2263 if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
2264 if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
2265 if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
2266 if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
2268 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
2270 elseif (iceflag .ge. 3) then
2271 if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then
2272 write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
2273 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
2274 ,ig, lay, ciwpmc(ig,lay), radice
2275 call wrf_error_fatal(errmess)
2276 end if
2277 factor = (radice - 2._rb)/3._rb
2278 index = int(factor)
2279 if (index .eq. 46) index = 45
2280 fint = factor - float(index)
2281 ib = ngb(ig)
2282 extcoice(ig) = extice3(index,ib) + fint * &
2283 (extice3(index+1,ib) - extice3(index,ib))
2284 ssacoice(ig) = ssaice3(index,ib) + fint * &
2285 (ssaice3(index+1,ib) - ssaice3(index,ib))
2286 gice(ig) = asyice3(index,ib) + fint * &
2287 (asyice3(index+1,ib) - asyice3(index,ib))
2288 fdelta(ig) = fdlice3(index,ib) + fint * &
2289 (fdlice3(index+1,ib) - fdlice3(index,ib))
2290 if (fdelta(ig) .lt. 0.0_rb) then
2291 write(errmess, *) 'FDELTA LESS THAN 0.0'
2292 call wrf_error_fatal(errmess)
2293 end if
2294 if (fdelta(ig) .gt. 1.0_rb) then
2295 write(errmess, *) 'FDELTA GT THAN 1.0'
2296 call wrf_error_fatal(errmess)
2297 end if
2298 forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig)
2299 ! See Fu 1996 p. 2067
2300 if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
2301 ! Check to ensure all calculated quantities are within physical limits.
2302 if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
2303 if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
2304 if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
2305 if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
2306 if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
2308 endif
2310 !!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2311 !!!! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
2312 !!!! Although far from perfect, the snow will utilize the
2313 !!!! same lookup table constants as cloud ice. Changes
2314 !!!! to those constants for larger particle snow would be
2315 !!!! an improvement.
2316 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2318 if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then
2319 radsno = resnmc(lay)
2320 if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then
2321 write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
2322 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
2323 ,ig, lay, cswpmc(ig,lay), radsno
2324 call wrf_error_fatal(errmess)
2325 end if
2326 factor = (radsno - 2._rb)/3._rb
2327 index = int(factor)
2328 if (index .eq. 46) index = 45
2329 fint = factor - float(index)
2330 ib = ngb(ig)
2331 extcosno(ig) = extice3(index,ib) + fint * &
2332 (extice3(index+1,ib) - extice3(index,ib))
2333 ssacosno(ig) = ssaice3(index,ib) + fint * &
2334 (ssaice3(index+1,ib) - ssaice3(index,ib))
2335 gsno(ig) = asyice3(index,ib) + fint * &
2336 (asyice3(index+1,ib) - asyice3(index,ib))
2337 fdelta(ig) = fdlice3(index,ib) + fint * &
2338 (fdlice3(index+1,ib) - fdlice3(index,ib))
2339 if (fdelta(ig) .lt. 0.0_rb) then
2340 write(errmess, *) 'FDELTA LESS THAN 0.0'
2341 call wrf_error_fatal(errmess)
2342 end if
2343 if (fdelta(ig) .gt. 1.0_rb) then
2344 write(errmess, *) 'FDELTA GT THAN 1.0'
2345 call wrf_error_fatal(errmess)
2346 end if
2347 forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig)
2348 ! See Fu 1996 p. 2067
2349 if (forwsno(ig) .gt. gsno(ig)) forwsno(ig) = gsno(ig)
2350 ! Check to ensure all calculated quantities are within physical limits.
2351 if (extcosno(ig) .lt. 0.0_rb) then
2352 write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0'
2353 call wrf_error_fatal(errmess)
2354 end if
2355 if (ssacosno(ig) .gt. 1.0_rb) then
2356 write(errmess, *) 'SNOW SSA GRTR THAN 1.0'
2357 call wrf_error_fatal(errmess)
2358 end if
2359 if (ssacosno(ig) .lt. 0.0_rb) then
2360 write(errmess, *) 'SNOW SSA LESS THAN 0.0'
2361 call wrf_error_fatal(errmess)
2362 end if
2363 if (gsno(ig) .gt. 1.0_rb) then
2364 write(errmess, *) 'SNOW ASYM GRTR THAN 1.0'
2365 call wrf_error_fatal(errmess)
2366 end if
2367 if (gsno(ig) .lt. 0.0_rb) then
2368 write(errmess, *) 'SNOW ASYM LESS THAN 0.0'
2369 call wrf_error_fatal(errmess)
2370 end if
2371 else
2372 extcosno(ig) = 0.0_rb
2373 ssacosno(ig) = 0.0_rb
2374 gsno(ig) = 0.0_rb
2375 forwsno(ig) = 0.0_rb
2376 endif
2379 ! Calculation of absorption coefficients due to water clouds.
2380 if (clwpmc(ig,lay) .eq. 0.0_rb) then
2381 extcoliq(ig) = 0.0_rb
2382 ssacoliq(ig) = 0.0_rb
2383 gliq(ig) = 0.0_rb
2384 forwliq(ig) = 0.0_rb
2386 elseif (liqflag .eq. 1) then
2387 radliq = relqmc(lay)
2388 if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop &
2389 'liquid effective radius out of bounds'
2390 index = int(radliq - 1.5_rb)
2391 if (index .eq. 0) index = 1
2392 if (index .eq. 58) index = 57
2393 fint = radliq - 1.5_rb - float(index)
2394 ib = ngb(ig)
2395 extcoliq(ig) = extliq1(index,ib) + fint * &
2396 (extliq1(index+1,ib) - extliq1(index,ib))
2397 ssacoliq(ig) = ssaliq1(index,ib) + fint * &
2398 (ssaliq1(index+1,ib) - ssaliq1(index,ib))
2399 if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb) &
2400 ssacoliq(ig) = ssaliq1(index,ib)
2401 gliq(ig) = asyliq1(index,ib) + fint * &
2402 (asyliq1(index+1,ib) - asyliq1(index,ib))
2403 forwliq(ig) = gliq(ig)*gliq(ig)
2404 ! Check to ensure all calculated quantities are within physical limits.
2405 if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
2406 if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
2407 if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
2408 if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
2409 if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
2410 endif
2413 if (iceflag .lt. 5) then
2414 tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
2415 tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
2416 taormc(ig,lay) = tauliqorig + tauiceorig
2418 ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
2419 (1._rb - forwliq(ig) * ssacoliq(ig))
2420 tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
2421 ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
2422 (1._rb - forwice(ig) * ssacoice(ig))
2423 tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
2424 scatliq = ssaliq * tauliq
2425 scatice = ssaice * tauice
2426 scatsno = 0.0_rb
2427 taucmc(ig,lay) = tauliq + tauice
2428 else
2429 tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
2430 tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
2431 tausnoorig = cswpmc(ig,lay) * extcosno(ig)
2432 taormc(ig,lay) = tauliqorig + tauiceorig + tausnoorig
2434 ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
2435 (1._rb - forwliq(ig) * ssacoliq(ig))
2436 tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
2437 ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
2438 (1._rb - forwice(ig) * ssacoice(ig))
2439 tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
2440 ssasno = ssacosno(ig) * (1._rb - forwsno(ig)) / &
2441 (1._rb - forwsno(ig) * ssacosno(ig))
2442 tausno = (1._rb - forwsno(ig) * ssacosno(ig)) * tausnoorig
2443 scatliq = ssaliq * tauliq
2444 scatice = ssaice * tauice
2445 scatsno = ssasno * tausno
2446 taucmc(ig,lay) = tauliq + tauice + tausno
2447 endif
2449 ! Ensure non-zero taucmc and scatice
2450 if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
2451 if(scatice.eq.0.) scatice = cldmin
2452 if(scatsno.eq.0.) scatsno = cldmin
2454 if (iceflag .lt. 5) then
2455 ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay)
2456 else
2457 ssacmc(ig,lay) = (scatliq + scatice + scatsno) / taucmc(ig,lay)
2458 endif
2460 if (iceflag .eq. 3 .or. iceflag.eq.4) then
2461 ! In accordance with the 1996 Fu paper, equation A.3,
2462 ! the moments for ice were calculated depending on whether using spheres
2463 ! or hexagonal ice crystals.
2464 ! Set asymetry parameter to first moment (istr=1)
2465 istr = 1
2466 asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))* &
2467 (scatliq*(gliq(ig)**istr - forwliq(ig)) / &
2468 (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
2469 (1.0_rb - forwice(ig)))**istr)
2470 elseif (iceflag .eq. 5) then
2471 istr = 1
2472 asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno)) &
2473 * (scatliq*(gliq(ig)**istr - forwliq(ig))/(1.0_rb - forwliq(ig)) &
2474 + scatice * ((gice(ig)-forwice(ig))/(1.0_rb - forwice(ig))) &
2475 + scatsno * ((gsno(ig)-forwsno(ig))/(1.0_rb - forwsno(ig)))**istr)
2477 else
2478 ! This code is the standard method for delta-m scaling.
2479 ! Set asymetry parameter to first moment (istr=1)
2480 istr = 1
2481 asmcmc(ig,lay) = (scatliq * &
2482 (gliq(ig)**istr - forwliq(ig)) / &
2483 (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / &
2484 (1.0_rb - forwice(ig)))/(scatliq + scatice)
2485 endif
2487 endif
2489 endif
2491 ! End g-point interval loop
2492 enddo
2494 ! End layer loop
2495 enddo
2497 end subroutine cldprmc_sw
2499 end module rrtmg_sw_cldprmc
2501 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
2502 ! author: $Author: trn $
2503 ! revision: $Revision: 1.3 $
2504 ! created: $Date: 2009/04/16 19:54:22 $
2506 module rrtmg_sw_reftra
2508 ! --------------------------------------------------------------------------
2509 ! | |
2510 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2511 ! | This software may be used, copied, or redistributed as long as it is |
2512 ! | not sold and this copyright notice is reproduced on each copy made. |
2513 ! | This model is provided as is without any express or implied warranties. |
2514 ! | (http://www.rtweb.aer.com/) |
2515 ! | |
2516 ! --------------------------------------------------------------------------
2518 ! ------- Modules -------
2520 use parkind, only : im => kind_im, rb => kind_rb
2521 use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
2522 use rrsw_vsn, only : hvrrft, hnamrft
2524 implicit none
2526 contains
2528 ! --------------------------------------------------------------------
2529 subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, &
2530 pref, prefd, ptra, ptrad)
2531 ! --------------------------------------------------------------------
2533 ! Purpose: computes the reflectivity and transmissivity of a clear or
2534 ! cloudy layer using a choice of various approximations.
2535 !
2536 ! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
2537 !
2538 ! Description:
2539 ! explicit arguments :
2540 ! --------------------
2541 ! inputs
2542 ! ------
2543 ! lrtchk = .t. for all layers in clear profile
2544 ! lrtchk = .t. for cloudy layers in cloud profile
2545 ! = .f. for clear layers in cloud profile
2546 ! pgg = assymetry factor
2547 ! prmuz = cosine solar zenith angle
2548 ! ptau = optical thickness
2549 ! pw = single scattering albedo
2550 !
2551 ! outputs
2552 ! -------
2553 ! pref : collimated beam reflectivity
2554 ! prefd : diffuse beam reflectivity
2555 ! ptra : collimated beam transmissivity
2556 ! ptrad : diffuse beam transmissivity
2557 !
2558 !
2559 ! Method:
2560 ! -------
2561 ! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
2562 ! kmodts = 1 eddington (joseph et al., 1976)
2563 ! = 2 pifm (zdunkowski et al., 1980)
2564 ! = 3 discrete ordinates (liou, 1973)
2565 !
2566 !
2567 ! Modifications:
2568 ! --------------
2569 ! Original: J-JMorcrette, ECMWF, Feb 2003
2570 ! Revised for F90 reformatting: MJIacono, AER, Jul 2006
2571 ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
2572 ! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008
2573 !
2574 ! ------------------------------------------------------------------
2576 ! ------- Declarations ------
2578 ! ------- Input -------
2580 integer(kind=im), intent(in) :: nlayers
2582 logical, intent(in) :: lrtchk(:) ! Logical flag for reflectivity and
2583 ! and transmissivity calculation;
2584 ! Dimensions: (nlayers)
2586 real(kind=rb), intent(in) :: pgg(:) ! asymmetry parameter
2587 ! Dimensions: (nlayers)
2588 real(kind=rb), intent(in) :: ptau(:) ! optical depth
2589 ! Dimensions: (nlayers)
2590 real(kind=rb), intent(in) :: pw(:) ! single scattering albedo
2591 ! Dimensions: (nlayers)
2592 real(kind=rb), intent(in) :: prmuz ! cosine of solar zenith angle
2594 ! ------- Output -------
2596 real(kind=rb), intent(inout) :: pref(:) ! direct beam reflectivity
2597 ! Dimensions: (nlayers+1)
2598 real(kind=rb), intent(inout) :: prefd(:) ! diffuse beam reflectivity
2599 ! Dimensions: (nlayers+1)
2600 real(kind=rb), intent(inout) :: ptra(:) ! direct beam transmissivity
2601 ! Dimensions: (nlayers+1)
2602 real(kind=rb), intent(inout) :: ptrad(:) ! diffuse beam transmissivity
2603 ! Dimensions: (nlayers+1)
2605 ! ------- Local -------
2607 integer(kind=im) :: jk, jl, kmodts
2608 integer(kind=im) :: itind
2610 real(kind=rb) :: tblind
2611 real(kind=rb) :: za, za1, za2
2612 real(kind=rb) :: zbeta, zdend, zdenr, zdent
2613 real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
2614 real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
2615 real(kind=rb) :: zr1, zr2, zr3, zr4, zr5
2616 real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
2617 real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
2618 real(kind=rb) :: zw, zwcrit, zwo
2619 real(kind=rb) :: denom
2621 real(kind=rb), parameter :: eps = 1.e-08_rb
2623 ! ------------------------------------------------------------------
2625 ! Initialize
2627 !jm not thread safe hvrrft = '$Revision: 1.3 $'
2629 zsr3=sqrt(3._rb)
2630 zwcrit=0.9999995_rb
2631 kmodts=2
2633 do jk=1, nlayers
2634 if (.not.lrtchk(jk)) then
2635 pref(jk) =0._rb
2636 ptra(jk) =1._rb
2637 prefd(jk)=0._rb
2638 ptrad(jk)=1._rb
2639 else
2640 zto1=ptau(jk)
2641 zw =pw(jk)
2642 zg =pgg(jk)
2644 ! General two-stream expressions
2646 zg3= 3._rb * zg
2647 if (kmodts == 1) then
2648 zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb
2649 zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb
2650 zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2651 else if (kmodts == 2) then
2652 zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb
2653 zgamma2= 3._rb *(zw * (1._rb - zg )) * 0.25_rb
2654 zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2655 else if (kmodts == 3) then
2656 zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb
2657 zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb
2658 zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb
2659 end if
2660 zgamma4= 1._rb - zgamma3
2662 ! Recompute original s.s.a. to test for conservative solution
2663 zwo = 0._rb
2664 denom = 1._rb
2665 if (zg .ne. 1._rb) denom = (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2)
2666 if (zw .gt. 0._rb .and. denom .ne. 0._rb) zwo = zw / denom
2668 if (zwo >= zwcrit) then
2669 ! Conservative scattering
2671 za = zgamma1 * prmuz
2672 za1 = za - zgamma3
2673 zgt = zgamma1 * zto1
2675 ! Homogeneous reflectance and transmittance,
2676 ! collimated beam
2678 ze1 = min ( zto1 / prmuz , 500._rb)
2679 ! ze2 = exp( -ze1 )
2681 ! Use exponential lookup table for transmittance, or expansion of
2682 ! exponential for low tau
2683 if (ze1 .le. od_lo) then
2684 ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2685 else
2686 tblind = ze1 / (bpade + ze1)
2687 itind = tblint * tblind + 0.5_rb
2688 ze2 = exp_tbl(itind)
2689 endif
2690 !
2692 pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt)
2693 ptra(jk) = 1._rb - pref(jk)
2695 ! isotropic incidence
2697 prefd(jk) = zgt / (1._rb + zgt)
2698 ptrad(jk) = 1._rb - prefd(jk)
2700 ! This is applied for consistency between total (delta-scaled) and direct (unscaled)
2701 ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup
2702 ! table returns a transmittance of 1.0.
2703 if (ze2 .eq. 1.0_rb) then
2704 pref(jk) = 0.0_rb
2705 ptra(jk) = 1.0_rb
2706 prefd(jk) = 0.0_rb
2707 ptrad(jk) = 1.0_rb
2708 endif
2710 else
2711 ! Non-conservative scattering
2713 za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
2714 za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
2715 zrk = sqrt ( zgamma1**2 - zgamma2**2)
2716 zrp = zrk * prmuz
2717 zrp1 = 1._rb + zrp
2718 zrm1 = 1._rb - zrp
2719 zrk2 = 2._rb * zrk
2720 zrpp = 1._rb - zrp*zrp
2721 zrkg = zrk + zgamma1
2722 zr1 = zrm1 * (za2 + zrk * zgamma3)
2723 zr2 = zrp1 * (za2 - zrk * zgamma3)
2724 zr3 = zrk2 * (zgamma3 - za2 * prmuz )
2725 zr4 = zrpp * zrkg
2726 zr5 = zrpp * (zrk - zgamma1)
2727 zt1 = zrp1 * (za1 + zrk * zgamma4)
2728 zt2 = zrm1 * (za1 - zrk * zgamma4)
2729 zt3 = zrk2 * (zgamma4 + za1 * prmuz )
2730 zt4 = zr4
2731 zt5 = zr5
2733 ! mji - reformulated code to avoid potential floating point exceptions
2734 ! zbeta = - zr5 / zr4
2735 zbeta = (zgamma1 - zrk) / zrkg
2736 !!
2738 ! Homogeneous reflectance and transmittance
2740 ze1 = min ( zrk * zto1, 500._rb)
2741 ze2 = min ( zto1 / prmuz , 500._rb)
2742 !
2743 ! Original
2744 ! zep1 = exp( ze1 )
2745 ! zem1 = exp(-ze1 )
2746 ! zep2 = exp( ze2 )
2747 ! zem2 = exp(-ze2 )
2748 !
2749 ! Revised original, to reduce exponentials
2750 ! zep1 = exp( ze1 )
2751 ! zem1 = 1._rb / zep1
2752 ! zep2 = exp( ze2 )
2753 ! zem2 = 1._rb / zep2
2754 !
2755 ! Use exponential lookup table for transmittance, or expansion of
2756 ! exponential for low tau
2757 if (ze1 .le. od_lo) then
2758 zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2759 zep1 = 1._rb / zem1
2760 else
2761 tblind = ze1 / (bpade + ze1)
2762 itind = tblint * tblind + 0.5_rb
2763 zem1 = exp_tbl(itind)
2764 zep1 = 1._rb / zem1
2765 endif
2767 if (ze2 .le. od_lo) then
2768 zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2
2769 zep2 = 1._rb / zem2
2770 else
2771 tblind = ze2 / (bpade + ze2)
2772 itind = tblint * tblind + 0.5_rb
2773 zem2 = exp_tbl(itind)
2774 zep2 = 1._rb / zem2
2775 endif
2777 ! collimated beam
2779 ! mji - reformulated code to avoid potential floating point exceptions
2780 ! zdenr = zr4*zep1 + zr5*zem1
2781 ! pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2782 ! zdent = zt4*zep1 + zt5*zem1
2783 ! ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2785 zdenr = zr4*zep1 + zr5*zem1
2786 zdent = zt4*zep1 + zt5*zem1
2787 if (zdenr .ge. -eps .and. zdenr .le. eps) then
2788 pref(jk) = eps
2789 ptra(jk) = zem2
2790 else
2791 pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2792 ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2793 endif
2794 !!
2796 ! diffuse beam
2798 zemm = zem1*zem1
2799 zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg)
2800 prefd(jk) = zgamma2 * (1._rb - zemm) * zdend
2801 ptrad(jk) = zrk2*zem1*zdend
2803 endif
2805 endif
2807 enddo
2809 end subroutine reftra_sw
2811 end module rrtmg_sw_reftra
2813 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
2814 ! author: $Author: trn $
2815 ! revision: $Revision: 1.3 $
2816 ! created: $Date: 2009/04/16 19:54:22 $
2818 module rrtmg_sw_setcoef
2820 ! --------------------------------------------------------------------------
2821 ! | |
2822 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2823 ! | This software may be used, copied, or redistributed as long as it is |
2824 ! | not sold and this copyright notice is reproduced on each copy made. |
2825 ! | This model is provided as is without any express or implied warranties. |
2826 ! | (http://www.rtweb.aer.com/) |
2827 ! | |
2828 ! --------------------------------------------------------------------------
2830 ! ------- Modules -------
2832 use parkind, only : im => kind_im, rb => kind_rb
2833 use parrrsw, only : mxmol
2834 use rrsw_ref, only : pref, preflog, tref
2835 use rrsw_vsn, only : hvrset, hnamset
2837 implicit none
2839 contains
2841 !----------------------------------------------------------------------------
2842 subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
2843 laytrop, layswtch, laylow, jp, jt, jt1, &
2844 co2mult, colch4, colco2, colh2o, colmol, coln2o, &
2845 colo2, colo3, fac00, fac01, fac10, fac11, &
2846 selffac, selffrac, indself, forfac, forfrac, indfor)
2847 !----------------------------------------------------------------------------
2848 !
2849 ! Purpose: For a given atmosphere, calculate the indices and
2850 ! fractions related to the pressure and temperature interpolations.
2852 ! Modifications:
2853 ! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01)
2854 ! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224
2855 ! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006
2857 ! ------ Declarations -------
2859 ! ----- Input -----
2860 integer(kind=im), intent(in) :: nlayers ! total number of layers
2862 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
2863 ! Dimensions: (nlayers)
2864 real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K)
2865 ! Dimensions: (nlayers)
2866 real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb)
2867 ! Dimensions: (0:nlayers)
2868 real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K)
2869 ! Dimensions: (0:nlayers)
2870 real(kind=rb), intent(in) :: tbound ! surface temperature (K)
2871 real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
2872 ! Dimensions: (nlayers)
2873 real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2)
2874 ! Dimensions: (mxmol,nlayers)
2876 ! ----- Output -----
2877 integer(kind=im), intent(out) :: laytrop ! tropopause layer index
2878 integer(kind=im), intent(out) :: layswtch !
2879 integer(kind=im), intent(out) :: laylow !
2881 integer(kind=im), intent(out) :: jp(:) !
2882 ! Dimensions: (nlayers)
2883 integer(kind=im), intent(out) :: jt(:) !
2884 ! Dimensions: (nlayers)
2885 integer(kind=im), intent(out) :: jt1(:) !
2886 ! Dimensions: (nlayers)
2888 real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o)
2889 ! Dimensions: (nlayers)
2890 real(kind=rb), intent(out) :: colco2(:) ! column amount (co2)
2891 ! Dimensions: (nlayers)
2892 real(kind=rb), intent(out) :: colo3(:) ! column amount (o3)
2893 ! Dimensions: (nlayers)
2894 real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o)
2895 ! Dimensions: (nlayers)
2896 real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4)
2897 ! Dimensions: (nlayers)
2898 real(kind=rb), intent(out) :: colo2(:) ! column amount (o2)
2899 ! Dimensions: (nlayers)
2900 real(kind=rb), intent(out) :: colmol(:) !
2901 ! Dimensions: (nlayers)
2902 real(kind=rb), intent(out) :: co2mult(:) !
2903 ! Dimensions: (nlayers)
2905 integer(kind=im), intent(out) :: indself(:)
2906 ! Dimensions: (nlayers)
2907 integer(kind=im), intent(out) :: indfor(:)
2908 ! Dimensions: (nlayers)
2909 real(kind=rb), intent(out) :: selffac(:)
2910 ! Dimensions: (nlayers)
2911 real(kind=rb), intent(out) :: selffrac(:)
2912 ! Dimensions: (nlayers)
2913 real(kind=rb), intent(out) :: forfac(:)
2914 ! Dimensions: (nlayers)
2915 real(kind=rb), intent(out) :: forfrac(:)
2916 ! Dimensions: (nlayers)
2918 real(kind=rb), intent(out) :: & !
2919 fac00(:), fac01(:), & ! Dimensions: (nlayers)
2920 fac10(:), fac11(:)
2922 ! ----- Local -----
2924 integer(kind=im) :: indbound
2925 integer(kind=im) :: indlev0
2926 integer(kind=im) :: lay
2927 integer(kind=im) :: jp1
2929 real(kind=rb) :: stpfac
2930 real(kind=rb) :: tbndfrac
2931 real(kind=rb) :: t0frac
2932 real(kind=rb) :: plog
2933 real(kind=rb) :: fp
2934 real(kind=rb) :: ft
2935 real(kind=rb) :: ft1
2936 real(kind=rb) :: water
2937 real(kind=rb) :: scalefac
2938 real(kind=rb) :: factor
2939 real(kind=rb) :: co2reg
2940 real(kind=rb) :: compfp
2943 ! Initializations
2944 stpfac = 296._rb/1013._rb
2946 indbound = tbound - 159._rb
2947 tbndfrac = tbound - int(tbound)
2948 indlev0 = tz(0) - 159._rb
2949 t0frac = tz(0) - int(tz(0))
2951 laytrop = 0
2952 layswtch = 0
2953 laylow = 0
2955 ! Begin layer loop
2956 do lay = 1, nlayers
2957 ! Find the two reference pressures on either side of the
2958 ! layer pressure. Store them in JP and JP1. Store in FP the
2959 ! fraction of the difference (in ln(pressure)) between these
2960 ! two values that the layer pressure lies.
2962 plog = log(pavel(lay))
2963 jp(lay) = int(36._rb - 5*(plog+0.04_rb))
2964 if (jp(lay) .lt. 1) then
2965 jp(lay) = 1
2966 elseif (jp(lay) .gt. 58) then
2967 jp(lay) = 58
2968 endif
2969 jp1 = jp(lay) + 1
2970 fp = 5._rb * (preflog(jp(lay)) - plog)
2972 ! Determine, for each reference pressure (JP and JP1), which
2973 ! reference temperature (these are different for each
2974 ! reference pressure) is nearest the layer temperature but does
2975 ! not exceed it. Store these indices in JT and JT1, resp.
2976 ! Store in FT (resp. FT1) the fraction of the way between JT
2977 ! (JT1) and the next highest reference temperature that the
2978 ! layer temperature falls.
2980 jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
2981 if (jt(lay) .lt. 1) then
2982 jt(lay) = 1
2983 elseif (jt(lay) .gt. 4) then
2984 jt(lay) = 4
2985 endif
2986 ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3)
2987 jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
2988 if (jt1(lay) .lt. 1) then
2989 jt1(lay) = 1
2990 elseif (jt1(lay) .gt. 4) then
2991 jt1(lay) = 4
2992 endif
2993 ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3)
2995 water = wkl(1,lay)/coldry(lay)
2996 scalefac = pavel(lay) * stpfac / tavel(lay)
2998 ! If the pressure is less than ~100mb, perform a different
2999 ! set of species interpolations.
3001 if (plog .le. 4.56_rb) go to 5300
3002 laytrop = laytrop + 1
3003 if (plog .ge. 6.62_rb) laylow = laylow + 1
3005 ! Set up factors needed to separately include the water vapor
3006 ! foreign-continuum in the calculation of absorption coefficient.
3008 forfac(lay) = scalefac / (1.+water)
3009 factor = (332.0_rb-tavel(lay))/36.0_rb
3010 indfor(lay) = min(2, max(1, int(factor)))
3011 forfrac(lay) = factor - float(indfor(lay))
3013 ! Set up factors needed to separately include the water vapor
3014 ! self-continuum in the calculation of absorption coefficient.
3016 selffac(lay) = water * forfac(lay)
3017 factor = (tavel(lay)-188.0_rb)/7.2_rb
3018 indself(lay) = min(9, max(1, int(factor)-7))
3019 selffrac(lay) = factor - float(indself(lay) + 7)
3021 ! Calculate needed column amounts.
3023 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3024 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3025 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3026 ! colo3(lay) = 0._rb
3027 ! colo3(lay) = colo3(lay)/1.16_rb
3028 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3029 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3030 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3031 colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
3032 ! colco2(lay) = 0._rb
3033 ! colo3(lay) = 0._rb
3034 ! coln2o(lay) = 0._rb
3035 ! colch4(lay) = 0._rb
3036 ! colo2(lay) = 0._rb
3037 ! colmol(lay) = 0._rb
3038 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3039 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3040 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3041 if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
3042 ! Using E = 1334.2 cm-1.
3043 co2reg = 3.55e-24_rb * coldry(lay)
3044 co2mult(lay)= (colco2(lay) - co2reg) * &
3045 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
3046 goto 5400
3048 ! Above laytrop.
3049 5300 continue
3051 ! Set up factors needed to separately include the water vapor
3052 ! foreign-continuum in the calculation of absorption coefficient.
3054 forfac(lay) = scalefac / (1.+water)
3055 factor = (tavel(lay)-188.0_rb)/36.0_rb
3056 indfor(lay) = 3
3057 forfrac(lay) = factor - 1.0_rb
3059 ! Calculate needed column amounts.
3061 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3062 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3063 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3064 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3065 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3066 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3067 colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
3068 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3069 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3070 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3071 if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
3072 co2reg = 3.55e-24_rb * coldry(lay)
3073 co2mult(lay)= (colco2(lay) - co2reg) * &
3074 272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
3076 selffac(lay) = 0._rb
3077 selffrac(lay)= 0._rb
3078 indself(lay) = 0
3080 5400 continue
3082 ! We have now isolated the layer ln pressure and temperature,
3083 ! between two reference pressures and two reference temperatures
3084 ! (for each reference pressure). We multiply the pressure
3085 ! fraction FP with the appropriate temperature fractions to get
3086 ! the factors that will be needed for the interpolation that yields
3087 ! the optical depths (performed in routines TAUGBn for band n).
3089 compfp = 1._rb - fp
3090 fac10(lay) = compfp * ft
3091 fac00(lay) = compfp * (1._rb - ft)
3092 fac11(lay) = fp * ft1
3093 fac01(lay) = fp * (1._rb - ft1)
3095 ! End layer loop
3096 enddo
3098 end subroutine setcoef_sw
3100 !***************************************************************************
3101 subroutine swatmref
3102 !***************************************************************************
3104 save
3106 ! These pressures are chosen such that the ln of the first pressure
3107 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
3108 ! each subsequent ln(pressure) differs from the previous one by 0.2.
3110 pref(:) = (/ &
3111 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
3112 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
3113 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
3114 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
3115 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
3116 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
3117 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
3118 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
3119 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
3120 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
3121 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
3122 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /)
3124 preflog(:) = (/ &
3125 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
3126 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
3127 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
3128 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
3129 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
3130 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
3131 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
3132 -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
3133 -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
3134 -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
3135 -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
3136 -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /)
3138 ! These are the temperatures associated with the respective
3139 ! pressures for the MLS standard atmosphere.
3141 tref(:) = (/ &
3142 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
3143 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
3144 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
3145 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
3146 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
3147 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
3148 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
3149 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
3150 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
3151 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
3152 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
3153 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /)
3155 end subroutine swatmref
3157 end module rrtmg_sw_setcoef
3159 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
3160 ! author: $Author: trn $
3161 ! revision: $Revision: 1.3 $
3162 ! created: $Date: 2009/04/16 19:54:22 $
3164 module rrtmg_sw_taumol
3166 ! --------------------------------------------------------------------------
3167 ! | |
3168 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
3169 ! | This software may be used, copied, or redistributed as long as it is |
3170 ! | not sold and this copyright notice is reproduced on each copy made. |
3171 ! | This model is provided as is without any express or implied warranties. |
3172 ! | (http://www.rtweb.aer.com/) |
3173 ! | |
3174 ! --------------------------------------------------------------------------
3176 ! ------- Modules -------
3178 use parkind, only : im => kind_im, rb => kind_rb
3179 ! use parrrsw, only : mg, jpband, nbndsw, ngptsw
3180 use rrsw_con, only: oneminus
3181 use rrsw_wvn, only: nspa, nspb
3182 use rrsw_vsn, only: hvrtau, hnamtau
3184 implicit none
3186 contains
3188 !----------------------------------------------------------------------------
3189 subroutine taumol_sw(nlayers, &
3190 colh2o, colco2, colch4, colo2, colo3, colmol, &
3191 laytrop, jp, jt, jt1, &
3192 fac00, fac01, fac10, fac11, &
3193 selffac, selffrac, indself, forfac, forfrac, indfor, &
3194 sfluxzen, taug, taur)
3195 !----------------------------------------------------------------------------
3197 ! ******************************************************************************
3198 ! * *
3199 ! * Optical depths developed for the *
3200 ! * *
3201 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
3202 ! * *
3203 ! * *
3204 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
3205 ! * 131 HARTWELL AVENUE *
3206 ! * LEXINGTON, MA 02421 *
3207 ! * *
3208 ! * *
3209 ! * ELI J. MLAWER *
3210 ! * JENNIFER DELAMERE *
3211 ! * STEVEN J. TAUBMAN *
3212 ! * SHEPARD A. CLOUGH *
3213 ! * *
3214 ! * *
3215 ! * *
3216 ! * *
3217 ! * email: mlawer@aer.com *
3218 ! * email: jdelamer@aer.com *
3219 ! * *
3220 ! * The authors wish to acknowledge the contributions of the *
3221 ! * following people: Patrick D. Brown, Michael J. Iacono, *
3222 ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
3223 ! * *
3224 ! ******************************************************************************
3225 ! * TAUMOL *
3226 ! * *
3227 ! * This file contains the subroutines TAUGBn (where n goes from *
3228 ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions *
3229 ! * per g-value and layer for band n. *
3230 ! * *
3231 ! * Output: optical depths (unitless) *
3232 ! * fractions needed to compute Planck functions at every layer *
3233 ! * and g-value *
3234 ! * *
3235 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
3236 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
3237 ! * *
3238 ! * Input *
3239 ! * *
3240 ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) *
3241 ! * *
3242 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
3243 ! * COMMON /PRECISE/ ONEMINUS *
3244 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
3245 ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND *
3246 ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, *
3247 ! * & COLH2O(MXLAY),COLCO2(MXLAY), *
3248 ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), *
3249 ! * & COLO2(MXLAY),CO2MULT(MXLAY) *
3250 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
3251 ! * & FAC10(MXLAY),FAC11(MXLAY) *
3252 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
3253 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
3254 ! * *
3255 ! * Description: *
3256 ! * NG(IBAND) - number of g-values in band IBAND *
3257 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
3258 ! * atmospheres that are stored for band IBAND per *
3259 ! * pressure level and temperature. Each of these *
3260 ! * atmospheres has different relative amounts of the *
3261 ! * key species for the band (i.e. different binary *
3262 ! * species parameters). *
3263 ! * NSPB(IBAND) - same for upper atmosphere *
3264 ! * ONEMINUS - since problems are caused in some cases by interpolation *
3265 ! * parameters equal to or greater than 1, for these cases *
3266 ! * these parameters are set to this value, slightly < 1. *
3267 ! * PAVEL - layer pressures (mb) *
3268 ! * TAVEL - layer temperatures (degrees K) *
3269 ! * PZ - level pressures (mb) *
3270 ! * TZ - level temperatures (degrees K) *
3271 ! * LAYTROP - layer at which switch is made from one combination of *
3272 ! * key species to another *
3273 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
3274 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
3275 ! * respectively (molecules/cm**2) *
3276 ! * CO2MULT - for bands in which carbon dioxide is implemented as a *
3277 ! * trace species, this is the factor used to multiply the *
3278 ! * band's average CO2 absorption coefficient to get the added *
3279 ! * contribution to the optical depth relative to 355 ppm. *
3280 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
3281 ! * compute the interpolation factors that multiply the *
3282 ! * appropriate reference k-values. A value of 0 (1) for *
3283 ! * i,j indicates that the corresponding factor multiplies *
3284 ! * reference k-value for the lower (higher) of the two *
3285 ! * appropriate temperatures, and altitudes, respectively. *
3286 ! * JP - the index of the lower (in altitude) of the two appropriate *
3287 ! * reference pressure levels needed for interpolation *
3288 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
3289 ! * temperatures needed for interpolation (for pressure *
3290 ! * levels JP and JP+1, respectively) *
3291 ! * SELFFAC - scale factor needed to water vapor self-continuum, equals *
3292 ! * (water vapor density)/(atmospheric density at 296K and *
3293 ! * 1013 mb) *
3294 ! * SELFFRAC - factor needed for temperature interpolation of reference *
3295 ! * water vapor self-continuum data *
3296 ! * INDSELF - index of the lower of the two appropriate reference *
3297 ! * temperatures needed for the self-continuum interpolation *
3298 ! * *
3299 ! * Data input *
3300 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
3301 ! * (note: n is the band number) *
3302 ! * *
3303 ! * Description: *
3304 ! * KA - k-values for low reference atmospheres (no water vapor *
3305 ! * self-continuum) (units: cm**2/molecule) *
3306 ! * KB - k-values for high reference atmospheres (all sources) *
3307 ! * (units: cm**2/molecule) *
3308 ! * SELFREF - k-values for water vapor self-continuum for reference *
3309 ! * atmospheres (used below LAYTROP) *
3310 ! * (units: cm**2/molecule) *
3311 ! * *
3312 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
3313 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
3314 ! * *
3315 ! *****************************************************************************
3316 !
3317 ! Modifications
3318 !
3319 ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003
3320 ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003
3321 ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
3322 !
3323 ! ------- Declarations -------
3325 ! ----- Input -----
3326 integer(kind=im), intent(in) :: nlayers ! total number of layers
3328 integer(kind=im), intent(in) :: laytrop ! tropopause layer index
3329 integer(kind=im), intent(in) :: jp(:) !
3330 ! Dimensions: (nlayers)
3331 integer(kind=im), intent(in) :: jt(:) !
3332 ! Dimensions: (nlayers)
3333 integer(kind=im), intent(in) :: jt1(:) !
3334 ! Dimensions: (nlayers)
3336 real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o)
3337 ! Dimensions: (nlayers)
3338 real(kind=rb), intent(in) :: colco2(:) ! column amount (co2)
3339 ! Dimensions: (nlayers)
3340 real(kind=rb), intent(in) :: colo3(:) ! column amount (o3)
3341 ! Dimensions: (nlayers)
3342 real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4)
3343 ! Dimensions: (nlayers)
3344 ! Dimensions: (nlayers)
3345 real(kind=rb), intent(in) :: colo2(:) ! column amount (o2)
3346 ! Dimensions: (nlayers)
3347 real(kind=rb), intent(in) :: colmol(:) !
3348 ! Dimensions: (nlayers)
3350 integer(kind=im), intent(in) :: indself(:)
3351 ! Dimensions: (nlayers)
3352 integer(kind=im), intent(in) :: indfor(:)
3353 ! Dimensions: (nlayers)
3354 real(kind=rb), intent(in) :: selffac(:)
3355 ! Dimensions: (nlayers)
3356 real(kind=rb), intent(in) :: selffrac(:)
3357 ! Dimensions: (nlayers)
3358 real(kind=rb), intent(in) :: forfac(:)
3359 ! Dimensions: (nlayers)
3360 real(kind=rb), intent(in) :: forfrac(:)
3361 ! Dimensions: (nlayers)
3363 real(kind=rb), intent(in) :: & !
3364 fac00(:), fac01(:), & ! Dimensions: (nlayers)
3365 fac10(:), fac11(:)
3367 ! ----- Output -----
3368 real(kind=rb), intent(out) :: sfluxzen(:) ! solar source function
3369 ! Dimensions: (ngptsw)
3370 real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth
3371 ! Dimensions: (nlayers,ngptsw)
3372 real(kind=rb), intent(out) :: taur(:,:) ! Rayleigh
3373 ! Dimensions: (nlayers,ngptsw)
3374 ! real(kind=rb), intent(out) :: ssa(:,:) ! single scattering albedo (inactive)
3375 ! Dimensions: (nlayers,ngptsw)
3377 !jm not thread safe hvrtau = '$Revision: 1.3 $'
3379 ! Initialize sfluxzen to 0.0 to prevent junk values when nlayers = laytrop
3381 sfluxzen(:) = 0.0
3383 ! Calculate gaseous optical depth and planck fractions for each spectral band.
3385 call taumol16
3386 call taumol17
3387 call taumol18
3388 call taumol19
3389 call taumol20
3390 call taumol21
3391 call taumol22
3392 call taumol23
3393 call taumol24
3394 call taumol25
3395 call taumol26
3396 call taumol27
3397 call taumol28
3398 call taumol29
3400 !-------------
3401 contains
3402 !-------------
3404 !----------------------------------------------------------------------------
3405 subroutine taumol16
3406 !----------------------------------------------------------------------------
3407 !
3408 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
3409 !
3410 !----------------------------------------------------------------------------
3412 ! ------- Modules -------
3414 use parrrsw, only : ng16
3415 use rrsw_kg16, only : absa, ka, absb, kb, forref, selfref, &
3416 sfluxref, rayl, layreffr, strrat1
3418 ! ------- Declarations -------
3420 ! Local
3422 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3423 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3424 fac110, fac111, fs, speccomb, specmult, specparm, &
3425 tauray
3427 ! Compute the optical depth by interpolating in ln(pressure),
3428 ! temperature, and appropriate species. Below LAYTROP, the water
3429 ! vapor self-continuum is interpolated (in temperature) separately.
3431 ! Lower atmosphere loop
3432 do lay = 1, laytrop
3433 speccomb = colh2o(lay) + strrat1*colch4(lay)
3434 specparm = colh2o(lay)/speccomb
3435 if (specparm .ge. oneminus) specparm = oneminus
3436 specmult = 8._rb*(specparm)
3437 js = 1 + int(specmult)
3438 fs = mod(specmult, 1._rb )
3439 fac000 = (1._rb - fs) * fac00(lay)
3440 fac010 = (1._rb - fs) * fac10(lay)
3441 fac100 = fs * fac00(lay)
3442 fac110 = fs * fac10(lay)
3443 fac001 = (1._rb - fs) * fac01(lay)
3444 fac011 = (1._rb - fs) * fac11(lay)
3445 fac101 = fs * fac01(lay)
3446 fac111 = fs * fac11(lay)
3447 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
3448 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js
3449 inds = indself(lay)
3450 indf = indfor(lay)
3451 tauray = colmol(lay) * rayl
3453 do ig = 1, ng16
3454 taug(lay,ig) = speccomb * &
3455 (fac000 * absa(ind0 ,ig) + &
3456 fac100 * absa(ind0 +1,ig) + &
3457 fac010 * absa(ind0 +9,ig) + &
3458 fac110 * absa(ind0+10,ig) + &
3459 fac001 * absa(ind1 ,ig) + &
3460 fac101 * absa(ind1 +1,ig) + &
3461 fac011 * absa(ind1 +9,ig) + &
3462 fac111 * absa(ind1+10,ig)) + &
3463 colh2o(lay) * &
3464 (selffac(lay) * (selfref(inds,ig) + &
3465 selffrac(lay) * &
3466 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3467 forfac(lay) * (forref(indf,ig) + &
3468 forfrac(lay) * &
3469 (forref(indf+1,ig) - forref(indf,ig))))
3470 ! ssa(lay,ig) = tauray/taug(lay,ig)
3471 taur(lay,ig) = tauray
3472 enddo
3473 enddo
3475 laysolfr = nlayers
3477 ! Upper atmosphere loop
3478 do lay = laytrop+1, nlayers
3479 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
3480 laysolfr = lay
3481 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
3482 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
3483 tauray = colmol(lay) * rayl
3485 do ig = 1, ng16
3486 taug(lay,ig) = colch4(lay) * &
3487 (fac00(lay) * absb(ind0 ,ig) + &
3488 fac10(lay) * absb(ind0+1,ig) + &
3489 fac01(lay) * absb(ind1 ,ig) + &
3490 fac11(lay) * absb(ind1+1,ig))
3491 ! ssa(lay,ig) = tauray/taug(lay,ig)
3492 if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig)
3493 taur(lay,ig) = tauray
3494 enddo
3495 enddo
3497 end subroutine taumol16
3499 !----------------------------------------------------------------------------
3500 subroutine taumol17
3501 !----------------------------------------------------------------------------
3502 !
3503 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
3504 !
3505 !----------------------------------------------------------------------------
3507 ! ------- Modules -------
3509 use parrrsw, only : ng17, ngs16
3510 use rrsw_kg17, only : absa, ka, absb, kb, forref, selfref, &
3511 sfluxref, rayl, layreffr, strrat
3513 ! ------- Declarations -------
3515 ! Local
3517 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3518 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3519 fac110, fac111, fs, speccomb, specmult, specparm, &
3520 tauray
3522 ! Compute the optical depth by interpolating in ln(pressure),
3523 ! temperature, and appropriate species. Below LAYTROP, the water
3524 ! vapor self-continuum is interpolated (in temperature) separately.
3526 ! Lower atmosphere loop
3527 do lay = 1, laytrop
3528 speccomb = colh2o(lay) + strrat*colco2(lay)
3529 specparm = colh2o(lay)/speccomb
3530 if (specparm .ge. oneminus) specparm = oneminus
3531 specmult = 8._rb*(specparm)
3532 js = 1 + int(specmult)
3533 fs = mod(specmult, 1._rb )
3534 fac000 = (1._rb - fs) * fac00(lay)
3535 fac010 = (1._rb - fs) * fac10(lay)
3536 fac100 = fs * fac00(lay)
3537 fac110 = fs * fac10(lay)
3538 fac001 = (1._rb - fs) * fac01(lay)
3539 fac011 = (1._rb - fs) * fac11(lay)
3540 fac101 = fs * fac01(lay)
3541 fac111 = fs * fac11(lay)
3542 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js
3543 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js
3544 inds = indself(lay)
3545 indf = indfor(lay)
3546 tauray = colmol(lay) * rayl
3548 do ig = 1, ng17
3549 taug(lay,ngs16+ig) = speccomb * &
3550 (fac000 * absa(ind0,ig) + &
3551 fac100 * absa(ind0+1,ig) + &
3552 fac010 * absa(ind0+9,ig) + &
3553 fac110 * absa(ind0+10,ig) + &
3554 fac001 * absa(ind1,ig) + &
3555 fac101 * absa(ind1+1,ig) + &
3556 fac011 * absa(ind1+9,ig) + &
3557 fac111 * absa(ind1+10,ig)) + &
3558 colh2o(lay) * &
3559 (selffac(lay) * (selfref(inds,ig) + &
3560 selffrac(lay) * &
3561 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3562 forfac(lay) * (forref(indf,ig) + &
3563 forfrac(lay) * &
3564 (forref(indf+1,ig) - forref(indf,ig))))
3565 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3566 taur(lay,ngs16+ig) = tauray
3567 enddo
3568 enddo
3570 laysolfr = nlayers
3572 ! Upper atmosphere loop
3573 do lay = laytrop+1, nlayers
3574 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
3575 laysolfr = lay
3576 speccomb = colh2o(lay) + strrat*colco2(lay)
3577 specparm = colh2o(lay)/speccomb
3578 if (specparm .ge. oneminus) specparm = oneminus
3579 specmult = 4._rb*(specparm)
3580 js = 1 + int(specmult)
3581 fs = mod(specmult, 1._rb )
3582 fac000 = (1._rb - fs) * fac00(lay)
3583 fac010 = (1._rb - fs) * fac10(lay)
3584 fac100 = fs * fac00(lay)
3585 fac110 = fs * fac10(lay)
3586 fac001 = (1._rb - fs) * fac01(lay)
3587 fac011 = (1._rb - fs) * fac11(lay)
3588 fac101 = fs * fac01(lay)
3589 fac111 = fs * fac11(lay)
3590 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js
3591 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js
3592 indf = indfor(lay)
3593 tauray = colmol(lay) * rayl
3595 do ig = 1, ng17
3596 taug(lay,ngs16+ig) = speccomb * &
3597 (fac000 * absb(ind0,ig) + &
3598 fac100 * absb(ind0+1,ig) + &
3599 fac010 * absb(ind0+5,ig) + &
3600 fac110 * absb(ind0+6,ig) + &
3601 fac001 * absb(ind1,ig) + &
3602 fac101 * absb(ind1+1,ig) + &
3603 fac011 * absb(ind1+5,ig) + &
3604 fac111 * absb(ind1+6,ig)) + &
3605 colh2o(lay) * &
3606 forfac(lay) * (forref(indf,ig) + &
3607 forfrac(lay) * &
3608 (forref(indf+1,ig) - forref(indf,ig)))
3609 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3610 if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js) &
3611 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3612 taur(lay,ngs16+ig) = tauray
3613 enddo
3614 enddo
3616 end subroutine taumol17
3618 !----------------------------------------------------------------------------
3619 subroutine taumol18
3620 !----------------------------------------------------------------------------
3621 !
3622 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
3623 !
3624 !----------------------------------------------------------------------------
3626 ! ------- Modules -------
3628 use parrrsw, only : ng18, ngs17
3629 use rrsw_kg18, only : absa, ka, absb, kb, forref, selfref, &
3630 sfluxref, rayl, layreffr, strrat
3632 ! ------- Declarations -------
3634 ! Local
3636 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3637 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3638 fac110, fac111, fs, speccomb, specmult, specparm, &
3639 tauray
3641 ! Compute the optical depth by interpolating in ln(pressure),
3642 ! temperature, and appropriate species. Below LAYTROP, the water
3643 ! vapor self-continuum is interpolated (in temperature) separately.
3645 laysolfr = laytrop
3647 ! Lower atmosphere loop
3648 do lay = 1, laytrop
3649 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3650 laysolfr = min(lay+1,laytrop)
3651 speccomb = colh2o(lay) + strrat*colch4(lay)
3652 specparm = colh2o(lay)/speccomb
3653 if (specparm .ge. oneminus) specparm = oneminus
3654 specmult = 8._rb*(specparm)
3655 js = 1 + int(specmult)
3656 fs = mod(specmult, 1._rb )
3657 fac000 = (1._rb - fs) * fac00(lay)
3658 fac010 = (1._rb - fs) * fac10(lay)
3659 fac100 = fs * fac00(lay)
3660 fac110 = fs * fac10(lay)
3661 fac001 = (1._rb - fs) * fac01(lay)
3662 fac011 = (1._rb - fs) * fac11(lay)
3663 fac101 = fs * fac01(lay)
3664 fac111 = fs * fac11(lay)
3665 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js
3666 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js
3667 inds = indself(lay)
3668 indf = indfor(lay)
3669 tauray = colmol(lay) * rayl
3671 do ig = 1, ng18
3672 taug(lay,ngs17+ig) = speccomb * &
3673 (fac000 * absa(ind0,ig) + &
3674 fac100 * absa(ind0+1,ig) + &
3675 fac010 * absa(ind0+9,ig) + &
3676 fac110 * absa(ind0+10,ig) + &
3677 fac001 * absa(ind1,ig) + &
3678 fac101 * absa(ind1+1,ig) + &
3679 fac011 * absa(ind1+9,ig) + &
3680 fac111 * absa(ind1+10,ig)) + &
3681 colh2o(lay) * &
3682 (selffac(lay) * (selfref(inds,ig) + &
3683 selffrac(lay) * &
3684 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3685 forfac(lay) * (forref(indf,ig) + &
3686 forfrac(lay) * &
3687 (forref(indf+1,ig) - forref(indf,ig))))
3688 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3689 if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js) &
3690 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3691 taur(lay,ngs17+ig) = tauray
3692 enddo
3693 enddo
3695 ! Upper atmosphere loop
3696 do lay = laytrop+1, nlayers
3697 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1
3698 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1
3699 tauray = colmol(lay) * rayl
3701 do ig = 1, ng18
3702 taug(lay,ngs17+ig) = colch4(lay) * &
3703 (fac00(lay) * absb(ind0,ig) + &
3704 fac10(lay) * absb(ind0+1,ig) + &
3705 fac01(lay) * absb(ind1,ig) + &
3706 fac11(lay) * absb(ind1+1,ig))
3707 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3708 taur(lay,ngs17+ig) = tauray
3709 enddo
3710 enddo
3712 end subroutine taumol18
3714 !----------------------------------------------------------------------------
3715 subroutine taumol19
3716 !----------------------------------------------------------------------------
3717 !
3718 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
3719 !
3720 !----------------------------------------------------------------------------
3722 ! ------- Modules -------
3724 use parrrsw, only : ng19, ngs18
3725 use rrsw_kg19, only : absa, ka, absb, kb, forref, selfref, &
3726 sfluxref, rayl, layreffr, strrat
3728 ! ------- Declarations -------
3730 ! Local
3732 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3733 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3734 fac110, fac111, fs, speccomb, specmult, specparm, &
3735 tauray
3737 ! Compute the optical depth by interpolating in ln(pressure),
3738 ! temperature, and appropriate species. Below LAYTROP, the water
3739 ! vapor self-continuum is interpolated (in temperature) separately.
3741 laysolfr = laytrop
3743 ! Lower atmosphere loop
3744 do lay = 1, laytrop
3745 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3746 laysolfr = min(lay+1,laytrop)
3747 speccomb = colh2o(lay) + strrat*colco2(lay)
3748 specparm = colh2o(lay)/speccomb
3749 if (specparm .ge. oneminus) specparm = oneminus
3750 specmult = 8._rb*(specparm)
3751 js = 1 + int(specmult)
3752 fs = mod(specmult, 1._rb )
3753 fac000 = (1._rb - fs) * fac00(lay)
3754 fac010 = (1._rb - fs) * fac10(lay)
3755 fac100 = fs * fac00(lay)
3756 fac110 = fs * fac10(lay)
3757 fac001 = (1._rb - fs) * fac01(lay)
3758 fac011 = (1._rb - fs) * fac11(lay)
3759 fac101 = fs * fac01(lay)
3760 fac111 = fs * fac11(lay)
3761 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js
3762 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js
3763 inds = indself(lay)
3764 indf = indfor(lay)
3765 tauray = colmol(lay) * rayl
3767 do ig = 1 , ng19
3768 taug(lay,ngs18+ig) = speccomb * &
3769 (fac000 * absa(ind0,ig) + &
3770 fac100 * absa(ind0+1,ig) + &
3771 fac010 * absa(ind0+9,ig) + &
3772 fac110 * absa(ind0+10,ig) + &
3773 fac001 * absa(ind1,ig) + &
3774 fac101 * absa(ind1+1,ig) + &
3775 fac011 * absa(ind1+9,ig) + &
3776 fac111 * absa(ind1+10,ig)) + &
3777 colh2o(lay) * &
3778 (selffac(lay) * (selfref(inds,ig) + &
3779 selffrac(lay) * &
3780 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3781 forfac(lay) * (forref(indf,ig) + &
3782 forfrac(lay) * &
3783 (forref(indf+1,ig) - forref(indf,ig))))
3784 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3785 if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js) &
3786 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3787 taur(lay,ngs18+ig) = tauray
3788 enddo
3789 enddo
3791 ! Upper atmosphere loop
3792 do lay = laytrop+1, nlayers
3793 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1
3794 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1
3795 tauray = colmol(lay) * rayl
3797 do ig = 1 , ng19
3798 taug(lay,ngs18+ig) = colco2(lay) * &
3799 (fac00(lay) * absb(ind0,ig) + &
3800 fac10(lay) * absb(ind0+1,ig) + &
3801 fac01(lay) * absb(ind1,ig) + &
3802 fac11(lay) * absb(ind1+1,ig))
3803 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3804 taur(lay,ngs18+ig) = tauray
3805 enddo
3806 enddo
3808 end subroutine taumol19
3810 !----------------------------------------------------------------------------
3811 subroutine taumol20
3812 !----------------------------------------------------------------------------
3813 !
3814 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
3815 !
3816 !----------------------------------------------------------------------------
3818 ! ------- Modules -------
3820 use parrrsw, only : ng20, ngs19
3821 use rrsw_kg20, only : absa, ka, absb, kb, forref, selfref, &
3822 sfluxref, absch4, rayl, layreffr
3824 implicit none
3826 ! ------- Declarations -------
3828 ! Local
3830 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3831 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3832 fac110, fac111, fs, speccomb, specmult, specparm, &
3833 tauray
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.
3839 laysolfr = laytrop
3841 ! Lower atmosphere loop
3842 do lay = 1, laytrop
3843 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3844 laysolfr = min(lay+1,laytrop)
3845 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1
3846 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1
3847 inds = indself(lay)
3848 indf = indfor(lay)
3849 tauray = colmol(lay) * rayl
3851 do ig = 1, ng20
3852 taug(lay,ngs19+ig) = colh2o(lay) * &
3853 ((fac00(lay) * absa(ind0,ig) + &
3854 fac10(lay) * absa(ind0+1,ig) + &
3855 fac01(lay) * absa(ind1,ig) + &
3856 fac11(lay) * absa(ind1+1,ig)) + &
3857 selffac(lay) * (selfref(inds,ig) + &
3858 selffrac(lay) * &
3859 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3860 forfac(lay) * (forref(indf,ig) + &
3861 forfrac(lay) * &
3862 (forref(indf+1,ig) - forref(indf,ig)))) &
3863 + colch4(lay) * absch4(ig)
3864 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3865 taur(lay,ngs19+ig) = tauray
3866 if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig)
3867 enddo
3868 enddo
3870 ! Upper atmosphere loop
3871 do lay = laytrop+1, nlayers
3872 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1
3873 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1
3874 indf = indfor(lay)
3875 tauray = colmol(lay) * rayl
3877 do ig = 1, ng20
3878 taug(lay,ngs19+ig) = colh2o(lay) * &
3879 (fac00(lay) * absb(ind0,ig) + &
3880 fac10(lay) * absb(ind0+1,ig) + &
3881 fac01(lay) * absb(ind1,ig) + &
3882 fac11(lay) * absb(ind1+1,ig) + &
3883 forfac(lay) * (forref(indf,ig) + &
3884 forfrac(lay) * &
3885 (forref(indf+1,ig) - forref(indf,ig)))) + &
3886 colch4(lay) * absch4(ig)
3887 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3888 taur(lay,ngs19+ig) = tauray
3889 enddo
3890 enddo
3892 end subroutine taumol20
3894 !----------------------------------------------------------------------------
3895 subroutine taumol21
3896 !----------------------------------------------------------------------------
3897 !
3898 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
3899 !
3900 !----------------------------------------------------------------------------
3902 ! ------- Modules -------
3904 use parrrsw, only : ng21, ngs20
3905 use rrsw_kg21, only : absa, ka, absb, kb, forref, selfref, &
3906 sfluxref, rayl, layreffr, strrat
3908 ! ------- Declarations -------
3910 ! Local
3912 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3913 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
3914 fac110, fac111, fs, speccomb, specmult, specparm, &
3915 tauray
3917 ! Compute the optical depth by interpolating in ln(pressure),
3918 ! temperature, and appropriate species. Below LAYTROP, the water
3919 ! vapor self-continuum is interpolated (in temperature) separately.
3921 laysolfr = laytrop
3923 ! Lower atmosphere loop
3924 do lay = 1, laytrop
3925 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
3926 laysolfr = min(lay+1,laytrop)
3927 speccomb = colh2o(lay) + strrat*colco2(lay)
3928 specparm = colh2o(lay)/speccomb
3929 if (specparm .ge. oneminus) specparm = oneminus
3930 specmult = 8._rb*(specparm)
3931 js = 1 + int(specmult)
3932 fs = mod(specmult, 1._rb )
3933 fac000 = (1._rb - fs) * fac00(lay)
3934 fac010 = (1._rb - fs) * fac10(lay)
3935 fac100 = fs * fac00(lay)
3936 fac110 = fs * fac10(lay)
3937 fac001 = (1._rb - fs) * fac01(lay)
3938 fac011 = (1._rb - fs) * fac11(lay)
3939 fac101 = fs * fac01(lay)
3940 fac111 = fs * fac11(lay)
3941 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js
3942 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js
3943 inds = indself(lay)
3944 indf = indfor(lay)
3945 tauray = colmol(lay) * rayl
3947 do ig = 1, ng21
3948 taug(lay,ngs20+ig) = speccomb * &
3949 (fac000 * absa(ind0,ig) + &
3950 fac100 * absa(ind0+1,ig) + &
3951 fac010 * absa(ind0+9,ig) + &
3952 fac110 * absa(ind0+10,ig) + &
3953 fac001 * absa(ind1,ig) + &
3954 fac101 * absa(ind1+1,ig) + &
3955 fac011 * absa(ind1+9,ig) + &
3956 fac111 * absa(ind1+10,ig)) + &
3957 colh2o(lay) * &
3958 (selffac(lay) * (selfref(inds,ig) + &
3959 selffrac(lay) * &
3960 (selfref(inds+1,ig) - selfref(inds,ig))) + &
3961 forfac(lay) * (forref(indf,ig) + &
3962 forfrac(lay) * &
3963 (forref(indf+1,ig) - forref(indf,ig))))
3964 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3965 if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js) &
3966 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3967 taur(lay,ngs20+ig) = tauray
3968 enddo
3969 enddo
3971 ! Upper atmosphere loop
3972 do lay = laytrop+1, nlayers
3973 speccomb = colh2o(lay) + strrat*colco2(lay)
3974 specparm = colh2o(lay)/speccomb
3975 if (specparm .ge. oneminus) specparm = oneminus
3976 specmult = 4._rb*(specparm)
3977 js = 1 + int(specmult)
3978 fs = mod(specmult, 1._rb )
3979 fac000 = (1._rb - fs) * fac00(lay)
3980 fac010 = (1._rb - fs) * fac10(lay)
3981 fac100 = fs * fac00(lay)
3982 fac110 = fs * fac10(lay)
3983 fac001 = (1._rb - fs) * fac01(lay)
3984 fac011 = (1._rb - fs) * fac11(lay)
3985 fac101 = fs * fac01(lay)
3986 fac111 = fs * fac11(lay)
3987 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js
3988 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js
3989 indf = indfor(lay)
3990 tauray = colmol(lay) * rayl
3992 do ig = 1, ng21
3993 taug(lay,ngs20+ig) = speccomb * &
3994 (fac000 * absb(ind0,ig) + &
3995 fac100 * absb(ind0+1,ig) + &
3996 fac010 * absb(ind0+5,ig) + &
3997 fac110 * absb(ind0+6,ig) + &
3998 fac001 * absb(ind1,ig) + &
3999 fac101 * absb(ind1+1,ig) + &
4000 fac011 * absb(ind1+5,ig) + &
4001 fac111 * absb(ind1+6,ig)) + &
4002 colh2o(lay) * &
4003 forfac(lay) * (forref(indf,ig) + &
4004 forfrac(lay) * &
4005 (forref(indf+1,ig) - forref(indf,ig)))
4006 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
4007 taur(lay,ngs20+ig) = tauray
4008 enddo
4009 enddo
4011 end subroutine taumol21
4013 !----------------------------------------------------------------------------
4014 subroutine taumol22
4015 !----------------------------------------------------------------------------
4016 !
4017 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
4018 !
4019 !----------------------------------------------------------------------------
4021 ! ------- Modules -------
4023 use parrrsw, only : ng22, ngs21
4024 use rrsw_kg22, only : absa, ka, absb, kb, forref, selfref, &
4025 sfluxref, rayl, layreffr, strrat
4027 ! ------- Declarations -------
4029 ! Local
4031 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4032 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4033 fac110, fac111, fs, speccomb, specmult, specparm, &
4034 tauray, o2adj, o2cont
4036 ! The following factor is the ratio of total O2 band intensity (lines
4037 ! and Mate continuum) to O2 band intensity (line only). It is needed
4038 ! to adjust the optical depths since the k's include only lines.
4039 o2adj = 1.6_rb
4041 ! Compute the optical depth by interpolating in ln(pressure),
4042 ! temperature, and appropriate species. Below LAYTROP, the water
4043 ! vapor self-continuum is interpolated (in temperature) separately.
4045 laysolfr = laytrop
4047 ! Lower atmosphere loop
4048 do lay = 1, laytrop
4049 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
4050 laysolfr = min(lay+1,laytrop)
4051 o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
4052 speccomb = colh2o(lay) + o2adj*strrat*colo2(lay)
4053 specparm = colh2o(lay)/speccomb
4054 if (specparm .ge. oneminus) specparm = oneminus
4055 specmult = 8._rb*(specparm)
4056 ! odadj = specparm + o2adj * (1._rb - specparm)
4057 js = 1 + int(specmult)
4058 fs = mod(specmult, 1._rb )
4059 fac000 = (1._rb - fs) * fac00(lay)
4060 fac010 = (1._rb - fs) * fac10(lay)
4061 fac100 = fs * fac00(lay)
4062 fac110 = fs * fac10(lay)
4063 fac001 = (1._rb - fs) * fac01(lay)
4064 fac011 = (1._rb - fs) * fac11(lay)
4065 fac101 = fs * fac01(lay)
4066 fac111 = fs * fac11(lay)
4067 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js
4068 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js
4069 inds = indself(lay)
4070 indf = indfor(lay)
4071 tauray = colmol(lay) * rayl
4073 do ig = 1, ng22
4074 taug(lay,ngs21+ig) = speccomb * &
4075 (fac000 * absa(ind0,ig) + &
4076 fac100 * absa(ind0+1,ig) + &
4077 fac010 * absa(ind0+9,ig) + &
4078 fac110 * absa(ind0+10,ig) + &
4079 fac001 * absa(ind1,ig) + &
4080 fac101 * absa(ind1+1,ig) + &
4081 fac011 * absa(ind1+9,ig) + &
4082 fac111 * absa(ind1+10,ig)) + &
4083 colh2o(lay) * &
4084 (selffac(lay) * (selfref(inds,ig) + &
4085 selffrac(lay) * &
4086 (selfref(inds+1,ig) - selfref(inds,ig))) + &
4087 forfac(lay) * (forref(indf,ig) + &
4088 forfrac(lay) * &
4089 (forref(indf+1,ig) - forref(indf,ig)))) &
4090 + o2cont
4091 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
4092 if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js) &
4093 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4094 taur(lay,ngs21+ig) = tauray
4095 enddo
4096 enddo
4098 ! Upper atmosphere loop
4099 do lay = laytrop+1, nlayers
4100 o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
4101 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1
4102 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1
4103 tauray = colmol(lay) * rayl
4105 do ig = 1, ng22
4106 taug(lay,ngs21+ig) = colo2(lay) * o2adj * &
4107 (fac00(lay) * absb(ind0,ig) + &
4108 fac10(lay) * absb(ind0+1,ig) + &
4109 fac01(lay) * absb(ind1,ig) + &
4110 fac11(lay) * absb(ind1+1,ig)) + &
4111 o2cont
4112 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
4113 taur(lay,ngs21+ig) = tauray
4114 enddo
4115 enddo
4117 end subroutine taumol22
4119 !----------------------------------------------------------------------------
4120 subroutine taumol23
4121 !----------------------------------------------------------------------------
4122 !
4123 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
4124 !
4125 !----------------------------------------------------------------------------
4127 ! ------- Modules -------
4129 use parrrsw, only : ng23, ngs22
4130 use rrsw_kg23, only : absa, ka, forref, selfref, &
4131 sfluxref, rayl, layreffr, givfac
4133 ! ------- Declarations -------
4135 ! Local
4137 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4138 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4139 fac110, fac111, fs, speccomb, specmult, specparm, &
4140 tauray
4142 ! Compute the optical depth by interpolating in ln(pressure),
4143 ! temperature, and appropriate species. Below LAYTROP, the water
4144 ! vapor self-continuum is interpolated (in temperature) separately.
4146 laysolfr = laytrop
4148 ! Lower atmosphere loop
4149 do lay = 1, laytrop
4150 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
4151 laysolfr = min(lay+1,laytrop)
4152 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1
4153 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1
4154 inds = indself(lay)
4155 indf = indfor(lay)
4157 do ig = 1, ng23
4158 tauray = colmol(lay) * rayl(ig)
4159 taug(lay,ngs22+ig) = colh2o(lay) * &
4160 (givfac * (fac00(lay) * absa(ind0,ig) + &
4161 fac10(lay) * absa(ind0+1,ig) + &
4162 fac01(lay) * absa(ind1,ig) + &
4163 fac11(lay) * absa(ind1+1,ig)) + &
4164 selffac(lay) * (selfref(inds,ig) + &
4165 selffrac(lay) * &
4166 (selfref(inds+1,ig) - selfref(inds,ig))) + &
4167 forfac(lay) * (forref(indf,ig) + &
4168 forfrac(lay) * &
4169 (forref(indf+1,ig) - forref(indf,ig))))
4170 ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
4171 if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig)
4172 taur(lay,ngs22+ig) = tauray
4173 enddo
4174 enddo
4176 ! Upper atmosphere loop
4177 do lay = laytrop+1, nlayers
4178 do ig = 1, ng23
4179 ! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
4180 ! ssa(lay,ngs22+ig) = 1.0_rb
4181 taug(lay,ngs22+ig) = 0._rb
4182 taur(lay,ngs22+ig) = colmol(lay) * rayl(ig)
4183 enddo
4184 enddo
4186 end subroutine taumol23
4188 !----------------------------------------------------------------------------
4189 subroutine taumol24
4190 !----------------------------------------------------------------------------
4191 !
4192 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
4193 !
4194 !----------------------------------------------------------------------------
4196 ! ------- Modules -------
4198 use parrrsw, only : ng24, ngs23
4199 use rrsw_kg24, only : absa, ka, absb, kb, forref, selfref, &
4200 sfluxref, abso3a, abso3b, rayla, raylb, &
4201 layreffr, strrat
4203 ! ------- Declarations -------
4205 ! Local
4207 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4208 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4209 fac110, fac111, fs, speccomb, specmult, specparm, &
4210 tauray
4212 ! Compute the optical depth by interpolating in ln(pressure),
4213 ! temperature, and appropriate species. Below LAYTROP, the water
4214 ! vapor self-continuum is interpolated (in temperature) separately.
4216 laysolfr = laytrop
4218 ! Lower atmosphere loop
4219 do lay = 1, laytrop
4220 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
4221 laysolfr = min(lay+1,laytrop)
4222 speccomb = colh2o(lay) + strrat*colo2(lay)
4223 specparm = colh2o(lay)/speccomb
4224 if (specparm .ge. oneminus) specparm = oneminus
4225 specmult = 8._rb*(specparm)
4226 js = 1 + int(specmult)
4227 fs = mod(specmult, 1._rb )
4228 fac000 = (1._rb - fs) * fac00(lay)
4229 fac010 = (1._rb - fs) * fac10(lay)
4230 fac100 = fs * fac00(lay)
4231 fac110 = fs * fac10(lay)
4232 fac001 = (1._rb - fs) * fac01(lay)
4233 fac011 = (1._rb - fs) * fac11(lay)
4234 fac101 = fs * fac01(lay)
4235 fac111 = fs * fac11(lay)
4236 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js
4237 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js
4238 inds = indself(lay)
4239 indf = indfor(lay)
4241 do ig = 1, ng24
4242 tauray = colmol(lay) * (rayla(ig,js) + &
4243 fs * (rayla(ig,js+1) - rayla(ig,js)))
4244 taug(lay,ngs23+ig) = speccomb * &
4245 (fac000 * absa(ind0,ig) + &
4246 fac100 * absa(ind0+1,ig) + &
4247 fac010 * absa(ind0+9,ig) + &
4248 fac110 * absa(ind0+10,ig) + &
4249 fac001 * absa(ind1,ig) + &
4250 fac101 * absa(ind1+1,ig) + &
4251 fac011 * absa(ind1+9,ig) + &
4252 fac111 * absa(ind1+10,ig)) + &
4253 colo3(lay) * abso3a(ig) + &
4254 colh2o(lay) * &
4255 (selffac(lay) * (selfref(inds,ig) + &
4256 selffrac(lay) * &
4257 (selfref(inds+1,ig) - selfref(inds,ig))) + &
4258 forfac(lay) * (forref(indf,ig) + &
4259 forfrac(lay) * &
4260 (forref(indf+1,ig) - forref(indf,ig))))
4261 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
4262 if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js) &
4263 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4264 taur(lay,ngs23+ig) = tauray
4265 enddo
4266 enddo
4268 ! Upper atmosphere loop
4269 do lay = laytrop+1, nlayers
4270 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1
4271 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1
4273 do ig = 1, ng24
4274 tauray = colmol(lay) * raylb(ig)
4275 taug(lay,ngs23+ig) = colo2(lay) * &
4276 (fac00(lay) * absb(ind0,ig) + &
4277 fac10(lay) * absb(ind0+1,ig) + &
4278 fac01(lay) * absb(ind1,ig) + &
4279 fac11(lay) * absb(ind1+1,ig)) + &
4280 colo3(lay) * abso3b(ig)
4281 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
4282 taur(lay,ngs23+ig) = tauray
4283 enddo
4284 enddo
4286 end subroutine taumol24
4288 !----------------------------------------------------------------------------
4289 subroutine taumol25
4290 !----------------------------------------------------------------------------
4291 !
4292 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
4293 !
4294 !----------------------------------------------------------------------------
4296 ! ------- Modules -------
4298 use parrrsw, only : ng25, ngs24
4299 use rrsw_kg25, only : absa, ka, &
4300 sfluxref, abso3a, abso3b, rayl, layreffr
4302 ! ------- Declarations -------
4304 ! Local
4306 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4307 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4308 fac110, fac111, fs, speccomb, specmult, specparm, &
4309 tauray
4311 ! Compute the optical depth by interpolating in ln(pressure),
4312 ! temperature, and appropriate species. Below LAYTROP, the water
4313 ! vapor self-continuum is interpolated (in temperature) separately.
4315 laysolfr = laytrop
4317 ! Lower atmosphere loop
4318 do lay = 1, laytrop
4319 if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
4320 laysolfr = min(lay+1,laytrop)
4321 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1
4322 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1
4324 do ig = 1, ng25
4325 tauray = colmol(lay) * rayl(ig)
4326 taug(lay,ngs24+ig) = colh2o(lay) * &
4327 (fac00(lay) * absa(ind0,ig) + &
4328 fac10(lay) * absa(ind0+1,ig) + &
4329 fac01(lay) * absa(ind1,ig) + &
4330 fac11(lay) * absa(ind1+1,ig)) + &
4331 colo3(lay) * abso3a(ig)
4332 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
4333 if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig)
4334 taur(lay,ngs24+ig) = tauray
4335 enddo
4336 enddo
4338 ! Upper atmosphere loop
4339 do lay = laytrop+1, nlayers
4340 do ig = 1, ng25
4341 tauray = colmol(lay) * rayl(ig)
4342 taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig)
4343 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
4344 taur(lay,ngs24+ig) = tauray
4345 enddo
4346 enddo
4348 end subroutine taumol25
4350 !----------------------------------------------------------------------------
4351 subroutine taumol26
4352 !----------------------------------------------------------------------------
4353 !
4354 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
4355 !
4356 !----------------------------------------------------------------------------
4358 ! ------- Modules -------
4360 use parrrsw, only : ng26, ngs25
4361 use rrsw_kg26, only : sfluxref, rayl
4363 ! ------- Declarations -------
4365 ! Local
4367 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4368 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4369 fac110, fac111, fs, speccomb, specmult, specparm, &
4370 tauray
4372 ! Compute the optical depth by interpolating in ln(pressure),
4373 ! temperature, and appropriate species. Below LAYTROP, the water
4374 ! vapor self-continuum is interpolated (in temperature) separately.
4376 laysolfr = laytrop
4378 ! Lower atmosphere loop
4379 do lay = 1, laytrop
4380 do ig = 1, ng26
4381 ! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4382 ! ssa(lay,ngs25+ig) = 1.0_rb
4383 if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig)
4384 taug(lay,ngs25+ig) = 0._rb
4385 taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4386 enddo
4387 enddo
4389 ! Upper atmosphere loop
4390 do lay = laytrop+1, nlayers
4391 do ig = 1, ng26
4392 ! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4393 ! ssa(lay,ngs25+ig) = 1.0_rb
4394 taug(lay,ngs25+ig) = 0._rb
4395 taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4396 enddo
4397 enddo
4399 end subroutine taumol26
4401 !----------------------------------------------------------------------------
4402 subroutine taumol27
4403 !----------------------------------------------------------------------------
4404 !
4405 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
4406 !
4407 !----------------------------------------------------------------------------
4409 ! ------- Modules -------
4411 use parrrsw, only : ng27, ngs26
4412 use rrsw_kg27, only : absa, ka, absb, kb, &
4413 sfluxref, rayl, layreffr, scalekur
4415 ! ------- Declarations -------
4417 ! Local
4419 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4420 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4421 fac110, fac111, fs, speccomb, specmult, specparm, &
4422 tauray
4424 ! Compute the optical depth by interpolating in ln(pressure),
4425 ! temperature, and appropriate species. Below LAYTROP, the water
4426 ! vapor self-continuum is interpolated (in temperature) separately.
4428 ! Lower atmosphere loop
4429 do lay = 1, laytrop
4430 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1
4431 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1
4433 do ig = 1, ng27
4434 tauray = colmol(lay) * rayl(ig)
4435 taug(lay,ngs26+ig) = colo3(lay) * &
4436 (fac00(lay) * absa(ind0,ig) + &
4437 fac10(lay) * absa(ind0+1,ig) + &
4438 fac01(lay) * absa(ind1,ig) + &
4439 fac11(lay) * absa(ind1+1,ig))
4440 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
4441 taur(lay,ngs26+ig) = tauray
4442 enddo
4443 enddo
4445 laysolfr = nlayers
4447 ! Upper atmosphere loop
4448 do lay = laytrop+1, nlayers
4449 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
4450 laysolfr = lay
4451 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1
4452 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1
4454 do ig = 1, ng27
4455 tauray = colmol(lay) * rayl(ig)
4456 taug(lay,ngs26+ig) = colo3(lay) * &
4457 (fac00(lay) * absb(ind0,ig) + &
4458 fac10(lay) * absb(ind0+1,ig) + &
4459 fac01(lay) * absb(ind1,ig) + &
4460 fac11(lay) * absb(ind1+1,ig))
4461 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
4462 if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig)
4463 taur(lay,ngs26+ig) = tauray
4464 enddo
4465 enddo
4467 end subroutine taumol27
4469 !----------------------------------------------------------------------------
4470 subroutine taumol28
4471 !----------------------------------------------------------------------------
4472 !
4473 ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
4474 !
4475 !----------------------------------------------------------------------------
4477 ! ------- Modules -------
4479 use parrrsw, only : ng28, ngs27
4480 use rrsw_kg28, only : absa, ka, absb, kb, &
4481 sfluxref, rayl, layreffr, strrat
4483 ! ------- Declarations -------
4485 ! Local
4487 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4488 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4489 fac110, fac111, fs, speccomb, specmult, specparm, &
4490 tauray
4492 ! Compute the optical depth by interpolating in ln(pressure),
4493 ! temperature, and appropriate species. Below LAYTROP, the water
4494 ! vapor self-continuum is interpolated (in temperature) separately.
4496 ! Lower atmosphere loop
4497 do lay = 1, laytrop
4498 speccomb = colo3(lay) + strrat*colo2(lay)
4499 specparm = colo3(lay)/speccomb
4500 if (specparm .ge. oneminus) specparm = oneminus
4501 specmult = 8._rb*(specparm)
4502 js = 1 + int(specmult)
4503 fs = mod(specmult, 1._rb )
4504 fac000 = (1._rb - fs) * fac00(lay)
4505 fac010 = (1._rb - fs) * fac10(lay)
4506 fac100 = fs * fac00(lay)
4507 fac110 = fs * fac10(lay)
4508 fac001 = (1._rb - fs) * fac01(lay)
4509 fac011 = (1._rb - fs) * fac11(lay)
4510 fac101 = fs * fac01(lay)
4511 fac111 = fs * fac11(lay)
4512 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js
4513 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js
4514 tauray = colmol(lay) * rayl
4516 do ig = 1, ng28
4517 taug(lay,ngs27+ig) = speccomb * &
4518 (fac000 * absa(ind0,ig) + &
4519 fac100 * absa(ind0+1,ig) + &
4520 fac010 * absa(ind0+9,ig) + &
4521 fac110 * absa(ind0+10,ig) + &
4522 fac001 * absa(ind1,ig) + &
4523 fac101 * absa(ind1+1,ig) + &
4524 fac011 * absa(ind1+9,ig) + &
4525 fac111 * absa(ind1+10,ig))
4526 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
4527 taur(lay,ngs27+ig) = tauray
4528 enddo
4529 enddo
4531 laysolfr = nlayers
4533 ! Upper atmosphere loop
4534 do lay = laytrop+1, nlayers
4535 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
4536 laysolfr = lay
4537 speccomb = colo3(lay) + strrat*colo2(lay)
4538 specparm = colo3(lay)/speccomb
4539 if (specparm .ge. oneminus) specparm = oneminus
4540 specmult = 4._rb*(specparm)
4541 js = 1 + int(specmult)
4542 fs = mod(specmult, 1._rb )
4543 fac000 = (1._rb - fs) * fac00(lay)
4544 fac010 = (1._rb - fs) * fac10(lay)
4545 fac100 = fs * fac00(lay)
4546 fac110 = fs * fac10(lay)
4547 fac001 = (1._rb - fs) * fac01(lay)
4548 fac011 = (1._rb - fs) * fac11(lay)
4549 fac101 = fs * fac01(lay)
4550 fac111 = fs * fac11(lay)
4551 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js
4552 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js
4553 tauray = colmol(lay) * rayl
4555 do ig = 1, ng28
4556 taug(lay,ngs27+ig) = speccomb * &
4557 (fac000 * absb(ind0,ig) + &
4558 fac100 * absb(ind0+1,ig) + &
4559 fac010 * absb(ind0+5,ig) + &
4560 fac110 * absb(ind0+6,ig) + &
4561 fac001 * absb(ind1,ig) + &
4562 fac101 * absb(ind1+1,ig) + &
4563 fac011 * absb(ind1+5,ig) + &
4564 fac111 * absb(ind1+6,ig))
4565 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
4566 if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js) &
4567 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4568 taur(lay,ngs27+ig) = tauray
4569 enddo
4570 enddo
4572 end subroutine taumol28
4574 !----------------------------------------------------------------------------
4575 subroutine taumol29
4576 !----------------------------------------------------------------------------
4577 !
4578 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
4579 !
4580 !----------------------------------------------------------------------------
4582 ! ------- Modules -------
4584 use parrrsw, only : ng29, ngs28
4585 use rrsw_kg29, only : absa, ka, absb, kb, forref, selfref, &
4586 sfluxref, absh2o, absco2, rayl, layreffr
4588 ! ------- Declarations -------
4590 ! Local
4592 integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4593 real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
4594 fac110, fac111, fs, speccomb, specmult, specparm, &
4595 tauray
4597 ! Compute the optical depth by interpolating in ln(pressure),
4598 ! temperature, and appropriate species. Below LAYTROP, the water
4599 ! vapor self-continuum is interpolated (in temperature) separately.
4601 ! Lower atmosphere loop
4602 do lay = 1, laytrop
4603 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1
4604 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1
4605 inds = indself(lay)
4606 indf = indfor(lay)
4607 tauray = colmol(lay) * rayl
4609 do ig = 1, ng29
4610 taug(lay,ngs28+ig) = colh2o(lay) * &
4611 ((fac00(lay) * absa(ind0,ig) + &
4612 fac10(lay) * absa(ind0+1,ig) + &
4613 fac01(lay) * absa(ind1,ig) + &
4614 fac11(lay) * absa(ind1+1,ig)) + &
4615 selffac(lay) * (selfref(inds,ig) + &
4616 selffrac(lay) * &
4617 (selfref(inds+1,ig) - selfref(inds,ig))) + &
4618 forfac(lay) * (forref(indf,ig) + &
4619 forfrac(lay) * &
4620 (forref(indf+1,ig) - forref(indf,ig)))) &
4621 + colco2(lay) * absco2(ig)
4622 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4623 taur(lay,ngs28+ig) = tauray
4624 enddo
4625 enddo
4627 laysolfr = nlayers
4629 ! Upper atmosphere loop
4630 do lay = laytrop+1, nlayers
4631 if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
4632 laysolfr = lay
4633 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1
4634 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1
4635 tauray = colmol(lay) * rayl
4637 do ig = 1, ng29
4638 taug(lay,ngs28+ig) = colco2(lay) * &
4639 (fac00(lay) * absb(ind0,ig) + &
4640 fac10(lay) * absb(ind0+1,ig) + &
4641 fac01(lay) * absb(ind1,ig) + &
4642 fac11(lay) * absb(ind1+1,ig)) &
4643 + colh2o(lay) * absh2o(ig)
4644 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4645 if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig)
4646 taur(lay,ngs28+ig) = tauray
4647 enddo
4648 enddo
4650 end subroutine taumol29
4652 end subroutine taumol_sw
4654 end module rrtmg_sw_taumol
4656 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
4657 ! author: $Author: trn $
4658 ! revision: $Revision: 1.3 $
4659 ! created: $Date: 2009/04/16 19:54:22 $
4661 module rrtmg_sw_init
4663 ! --------------------------------------------------------------------------
4664 ! | |
4665 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
4666 ! | This software may be used, copied, or redistributed as long as it is |
4667 ! | not sold and this copyright notice is reproduced on each copy made. |
4668 ! | This model is provided as is without any express or implied warranties. |
4669 ! | (http://www.rtweb.aer.com/) |
4670 ! | |
4671 ! --------------------------------------------------------------------------
4673 ! ------- Modules -------
4674 use parkind, only : im => kind_im, rb => kind_rb
4675 use rrsw_wvn
4676 use rrtmg_sw_setcoef, only: swatmref
4678 implicit none
4680 contains
4682 ! **************************************************************************
4683 subroutine rrtmg_sw_ini(cpdair)
4684 ! **************************************************************************
4685 !
4686 ! Original version: Michael J. Iacono; February, 2004
4687 ! Revision for F90 formatting: M. J. Iacono, July, 2006
4688 !
4689 ! This subroutine performs calculations necessary for the initialization
4690 ! of the shortwave model. Lookup tables are computed for use in the SW
4691 ! radiative transfer, and input absorption coefficient data for each
4692 ! spectral band are reduced from 224 g-point intervals to 112.
4693 ! **************************************************************************
4695 use parrrsw, only : mg, nbndsw, ngptsw
4696 use rrsw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
4697 use rrsw_vsn, only: hvrini, hnamini
4699 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
4700 ! at constant pressure at 273 K
4701 ! (J kg-1 K-1)
4703 ! ------- Local -------
4705 integer(kind=im) :: ibnd, igc, ig, ind, ipr
4706 integer(kind=im) :: igcsm, iprsm
4707 integer(kind=im) :: itr
4709 real(kind=rb) :: wtsum, wtsm(mg)
4710 real(kind=rb) :: tfn
4712 real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table
4714 ! ------- Definitions -------
4715 ! Arrays for 10000-point look-up tables:
4716 ! TAU_TBL Clear-sky optical depth
4717 ! EXP_TBL Exponential lookup table for transmittance
4718 ! PADE Pade approximation constant (= 0.278)
4719 ! BPADE Inverse of the Pade approximation constant
4720 !
4722 !jm not thread safe hvrini = '$Revision: 1.3 $'
4724 ! Initialize model data
4725 call swdatinit(cpdair)
4726 call swcmbdat ! g-point interval reduction data
4727 call swaerpr ! aerosol optical properties
4728 call swcldpr ! cloud optical properties
4729 call swatmref ! reference MLS profile
4730 ! Moved to module_ra_rrtmg_sw for WRF
4731 ! call sw_kgb16 ! molecular absorption coefficients
4732 ! call sw_kgb17
4733 ! call sw_kgb18
4734 ! call sw_kgb19
4735 ! call sw_kgb20
4736 ! call sw_kgb21
4737 ! call sw_kgb22
4738 ! call sw_kgb23
4739 ! call sw_kgb24
4740 ! call sw_kgb25
4741 ! call sw_kgb26
4742 ! call sw_kgb27
4743 ! call sw_kgb28
4744 ! call sw_kgb29
4746 ! Define exponential lookup tables for transmittance. Tau is
4747 ! computed as a function of the tau transition function, and transmittance
4748 ! is calculated as a function of tau. All tables are computed at intervals
4749 ! of 0.0001. The inverse of the constant used in the Pade approximation to
4750 ! the tau transition function is set to bpade.
4752 exp_tbl(0) = 1.0_rb
4753 exp_tbl(ntbl) = expeps
4754 bpade = 1.0_rb / pade
4755 do itr = 1, ntbl-1
4756 tfn = float(itr) / float(ntbl)
4757 tau_tbl = bpade * tfn / (1._rb - tfn)
4758 exp_tbl(itr) = exp(-tau_tbl)
4759 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
4760 enddo
4762 ! Perform g-point reduction from 16 per band (224 total points) to
4763 ! a band dependent number (112 total points) for all absorption
4764 ! coefficient input data and Planck fraction input data.
4765 ! Compute relative weighting for new g-point combinations.
4767 igcsm = 0
4768 do ibnd = 1,nbndsw
4769 iprsm = 0
4770 if (ngc(ibnd).lt.mg) then
4771 do igc = 1,ngc(ibnd)
4772 igcsm = igcsm + 1
4773 wtsum = 0.
4774 do ipr = 1, ngn(igcsm)
4775 iprsm = iprsm + 1
4776 wtsum = wtsum + wt(iprsm)
4777 enddo
4778 wtsm(igc) = wtsum
4779 enddo
4780 do ig = 1, ng(ibnd+15)
4781 ind = (ibnd-1)*mg + ig
4782 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
4783 enddo
4784 else
4785 do ig = 1, ng(ibnd+15)
4786 igcsm = igcsm + 1
4787 ind = (ibnd-1)*mg + ig
4788 rwgt(ind) = 1.0_rb
4789 enddo
4790 endif
4791 enddo
4793 ! Reduce g-points for absorption coefficient data in each LW spectral band.
4795 call cmbgb16s
4796 call cmbgb17
4797 call cmbgb18
4798 call cmbgb19
4799 call cmbgb20
4800 call cmbgb21
4801 call cmbgb22
4802 call cmbgb23
4803 call cmbgb24
4804 call cmbgb25
4805 call cmbgb26
4806 call cmbgb27
4807 call cmbgb28
4808 call cmbgb29
4810 end subroutine rrtmg_sw_ini
4812 !***************************************************************************
4813 subroutine swdatinit(cpdair)
4814 !***************************************************************************
4816 ! --------- Modules ----------
4818 use rrsw_con, only: heatfac, grav, planck, boltz, &
4819 clight, avogad, alosmt, gascon, radcn1, radcn2, &
4820 sbcnst, secdy, oneminus, pi
4821 use rrsw_vsn
4823 save
4825 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
4826 ! at constant pressure at 273 K
4827 ! (J kg-1 K-1)
4829 ! Shortwave spectral band limits (wavenumbers)
4830 wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, &
4831 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb, 820._rb/)
4832 wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, 8050._rb, &
4833 12850._rb,16000._rb,22650._rb,29000._rb,38000._rb,50000._rb, 2600._rb/)
4834 delwave(:) = (/ 650._rb, 750._rb, 650._rb, 500._rb, 1000._rb, 1550._rb, 350._rb, &
4835 4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb,12000._rb, 1780._rb/)
4837 ! Spectral band information
4838 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
4839 nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
4840 nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
4842 ! Fundamental physical constants from NIST 2002
4844 grav = 9.8066_rb ! Acceleration of gravity
4845 ! (m s-2)
4846 planck = 6.62606876e-27_rb ! Planck constant
4847 ! (ergs s; g cm2 s-1)
4848 boltz = 1.3806503e-16_rb ! Boltzmann constant
4849 ! (ergs K-1; g cm2 s-2 K-1)
4850 clight = 2.99792458e+10_rb ! Speed of light in a vacuum
4851 ! (cm s-1)
4852 avogad = 6.02214199e+23_rb ! Avogadro constant
4853 ! (mol-1)
4854 alosmt = 2.6867775e+19_rb ! Loschmidt constant
4855 ! (cm-3)
4856 gascon = 8.31447200e+07_rb ! Molar gas constant
4857 ! (ergs mol-1 K-1)
4858 radcn1 = 1.191042772e-12_rb ! First radiation constant
4859 ! (W cm2 sr-1)
4860 radcn2 = 1.4387752_rb ! Second radiation constant
4861 ! (cm K)
4862 sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
4863 ! (W cm-2 K-4)
4864 secdy = 8.6400e4_rb ! Number of seconds per day
4865 ! (s d-1)
4867 !jm 20141107 moved here for thread safety
4868 oneminus = 1.0_rb - 1.e-06_rb ! zepsec
4869 pi = 2._rb * asin(1._rb)
4871 !
4872 ! units are generally cgs
4873 !
4874 ! The first and second radiation constants are taken from NIST.
4875 ! They were previously obtained from the relations:
4876 ! radcn1 = 2.*planck*clight*clight*1.e-07
4877 ! radcn2 = planck*clight/boltz
4879 ! Heatfac is the factor by which delta-flux / delta-pressure is
4880 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
4881 ! the heating rate in units of degrees/day. It is equal to:
4882 ! Original value:
4883 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4884 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
4885 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4886 ! = (9.8066)(86400)(1e-5)/(1.004)
4887 ! heatfac = 8.4391_rb
4888 !
4889 ! Modified value for consistency with CAM3:
4890 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4891 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
4892 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4893 ! = (9.80616)(86400)(1e-5)/(1.00464)
4894 ! heatfac = 8.43339130434_rb
4895 !
4896 ! Calculated value (from constants above and input cpdair)
4897 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
4898 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
4899 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
4900 heatfac = grav * secdy / (cpdair * 1.e2_rb)
4902 end subroutine swdatinit
4904 !***************************************************************************
4905 subroutine swcmbdat
4906 !***************************************************************************
4908 save
4910 ! ------- Definitions -------
4911 ! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
4912 ! This mapping from 224 to 112 points has been carefully selected to
4913 ! minimize the effect on the resulting fluxes and cooling rates, and
4914 ! caution should be used if the mapping is modified. The full 224
4915 ! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
4916 ! ngpt The total number of new g-points
4917 ! ngc The number of new g-points in each band
4918 ! ngs The cumulative sum of new g-points for each band
4919 ! ngm The index of each new g-point relative to the original
4920 ! 16 g-points for each band.
4921 ! ngn The number of original g-points that are combined to make
4922 ! each new g-point in each band.
4923 ! ngb The band index for each new g-point.
4924 ! wt RRTM weights for 16 g-points.
4926 ! Use this set for 112 quadrature point (g-point) model
4927 ! ------- Data statements -------
4928 ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
4929 ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
4930 ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16
4931 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17
4932 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18
4933 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19
4934 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20
4935 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21
4936 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22
4937 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23
4938 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24
4939 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25
4940 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26
4941 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27
4942 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28
4943 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29
4944 ngn(:) = (/ 2,2,2,2,4,4, & ! band 16
4945 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17
4946 1,1,1,1,2,2,4,4, & ! band 18
4947 1,1,1,1,2,2,4,4, & ! band 19
4948 1,1,1,1,1,1,1,1,2,6, & ! band 20
4949 1,1,1,1,1,1,1,1,2,6, & ! band 21
4950 8,8, & ! band 22
4951 2,2,1,1,1,1,1,1,2,4, & ! band 23
4952 2,2,2,2,2,2,2,2, & ! band 24
4953 1,1,2,2,4,6, & ! band 25
4954 1,1,2,2,4,6, & ! band 26
4955 1,1,1,1,1,1,4,6, & ! band 27
4956 1,1,2,2,4,6, & ! band 28
4957 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29
4958 ngb(:) = (/ 16,16,16,16,16,16, & ! band 16
4959 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
4960 18,18,18,18,18,18,18,18, & ! band 18
4961 19,19,19,19,19,19,19,19, & ! band 19
4962 20,20,20,20,20,20,20,20,20,20, & ! band 20
4963 21,21,21,21,21,21,21,21,21,21, & ! band 21
4964 22,22, & ! band 22
4965 23,23,23,23,23,23,23,23,23,23, & ! band 23
4966 24,24,24,24,24,24,24,24, & ! band 24
4967 25,25,25,25,25,25, & ! band 25
4968 26,26,26,26,26,26, & ! band 26
4969 27,27,27,27,27,27,27,27, & ! band 27
4970 28,28,28,28,28,28, & ! band 28
4971 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
4973 ! Use this set for full 224 quadrature point (g-point) model
4974 ! ------- Data statements -------
4975 ! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
4976 ! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
4977 ! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
4978 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
4979 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
4980 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
4981 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
4982 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
4983 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
4984 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
4985 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
4986 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
4987 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
4988 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
4989 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
4990 ! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
4991 ! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
4992 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
4993 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
4994 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
4995 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
4996 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
4997 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
4998 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
4999 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
5000 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
5001 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
5002 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
5003 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
5004 ! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
5005 ! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
5006 ! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
5007 ! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
5008 ! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
5009 ! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
5010 ! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
5011 ! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
5012 ! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
5013 ! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
5014 ! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
5015 ! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
5016 ! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
5017 ! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
5018 ! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
5021 wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
5022 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
5023 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
5024 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
5025 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
5026 0.0000750000_rb /)
5028 end subroutine swcmbdat
5030 !***************************************************************************
5031 subroutine swaerpr
5032 !***************************************************************************
5034 ! Purpose: Define spectral aerosol properties for six ECMWF aerosol types
5035 ! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
5036 !
5037 ! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003
5038 ! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
5040 use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
5042 save
5044 rsrtaua( 1, :) = (/ &
5045 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
5046 rsrtaua( 2, :) = (/ &
5047 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
5048 rsrtaua( 3, :) = (/ &
5049 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
5050 rsrtaua( 4, :) = (/ &
5051 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
5052 rsrtaua( 5, :) = (/ &
5053 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
5054 rsrtaua( 6, :) = (/ &
5055 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
5056 rsrtaua( 7, :) = (/ &
5057 0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
5058 rsrtaua( 8, :) = (/ &
5059 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
5060 rsrtaua( 9, :) = (/ &
5061 0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
5062 rsrtaua(10, :) = (/ &
5063 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
5064 rsrtaua(11, :) = (/ &
5065 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
5066 rsrtaua(12, :) = (/ &
5067 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
5068 rsrtaua(13, :) = (/ &
5069 1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
5070 rsrtaua(14, :) = (/ &
5071 0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
5073 rsrpiza( 1, :) = (/ &
5074 .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
5075 rsrpiza( 2, :) = (/ &
5076 .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
5077 rsrpiza( 3, :) = (/ &
5078 .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
5079 rsrpiza( 4, :) = (/ &
5080 .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
5081 rsrpiza( 5, :) = (/ &
5082 .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
5083 rsrpiza( 6, :) = (/ &
5084 .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
5085 rsrpiza( 7, :) = (/ &
5086 .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
5087 rsrpiza( 8, :) = (/ &
5088 .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
5089 rsrpiza( 9, :) = (/ &
5090 .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
5091 rsrpiza(10, :) = (/ &
5092 .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
5093 rsrpiza(11, :) = (/ &
5094 .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
5095 rsrpiza(12, :) = (/ &
5096 .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
5097 rsrpiza(13, :) = (/ &
5098 .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
5099 rsrpiza(14, :) = (/ &
5100 .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
5102 rsrasya( 1, :) = (/ &
5103 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
5104 rsrasya( 2, :) = (/ &
5105 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
5106 rsrasya( 3, :) = (/ &
5107 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
5108 rsrasya( 4, :) = (/ &
5109 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
5110 rsrasya( 5, :) = (/ &
5111 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
5112 rsrasya( 6, :) = (/ &
5113 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
5114 rsrasya( 7, :) = (/ &
5115 0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
5116 rsrasya( 8, :) = (/ &
5117 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
5118 rsrasya( 9, :) = (/ &
5119 0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
5120 rsrasya(10, :) = (/ &
5121 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
5122 rsrasya(11, :) = (/ &
5123 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
5124 rsrasya(12, :) = (/ &
5125 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
5126 rsrasya(13, :) = (/ &
5127 0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
5128 rsrasya(14, :) = (/ &
5129 0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
5131 end subroutine swaerpr
5133 !***************************************************************************
5134 subroutine cmbgb16s
5135 !***************************************************************************
5136 !
5137 ! Original version: MJIacono; July 1998
5138 ! Revision for RRTM_SW: MJIacono; November 2002
5139 ! Revision for RRTMG_SW: MJIacono; December 2003
5140 ! Revision for F90 reformatting: MJIacono; July 2006
5141 !
5142 ! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
5143 ! data for each band, which are defined for 16 g-points and 14 spectral
5144 ! bands. The data are combined with appropriate weighting following the
5145 ! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
5146 ! function data in array SFLUXREF are combined without weighting. All
5147 ! g-point reduced data are put into new arrays for use in RRTMG_SW.
5148 !
5149 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
5150 !
5151 !-----------------------------------------------------------------------
5153 use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5154 absa, ka, absb, kb, selfref, forref, sfluxref
5156 ! ------- Local -------
5157 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5158 real(kind=rb) :: sumk, sumf
5161 do jn = 1,9
5162 do jt = 1,5
5163 do jp = 1,13
5164 iprsm = 0
5165 do igc = 1,ngc(1)
5166 sumk = 0.
5167 do ipr = 1, ngn(igc)
5168 iprsm = iprsm + 1
5169 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
5170 enddo
5171 ka(jn,jt,jp,igc) = sumk
5172 enddo
5173 enddo
5174 enddo
5175 enddo
5177 do jt = 1,5
5178 do jp = 13,59
5179 iprsm = 0
5180 do igc = 1,ngc(1)
5181 sumk = 0.
5182 do ipr = 1, ngn(igc)
5183 iprsm = iprsm + 1
5184 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
5185 enddo
5186 kb(jt,jp,igc) = sumk
5187 enddo
5188 enddo
5189 enddo
5191 do jt = 1,10
5192 iprsm = 0
5193 do igc = 1,ngc(1)
5194 sumk = 0.
5195 do ipr = 1, ngn(igc)
5196 iprsm = iprsm + 1
5197 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
5198 enddo
5199 selfref(jt,igc) = sumk
5200 enddo
5201 enddo
5203 do jt = 1,3
5204 iprsm = 0
5205 do igc = 1,ngc(1)
5206 sumk = 0.
5207 do ipr = 1, ngn(igc)
5208 iprsm = iprsm + 1
5209 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
5210 enddo
5211 forref(jt,igc) = sumk
5212 enddo
5213 enddo
5215 iprsm = 0
5216 do igc = 1,ngc(1)
5217 sumf = 0.
5218 do ipr = 1, ngn(igc)
5219 iprsm = iprsm + 1
5220 sumf = sumf + sfluxrefo(iprsm)
5221 enddo
5222 sfluxref(igc) = sumf
5223 enddo
5225 end subroutine cmbgb16s
5227 !***************************************************************************
5228 subroutine cmbgb17
5229 !***************************************************************************
5230 !
5231 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
5232 !-----------------------------------------------------------------------
5234 use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5235 absa, ka, absb, kb, selfref, forref, sfluxref
5237 ! ------- Local -------
5238 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5239 real(kind=rb) :: sumk, sumf
5242 do jn = 1,9
5243 do jt = 1,5
5244 do jp = 1,13
5245 iprsm = 0
5246 do igc = 1,ngc(2)
5247 sumk = 0.
5248 do ipr = 1, ngn(ngs(1)+igc)
5249 iprsm = iprsm + 1
5250 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
5251 enddo
5252 ka(jn,jt,jp,igc) = sumk
5253 enddo
5254 enddo
5255 enddo
5256 enddo
5258 do jn = 1,5
5259 do jt = 1,5
5260 do jp = 13,59
5261 iprsm = 0
5262 do igc = 1,ngc(2)
5263 sumk = 0.
5264 do ipr = 1, ngn(ngs(1)+igc)
5265 iprsm = iprsm + 1
5266 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
5267 enddo
5268 kb(jn,jt,jp,igc) = sumk
5269 enddo
5270 enddo
5271 enddo
5272 enddo
5274 do jt = 1,10
5275 iprsm = 0
5276 do igc = 1,ngc(2)
5277 sumk = 0.
5278 do ipr = 1, ngn(ngs(1)+igc)
5279 iprsm = iprsm + 1
5280 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
5281 enddo
5282 selfref(jt,igc) = sumk
5283 enddo
5284 enddo
5286 do jt = 1,4
5287 iprsm = 0
5288 do igc = 1,ngc(2)
5289 sumk = 0.
5290 do ipr = 1, ngn(ngs(1)+igc)
5291 iprsm = iprsm + 1
5292 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
5293 enddo
5294 forref(jt,igc) = sumk
5295 enddo
5296 enddo
5298 do jp = 1,5
5299 iprsm = 0
5300 do igc = 1,ngc(2)
5301 sumf = 0.
5302 do ipr = 1, ngn(ngs(1)+igc)
5303 iprsm = iprsm + 1
5304 sumf = sumf + sfluxrefo(iprsm,jp)
5305 enddo
5306 sfluxref(igc,jp) = sumf
5307 enddo
5308 enddo
5310 end subroutine cmbgb17
5312 !***************************************************************************
5313 subroutine cmbgb18
5314 !***************************************************************************
5315 !
5316 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
5317 !-----------------------------------------------------------------------
5319 use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5320 absa, ka, absb, kb, selfref, forref, sfluxref
5322 ! ------- Local -------
5323 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5324 real(kind=rb) :: sumk, sumf
5327 do jn = 1,9
5328 do jt = 1,5
5329 do jp = 1,13
5330 iprsm = 0
5331 do igc = 1,ngc(3)
5332 sumk = 0.
5333 do ipr = 1, ngn(ngs(2)+igc)
5334 iprsm = iprsm + 1
5335 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
5336 enddo
5337 ka(jn,jt,jp,igc) = sumk
5338 enddo
5339 enddo
5340 enddo
5341 enddo
5343 do jt = 1,5
5344 do jp = 13,59
5345 iprsm = 0
5346 do igc = 1,ngc(3)
5347 sumk = 0.
5348 do ipr = 1, ngn(ngs(2)+igc)
5349 iprsm = iprsm + 1
5350 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
5351 enddo
5352 kb(jt,jp,igc) = sumk
5353 enddo
5354 enddo
5355 enddo
5357 do jt = 1,10
5358 iprsm = 0
5359 do igc = 1,ngc(3)
5360 sumk = 0.
5361 do ipr = 1, ngn(ngs(2)+igc)
5362 iprsm = iprsm + 1
5363 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
5364 enddo
5365 selfref(jt,igc) = sumk
5366 enddo
5367 enddo
5369 do jt = 1,3
5370 iprsm = 0
5371 do igc = 1,ngc(3)
5372 sumk = 0.
5373 do ipr = 1, ngn(ngs(2)+igc)
5374 iprsm = iprsm + 1
5375 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
5376 enddo
5377 forref(jt,igc) = sumk
5378 enddo
5379 enddo
5381 do jp = 1,9
5382 iprsm = 0
5383 do igc = 1,ngc(3)
5384 sumf = 0.
5385 do ipr = 1, ngn(ngs(2)+igc)
5386 iprsm = iprsm + 1
5387 sumf = sumf + sfluxrefo(iprsm,jp)
5388 enddo
5389 sfluxref(igc,jp) = sumf
5390 enddo
5391 enddo
5393 end subroutine cmbgb18
5395 !***************************************************************************
5396 subroutine cmbgb19
5397 !***************************************************************************
5398 !
5399 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
5400 !-----------------------------------------------------------------------
5402 use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5403 absa, ka, absb, kb, selfref, forref, sfluxref
5405 ! ------- Local -------
5406 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5407 real(kind=rb) :: sumk, sumf
5410 do jn = 1,9
5411 do jt = 1,5
5412 do jp = 1,13
5413 iprsm = 0
5414 do igc = 1,ngc(4)
5415 sumk = 0.
5416 do ipr = 1, ngn(ngs(3)+igc)
5417 iprsm = iprsm + 1
5418 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
5419 enddo
5420 ka(jn,jt,jp,igc) = sumk
5421 enddo
5422 enddo
5423 enddo
5424 enddo
5426 do jt = 1,5
5427 do jp = 13,59
5428 iprsm = 0
5429 do igc = 1,ngc(4)
5430 sumk = 0.
5431 do ipr = 1, ngn(ngs(3)+igc)
5432 iprsm = iprsm + 1
5433 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
5434 enddo
5435 kb(jt,jp,igc) = sumk
5436 enddo
5437 enddo
5438 enddo
5440 do jt = 1,10
5441 iprsm = 0
5442 do igc = 1,ngc(4)
5443 sumk = 0.
5444 do ipr = 1, ngn(ngs(3)+igc)
5445 iprsm = iprsm + 1
5446 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
5447 enddo
5448 selfref(jt,igc) = sumk
5449 enddo
5450 enddo
5452 do jt = 1,3
5453 iprsm = 0
5454 do igc = 1,ngc(4)
5455 sumk = 0.
5456 do ipr = 1, ngn(ngs(3)+igc)
5457 iprsm = iprsm + 1
5458 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
5459 enddo
5460 forref(jt,igc) = sumk
5461 enddo
5462 enddo
5464 do jp = 1,9
5465 iprsm = 0
5466 do igc = 1,ngc(4)
5467 sumf = 0.
5468 do ipr = 1, ngn(ngs(3)+igc)
5469 iprsm = iprsm + 1
5470 sumf = sumf + sfluxrefo(iprsm,jp)
5471 enddo
5472 sfluxref(igc,jp) = sumf
5473 enddo
5474 enddo
5476 end subroutine cmbgb19
5478 !***************************************************************************
5479 subroutine cmbgb20
5480 !***************************************************************************
5481 !
5482 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
5483 !-----------------------------------------------------------------------
5485 use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
5486 absa, ka, absb, kb, selfref, forref, sfluxref, absch4
5488 ! ------- Local -------
5489 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5490 real(kind=rb) :: sumk, sumf1, sumf2
5493 do jt = 1,5
5494 do jp = 1,13
5495 iprsm = 0
5496 do igc = 1,ngc(5)
5497 sumk = 0.
5498 do ipr = 1, ngn(ngs(4)+igc)
5499 iprsm = iprsm + 1
5500 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
5501 enddo
5502 ka(jt,jp,igc) = sumk
5503 enddo
5504 enddo
5505 do jp = 13,59
5506 iprsm = 0
5507 do igc = 1,ngc(5)
5508 sumk = 0.
5509 do ipr = 1, ngn(ngs(4)+igc)
5510 iprsm = iprsm + 1
5511 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
5512 enddo
5513 kb(jt,jp,igc) = sumk
5514 enddo
5515 enddo
5516 enddo
5518 do jt = 1,10
5519 iprsm = 0
5520 do igc = 1,ngc(5)
5521 sumk = 0.
5522 do ipr = 1, ngn(ngs(4)+igc)
5523 iprsm = iprsm + 1
5524 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
5525 enddo
5526 selfref(jt,igc) = sumk
5527 enddo
5528 enddo
5530 do jt = 1,4
5531 iprsm = 0
5532 do igc = 1,ngc(5)
5533 sumk = 0.
5534 do ipr = 1, ngn(ngs(4)+igc)
5535 iprsm = iprsm + 1
5536 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
5537 enddo
5538 forref(jt,igc) = sumk
5539 enddo
5540 enddo
5542 iprsm = 0
5543 do igc = 1,ngc(5)
5544 sumf1 = 0.
5545 sumf2 = 0.
5546 do ipr = 1, ngn(ngs(4)+igc)
5547 iprsm = iprsm + 1
5548 sumf1 = sumf1 + sfluxrefo(iprsm)
5549 sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
5550 enddo
5551 sfluxref(igc) = sumf1
5552 absch4(igc) = sumf2
5553 enddo
5555 end subroutine cmbgb20
5557 !***************************************************************************
5558 subroutine cmbgb21
5559 !***************************************************************************
5560 !
5561 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
5562 !-----------------------------------------------------------------------
5564 use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5565 absa, ka, absb, kb, selfref, forref, sfluxref
5567 ! ------- Local -------
5568 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5569 real(kind=rb) :: sumk, sumf
5572 do jn = 1,9
5573 do jt = 1,5
5574 do jp = 1,13
5575 iprsm = 0
5576 do igc = 1,ngc(6)
5577 sumk = 0.
5578 do ipr = 1, ngn(ngs(5)+igc)
5579 iprsm = iprsm + 1
5580 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5581 enddo
5582 ka(jn,jt,jp,igc) = sumk
5583 enddo
5584 enddo
5585 enddo
5586 enddo
5588 do jn = 1,5
5589 do jt = 1,5
5590 do jp = 13,59
5591 iprsm = 0
5592 do igc = 1,ngc(6)
5593 sumk = 0.
5594 do ipr = 1, ngn(ngs(5)+igc)
5595 iprsm = iprsm + 1
5596 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5597 enddo
5598 kb(jn,jt,jp,igc) = sumk
5599 enddo
5600 enddo
5601 enddo
5602 enddo
5604 do jt = 1,10
5605 iprsm = 0
5606 do igc = 1,ngc(6)
5607 sumk = 0.
5608 do ipr = 1, ngn(ngs(5)+igc)
5609 iprsm = iprsm + 1
5610 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
5611 enddo
5612 selfref(jt,igc) = sumk
5613 enddo
5614 enddo
5616 do jt = 1,4
5617 iprsm = 0
5618 do igc = 1,ngc(6)
5619 sumk = 0.
5620 do ipr = 1, ngn(ngs(5)+igc)
5621 iprsm = iprsm + 1
5622 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
5623 enddo
5624 forref(jt,igc) = sumk
5625 enddo
5626 enddo
5628 do jp = 1,9
5629 iprsm = 0
5630 do igc = 1,ngc(6)
5631 sumf = 0.
5632 do ipr = 1, ngn(ngs(5)+igc)
5633 iprsm = iprsm + 1
5634 sumf = sumf + sfluxrefo(iprsm,jp)
5635 enddo
5636 sfluxref(igc,jp) = sumf
5637 enddo
5638 enddo
5640 end subroutine cmbgb21
5642 !***************************************************************************
5643 subroutine cmbgb22
5644 !***************************************************************************
5645 !
5646 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
5647 !-----------------------------------------------------------------------
5649 use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5650 absa, ka, absb, kb, selfref, forref, sfluxref
5652 ! ------- Local -------
5653 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5654 real(kind=rb) :: sumk, sumf
5657 do jn = 1,9
5658 do jt = 1,5
5659 do jp = 1,13
5660 iprsm = 0
5661 do igc = 1,ngc(7)
5662 sumk = 0.
5663 do ipr = 1, ngn(ngs(6)+igc)
5664 iprsm = iprsm + 1
5665 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
5666 enddo
5667 ka(jn,jt,jp,igc) = sumk
5668 enddo
5669 enddo
5670 enddo
5671 enddo
5673 do jt = 1,5
5674 do jp = 13,59
5675 iprsm = 0
5676 do igc = 1,ngc(7)
5677 sumk = 0.
5678 do ipr = 1, ngn(ngs(6)+igc)
5679 iprsm = iprsm + 1
5680 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
5681 enddo
5682 kb(jt,jp,igc) = sumk
5683 enddo
5684 enddo
5685 enddo
5687 do jt = 1,10
5688 iprsm = 0
5689 do igc = 1,ngc(7)
5690 sumk = 0.
5691 do ipr = 1, ngn(ngs(6)+igc)
5692 iprsm = iprsm + 1
5693 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
5694 enddo
5695 selfref(jt,igc) = sumk
5696 enddo
5697 enddo
5699 do jt = 1,3
5700 iprsm = 0
5701 do igc = 1,ngc(7)
5702 sumk = 0.
5703 do ipr = 1, ngn(ngs(6)+igc)
5704 iprsm = iprsm + 1
5705 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
5706 enddo
5707 forref(jt,igc) = sumk
5708 enddo
5709 enddo
5711 do jp = 1,9
5712 iprsm = 0
5713 do igc = 1,ngc(7)
5714 sumf = 0.
5715 do ipr = 1, ngn(ngs(6)+igc)
5716 iprsm = iprsm + 1
5717 sumf = sumf + sfluxrefo(iprsm,jp)
5718 enddo
5719 sfluxref(igc,jp) = sumf
5720 enddo
5721 enddo
5723 end subroutine cmbgb22
5725 !***************************************************************************
5726 subroutine cmbgb23
5727 !***************************************************************************
5728 !
5729 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
5730 !-----------------------------------------------------------------------
5732 use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
5733 absa, ka, selfref, forref, sfluxref, rayl
5735 ! ------- Local -------
5736 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5737 real(kind=rb) :: sumk, sumf1, sumf2
5740 do jt = 1,5
5741 do jp = 1,13
5742 iprsm = 0
5743 do igc = 1,ngc(8)
5744 sumk = 0.
5745 do ipr = 1, ngn(ngs(7)+igc)
5746 iprsm = iprsm + 1
5747 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
5748 enddo
5749 ka(jt,jp,igc) = sumk
5750 enddo
5751 enddo
5752 enddo
5754 do jt = 1,10
5755 iprsm = 0
5756 do igc = 1,ngc(8)
5757 sumk = 0.
5758 do ipr = 1, ngn(ngs(7)+igc)
5759 iprsm = iprsm + 1
5760 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
5761 enddo
5762 selfref(jt,igc) = sumk
5763 enddo
5764 enddo
5766 do jt = 1,3
5767 iprsm = 0
5768 do igc = 1,ngc(8)
5769 sumk = 0.
5770 do ipr = 1, ngn(ngs(7)+igc)
5771 iprsm = iprsm + 1
5772 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
5773 enddo
5774 forref(jt,igc) = sumk
5775 enddo
5776 enddo
5778 iprsm = 0
5779 do igc = 1,ngc(8)
5780 sumf1 = 0.
5781 sumf2 = 0.
5782 do ipr = 1, ngn(ngs(7)+igc)
5783 iprsm = iprsm + 1
5784 sumf1 = sumf1 + sfluxrefo(iprsm)
5785 sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
5786 enddo
5787 sfluxref(igc) = sumf1
5788 rayl(igc) = sumf2
5789 enddo
5791 end subroutine cmbgb23
5793 !***************************************************************************
5794 subroutine cmbgb24
5795 !***************************************************************************
5796 !
5797 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
5798 !-----------------------------------------------------------------------
5800 use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5801 abso3ao, abso3bo, raylao, raylbo, &
5802 absa, ka, absb, kb, selfref, forref, sfluxref, &
5803 abso3a, abso3b, rayla, raylb
5805 ! ------- Local -------
5806 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5807 real(kind=rb) :: sumk, sumf1, sumf2, sumf3
5810 do jn = 1,9
5811 do jt = 1,5
5812 do jp = 1,13
5813 iprsm = 0
5814 do igc = 1,ngc(9)
5815 sumk = 0.
5816 do ipr = 1, ngn(ngs(8)+igc)
5817 iprsm = iprsm + 1
5818 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
5819 enddo
5820 ka(jn,jt,jp,igc) = sumk
5821 enddo
5822 enddo
5823 enddo
5824 enddo
5826 do jt = 1,5
5827 do jp = 13,59
5828 iprsm = 0
5829 do igc = 1,ngc(9)
5830 sumk = 0.
5831 do ipr = 1, ngn(ngs(8)+igc)
5832 iprsm = iprsm + 1
5833 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
5834 enddo
5835 kb(jt,jp,igc) = sumk
5836 enddo
5837 enddo
5838 enddo
5840 do jt = 1,10
5841 iprsm = 0
5842 do igc = 1,ngc(9)
5843 sumk = 0.
5844 do ipr = 1, ngn(ngs(8)+igc)
5845 iprsm = iprsm + 1
5846 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
5847 enddo
5848 selfref(jt,igc) = sumk
5849 enddo
5850 enddo
5852 do jt = 1,3
5853 iprsm = 0
5854 do igc = 1,ngc(9)
5855 sumk = 0.
5856 do ipr = 1, ngn(ngs(8)+igc)
5857 iprsm = iprsm + 1
5858 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
5859 enddo
5860 forref(jt,igc) = sumk
5861 enddo
5862 enddo
5864 iprsm = 0
5865 do igc = 1,ngc(9)
5866 sumf1 = 0.
5867 sumf2 = 0.
5868 sumf3 = 0.
5869 do ipr = 1, ngn(ngs(8)+igc)
5870 iprsm = iprsm + 1
5871 sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
5872 sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
5873 sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
5874 enddo
5875 raylb(igc) = sumf1
5876 abso3a(igc) = sumf2
5877 abso3b(igc) = sumf3
5878 enddo
5880 do jp = 1,9
5881 iprsm = 0
5882 do igc = 1,ngc(9)
5883 sumf1 = 0.
5884 sumf2 = 0.
5885 do ipr = 1, ngn(ngs(8)+igc)
5886 iprsm = iprsm + 1
5887 sumf1 = sumf1 + sfluxrefo(iprsm,jp)
5888 sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
5889 enddo
5890 sfluxref(igc,jp) = sumf1
5891 rayla(igc,jp) = sumf2
5892 enddo
5893 enddo
5895 end subroutine cmbgb24
5897 !***************************************************************************
5898 subroutine cmbgb25
5899 !***************************************************************************
5900 !
5901 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
5902 !-----------------------------------------------------------------------
5904 use rrsw_kg25, only : kao, sfluxrefo, &
5905 abso3ao, abso3bo, raylo, &
5906 absa, ka, sfluxref, &
5907 abso3a, abso3b, rayl
5909 ! ------- Local -------
5910 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5911 real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4
5914 do jt = 1,5
5915 do jp = 1,13
5916 iprsm = 0
5917 do igc = 1,ngc(10)
5918 sumk = 0.
5919 do ipr = 1, ngn(ngs(9)+igc)
5920 iprsm = iprsm + 1
5921 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
5922 enddo
5923 ka(jt,jp,igc) = sumk
5924 enddo
5925 enddo
5926 enddo
5928 iprsm = 0
5929 do igc = 1,ngc(10)
5930 sumf1 = 0.
5931 sumf2 = 0.
5932 sumf3 = 0.
5933 sumf4 = 0.
5934 do ipr = 1, ngn(ngs(9)+igc)
5935 iprsm = iprsm + 1
5936 sumf1 = sumf1 + sfluxrefo(iprsm)
5937 sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
5938 sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
5939 sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
5940 enddo
5941 sfluxref(igc) = sumf1
5942 abso3a(igc) = sumf2
5943 abso3b(igc) = sumf3
5944 rayl(igc) = sumf4
5945 enddo
5947 end subroutine cmbgb25
5949 !***************************************************************************
5950 subroutine cmbgb26
5951 !***************************************************************************
5952 !
5953 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
5954 !-----------------------------------------------------------------------
5956 use rrsw_kg26, only : sfluxrefo, raylo, &
5957 sfluxref, rayl
5959 ! ------- Local -------
5960 integer(kind=im) :: igc, ipr, iprsm
5961 real(kind=rb) :: sumf1, sumf2
5964 iprsm = 0
5965 do igc = 1,ngc(11)
5966 sumf1 = 0.
5967 sumf2 = 0.
5968 do ipr = 1, ngn(ngs(10)+igc)
5969 iprsm = iprsm + 1
5970 sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
5971 sumf2 = sumf2 + sfluxrefo(iprsm)
5972 enddo
5973 rayl(igc) = sumf1
5974 sfluxref(igc) = sumf2
5975 enddo
5977 end subroutine cmbgb26
5979 !***************************************************************************
5980 subroutine cmbgb27
5981 !***************************************************************************
5982 !
5983 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
5984 !-----------------------------------------------------------------------
5986 use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
5987 absa, ka, absb, kb, sfluxref, rayl
5989 ! ------- Local -------
5990 integer(kind=im) :: jt, jp, igc, ipr, iprsm
5991 real(kind=rb) :: sumk, sumf1, sumf2
5994 do jt = 1,5
5995 do jp = 1,13
5996 iprsm = 0
5997 do igc = 1,ngc(12)
5998 sumk = 0.
5999 do ipr = 1, ngn(ngs(11)+igc)
6000 iprsm = iprsm + 1
6001 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
6002 enddo
6003 ka(jt,jp,igc) = sumk
6004 enddo
6005 enddo
6006 do jp = 13,59
6007 iprsm = 0
6008 do igc = 1,ngc(12)
6009 sumk = 0.
6010 do ipr = 1, ngn(ngs(11)+igc)
6011 iprsm = iprsm + 1
6012 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
6013 enddo
6014 kb(jt,jp,igc) = sumk
6015 enddo
6016 enddo
6017 enddo
6019 iprsm = 0
6020 do igc = 1,ngc(12)
6021 sumf1 = 0.
6022 sumf2 = 0.
6023 do ipr = 1, ngn(ngs(11)+igc)
6024 iprsm = iprsm + 1
6025 sumf1 = sumf1 + sfluxrefo(iprsm)
6026 sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
6027 enddo
6028 sfluxref(igc) = sumf1
6029 rayl(igc) = sumf2
6030 enddo
6032 end subroutine cmbgb27
6034 !***************************************************************************
6035 subroutine cmbgb28
6036 !***************************************************************************
6037 !
6038 ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
6039 !-----------------------------------------------------------------------
6041 use rrsw_kg28, only : kao, kbo, sfluxrefo, &
6042 absa, ka, absb, kb, sfluxref
6044 ! ------- Local -------
6045 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
6046 real(kind=rb) :: sumk, sumf
6049 do jn = 1,9
6050 do jt = 1,5
6051 do jp = 1,13
6052 iprsm = 0
6053 do igc = 1,ngc(13)
6054 sumk = 0.
6055 do ipr = 1, ngn(ngs(12)+igc)
6056 iprsm = iprsm + 1
6057 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
6058 enddo
6059 ka(jn,jt,jp,igc) = sumk
6060 enddo
6061 enddo
6062 enddo
6063 enddo
6065 do jn = 1,5
6066 do jt = 1,5
6067 do jp = 13,59
6068 iprsm = 0
6069 do igc = 1,ngc(13)
6070 sumk = 0.
6071 do ipr = 1, ngn(ngs(12)+igc)
6072 iprsm = iprsm + 1
6073 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
6074 enddo
6075 kb(jn,jt,jp,igc) = sumk
6076 enddo
6077 enddo
6078 enddo
6079 enddo
6081 do jp = 1,5
6082 iprsm = 0
6083 do igc = 1,ngc(13)
6084 sumf = 0.
6085 do ipr = 1, ngn(ngs(12)+igc)
6086 iprsm = iprsm + 1
6087 sumf = sumf + sfluxrefo(iprsm,jp)
6088 enddo
6089 sfluxref(igc,jp) = sumf
6090 enddo
6091 enddo
6093 end subroutine cmbgb28
6095 !***************************************************************************
6096 subroutine cmbgb29
6097 !***************************************************************************
6098 !
6099 ! band 29: 820-2600 cm-1 (low - h2o; high - co2)
6100 !-----------------------------------------------------------------------
6102 use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
6103 absh2oo, absco2o, &
6104 absa, ka, absb, kb, selfref, forref, sfluxref, &
6105 absh2o, absco2
6107 ! ------- Local -------
6108 integer(kind=im) :: jt, jp, igc, ipr, iprsm
6109 real(kind=rb) :: sumk, sumf1, sumf2, sumf3
6112 do jt = 1,5
6113 do jp = 1,13
6114 iprsm = 0
6115 do igc = 1,ngc(14)
6116 sumk = 0.
6117 do ipr = 1, ngn(ngs(13)+igc)
6118 iprsm = iprsm + 1
6119 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
6120 enddo
6121 ka(jt,jp,igc) = sumk
6122 enddo
6123 enddo
6124 do jp = 13,59
6125 iprsm = 0
6126 do igc = 1,ngc(14)
6127 sumk = 0.
6128 do ipr = 1, ngn(ngs(13)+igc)
6129 iprsm = iprsm + 1
6130 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
6131 enddo
6132 kb(jt,jp,igc) = sumk
6133 enddo
6134 enddo
6135 enddo
6137 do jt = 1,10
6138 iprsm = 0
6139 do igc = 1,ngc(14)
6140 sumk = 0.
6141 do ipr = 1, ngn(ngs(13)+igc)
6142 iprsm = iprsm + 1
6143 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
6144 enddo
6145 selfref(jt,igc) = sumk
6146 enddo
6147 enddo
6149 do jt = 1,4
6150 iprsm = 0
6151 do igc = 1,ngc(14)
6152 sumk = 0.
6153 do ipr = 1, ngn(ngs(13)+igc)
6154 iprsm = iprsm + 1
6155 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
6156 enddo
6157 forref(jt,igc) = sumk
6158 enddo
6159 enddo
6161 iprsm = 0
6162 do igc = 1,ngc(14)
6163 sumf1 = 0.
6164 sumf2 = 0.
6165 sumf3 = 0.
6166 do ipr = 1, ngn(ngs(13)+igc)
6167 iprsm = iprsm + 1
6168 sumf1 = sumf1 + sfluxrefo(iprsm)
6169 sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
6170 sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
6171 enddo
6172 sfluxref(igc) = sumf1
6173 absco2(igc) = sumf2
6174 absh2o(igc) = sumf3
6175 enddo
6177 end subroutine cmbgb29
6179 !***********************************************************************
6180 subroutine swcldpr
6182 ! Purpose: Define cloud extinction coefficient, single scattering albedo
6183 ! and asymmetry parameter data.
6184 !
6186 ! ------- Modules -------
6188 use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
6189 extice2, ssaice2, asyice2, &
6190 extice3, ssaice3, asyice3, fdlice3, &
6191 abari, bbari, cbari, dbari, ebari, fbari
6193 save
6195 !-----------------------------------------------------------------------
6196 !
6197 ! Explanation of the method for each value of INFLAG. A value of
6198 ! 0 for INFLAG do not distingish being liquid and ice clouds.
6199 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
6200 ! requires further user input to specify the method to be used to
6201 ! compute the aborption due to each.
6202 ! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical
6203 ! depth, the cloud single-scattering albedo, and the
6204 ! moments of the phase function (0:NSTREAM). Note
6205 ! that these values are delta-m scaled within this
6206 ! subroutine.
6208 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
6209 ! water path (g/m2), and cloud ice fraction are input.
6210 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
6211 ! optical properties due to ice clouds are computed from
6212 ! the optical properties stored in the RT code, STREAMER v3.0
6213 ! (Reference: Key. J., Streamer User's Guide, Cooperative
6214 ! Institute for Meteorological Satellite Studies, 2001, 96 pp.).
6215 ! Valid range of values for re are between 5.0 and
6216 ! 131.0 micron.
6217 ! This version uses Ebert and Curry, JGR, (1992) method for
6218 ! ice particles larger than 131.0 microns.
6219 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
6220 ! and the optical depths, single-scattering albedo,
6221 ! and phase function moments are calculated as in
6222 ! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
6223 ! tables which were appropriately averaged for the
6224 ! bands in RRTM_SW. Linear interpolation is used to
6225 ! get the coefficients from the stored tables.
6226 ! Valid range of values for dge are between 5.0 and
6227 ! 140.0 micron.
6228 ! This version uses Ebert and Curry, JGR, (1992) method for
6229 ! ice particles larger than 140.0 microns.
6230 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
6231 ! and the optical depths due to water clouds are computed
6232 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with
6233 ! modified coefficients derived from Mie scattering calculations.
6234 ! The values for absorption coefficients appropriate for
6235 ! the spectral bands in RRTM/RRTMG have been obtained for a
6236 ! range of effective radii by an averaging procedure
6237 ! based on the work of J. Pinto (private communication).
6238 ! Linear interpolation is used to get the absorption
6239 ! coefficients for the input effective radius.
6240 !
6241 !..Updated tables suggested by Peter Blossey (Univ. Washington) that came from RRTM v3.9 from AER, Inc.
6242 !
6243 ! ------------------------------------------------------------------
6245 ! Everything below is for INFLAG = 2.
6247 ! Coefficients for Ebert and Curry method
6248 abari(:) = (/ &
6249 & 3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /)
6250 bbari(:) = (/ &
6251 & 2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /)
6252 cbari(:) = (/ &
6253 & 1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /)
6254 dbari(:) = (/ &
6255 & 0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /)
6256 ebari(:) = (/ &
6257 & 7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /)
6258 fbari(:) = (/ &
6259 & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /)
6261 ! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters
6262 ! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients
6263 ! BAND 16
6264 extliq1(:, 16) = (/ &
6265 & 9.004493E-01_rb,6.366723E-01_rb,4.542354E-01_rb,3.468253E-01_rb,2.816431E-01_rb,&
6266 & 2.383415E-01_rb,2.070854E-01_rb,1.831854E-01_rb,1.642115E-01_rb,1.487539E-01_rb,&
6267 & 1.359169E-01_rb,1.250900E-01_rb,1.158354E-01_rb,1.078400E-01_rb,1.008646E-01_rb,&
6268 & 9.472307E-02_rb,8.928000E-02_rb,8.442308E-02_rb,8.005924E-02_rb,7.612231E-02_rb,&
6269 & 7.255153E-02_rb,6.929539E-02_rb,6.631769E-02_rb,6.358153E-02_rb,6.106231E-02_rb,&
6270 & 5.873077E-02_rb,5.656924E-02_rb,5.455769E-02_rb,5.267846E-02_rb,5.091923E-02_rb,&
6271 & 4.926692E-02_rb,4.771154E-02_rb,4.623923E-02_rb,4.484385E-02_rb,4.351539E-02_rb,&
6272 & 4.224615E-02_rb,4.103385E-02_rb,3.986538E-02_rb,3.874077E-02_rb,3.765462E-02_rb,&
6273 & 3.660077E-02_rb,3.557384E-02_rb,3.457615E-02_rb,3.360308E-02_rb,3.265000E-02_rb,&
6274 & 3.171770E-02_rb,3.080538E-02_rb,2.990846E-02_rb,2.903000E-02_rb,2.816461E-02_rb,&
6275 & 2.731539E-02_rb,2.648231E-02_rb,2.566308E-02_rb,2.485923E-02_rb,2.407000E-02_rb,&
6276 & 2.329615E-02_rb,2.253769E-02_rb,2.179615E-02_rb /)
6277 ! BAND 17
6278 extliq1(:, 17) = (/ &
6279 & 6.741200e-01_rb,5.390739e-01_rb,4.198767e-01_rb,3.332553e-01_rb,2.735633e-01_rb,&
6280 & 2.317727e-01_rb,2.012760e-01_rb,1.780400e-01_rb,1.596927e-01_rb,1.447980e-01_rb,&
6281 & 1.324480e-01_rb,1.220347e-01_rb,1.131327e-01_rb,1.054313e-01_rb,9.870534e-02_rb,&
6282 & 9.278200e-02_rb,8.752599e-02_rb,8.282933e-02_rb,7.860600e-02_rb,7.479133e-02_rb,&
6283 & 7.132800e-02_rb,6.816733e-02_rb,6.527401e-02_rb,6.261266e-02_rb,6.015934e-02_rb,&
6284 & 5.788867e-02_rb,5.578134e-02_rb,5.381667e-02_rb,5.198133e-02_rb,5.026067e-02_rb,&
6285 & 4.864466e-02_rb,4.712267e-02_rb,4.568066e-02_rb,4.431200e-02_rb,4.300867e-02_rb,&
6286 & 4.176600e-02_rb,4.057400e-02_rb,3.942534e-02_rb,3.832066e-02_rb,3.725068e-02_rb,&
6287 & 3.621400e-02_rb,3.520533e-02_rb,3.422333e-02_rb,3.326400e-02_rb,3.232467e-02_rb,&
6288 & 3.140535e-02_rb,3.050400e-02_rb,2.962000e-02_rb,2.875267e-02_rb,2.789800e-02_rb,&
6289 & 2.705934e-02_rb,2.623667e-02_rb,2.542667e-02_rb,2.463200e-02_rb,2.385267e-02_rb,&
6290 & 2.308667e-02_rb,2.233667e-02_rb,2.160067e-02_rb /)
6291 ! BAND 18
6292 extliq1(:, 18) = (/ &
6293 & 9.250861e-01_rb,6.245692e-01_rb,4.347038e-01_rb,3.320208e-01_rb,2.714869e-01_rb,&
6294 & 2.309516e-01_rb,2.012592e-01_rb,1.783315e-01_rb,1.600369e-01_rb,1.451000e-01_rb,&
6295 & 1.326838e-01_rb,1.222069e-01_rb,1.132554e-01_rb,1.055146e-01_rb,9.876000e-02_rb,&
6296 & 9.281386e-02_rb,8.754000e-02_rb,8.283078e-02_rb,7.860077e-02_rb,7.477769e-02_rb,&
6297 & 7.130847e-02_rb,6.814461e-02_rb,6.524615e-02_rb,6.258462e-02_rb,6.012847e-02_rb,&
6298 & 5.785462e-02_rb,5.574231e-02_rb,5.378000e-02_rb,5.194461e-02_rb,5.022462e-02_rb,&
6299 & 4.860846e-02_rb,4.708462e-02_rb,4.564154e-02_rb,4.427462e-02_rb,4.297231e-02_rb,&
6300 & 4.172769e-02_rb,4.053693e-02_rb,3.939000e-02_rb,3.828462e-02_rb,3.721692e-02_rb,&
6301 & 3.618000e-02_rb,3.517077e-02_rb,3.418923e-02_rb,3.323077e-02_rb,3.229154e-02_rb,&
6302 & 3.137154e-02_rb,3.047154e-02_rb,2.959077e-02_rb,2.872308e-02_rb,2.786846e-02_rb,&
6303 & 2.703077e-02_rb,2.620923e-02_rb,2.540077e-02_rb,2.460615e-02_rb,2.382693e-02_rb,&
6304 & 2.306231e-02_rb,2.231231e-02_rb,2.157923e-02_rb /)
6305 ! BAND 19
6306 extliq1(:, 19) = (/ &
6307 & 9.298960e-01_rb,5.776460e-01_rb,4.083450e-01_rb,3.211160e-01_rb,2.666390e-01_rb,&
6308 & 2.281990e-01_rb,1.993250e-01_rb,1.768080e-01_rb,1.587810e-01_rb,1.440390e-01_rb,&
6309 & 1.317720e-01_rb,1.214150e-01_rb,1.125540e-01_rb,1.048890e-01_rb,9.819600e-02_rb,&
6310 & 9.230201e-02_rb,8.706900e-02_rb,8.239698e-02_rb,7.819500e-02_rb,7.439899e-02_rb,&
6311 & 7.095300e-02_rb,6.780700e-02_rb,6.492900e-02_rb,6.228600e-02_rb,5.984600e-02_rb,&
6312 & 5.758599e-02_rb,5.549099e-02_rb,5.353801e-02_rb,5.171400e-02_rb,5.000500e-02_rb,&
6313 & 4.840000e-02_rb,4.688500e-02_rb,4.545100e-02_rb,4.409300e-02_rb,4.279700e-02_rb,&
6314 & 4.156100e-02_rb,4.037700e-02_rb,3.923800e-02_rb,3.813800e-02_rb,3.707600e-02_rb,&
6315 & 3.604500e-02_rb,3.504300e-02_rb,3.406500e-02_rb,3.310800e-02_rb,3.217700e-02_rb,&
6316 & 3.126600e-02_rb,3.036800e-02_rb,2.948900e-02_rb,2.862400e-02_rb,2.777500e-02_rb,&
6317 & 2.694200e-02_rb,2.612300e-02_rb,2.531700e-02_rb,2.452800e-02_rb,2.375100e-02_rb,&
6318 & 2.299100e-02_rb,2.224300e-02_rb,2.151201e-02_rb /)
6319 ! BAND 20
6320 extliq1(:, 20) = (/ &
6321 & 8.780964e-01_rb,5.407031e-01_rb,3.961100e-01_rb,3.166645e-01_rb,2.640455e-01_rb,&
6322 & 2.261070e-01_rb,1.974820e-01_rb,1.751775e-01_rb,1.573415e-01_rb,1.427725e-01_rb,&
6323 & 1.306535e-01_rb,1.204195e-01_rb,1.116650e-01_rb,1.040915e-01_rb,9.747550e-02_rb,&
6324 & 9.164800e-02_rb,8.647649e-02_rb,8.185501e-02_rb,7.770200e-02_rb,7.394749e-02_rb,&
6325 & 7.053800e-02_rb,6.742700e-02_rb,6.457999e-02_rb,6.196149e-02_rb,5.954450e-02_rb,&
6326 & 5.730650e-02_rb,5.522949e-02_rb,5.329450e-02_rb,5.148500e-02_rb,4.979000e-02_rb,&
6327 & 4.819600e-02_rb,4.669301e-02_rb,4.527050e-02_rb,4.391899e-02_rb,4.263500e-02_rb,&
6328 & 4.140500e-02_rb,4.022850e-02_rb,3.909500e-02_rb,3.800199e-02_rb,3.694600e-02_rb,&
6329 & 3.592000e-02_rb,3.492250e-02_rb,3.395050e-02_rb,3.300150e-02_rb,3.207250e-02_rb,&
6330 & 3.116250e-02_rb,3.027100e-02_rb,2.939500e-02_rb,2.853500e-02_rb,2.768900e-02_rb,&
6331 & 2.686000e-02_rb,2.604350e-02_rb,2.524150e-02_rb,2.445350e-02_rb,2.368049e-02_rb,&
6332 & 2.292150e-02_rb,2.217800e-02_rb,2.144800e-02_rb /)
6333 ! BAND 21
6334 extliq1(:, 21) = (/ &
6335 & 7.937480e-01_rb,5.123036e-01_rb,3.858181e-01_rb,3.099622e-01_rb,2.586829e-01_rb,&
6336 & 2.217587e-01_rb,1.939755e-01_rb,1.723397e-01_rb,1.550258e-01_rb,1.408600e-01_rb,&
6337 & 1.290545e-01_rb,1.190661e-01_rb,1.105039e-01_rb,1.030848e-01_rb,9.659387e-02_rb,&
6338 & 9.086775e-02_rb,8.577807e-02_rb,8.122452e-02_rb,7.712711e-02_rb,7.342193e-02_rb,&
6339 & 7.005387e-02_rb,6.697840e-02_rb,6.416000e-02_rb,6.156903e-02_rb,5.917484e-02_rb,&
6340 & 5.695807e-02_rb,5.489968e-02_rb,5.298097e-02_rb,5.118806e-02_rb,4.950645e-02_rb,&
6341 & 4.792710e-02_rb,4.643581e-02_rb,4.502484e-02_rb,4.368547e-02_rb,4.241001e-02_rb,&
6342 & 4.118936e-02_rb,4.002193e-02_rb,3.889711e-02_rb,3.781322e-02_rb,3.676387e-02_rb,&
6343 & 3.574549e-02_rb,3.475548e-02_rb,3.379033e-02_rb,3.284678e-02_rb,3.192420e-02_rb,&
6344 & 3.102032e-02_rb,3.013484e-02_rb,2.926258e-02_rb,2.840839e-02_rb,2.756742e-02_rb,&
6345 & 2.674258e-02_rb,2.593064e-02_rb,2.513258e-02_rb,2.435000e-02_rb,2.358064e-02_rb,&
6346 & 2.282581e-02_rb,2.208548e-02_rb,2.135936e-02_rb /)
6347 ! BAND 22
6348 extliq1(:, 22) = (/ &
6349 & 7.533129e-01_rb,5.033129e-01_rb,3.811271e-01_rb,3.062757e-01_rb,2.558729e-01_rb,&
6350 & 2.196828e-01_rb,1.924372e-01_rb,1.711714e-01_rb,1.541086e-01_rb,1.401114e-01_rb,&
6351 & 1.284257e-01_rb,1.185200e-01_rb,1.100243e-01_rb,1.026529e-01_rb,9.620142e-02_rb,&
6352 & 9.050714e-02_rb,8.544428e-02_rb,8.091714e-02_rb,7.684000e-02_rb,7.315429e-02_rb,&
6353 & 6.980143e-02_rb,6.673999e-02_rb,6.394000e-02_rb,6.136000e-02_rb,5.897715e-02_rb,&
6354 & 5.677000e-02_rb,5.472285e-02_rb,5.281286e-02_rb,5.102858e-02_rb,4.935429e-02_rb,&
6355 & 4.778000e-02_rb,4.629714e-02_rb,4.489142e-02_rb,4.355857e-02_rb,4.228715e-02_rb,&
6356 & 4.107285e-02_rb,3.990857e-02_rb,3.879000e-02_rb,3.770999e-02_rb,3.666429e-02_rb,&
6357 & 3.565000e-02_rb,3.466286e-02_rb,3.370143e-02_rb,3.276143e-02_rb,3.184143e-02_rb,&
6358 & 3.094000e-02_rb,3.005714e-02_rb,2.919000e-02_rb,2.833714e-02_rb,2.750000e-02_rb,&
6359 & 2.667714e-02_rb,2.586714e-02_rb,2.507143e-02_rb,2.429143e-02_rb,2.352428e-02_rb,&
6360 & 2.277143e-02_rb,2.203429e-02_rb,2.130857e-02_rb /)
6361 ! BAND 23
6362 extliq1(:, 23) = (/ &
6363 & 7.079894e-01_rb,4.878198e-01_rb,3.719852e-01_rb,3.001873e-01_rb,2.514795e-01_rb,&
6364 & 2.163013e-01_rb,1.897100e-01_rb,1.689033e-01_rb,1.521793e-01_rb,1.384449e-01_rb,&
6365 & 1.269666e-01_rb,1.172326e-01_rb,1.088745e-01_rb,1.016224e-01_rb,9.527085e-02_rb,&
6366 & 8.966240e-02_rb,8.467543e-02_rb,8.021144e-02_rb,7.619344e-02_rb,7.255676e-02_rb,&
6367 & 6.924996e-02_rb,6.623030e-02_rb,6.346261e-02_rb,6.091499e-02_rb,5.856325e-02_rb,&
6368 & 5.638385e-02_rb,5.435930e-02_rb,5.247156e-02_rb,5.070699e-02_rb,4.905230e-02_rb,&
6369 & 4.749499e-02_rb,4.602611e-02_rb,4.463581e-02_rb,4.331543e-02_rb,4.205647e-02_rb,&
6370 & 4.085241e-02_rb,3.969978e-02_rb,3.859033e-02_rb,3.751877e-02_rb,3.648168e-02_rb,&
6371 & 3.547468e-02_rb,3.449553e-02_rb,3.354072e-02_rb,3.260732e-02_rb,3.169438e-02_rb,&
6372 & 3.079969e-02_rb,2.992146e-02_rb,2.905875e-02_rb,2.821201e-02_rb,2.737873e-02_rb,&
6373 & 2.656052e-02_rb,2.575586e-02_rb,2.496511e-02_rb,2.418783e-02_rb,2.342500e-02_rb,&
6374 & 2.267646e-02_rb,2.194177e-02_rb,2.122146e-02_rb /)
6375 ! BAND 24
6376 extliq1(:, 24) = (/ &
6377 & 6.850164e-01_rb,4.762468e-01_rb,3.642001e-01_rb,2.946012e-01_rb,2.472001e-01_rb,&
6378 & 2.128588e-01_rb,1.868537e-01_rb,1.664893e-01_rb,1.501142e-01_rb,1.366620e-01_rb,&
6379 & 1.254147e-01_rb,1.158721e-01_rb,1.076732e-01_rb,1.005530e-01_rb,9.431306e-02_rb,&
6380 & 8.879891e-02_rb,8.389232e-02_rb,7.949714e-02_rb,7.553857e-02_rb,7.195474e-02_rb,&
6381 & 6.869413e-02_rb,6.571444e-02_rb,6.298286e-02_rb,6.046779e-02_rb,5.814474e-02_rb,&
6382 & 5.599141e-02_rb,5.399114e-02_rb,5.212443e-02_rb,5.037870e-02_rb,4.874321e-02_rb,&
6383 & 4.720219e-02_rb,4.574813e-02_rb,4.437160e-02_rb,4.306460e-02_rb,4.181810e-02_rb,&
6384 & 4.062603e-02_rb,3.948252e-02_rb,3.838256e-02_rb,3.732049e-02_rb,3.629192e-02_rb,&
6385 & 3.529301e-02_rb,3.432190e-02_rb,3.337412e-02_rb,3.244842e-02_rb,3.154175e-02_rb,&
6386 & 3.065253e-02_rb,2.978063e-02_rb,2.892367e-02_rb,2.808221e-02_rb,2.725478e-02_rb,&
6387 & 2.644174e-02_rb,2.564175e-02_rb,2.485508e-02_rb,2.408303e-02_rb,2.332365e-02_rb,&
6388 & 2.257890e-02_rb,2.184824e-02_rb,2.113224e-02_rb /)
6389 ! BAND 25
6390 extliq1(:, 25) = (/ &
6391 & 6.673017e-01_rb,4.664520e-01_rb,3.579398e-01_rb,2.902234e-01_rb,2.439904e-01_rb,&
6392 & 2.104149e-01_rb,1.849277e-01_rb,1.649234e-01_rb,1.488087e-01_rb,1.355515e-01_rb,&
6393 & 1.244562e-01_rb,1.150329e-01_rb,1.069321e-01_rb,9.989310e-02_rb,9.372070e-02_rb,&
6394 & 8.826450e-02_rb,8.340622e-02_rb,7.905378e-02_rb,7.513109e-02_rb,7.157859e-02_rb,&
6395 & 6.834588e-02_rb,6.539114e-02_rb,6.268150e-02_rb,6.018621e-02_rb,5.788098e-02_rb,&
6396 & 5.574351e-02_rb,5.375699e-02_rb,5.190412e-02_rb,5.017099e-02_rb,4.854497e-02_rb,&
6397 & 4.701490e-02_rb,4.557030e-02_rb,4.420249e-02_rb,4.290304e-02_rb,4.166427e-02_rb,&
6398 & 4.047820e-02_rb,3.934232e-02_rb,3.824778e-02_rb,3.719236e-02_rb,3.616931e-02_rb,&
6399 & 3.517597e-02_rb,3.420856e-02_rb,3.326566e-02_rb,3.234346e-02_rb,3.144122e-02_rb,&
6400 & 3.055684e-02_rb,2.968798e-02_rb,2.883519e-02_rb,2.799635e-02_rb,2.717228e-02_rb,&
6401 & 2.636182e-02_rb,2.556424e-02_rb,2.478114e-02_rb,2.401086e-02_rb,2.325657e-02_rb,&
6402 & 2.251506e-02_rb,2.178594e-02_rb,2.107301e-02_rb /)
6403 ! BAND 26
6404 extliq1(:, 26) = (/ &
6405 & 6.552414e-01_rb,4.599454e-01_rb,3.538626e-01_rb,2.873547e-01_rb,2.418033e-01_rb,&
6406 & 2.086660e-01_rb,1.834885e-01_rb,1.637142e-01_rb,1.477767e-01_rb,1.346583e-01_rb,&
6407 & 1.236734e-01_rb,1.143412e-01_rb,1.063148e-01_rb,9.933905e-02_rb,9.322026e-02_rb,&
6408 & 8.780979e-02_rb,8.299230e-02_rb,7.867554e-02_rb,7.478450e-02_rb,7.126053e-02_rb,&
6409 & 6.805276e-02_rb,6.512143e-02_rb,6.243211e-02_rb,5.995541e-02_rb,5.766712e-02_rb,&
6410 & 5.554484e-02_rb,5.357246e-02_rb,5.173222e-02_rb,5.001069e-02_rb,4.839505e-02_rb,&
6411 & 4.687471e-02_rb,4.543861e-02_rb,4.407857e-02_rb,4.278577e-02_rb,4.155331e-02_rb,&
6412 & 4.037322e-02_rb,3.924302e-02_rb,3.815376e-02_rb,3.710172e-02_rb,3.608296e-02_rb,&
6413 & 3.509330e-02_rb,3.412980e-02_rb,3.319009e-02_rb,3.227106e-02_rb,3.137157e-02_rb,&
6414 & 3.048950e-02_rb,2.962365e-02_rb,2.877297e-02_rb,2.793726e-02_rb,2.711500e-02_rb,&
6415 & 2.630666e-02_rb,2.551206e-02_rb,2.473052e-02_rb,2.396287e-02_rb,2.320861e-02_rb,&
6416 & 2.246810e-02_rb,2.174162e-02_rb,2.102927e-02_rb /)
6417 ! BAND 27
6418 extliq1(:, 27) = (/ &
6419 & 6.430901e-01_rb,4.532134e-01_rb,3.496132e-01_rb,2.844655e-01_rb,2.397347e-01_rb,&
6420 & 2.071236e-01_rb,1.822976e-01_rb,1.627640e-01_rb,1.469961e-01_rb,1.340006e-01_rb,&
6421 & 1.231069e-01_rb,1.138441e-01_rb,1.058706e-01_rb,9.893678e-02_rb,9.285166e-02_rb,&
6422 & 8.746871e-02_rb,8.267411e-02_rb,7.837656e-02_rb,7.450257e-02_rb,7.099318e-02_rb,&
6423 & 6.779929e-02_rb,6.487987e-02_rb,6.220168e-02_rb,5.973530e-02_rb,5.745636e-02_rb,&
6424 & 5.534344e-02_rb,5.337986e-02_rb,5.154797e-02_rb,4.983404e-02_rb,4.822582e-02_rb,&
6425 & 4.671228e-02_rb,4.528321e-02_rb,4.392997e-02_rb,4.264325e-02_rb,4.141647e-02_rb,&
6426 & 4.024259e-02_rb,3.911767e-02_rb,3.803309e-02_rb,3.698782e-02_rb,3.597140e-02_rb,&
6427 & 3.498774e-02_rb,3.402852e-02_rb,3.309340e-02_rb,3.217818e-02_rb,3.128292e-02_rb,&
6428 & 3.040486e-02_rb,2.954230e-02_rb,2.869545e-02_rb,2.786261e-02_rb,2.704372e-02_rb,&
6429 & 2.623813e-02_rb,2.544668e-02_rb,2.466788e-02_rb,2.390313e-02_rb,2.315136e-02_rb,&
6430 & 2.241391e-02_rb,2.168921e-02_rb,2.097903e-02_rb /)
6431 ! BAND 28
6432 extliq1(:, 28) = (/ &
6433 & 6.367074e-01_rb,4.495768e-01_rb,3.471263e-01_rb,2.826149e-01_rb,2.382868e-01_rb,&
6434 & 2.059640e-01_rb,1.813562e-01_rb,1.619881e-01_rb,1.463436e-01_rb,1.334402e-01_rb,&
6435 & 1.226166e-01_rb,1.134096e-01_rb,1.054829e-01_rb,9.858838e-02_rb,9.253790e-02_rb,&
6436 & 8.718582e-02_rb,8.241830e-02_rb,7.814482e-02_rb,7.429212e-02_rb,7.080165e-02_rb,&
6437 & 6.762385e-02_rb,6.471838e-02_rb,6.205388e-02_rb,5.959726e-02_rb,5.732871e-02_rb,&
6438 & 5.522402e-02_rb,5.326793e-02_rb,5.144230e-02_rb,4.973440e-02_rb,4.813188e-02_rb,&
6439 & 4.662283e-02_rb,4.519798e-02_rb,4.384833e-02_rb,4.256541e-02_rb,4.134253e-02_rb,&
6440 & 4.017136e-02_rb,3.904911e-02_rb,3.796779e-02_rb,3.692364e-02_rb,3.591182e-02_rb,&
6441 & 3.492930e-02_rb,3.397230e-02_rb,3.303920e-02_rb,3.212572e-02_rb,3.123278e-02_rb,&
6442 & 3.035519e-02_rb,2.949493e-02_rb,2.864985e-02_rb,2.781840e-02_rb,2.700197e-02_rb,&
6443 & 2.619682e-02_rb,2.540674e-02_rb,2.462966e-02_rb,2.386613e-02_rb,2.311602e-02_rb,&
6444 & 2.237846e-02_rb,2.165660e-02_rb,2.094756e-02_rb /)
6445 ! BAND 29
6446 extliq1(:, 29) = (/ &
6447 & 4.298416e-01_rb,4.391639e-01_rb,3.975030e-01_rb,3.443028e-01_rb,2.957345e-01_rb,&
6448 & 2.556461e-01_rb,2.234755e-01_rb,1.976636e-01_rb,1.767428e-01_rb,1.595611e-01_rb,&
6449 & 1.452636e-01_rb,1.332156e-01_rb,1.229481e-01_rb,1.141059e-01_rb,1.064208e-01_rb,&
6450 & 9.968527e-02_rb,9.373833e-02_rb,8.845221e-02_rb,8.372112e-02_rb,7.946667e-02_rb,&
6451 & 7.561807e-02_rb,7.212029e-02_rb,6.893166e-02_rb,6.600944e-02_rb,6.332277e-02_rb,&
6452 & 6.084277e-02_rb,5.854721e-02_rb,5.641361e-02_rb,5.442639e-02_rb,5.256750e-02_rb,&
6453 & 5.082499e-02_rb,4.918556e-02_rb,4.763694e-02_rb,4.617222e-02_rb,4.477861e-02_rb,&
6454 & 4.344861e-02_rb,4.217999e-02_rb,4.096111e-02_rb,3.978638e-02_rb,3.865361e-02_rb,&
6455 & 3.755473e-02_rb,3.649028e-02_rb,3.545361e-02_rb,3.444361e-02_rb,3.345666e-02_rb,&
6456 & 3.249167e-02_rb,3.154722e-02_rb,3.062083e-02_rb,2.971250e-02_rb,2.882083e-02_rb,&
6457 & 2.794611e-02_rb,2.708778e-02_rb,2.624500e-02_rb,2.541750e-02_rb,2.460528e-02_rb,&
6458 & 2.381194e-02_rb,2.303250e-02_rb,2.226833e-02_rb /)
6459 ! BAND 16
6460 ssaliq1(:, 16) = (/ &
6461 & 8.362119e-01_rb,8.098460e-01_rb,7.762291e-01_rb,7.486042e-01_rb,7.294172e-01_rb,&
6462 & 7.161000e-01_rb,7.060656e-01_rb,6.978387e-01_rb,6.907193e-01_rb,6.843551e-01_rb,&
6463 & 6.785668e-01_rb,6.732450e-01_rb,6.683191e-01_rb,6.637264e-01_rb,6.594307e-01_rb,&
6464 & 6.554033e-01_rb,6.516115e-01_rb,6.480295e-01_rb,6.446429e-01_rb,6.414306e-01_rb,&
6465 & 6.383783e-01_rb,6.354750e-01_rb,6.327068e-01_rb,6.300665e-01_rb,6.275376e-01_rb,&
6466 & 6.251245e-01_rb,6.228136e-01_rb,6.205944e-01_rb,6.184720e-01_rb,6.164330e-01_rb,&
6467 & 6.144742e-01_rb,6.125962e-01_rb,6.108004e-01_rb,6.090740e-01_rb,6.074200e-01_rb,&
6468 & 6.058381e-01_rb,6.043209e-01_rb,6.028681e-01_rb,6.014836e-01_rb,6.001626e-01_rb,&
6469 & 5.988957e-01_rb,5.976864e-01_rb,5.965390e-01_rb,5.954379e-01_rb,5.943972e-01_rb,&
6470 & 5.934019e-01_rb,5.924624e-01_rb,5.915579e-01_rb,5.907025e-01_rb,5.898913e-01_rb,&
6471 & 5.891213e-01_rb,5.883815e-01_rb,5.876851e-01_rb,5.870158e-01_rb,5.863868e-01_rb,&
6472 & 5.857821e-01_rb,5.852111e-01_rb,5.846579e-01_rb /)
6473 ! BAND 17
6474 ssaliq1(:, 17) = (/ &
6475 & 6.995459e-01_rb,7.158012e-01_rb,7.076001e-01_rb,6.927244e-01_rb,6.786434e-01_rb,&
6476 & 6.673545e-01_rb,6.585859e-01_rb,6.516314e-01_rb,6.459010e-01_rb,6.410225e-01_rb,&
6477 & 6.367574e-01_rb,6.329554e-01_rb,6.295119e-01_rb,6.263595e-01_rb,6.234462e-01_rb,&
6478 & 6.207274e-01_rb,6.181755e-01_rb,6.157678e-01_rb,6.134880e-01_rb,6.113173e-01_rb,&
6479 & 6.092495e-01_rb,6.072689e-01_rb,6.053717e-01_rb,6.035507e-01_rb,6.018001e-01_rb,&
6480 & 6.001134e-01_rb,5.984951e-01_rb,5.969294e-01_rb,5.954256e-01_rb,5.939698e-01_rb,&
6481 & 5.925716e-01_rb,5.912265e-01_rb,5.899270e-01_rb,5.886771e-01_rb,5.874746e-01_rb,&
6482 & 5.863185e-01_rb,5.852077e-01_rb,5.841460e-01_rb,5.831249e-01_rb,5.821474e-01_rb,&
6483 & 5.812078e-01_rb,5.803173e-01_rb,5.794616e-01_rb,5.786443e-01_rb,5.778617e-01_rb,&
6484 & 5.771236e-01_rb,5.764191e-01_rb,5.757400e-01_rb,5.750971e-01_rb,5.744842e-01_rb,&
6485 & 5.739012e-01_rb,5.733482e-01_rb,5.728175e-01_rb,5.723214e-01_rb,5.718383e-01_rb,&
6486 & 5.713827e-01_rb,5.709471e-01_rb,5.705330e-01_rb /)
6487 ! BAND 18
6488 ssaliq1(:, 18) = (/ &
6489 & 9.929711e-01_rb,9.896942e-01_rb,9.852408e-01_rb,9.806820e-01_rb,9.764512e-01_rb,&
6490 & 9.725375e-01_rb,9.688677e-01_rb,9.653832e-01_rb,9.620552e-01_rb,9.588522e-01_rb,&
6491 & 9.557475e-01_rb,9.527265e-01_rb,9.497731e-01_rb,9.468756e-01_rb,9.440270e-01_rb,&
6492 & 9.412230e-01_rb,9.384592e-01_rb,9.357287e-01_rb,9.330369e-01_rb,9.303778e-01_rb,&
6493 & 9.277502e-01_rb,9.251546e-01_rb,9.225907e-01_rb,9.200553e-01_rb,9.175521e-01_rb,&
6494 & 9.150773e-01_rb,9.126352e-01_rb,9.102260e-01_rb,9.078485e-01_rb,9.055057e-01_rb,&
6495 & 9.031978e-01_rb,9.009306e-01_rb,8.987010e-01_rb,8.965177e-01_rb,8.943774e-01_rb,&
6496 & 8.922869e-01_rb,8.902430e-01_rb,8.882551e-01_rb,8.863182e-01_rb,8.844373e-01_rb,&
6497 & 8.826143e-01_rb,8.808499e-01_rb,8.791413e-01_rb,8.774940e-01_rb,8.759019e-01_rb,&
6498 & 8.743650e-01_rb,8.728941e-01_rb,8.714712e-01_rb,8.701065e-01_rb,8.688008e-01_rb,&
6499 & 8.675409e-01_rb,8.663295e-01_rb,8.651714e-01_rb,8.640637e-01_rb,8.629943e-01_rb,&
6500 & 8.619762e-01_rb,8.609995e-01_rb,8.600581e-01_rb /)
6501 ! BAND 19
6502 ssaliq1(:, 19) = (/ &
6503 & 9.910612e-01_rb,9.854226e-01_rb,9.795008e-01_rb,9.742920e-01_rb,9.695996e-01_rb,&
6504 & 9.652274e-01_rb,9.610648e-01_rb,9.570521e-01_rb,9.531397e-01_rb,9.493086e-01_rb,&
6505 & 9.455413e-01_rb,9.418362e-01_rb,9.381902e-01_rb,9.346016e-01_rb,9.310718e-01_rb,&
6506 & 9.275957e-01_rb,9.241757e-01_rb,9.208038e-01_rb,9.174802e-01_rb,9.142058e-01_rb,&
6507 & 9.109753e-01_rb,9.077895e-01_rb,9.046433e-01_rb,9.015409e-01_rb,8.984784e-01_rb,&
6508 & 8.954572e-01_rb,8.924748e-01_rb,8.895367e-01_rb,8.866395e-01_rb,8.837864e-01_rb,&
6509 & 8.809819e-01_rb,8.782267e-01_rb,8.755231e-01_rb,8.728712e-01_rb,8.702802e-01_rb,&
6510 & 8.677443e-01_rb,8.652733e-01_rb,8.628678e-01_rb,8.605300e-01_rb,8.582593e-01_rb,&
6511 & 8.560596e-01_rb,8.539352e-01_rb,8.518782e-01_rb,8.498915e-01_rb,8.479790e-01_rb,&
6512 & 8.461384e-01_rb,8.443645e-01_rb,8.426613e-01_rb,8.410229e-01_rb,8.394495e-01_rb,&
6513 & 8.379428e-01_rb,8.364967e-01_rb,8.351117e-01_rb,8.337820e-01_rb,8.325091e-01_rb,&
6514 & 8.312874e-01_rb,8.301169e-01_rb,8.289985e-01_rb /)
6515 ! BAND 20
6516 ssaliq1(:, 20) = (/ &
6517 & 9.969802e-01_rb,9.950445e-01_rb,9.931448e-01_rb,9.914272e-01_rb,9.898652e-01_rb,&
6518 & 9.884250e-01_rb,9.870637e-01_rb,9.857482e-01_rb,9.844558e-01_rb,9.831755e-01_rb,&
6519 & 9.819068e-01_rb,9.806477e-01_rb,9.794000e-01_rb,9.781666e-01_rb,9.769461e-01_rb,&
6520 & 9.757386e-01_rb,9.745459e-01_rb,9.733650e-01_rb,9.721953e-01_rb,9.710398e-01_rb,&
6521 & 9.698936e-01_rb,9.687583e-01_rb,9.676334e-01_rb,9.665192e-01_rb,9.654132e-01_rb,&
6522 & 9.643208e-01_rb,9.632374e-01_rb,9.621625e-01_rb,9.611003e-01_rb,9.600518e-01_rb,&
6523 & 9.590144e-01_rb,9.579922e-01_rb,9.569864e-01_rb,9.559948e-01_rb,9.550239e-01_rb,&
6524 & 9.540698e-01_rb,9.531382e-01_rb,9.522280e-01_rb,9.513409e-01_rb,9.504772e-01_rb,&
6525 & 9.496360e-01_rb,9.488220e-01_rb,9.480327e-01_rb,9.472693e-01_rb,9.465333e-01_rb,&
6526 & 9.458211e-01_rb,9.451344e-01_rb,9.444732e-01_rb,9.438372e-01_rb,9.432268e-01_rb,&
6527 & 9.426391e-01_rb,9.420757e-01_rb,9.415308e-01_rb,9.410102e-01_rb,9.405115e-01_rb,&
6528 & 9.400326e-01_rb,9.395716e-01_rb,9.391313e-01_rb /)
6529 ! BAND 21
6530 ssaliq1(:, 21) = (/ &
6531 & 9.980034e-01_rb,9.968572e-01_rb,9.958696e-01_rb,9.949747e-01_rb,9.941241e-01_rb,&
6532 & 9.933043e-01_rb,9.924971e-01_rb,9.916978e-01_rb,9.909023e-01_rb,9.901046e-01_rb,&
6533 & 9.893087e-01_rb,9.885146e-01_rb,9.877195e-01_rb,9.869283e-01_rb,9.861379e-01_rb,&
6534 & 9.853523e-01_rb,9.845715e-01_rb,9.837945e-01_rb,9.830217e-01_rb,9.822567e-01_rb,&
6535 & 9.814935e-01_rb,9.807356e-01_rb,9.799815e-01_rb,9.792332e-01_rb,9.784845e-01_rb,&
6536 & 9.777424e-01_rb,9.770042e-01_rb,9.762695e-01_rb,9.755416e-01_rb,9.748152e-01_rb,&
6537 & 9.740974e-01_rb,9.733873e-01_rb,9.726813e-01_rb,9.719861e-01_rb,9.713010e-01_rb,&
6538 & 9.706262e-01_rb,9.699647e-01_rb,9.693144e-01_rb,9.686794e-01_rb,9.680596e-01_rb,&
6539 & 9.674540e-01_rb,9.668657e-01_rb,9.662926e-01_rb,9.657390e-01_rb,9.652019e-01_rb,&
6540 & 9.646820e-01_rb,9.641784e-01_rb,9.636945e-01_rb,9.632260e-01_rb,9.627743e-01_rb,&
6541 & 9.623418e-01_rb,9.619227e-01_rb,9.615194e-01_rb,9.611341e-01_rb,9.607629e-01_rb,&
6542 & 9.604057e-01_rb,9.600622e-01_rb,9.597322e-01_rb /)
6543 ! BAND 22
6544 ssaliq1(:, 22) = (/ &
6545 & 9.988219e-01_rb,9.981767e-01_rb,9.976168e-01_rb,9.971066e-01_rb,9.966195e-01_rb,&
6546 & 9.961566e-01_rb,9.956995e-01_rb,9.952481e-01_rb,9.947982e-01_rb,9.943495e-01_rb,&
6547 & 9.938955e-01_rb,9.934368e-01_rb,9.929825e-01_rb,9.925239e-01_rb,9.920653e-01_rb,&
6548 & 9.916096e-01_rb,9.911552e-01_rb,9.907067e-01_rb,9.902594e-01_rb,9.898178e-01_rb,&
6549 & 9.893791e-01_rb,9.889453e-01_rb,9.885122e-01_rb,9.880837e-01_rb,9.876567e-01_rb,&
6550 & 9.872331e-01_rb,9.868121e-01_rb,9.863938e-01_rb,9.859790e-01_rb,9.855650e-01_rb,&
6551 & 9.851548e-01_rb,9.847491e-01_rb,9.843496e-01_rb,9.839521e-01_rb,9.835606e-01_rb,&
6552 & 9.831771e-01_rb,9.827975e-01_rb,9.824292e-01_rb,9.820653e-01_rb,9.817124e-01_rb,&
6553 & 9.813644e-01_rb,9.810291e-01_rb,9.807020e-01_rb,9.803864e-01_rb,9.800782e-01_rb,&
6554 & 9.797821e-01_rb,9.794958e-01_rb,9.792179e-01_rb,9.789509e-01_rb,9.786940e-01_rb,&
6555 & 9.784460e-01_rb,9.782090e-01_rb,9.779789e-01_rb,9.777553e-01_rb,9.775425e-01_rb,&
6556 & 9.773387e-01_rb,9.771420e-01_rb,9.769529e-01_rb /)
6557 ! BAND 23
6558 ssaliq1(:, 23) = (/ &
6559 & 9.998902e-01_rb,9.998395e-01_rb,9.997915e-01_rb,9.997442e-01_rb,9.997016e-01_rb,&
6560 & 9.996600e-01_rb,9.996200e-01_rb,9.995806e-01_rb,9.995411e-01_rb,9.995005e-01_rb,&
6561 & 9.994589e-01_rb,9.994178e-01_rb,9.993766e-01_rb,9.993359e-01_rb,9.992948e-01_rb,&
6562 & 9.992533e-01_rb,9.992120e-01_rb,9.991723e-01_rb,9.991313e-01_rb,9.990906e-01_rb,&
6563 & 9.990510e-01_rb,9.990113e-01_rb,9.989716e-01_rb,9.989323e-01_rb,9.988923e-01_rb,&
6564 & 9.988532e-01_rb,9.988140e-01_rb,9.987761e-01_rb,9.987373e-01_rb,9.986989e-01_rb,&
6565 & 9.986597e-01_rb,9.986239e-01_rb,9.985861e-01_rb,9.985485e-01_rb,9.985123e-01_rb,&
6566 & 9.984762e-01_rb,9.984415e-01_rb,9.984065e-01_rb,9.983722e-01_rb,9.983398e-01_rb,&
6567 & 9.983078e-01_rb,9.982758e-01_rb,9.982461e-01_rb,9.982157e-01_rb,9.981872e-01_rb,&
6568 & 9.981595e-01_rb,9.981324e-01_rb,9.981068e-01_rb,9.980811e-01_rb,9.980580e-01_rb,&
6569 & 9.980344e-01_rb,9.980111e-01_rb,9.979908e-01_rb,9.979690e-01_rb,9.979492e-01_rb,&
6570 & 9.979316e-01_rb,9.979116e-01_rb,9.978948e-01_rb /)
6571 ! BAND 24
6572 ssaliq1(:, 24) = (/ &
6573 & 9.999978e-01_rb,9.999948e-01_rb,9.999915e-01_rb,9.999905e-01_rb,9.999896e-01_rb,&
6574 & 9.999887e-01_rb,9.999888e-01_rb,9.999888e-01_rb,9.999870e-01_rb,9.999854e-01_rb,&
6575 & 9.999855e-01_rb,9.999856e-01_rb,9.999839e-01_rb,9.999834e-01_rb,9.999829e-01_rb,&
6576 & 9.999809e-01_rb,9.999816e-01_rb,9.999793e-01_rb,9.999782e-01_rb,9.999779e-01_rb,&
6577 & 9.999772e-01_rb,9.999764e-01_rb,9.999756e-01_rb,9.999744e-01_rb,9.999744e-01_rb,&
6578 & 9.999736e-01_rb,9.999729e-01_rb,9.999716e-01_rb,9.999706e-01_rb,9.999692e-01_rb,&
6579 & 9.999690e-01_rb,9.999675e-01_rb,9.999673e-01_rb,9.999660e-01_rb,9.999654e-01_rb,&
6580 & 9.999647e-01_rb,9.999647e-01_rb,9.999625e-01_rb,9.999620e-01_rb,9.999614e-01_rb,&
6581 & 9.999613e-01_rb,9.999607e-01_rb,9.999604e-01_rb,9.999594e-01_rb,9.999589e-01_rb,&
6582 & 9.999586e-01_rb,9.999567e-01_rb,9.999550e-01_rb,9.999557e-01_rb,9.999542e-01_rb,&
6583 & 9.999546e-01_rb,9.999539e-01_rb,9.999536e-01_rb,9.999526e-01_rb,9.999523e-01_rb,&
6584 & 9.999508e-01_rb,9.999534e-01_rb,9.999507e-01_rb /)
6585 ! BAND 25
6586 ssaliq1(:, 25) = (/ &
6587 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6588 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6589 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6590 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999995e-01_rb,&
6591 & 9.999995e-01_rb,9.999990e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,&
6592 & 9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999986e-01_rb,9.999988e-01_rb,&
6593 & 9.999986e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,&
6594 & 9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999981e-01_rb,&
6595 & 9.999981e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999984e-01_rb,&
6596 & 9.999982e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999981e-01_rb,&
6597 & 9.999978e-01_rb,9.999979e-01_rb,9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,&
6598 & 9.999983e-01_rb,9.999983e-01_rb,9.999983e-01_rb /)
6599 ! BAND 26
6600 ssaliq1(:, 26) = (/ &
6601 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6602 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6603 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,&
6604 & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999991e-01_rb,&
6605 & 9.999990e-01_rb,9.999992e-01_rb,9.999995e-01_rb,9.999986e-01_rb,9.999994e-01_rb,&
6606 & 9.999985e-01_rb,9.999980e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999979e-01_rb,&
6607 & 9.999969e-01_rb,9.999977e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999969e-01_rb,&
6608 & 9.999965e-01_rb,9.999970e-01_rb,9.999985e-01_rb,9.999973e-01_rb,9.999961e-01_rb,&
6609 & 9.999968e-01_rb,9.999952e-01_rb,9.999970e-01_rb,9.999974e-01_rb,9.999965e-01_rb,&
6610 & 9.999969e-01_rb,9.999970e-01_rb,9.999970e-01_rb,9.999960e-01_rb,9.999923e-01_rb,&
6611 & 9.999958e-01_rb,9.999937e-01_rb,9.999960e-01_rb,9.999953e-01_rb,9.999946e-01_rb,&
6612 & 9.999946e-01_rb,9.999957e-01_rb,9.999951e-01_rb /)
6613 ! BAND 27
6614 ssaliq1(:, 27) = (/ &
6615 & 1.000000e+00_rb,1.000000e+00_rb,9.999983e-01_rb,9.999979e-01_rb,9.999965e-01_rb,&
6616 & 9.999949e-01_rb,9.999948e-01_rb,9.999918e-01_rb,9.999917e-01_rb,9.999923e-01_rb,&
6617 & 9.999908e-01_rb,9.999889e-01_rb,9.999902e-01_rb,9.999895e-01_rb,9.999881e-01_rb,&
6618 & 9.999882e-01_rb,9.999876e-01_rb,9.999866e-01_rb,9.999866e-01_rb,9.999858e-01_rb,&
6619 & 9.999860e-01_rb,9.999852e-01_rb,9.999836e-01_rb,9.999831e-01_rb,9.999818e-01_rb,&
6620 & 9.999808e-01_rb,9.999816e-01_rb,9.999800e-01_rb,9.999783e-01_rb,9.999780e-01_rb,&
6621 & 9.999763e-01_rb,9.999746e-01_rb,9.999731e-01_rb,9.999713e-01_rb,9.999762e-01_rb,&
6622 & 9.999740e-01_rb,9.999670e-01_rb,9.999703e-01_rb,9.999687e-01_rb,9.999666e-01_rb,&
6623 & 9.999683e-01_rb,9.999667e-01_rb,9.999611e-01_rb,9.999635e-01_rb,9.999600e-01_rb,&
6624 & 9.999635e-01_rb,9.999594e-01_rb,9.999601e-01_rb,9.999586e-01_rb,9.999559e-01_rb,&
6625 & 9.999569e-01_rb,9.999558e-01_rb,9.999523e-01_rb,9.999535e-01_rb,9.999529e-01_rb,&
6626 & 9.999553e-01_rb,9.999495e-01_rb,9.999490e-01_rb /)
6627 ! BAND 28
6628 ssaliq1(:, 28) = (/ &
6629 & 9.999920e-01_rb,9.999873e-01_rb,9.999855e-01_rb,9.999832e-01_rb,9.999807e-01_rb,&
6630 & 9.999778e-01_rb,9.999754e-01_rb,9.999721e-01_rb,9.999692e-01_rb,9.999651e-01_rb,&
6631 & 9.999621e-01_rb,9.999607e-01_rb,9.999567e-01_rb,9.999546e-01_rb,9.999521e-01_rb,&
6632 & 9.999491e-01_rb,9.999457e-01_rb,9.999439e-01_rb,9.999403e-01_rb,9.999374e-01_rb,&
6633 & 9.999353e-01_rb,9.999315e-01_rb,9.999282e-01_rb,9.999244e-01_rb,9.999234e-01_rb,&
6634 & 9.999189e-01_rb,9.999130e-01_rb,9.999117e-01_rb,9.999073e-01_rb,9.999020e-01_rb,&
6635 & 9.998993e-01_rb,9.998987e-01_rb,9.998922e-01_rb,9.998893e-01_rb,9.998869e-01_rb,&
6636 & 9.998805e-01_rb,9.998778e-01_rb,9.998751e-01_rb,9.998708e-01_rb,9.998676e-01_rb,&
6637 & 9.998624e-01_rb,9.998642e-01_rb,9.998582e-01_rb,9.998547e-01_rb,9.998546e-01_rb,&
6638 & 9.998477e-01_rb,9.998487e-01_rb,9.998466e-01_rb,9.998403e-01_rb,9.998412e-01_rb,&
6639 & 9.998406e-01_rb,9.998342e-01_rb,9.998326e-01_rb,9.998333e-01_rb,9.998328e-01_rb,&
6640 & 9.998290e-01_rb,9.998276e-01_rb,9.998249e-01_rb /)
6641 ! BAND 29
6642 ssaliq1(:, 29) = (/ &
6643 & 8.383753e-01_rb,8.461471e-01_rb,8.373325e-01_rb,8.212889e-01_rb,8.023834e-01_rb,&
6644 & 7.829501e-01_rb,7.641777e-01_rb,7.466000e-01_rb,7.304023e-01_rb,7.155998e-01_rb,&
6645 & 7.021259e-01_rb,6.898840e-01_rb,6.787615e-01_rb,6.686479e-01_rb,6.594414e-01_rb,&
6646 & 6.510417e-01_rb,6.433668e-01_rb,6.363335e-01_rb,6.298788e-01_rb,6.239398e-01_rb,&
6647 & 6.184633e-01_rb,6.134055e-01_rb,6.087228e-01_rb,6.043786e-01_rb,6.003439e-01_rb,&
6648 & 5.965910e-01_rb,5.930917e-01_rb,5.898280e-01_rb,5.867798e-01_rb,5.839264e-01_rb,&
6649 & 5.812576e-01_rb,5.787592e-01_rb,5.764163e-01_rb,5.742189e-01_rb,5.721598e-01_rb,&
6650 & 5.702286e-01_rb,5.684182e-01_rb,5.667176e-01_rb,5.651237e-01_rb,5.636253e-01_rb,&
6651 & 5.622228e-01_rb,5.609074e-01_rb,5.596713e-01_rb,5.585089e-01_rb,5.574223e-01_rb,&
6652 & 5.564002e-01_rb,5.554411e-01_rb,5.545397e-01_rb,5.536914e-01_rb,5.528967e-01_rb,&
6653 & 5.521495e-01_rb,5.514457e-01_rb,5.507818e-01_rb,5.501623e-01_rb,5.495750e-01_rb,&
6654 & 5.490192e-01_rb,5.484980e-01_rb,5.480046e-01_rb /)
6655 ! BAND 16
6656 asyliq1(:, 16) = (/ &
6657 & 8.038165e-01_rb,8.014154e-01_rb,7.942381e-01_rb,7.970521e-01_rb,8.086621e-01_rb,&
6658 & 8.233392e-01_rb,8.374127e-01_rb,8.495742e-01_rb,8.596945e-01_rb,8.680497e-01_rb,&
6659 & 8.750005e-01_rb,8.808589e-01_rb,8.858749e-01_rb,8.902403e-01_rb,8.940939e-01_rb,&
6660 & 8.975379e-01_rb,9.006450e-01_rb,9.034741e-01_rb,9.060659e-01_rb,9.084561e-01_rb,&
6661 & 9.106675e-01_rb,9.127198e-01_rb,9.146332e-01_rb,9.164194e-01_rb,9.180970e-01_rb,&
6662 & 9.196658e-01_rb,9.211421e-01_rb,9.225352e-01_rb,9.238443e-01_rb,9.250841e-01_rb,&
6663 & 9.262541e-01_rb,9.273620e-01_rb,9.284081e-01_rb,9.294002e-01_rb,9.303395e-01_rb,&
6664 & 9.312285e-01_rb,9.320715e-01_rb,9.328716e-01_rb,9.336271e-01_rb,9.343427e-01_rb,&
6665 & 9.350219e-01_rb,9.356647e-01_rb,9.362728e-01_rb,9.368495e-01_rb,9.373956e-01_rb,&
6666 & 9.379113e-01_rb,9.383987e-01_rb,9.388608e-01_rb,9.392986e-01_rb,9.397132e-01_rb,&
6667 & 9.401063e-01_rb,9.404776e-01_rb,9.408299e-01_rb,9.411641e-01_rb,9.414800e-01_rb,&
6668 & 9.417787e-01_rb,9.420633e-01_rb,9.423364e-01_rb /)
6669 ! BAND 17
6670 asyliq1(:, 17) = (/ &
6671 & 8.941000e-01_rb,9.054049e-01_rb,9.049510e-01_rb,9.027216e-01_rb,9.021636e-01_rb,&
6672 & 9.037878e-01_rb,9.069852e-01_rb,9.109817e-01_rb,9.152013e-01_rb,9.193040e-01_rb,&
6673 & 9.231177e-01_rb,9.265712e-01_rb,9.296606e-01_rb,9.324048e-01_rb,9.348419e-01_rb,&
6674 & 9.370131e-01_rb,9.389529e-01_rb,9.406954e-01_rb,9.422727e-01_rb,9.437088e-01_rb,&
6675 & 9.450221e-01_rb,9.462308e-01_rb,9.473488e-01_rb,9.483830e-01_rb,9.493492e-01_rb,&
6676 & 9.502541e-01_rb,9.510999e-01_rb,9.518971e-01_rb,9.526455e-01_rb,9.533554e-01_rb,&
6677 & 9.540249e-01_rb,9.546571e-01_rb,9.552551e-01_rb,9.558258e-01_rb,9.563603e-01_rb,&
6678 & 9.568713e-01_rb,9.573569e-01_rb,9.578141e-01_rb,9.582485e-01_rb,9.586604e-01_rb,&
6679 & 9.590525e-01_rb,9.594218e-01_rb,9.597710e-01_rb,9.601052e-01_rb,9.604181e-01_rb,&
6680 & 9.607159e-01_rb,9.609979e-01_rb,9.612655e-01_rb,9.615184e-01_rb,9.617564e-01_rb,&
6681 & 9.619860e-01_rb,9.622009e-01_rb,9.624031e-01_rb,9.625957e-01_rb,9.627792e-01_rb,&
6682 & 9.629530e-01_rb,9.631171e-01_rb,9.632746e-01_rb /)
6683 ! BAND 18
6684 asyliq1(:, 18) = (/ &
6685 & 8.574638e-01_rb,8.351383e-01_rb,8.142977e-01_rb,8.083068e-01_rb,8.129284e-01_rb,&
6686 & 8.215827e-01_rb,8.307238e-01_rb,8.389963e-01_rb,8.460481e-01_rb,8.519273e-01_rb,&
6687 & 8.568153e-01_rb,8.609116e-01_rb,8.643892e-01_rb,8.673941e-01_rb,8.700248e-01_rb,&
6688 & 8.723707e-01_rb,8.744902e-01_rb,8.764240e-01_rb,8.782057e-01_rb,8.798593e-01_rb,&
6689 & 8.814063e-01_rb,8.828573e-01_rb,8.842261e-01_rb,8.855196e-01_rb,8.867497e-01_rb,&
6690 & 8.879164e-01_rb,8.890316e-01_rb,8.900941e-01_rb,8.911118e-01_rb,8.920832e-01_rb,&
6691 & 8.930156e-01_rb,8.939091e-01_rb,8.947663e-01_rb,8.955888e-01_rb,8.963786e-01_rb,&
6692 & 8.971350e-01_rb,8.978617e-01_rb,8.985590e-01_rb,8.992243e-01_rb,8.998631e-01_rb,&
6693 & 9.004753e-01_rb,9.010602e-01_rb,9.016192e-01_rb,9.021542e-01_rb,9.026644e-01_rb,&
6694 & 9.031535e-01_rb,9.036194e-01_rb,9.040656e-01_rb,9.044894e-01_rb,9.048933e-01_rb,&
6695 & 9.052789e-01_rb,9.056481e-01_rb,9.060004e-01_rb,9.063343e-01_rb,9.066544e-01_rb,&
6696 & 9.069604e-01_rb,9.072512e-01_rb,9.075290e-01_rb /)
6697 ! BAND 19
6698 asyliq1(:, 19) = (/ &
6699 & 8.349569e-01_rb,8.034579e-01_rb,7.932136e-01_rb,8.010156e-01_rb,8.137083e-01_rb,&
6700 & 8.255339e-01_rb,8.351938e-01_rb,8.428286e-01_rb,8.488944e-01_rb,8.538187e-01_rb,&
6701 & 8.579255e-01_rb,8.614473e-01_rb,8.645338e-01_rb,8.672908e-01_rb,8.697947e-01_rb,&
6702 & 8.720843e-01_rb,8.742015e-01_rb,8.761718e-01_rb,8.780160e-01_rb,8.797479e-01_rb,&
6703 & 8.813810e-01_rb,8.829250e-01_rb,8.843907e-01_rb,8.857822e-01_rb,8.871059e-01_rb,&
6704 & 8.883724e-01_rb,8.895810e-01_rb,8.907384e-01_rb,8.918456e-01_rb,8.929083e-01_rb,&
6705 & 8.939284e-01_rb,8.949060e-01_rb,8.958463e-01_rb,8.967486e-01_rb,8.976129e-01_rb,&
6706 & 8.984463e-01_rb,8.992439e-01_rb,9.000094e-01_rb,9.007438e-01_rb,9.014496e-01_rb,&
6707 & 9.021235e-01_rb,9.027699e-01_rb,9.033859e-01_rb,9.039772e-01_rb,9.045419e-01_rb,&
6708 & 9.050819e-01_rb,9.055975e-01_rb,9.060907e-01_rb,9.065607e-01_rb,9.070093e-01_rb,&
6709 & 9.074389e-01_rb,9.078475e-01_rb,9.082388e-01_rb,9.086117e-01_rb,9.089678e-01_rb,&
6710 & 9.093081e-01_rb,9.096307e-01_rb,9.099410e-01_rb /)
6711 ! BAND 20
6712 asyliq1(:, 20) = (/ &
6713 & 8.109692e-01_rb,7.846657e-01_rb,7.881928e-01_rb,8.009509e-01_rb,8.131208e-01_rb,&
6714 & 8.230400e-01_rb,8.309448e-01_rb,8.372920e-01_rb,8.424837e-01_rb,8.468166e-01_rb,&
6715 & 8.504947e-01_rb,8.536642e-01_rb,8.564256e-01_rb,8.588513e-01_rb,8.610011e-01_rb,&
6716 & 8.629122e-01_rb,8.646262e-01_rb,8.661720e-01_rb,8.675752e-01_rb,8.688582e-01_rb,&
6717 & 8.700379e-01_rb,8.711300e-01_rb,8.721485e-01_rb,8.731027e-01_rb,8.740010e-01_rb,&
6718 & 8.748499e-01_rb,8.756564e-01_rb,8.764239e-01_rb,8.771542e-01_rb,8.778523e-01_rb,&
6719 & 8.785211e-01_rb,8.791601e-01_rb,8.797725e-01_rb,8.803589e-01_rb,8.809173e-01_rb,&
6720 & 8.814552e-01_rb,8.819705e-01_rb,8.824611e-01_rb,8.829311e-01_rb,8.833791e-01_rb,&
6721 & 8.838078e-01_rb,8.842148e-01_rb,8.846044e-01_rb,8.849756e-01_rb,8.853291e-01_rb,&
6722 & 8.856645e-01_rb,8.859841e-01_rb,8.862904e-01_rb,8.865801e-01_rb,8.868551e-01_rb,&
6723 & 8.871182e-01_rb,8.873673e-01_rb,8.876059e-01_rb,8.878307e-01_rb,8.880462e-01_rb,&
6724 & 8.882501e-01_rb,8.884453e-01_rb,8.886339e-01_rb /)
6725 ! BAND 21
6726 asyliq1(:, 21) = (/ &
6727 & 7.838510e-01_rb,7.803151e-01_rb,7.980477e-01_rb,8.144160e-01_rb,8.261784e-01_rb,&
6728 & 8.344240e-01_rb,8.404278e-01_rb,8.450391e-01_rb,8.487593e-01_rb,8.518741e-01_rb,&
6729 & 8.545484e-01_rb,8.568890e-01_rb,8.589560e-01_rb,8.607983e-01_rb,8.624504e-01_rb,&
6730 & 8.639408e-01_rb,8.652945e-01_rb,8.665301e-01_rb,8.676634e-01_rb,8.687121e-01_rb,&
6731 & 8.696855e-01_rb,8.705933e-01_rb,8.714448e-01_rb,8.722454e-01_rb,8.730014e-01_rb,&
6732 & 8.737180e-01_rb,8.743982e-01_rb,8.750436e-01_rb,8.756598e-01_rb,8.762481e-01_rb,&
6733 & 8.768089e-01_rb,8.773427e-01_rb,8.778532e-01_rb,8.783434e-01_rb,8.788089e-01_rb,&
6734 & 8.792530e-01_rb,8.796784e-01_rb,8.800845e-01_rb,8.804716e-01_rb,8.808411e-01_rb,&
6735 & 8.811923e-01_rb,8.815276e-01_rb,8.818472e-01_rb,8.821504e-01_rb,8.824408e-01_rb,&
6736 & 8.827155e-01_rb,8.829777e-01_rb,8.832269e-01_rb,8.834631e-01_rb,8.836892e-01_rb,&
6737 & 8.839034e-01_rb,8.841075e-01_rb,8.843021e-01_rb,8.844866e-01_rb,8.846631e-01_rb,&
6738 & 8.848304e-01_rb,8.849910e-01_rb,8.851425e-01_rb /)
6739 ! BAND 22
6740 asyliq1(:, 22) = (/ &
6741 & 7.760783e-01_rb,7.890215e-01_rb,8.090192e-01_rb,8.230252e-01_rb,8.321369e-01_rb,&
6742 & 8.384258e-01_rb,8.431529e-01_rb,8.469558e-01_rb,8.501499e-01_rb,8.528899e-01_rb,&
6743 & 8.552899e-01_rb,8.573956e-01_rb,8.592570e-01_rb,8.609098e-01_rb,8.623897e-01_rb,&
6744 & 8.637169e-01_rb,8.649184e-01_rb,8.660097e-01_rb,8.670096e-01_rb,8.679338e-01_rb,&
6745 & 8.687896e-01_rb,8.695880e-01_rb,8.703365e-01_rb,8.710422e-01_rb,8.717092e-01_rb,&
6746 & 8.723378e-01_rb,8.729363e-01_rb,8.735063e-01_rb,8.740475e-01_rb,8.745661e-01_rb,&
6747 & 8.750560e-01_rb,8.755275e-01_rb,8.759731e-01_rb,8.764000e-01_rb,8.768071e-01_rb,&
6748 & 8.771942e-01_rb,8.775628e-01_rb,8.779126e-01_rb,8.782483e-01_rb,8.785626e-01_rb,&
6749 & 8.788610e-01_rb,8.791482e-01_rb,8.794180e-01_rb,8.796765e-01_rb,8.799207e-01_rb,&
6750 & 8.801522e-01_rb,8.803707e-01_rb,8.805777e-01_rb,8.807749e-01_rb,8.809605e-01_rb,&
6751 & 8.811362e-01_rb,8.813047e-01_rb,8.814647e-01_rb,8.816131e-01_rb,8.817588e-01_rb,&
6752 & 8.818930e-01_rb,8.820230e-01_rb,8.821445e-01_rb /)
6753 ! BAND 23
6754 asyliq1(:, 23) = (/ &
6755 & 7.847907e-01_rb,8.099917e-01_rb,8.257428e-01_rb,8.350423e-01_rb,8.411971e-01_rb,&
6756 & 8.457241e-01_rb,8.493010e-01_rb,8.522565e-01_rb,8.547660e-01_rb,8.569311e-01_rb,&
6757 & 8.588181e-01_rb,8.604729e-01_rb,8.619296e-01_rb,8.632208e-01_rb,8.643725e-01_rb,&
6758 & 8.654050e-01_rb,8.663363e-01_rb,8.671835e-01_rb,8.679590e-01_rb,8.686707e-01_rb,&
6759 & 8.693308e-01_rb,8.699433e-01_rb,8.705147e-01_rb,8.710490e-01_rb,8.715497e-01_rb,&
6760 & 8.720219e-01_rb,8.724669e-01_rb,8.728849e-01_rb,8.732806e-01_rb,8.736550e-01_rb,&
6761 & 8.740099e-01_rb,8.743435e-01_rb,8.746601e-01_rb,8.749610e-01_rb,8.752449e-01_rb,&
6762 & 8.755143e-01_rb,8.757688e-01_rb,8.760095e-01_rb,8.762375e-01_rb,8.764532e-01_rb,&
6763 & 8.766579e-01_rb,8.768506e-01_rb,8.770323e-01_rb,8.772049e-01_rb,8.773690e-01_rb,&
6764 & 8.775226e-01_rb,8.776679e-01_rb,8.778062e-01_rb,8.779360e-01_rb,8.780587e-01_rb,&
6765 & 8.781747e-01_rb,8.782852e-01_rb,8.783892e-01_rb,8.784891e-01_rb,8.785824e-01_rb,&
6766 & 8.786705e-01_rb,8.787546e-01_rb,8.788336e-01_rb /)
6767 ! BAND 24
6768 asyliq1(:, 24) = (/ &
6769 & 8.054324e-01_rb,8.266282e-01_rb,8.378075e-01_rb,8.449848e-01_rb,8.502166e-01_rb,&
6770 & 8.542268e-01_rb,8.573477e-01_rb,8.598022e-01_rb,8.617689e-01_rb,8.633859e-01_rb,&
6771 & 8.647536e-01_rb,8.659354e-01_rb,8.669807e-01_rb,8.679143e-01_rb,8.687577e-01_rb,&
6772 & 8.695222e-01_rb,8.702207e-01_rb,8.708591e-01_rb,8.714446e-01_rb,8.719836e-01_rb,&
6773 & 8.724812e-01_rb,8.729426e-01_rb,8.733689e-01_rb,8.737665e-01_rb,8.741373e-01_rb,&
6774 & 8.744834e-01_rb,8.748070e-01_rb,8.751131e-01_rb,8.754011e-01_rb,8.756676e-01_rb,&
6775 & 8.759219e-01_rb,8.761599e-01_rb,8.763857e-01_rb,8.765984e-01_rb,8.767999e-01_rb,&
6776 & 8.769889e-01_rb,8.771669e-01_rb,8.773373e-01_rb,8.774969e-01_rb,8.776469e-01_rb,&
6777 & 8.777894e-01_rb,8.779237e-01_rb,8.780505e-01_rb,8.781703e-01_rb,8.782820e-01_rb,&
6778 & 8.783886e-01_rb,8.784894e-01_rb,8.785844e-01_rb,8.786736e-01_rb,8.787584e-01_rb,&
6779 & 8.788379e-01_rb,8.789130e-01_rb,8.789849e-01_rb,8.790506e-01_rb,8.791141e-01_rb,&
6780 & 8.791750e-01_rb,8.792324e-01_rb,8.792867e-01_rb /)
6781 ! BAND 25
6782 asyliq1(:, 25) = (/ &
6783 & 8.249534e-01_rb,8.391988e-01_rb,8.474107e-01_rb,8.526860e-01_rb,8.563983e-01_rb,&
6784 & 8.592389e-01_rb,8.615144e-01_rb,8.633790e-01_rb,8.649325e-01_rb,8.662504e-01_rb,&
6785 & 8.673841e-01_rb,8.683741e-01_rb,8.692495e-01_rb,8.700309e-01_rb,8.707328e-01_rb,&
6786 & 8.713650e-01_rb,8.719432e-01_rb,8.724676e-01_rb,8.729498e-01_rb,8.733922e-01_rb,&
6787 & 8.737981e-01_rb,8.741745e-01_rb,8.745225e-01_rb,8.748467e-01_rb,8.751512e-01_rb,&
6788 & 8.754315e-01_rb,8.756962e-01_rb,8.759450e-01_rb,8.761774e-01_rb,8.763945e-01_rb,&
6789 & 8.766021e-01_rb,8.767970e-01_rb,8.769803e-01_rb,8.771511e-01_rb,8.773151e-01_rb,&
6790 & 8.774689e-01_rb,8.776147e-01_rb,8.777533e-01_rb,8.778831e-01_rb,8.780050e-01_rb,&
6791 & 8.781197e-01_rb,8.782301e-01_rb,8.783323e-01_rb,8.784312e-01_rb,8.785222e-01_rb,&
6792 & 8.786096e-01_rb,8.786916e-01_rb,8.787688e-01_rb,8.788411e-01_rb,8.789122e-01_rb,&
6793 & 8.789762e-01_rb,8.790373e-01_rb,8.790954e-01_rb,8.791514e-01_rb,8.792018e-01_rb,&
6794 & 8.792517e-01_rb,8.792990e-01_rb,8.793429e-01_rb /)
6795 ! BAND 26
6796 asyliq1(:, 26) = (/ &
6797 & 8.323091e-01_rb,8.429776e-01_rb,8.498123e-01_rb,8.546929e-01_rb,8.584295e-01_rb,&
6798 & 8.613489e-01_rb,8.636324e-01_rb,8.654303e-01_rb,8.668675e-01_rb,8.680404e-01_rb,&
6799 & 8.690174e-01_rb,8.698495e-01_rb,8.705666e-01_rb,8.711961e-01_rb,8.717556e-01_rb,&
6800 & 8.722546e-01_rb,8.727063e-01_rb,8.731170e-01_rb,8.734933e-01_rb,8.738382e-01_rb,&
6801 & 8.741590e-01_rb,8.744525e-01_rb,8.747295e-01_rb,8.749843e-01_rb,8.752210e-01_rb,&
6802 & 8.754437e-01_rb,8.756524e-01_rb,8.758472e-01_rb,8.760288e-01_rb,8.762030e-01_rb,&
6803 & 8.763603e-01_rb,8.765122e-01_rb,8.766539e-01_rb,8.767894e-01_rb,8.769130e-01_rb,&
6804 & 8.770310e-01_rb,8.771422e-01_rb,8.772437e-01_rb,8.773419e-01_rb,8.774355e-01_rb,&
6805 & 8.775221e-01_rb,8.776047e-01_rb,8.776802e-01_rb,8.777539e-01_rb,8.778216e-01_rb,&
6806 & 8.778859e-01_rb,8.779473e-01_rb,8.780031e-01_rb,8.780562e-01_rb,8.781097e-01_rb,&
6807 & 8.781570e-01_rb,8.782021e-01_rb,8.782463e-01_rb,8.782845e-01_rb,8.783235e-01_rb,&
6808 & 8.783610e-01_rb,8.783953e-01_rb,8.784273e-01_rb /)
6809 ! BAND 27
6810 asyliq1(:, 27) = (/ &
6811 & 8.396448e-01_rb,8.480172e-01_rb,8.535934e-01_rb,8.574145e-01_rb,8.600835e-01_rb,&
6812 & 8.620347e-01_rb,8.635500e-01_rb,8.648003e-01_rb,8.658758e-01_rb,8.668248e-01_rb,&
6813 & 8.676697e-01_rb,8.684220e-01_rb,8.690893e-01_rb,8.696807e-01_rb,8.702046e-01_rb,&
6814 & 8.706676e-01_rb,8.710798e-01_rb,8.714478e-01_rb,8.717778e-01_rb,8.720747e-01_rb,&
6815 & 8.723431e-01_rb,8.725889e-01_rb,8.728144e-01_rb,8.730201e-01_rb,8.732129e-01_rb,&
6816 & 8.733907e-01_rb,8.735541e-01_rb,8.737100e-01_rb,8.738533e-01_rb,8.739882e-01_rb,&
6817 & 8.741164e-01_rb,8.742362e-01_rb,8.743485e-01_rb,8.744530e-01_rb,8.745512e-01_rb,&
6818 & 8.746471e-01_rb,8.747373e-01_rb,8.748186e-01_rb,8.748973e-01_rb,8.749732e-01_rb,&
6819 & 8.750443e-01_rb,8.751105e-01_rb,8.751747e-01_rb,8.752344e-01_rb,8.752902e-01_rb,&
6820 & 8.753412e-01_rb,8.753917e-01_rb,8.754393e-01_rb,8.754843e-01_rb,8.755282e-01_rb,&
6821 & 8.755662e-01_rb,8.756039e-01_rb,8.756408e-01_rb,8.756722e-01_rb,8.757072e-01_rb,&
6822 & 8.757352e-01_rb,8.757653e-01_rb,8.757932e-01_rb /)
6823 ! BAND 28
6824 asyliq1(:, 28) = (/ &
6825 & 8.374590e-01_rb,8.465669e-01_rb,8.518701e-01_rb,8.547627e-01_rb,8.565745e-01_rb,&
6826 & 8.579065e-01_rb,8.589717e-01_rb,8.598632e-01_rb,8.606363e-01_rb,8.613268e-01_rb,&
6827 & 8.619560e-01_rb,8.625340e-01_rb,8.630689e-01_rb,8.635601e-01_rb,8.640084e-01_rb,&
6828 & 8.644180e-01_rb,8.647885e-01_rb,8.651220e-01_rb,8.654218e-01_rb,8.656908e-01_rb,&
6829 & 8.659294e-01_rb,8.661422e-01_rb,8.663334e-01_rb,8.665037e-01_rb,8.666543e-01_rb,&
6830 & 8.667913e-01_rb,8.669156e-01_rb,8.670242e-01_rb,8.671249e-01_rb,8.672161e-01_rb,&
6831 & 8.672993e-01_rb,8.673733e-01_rb,8.674457e-01_rb,8.675103e-01_rb,8.675713e-01_rb,&
6832 & 8.676267e-01_rb,8.676798e-01_rb,8.677286e-01_rb,8.677745e-01_rb,8.678178e-01_rb,&
6833 & 8.678601e-01_rb,8.678986e-01_rb,8.679351e-01_rb,8.679693e-01_rb,8.680013e-01_rb,&
6834 & 8.680334e-01_rb,8.680624e-01_rb,8.680915e-01_rb,8.681178e-01_rb,8.681428e-01_rb,&
6835 & 8.681654e-01_rb,8.681899e-01_rb,8.682103e-01_rb,8.682317e-01_rb,8.682498e-01_rb,&
6836 & 8.682677e-01_rb,8.682861e-01_rb,8.683041e-01_rb /)
6837 ! BAND 29
6838 asyliq1(:, 29) = (/ &
6839 & 7.877069e-01_rb,8.244281e-01_rb,8.367971e-01_rb,8.409074e-01_rb,8.429859e-01_rb,&
6840 & 8.454386e-01_rb,8.489350e-01_rb,8.534141e-01_rb,8.585814e-01_rb,8.641267e-01_rb,&
6841 & 8.697999e-01_rb,8.754223e-01_rb,8.808785e-01_rb,8.860944e-01_rb,8.910354e-01_rb,&
6842 & 8.956837e-01_rb,9.000392e-01_rb,9.041091e-01_rb,9.079071e-01_rb,9.114479e-01_rb,&
6843 & 9.147462e-01_rb,9.178234e-01_rb,9.206903e-01_rb,9.233663e-01_rb,9.258668e-01_rb,&
6844 & 9.282006e-01_rb,9.303847e-01_rb,9.324288e-01_rb,9.343418e-01_rb,9.361356e-01_rb,&
6845 & 9.378176e-01_rb,9.393939e-01_rb,9.408736e-01_rb,9.422622e-01_rb,9.435670e-01_rb,&
6846 & 9.447900e-01_rb,9.459395e-01_rb,9.470199e-01_rb,9.480335e-01_rb,9.489852e-01_rb,&
6847 & 9.498782e-01_rb,9.507168e-01_rb,9.515044e-01_rb,9.522470e-01_rb,9.529409e-01_rb,&
6848 & 9.535946e-01_rb,9.542071e-01_rb,9.547838e-01_rb,9.553256e-01_rb,9.558351e-01_rb,&
6849 & 9.563139e-01_rb,9.567660e-01_rb,9.571915e-01_rb,9.575901e-01_rb,9.579685e-01_rb,&
6850 & 9.583239e-01_rb,9.586602e-01_rb,9.589766e-01_rb /)
6853 ! Spherical Ice Particle Parameterization
6854 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
6855 extice2(:, 16) = (/ &
6856 ! band 16
6857 & 4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb,1.063406e-01_rb,&
6858 & 8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb,5.970353e-02_rb,5.375249e-02_rb,&
6859 & 4.887577e-02_rb,4.481025e-02_rb,4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,&
6860 & 3.365396e-02_rb,3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb,&
6861 & 2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb,2.175276e-02_rb,&
6862 & 2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb,1.888412e-02_rb,1.829018e-02_rb,&
6863 & 1.773586e-02_rb,1.721738e-02_rb,1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,&
6864 & 1.544122e-02_rb,1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb,&
6865 & 1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /)
6866 extice2(:, 17) = (/ &
6867 ! band 17
6868 & 3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb,1.031602e-01_rb,&
6869 & 8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb,5.900909e-02_rb,5.328833e-02_rb,&
6870 & 4.857728e-02_rb,4.463133e-02_rb,4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,&
6871 & 3.369280e-02_rb,3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb,&
6872 & 2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb,2.175571e-02_rb,&
6873 & 2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb,1.881278e-02_rb,1.819901e-02_rb,&
6874 & 1.762463e-02_rb,1.708598e-02_rb,1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,&
6875 & 1.522937e-02_rb,1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb,&
6876 & 1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /)
6877 extice2(:, 18) = (/ &
6878 ! band 18
6879 & 4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb,1.047528e-01_rb,&
6880 & 8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb,5.844616e-02_rb,5.259609e-02_rb,&
6881 & 4.781531e-02_rb,4.383980e-02_rb,4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,&
6882 & 3.298525e-02_rb,3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb,&
6883 & 2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb,2.152164e-02_rb,&
6884 & 2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb,1.878296e-02_rb,1.821744e-02_rb,&
6885 & 1.769015e-02_rb,1.719741e-02_rb,1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,&
6886 & 1.551298e-02_rb,1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb,&
6887 & 1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /)
6888 extice2(:, 19) = (/ &
6889 ! band 19
6890 & 3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb,1.038247e-01_rb,&
6891 & 8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb,5.892850e-02_rb,5.313885e-02_rb,&
6892 & 4.838068e-02_rb,4.440356e-02_rb,4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,&
6893 & 3.343269e-02_rb,3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb,&
6894 & 2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb,2.160789e-02_rb,&
6895 & 2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb,1.873177e-02_rb,1.813469e-02_rb,&
6896 & 1.757689e-02_rb,1.705468e-02_rb,1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,&
6897 & 1.526192e-02_rb,1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb,&
6898 & 1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /)
6899 extice2(:, 20) = (/ &
6900 ! band 20
6901 & 3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb,1.028944e-01_rb,&
6902 & 8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb,5.866714e-02_rb,5.293694e-02_rb,&
6903 & 4.822153e-02_rb,4.427547e-02_rb,4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,&
6904 & 3.336440e-02_rb,3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb,&
6905 & 2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb,2.154821e-02_rb,&
6906 & 2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb,1.866212e-02_rb,1.806221e-02_rb,&
6907 & 1.750152e-02_rb,1.697637e-02_rb,1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,&
6908 & 1.517172e-02_rb,1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb,&
6909 & 1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /)
6910 extice2(:, 21) = (/ &
6911 ! band 21
6912 & 3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb,1.019462e-01_rb,&
6913 & 8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb,5.830218e-02_rb,5.263421e-02_rb,&
6914 & 4.796697e-02_rb,4.405891e-02_rb,4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,&
6915 & 3.324008e-02_rb,3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb,&
6916 & 2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb,2.149614e-02_rb,&
6917 & 2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb,1.862174e-02_rb,1.802389e-02_rb,&
6918 & 1.746500e-02_rb,1.694142e-02_rb,1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,&
6919 & 1.514129e-02_rb,1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb,&
6920 & 1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /)
6921 extice2(:, 22) = (/ &
6922 ! band 22
6923 & 3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb,1.016109e-01_rb,&
6924 & 8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb,5.810290e-02_rb,5.245608e-02_rb,&
6925 & 4.780702e-02_rb,4.391478e-02_rb,4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,&
6926 & 3.314296e-02_rb,3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb,&
6927 & 2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb,2.145688e-02_rb,&
6928 & 2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb,1.859808e-02_rb,1.800356e-02_rb,&
6929 & 1.744782e-02_rb,1.692721e-02_rb,1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,&
6930 & 1.513751e-02_rb,1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb,&
6931 & 1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /)
6932 extice2(:, 23) = (/ &
6933 ! band 23
6934 & 3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb,1.004203e-01_rb,&
6935 & 8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb,5.776176e-02_rb,5.219398e-02_rb,&
6936 & 4.760288e-02_rb,4.375369e-02_rb,4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,&
6937 & 3.307079e-02_rb,3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb,&
6938 & 2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb,2.141556e-02_rb,&
6939 & 2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb,1.855009e-02_rb,1.795330e-02_rb,&
6940 & 1.739514e-02_rb,1.687199e-02_rb,1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,&
6941 & 1.507143e-02_rb,1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb,&
6942 & 1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /)
6943 extice2(:, 24) = (/ &
6944 ! band 24
6945 & 3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb,9.955787e-02_rb,&
6946 & 8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb,5.751081e-02_rb,5.199888e-02_rb,&
6947 & 4.744835e-02_rb,4.362899e-02_rb,4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,&
6948 & 3.300546e-02_rb,3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb,&
6949 & 2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb,2.136402e-02_rb,&
6950 & 2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb,1.849087e-02_rb,1.789178e-02_rb,&
6951 & 1.733124e-02_rb,1.680565e-02_rb,1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,&
6952 & 1.499502e-02_rb,1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb,&
6953 & 1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /)
6954 extice2(:, 25) = (/ &
6955 ! band 25
6956 & 3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb,9.881779e-02_rb,&
6957 & 8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb,5.723183e-02_rb,5.176908e-02_rb,&
6958 & 4.725658e-02_rb,4.346715e-02_rb,4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,&
6959 & 3.291583e-02_rb,3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb,&
6960 & 2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb,2.132934e-02_rb,&
6961 & 2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb,1.846448e-02_rb,1.786680e-02_rb,&
6962 & 1.730745e-02_rb,1.678289e-02_rb,1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,&
6963 & 1.497499e-02_rb,1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb,&
6964 & 1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /)
6965 extice2(:, 26) = (/ &
6966 ! band 26
6967 & 3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb,9.838078e-02_rb,&
6968 & 8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb,5.703770e-02_rb,5.160290e-02_rb,&
6969 & 4.711259e-02_rb,4.334110e-02_rb,4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,&
6970 & 3.283589e-02_rb,3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb,&
6971 & 2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb,2.129165e-02_rb,&
6972 & 2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb,1.843542e-02_rb,1.783943e-02_rb,&
6973 & 1.728162e-02_rb,1.675847e-02_rb,1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,&
6974 & 1.495515e-02_rb,1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb,&
6975 & 1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /)
6976 extice2(:, 27) = (/ &
6977 ! band 27
6978 & 3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb,9.790253e-02_rb,&
6979 & 8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb,5.687024e-02_rb,5.146670e-02_rb,&
6980 & 4.700001e-02_rb,4.324667e-02_rb,4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,&
6981 & 3.278257e-02_rb,3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb,&
6982 & 2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb,2.126273e-02_rb,&
6983 & 2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb,1.840801e-02_rb,1.781204e-02_rb,&
6984 & 1.725417e-02_rb,1.673086e-02_rb,1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,&
6985 & 1.492634e-02_rb,1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb,&
6986 & 1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /)
6987 extice2(:, 28) = (/ &
6988 ! band 28
6989 & 3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb,9.804612e-02_rb,&
6990 & 8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb,5.697710e-02_rb,5.156460e-02_rb,&
6991 & 4.708957e-02_rb,4.332850e-02_rb,4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,&
6992 & 3.283879e-02_rb,3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb,&
6993 & 2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb,2.128195e-02_rb,&
6994 & 2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb,1.841614e-02_rb,1.781774e-02_rb,&
6995 & 1.725754e-02_rb,1.673203e-02_rb,1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,&
6996 & 1.491958e-02_rb,1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb,&
6997 & 1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /)
6998 extice2(:, 29) = (/ &
6999 ! band 29
7000 & 4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb,1.102161e-01_rb,&
7001 & 9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb,6.260168e-02_rb,5.645603e-02_rb,&
7002 & 5.139732e-02_rb,4.716088e-02_rb,4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,&
7003 & 3.541094e-02_rb,3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb,&
7004 & 2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb,2.253072e-02_rb,&
7005 & 2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb,1.933015e-02_rb,1.866041e-02_rb,&
7006 & 1.803283e-02_rb,1.744348e-02_rb,1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,&
7007 & 1.540539e-02_rb,1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb,&
7008 & 1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /)
7010 ! single-scattering albedo: unitless
7011 ssaice2(:, 16) = (/ &
7012 ! band 16
7013 & 6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb,6.178420e-01_rb,&
7014 & 6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb,5.995830e-01_rb,5.963030e-01_rb,&
7015 & 5.933372e-01_rb,5.906311e-01_rb,5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,&
7016 & 5.816896e-01_rb,5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb,&
7017 & 5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb,5.677571e-01_rb,&
7018 & 5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb,5.630643e-01_rb,5.619850e-01_rb,&
7019 & 5.609381e-01_rb,5.599214e-01_rb,5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,&
7020 & 5.561193e-01_rb,5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb,&
7021 & 5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /)
7022 ssaice2(:, 17) = (/ &
7023 ! band 17
7024 & 7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb,6.956928e-01_rb,&
7025 & 6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb,6.679838e-01_rb,6.632742e-01_rb,&
7026 & 6.591036e-01_rb,6.553766e-01_rb,6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,&
7027 & 6.436531e-01_rb,6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb,&
7028 & 6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb,6.274512e-01_rb,&
7029 & 6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb,6.225953e-01_rb,6.215201e-01_rb,&
7030 & 6.204914e-01_rb,6.195055e-01_rb,6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,&
7031 & 6.159280e-01_rb,6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb,&
7032 & 6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /)
7033 ssaice2(:, 18) = (/ &
7034 ! band 18
7035 & 9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb,9.577179e-01_rb,&
7036 & 9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb,9.399467e-01_rb,9.365708e-01_rb,&
7037 & 9.334672e-01_rb,9.305921e-01_rb,9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,&
7038 & 9.207954e-01_rb,9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb,&
7039 & 9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb,9.046406e-01_rb,&
7040 & 9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb,8.989804e-01_rb,8.976655e-01_rb,&
7041 & 8.963857e-01_rb,8.951389e-01_rb,8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,&
7042 & 8.904464e-01_rb,8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb,&
7043 & 8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /)
7044 ssaice2(:, 19) = (/ &
7045 ! band 19
7046 & 9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb,9.014238e-01_rb,&
7047 & 8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb,8.701736e-01_rb,8.643950e-01_rb,&
7048 & 8.591299e-01_rb,8.542942e-01_rb,8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,&
7049 & 8.381324e-01_rb,8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb,&
7050 & 8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb,8.126403e-01_rb,&
7051 & 8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb,8.040765e-01_rb,8.021156e-01_rb,&
7052 & 8.002174e-01_rb,7.983781e-01_rb,7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,&
7053 & 7.915432e-01_rb,7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb,&
7054 & 7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /)
7055 ssaice2(:, 20) = (/ &
7056 ! band 20
7057 & 9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb,9.743652e-01_rb,&
7058 & 9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb,9.659531e-01_rb,9.643915e-01_rb,&
7059 & 9.629667e-01_rb,9.616561e-01_rb,9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,&
7060 & 9.572607e-01_rb,9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb,&
7061 & 9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb,9.502643e-01_rb,&
7062 & 9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb,9.478910e-01_rb,9.473456e-01_rb,&
7063 & 9.468169e-01_rb,9.463039e-01_rb,9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,&
7064 & 9.443910e-01_rb,9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb,&
7065 & 9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /)
7066 ssaice2(:, 21) = (/ &
7067 ! band 21
7068 & 9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb,9.710184e-01_rb,&
7069 & 9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb,9.623352e-01_rb,9.607083e-01_rb,&
7070 & 9.592198e-01_rb,9.578474e-01_rb,9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,&
7071 & 9.532226e-01_rb,9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb,&
7072 & 9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb,9.457985e-01_rb,&
7073 & 9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb,9.432656e-01_rb,9.426826e-01_rb,&
7074 & 9.421173e-01_rb,9.415684e-01_rb,9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,&
7075 & 9.395198e-01_rb,9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb,&
7076 & 9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /)
7077 ssaice2(:, 22) = (/ &
7078 ! band 22
7079 & 9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb,9.981606e-01_rb,&
7080 & 9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb,9.977691e-01_rb,9.976798e-01_rb,&
7081 & 9.975929e-01_rb,9.975081e-01_rb,9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,&
7082 & 9.971855e-01_rb,9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb,&
7083 & 9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb,9.965250e-01_rb,&
7084 & 9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb,9.962508e-01_rb,9.961836e-01_rb,&
7085 & 9.961170e-01_rb,9.960508e-01_rb,9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,&
7086 & 9.957906e-01_rb,9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb,&
7087 & 9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /)
7088 ssaice2(:, 23) = (/ &
7089 ! band 23
7090 & 9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb,9.997436e-01_rb,&
7091 & 9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb,9.996999e-01_rb,9.996886e-01_rb,&
7092 & 9.996771e-01_rb,9.996653e-01_rb,9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,&
7093 & 9.996152e-01_rb,9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb,&
7094 & 9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb,9.994831e-01_rb,&
7095 & 9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb,9.994154e-01_rb,9.993976e-01_rb,&
7096 & 9.993795e-01_rb,9.993610e-01_rb,9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,&
7097 & 9.992837e-01_rb,9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb,&
7098 & 9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /)
7099 ssaice2(:, 24) = (/ &
7100 ! band 24
7101 & 9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb,9.999934e-01_rb,&
7102 & 9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb,9.999904e-01_rb,9.999895e-01_rb,&
7103 & 9.999885e-01_rb,9.999874e-01_rb,9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,&
7104 & 9.999824e-01_rb,9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb,&
7105 & 9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb,9.999673e-01_rb,&
7106 & 9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb,9.999589e-01_rb,9.999566e-01_rb,&
7107 & 9.999543e-01_rb,9.999519e-01_rb,9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,&
7108 & 9.999418e-01_rb,9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb,&
7109 & 9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /)
7110 ssaice2(:, 25) = (/ &
7111 ! band 25
7112 & 9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,&
7113 & 9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,&
7114 & 9.999991e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,&
7115 & 9.999984e-01_rb,9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,&
7116 & 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb,9.999969e-01_rb,&
7117 & 9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb,9.999960e-01_rb,9.999957e-01_rb,&
7118 & 9.999955e-01_rb,9.999953e-01_rb,9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,&
7119 & 9.999942e-01_rb,9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb,&
7120 & 9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /)
7121 ssaice2(:, 26) = (/ &
7122 ! band 26
7123 & 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,&
7124 & 9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
7125 & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,&
7126 & 9.999978e-01_rb,9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb,&
7127 & 9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb,9.999956e-01_rb,&
7128 & 9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb,9.999944e-01_rb,9.999941e-01_rb,&
7129 & 9.999938e-01_rb,9.999934e-01_rb,9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,&
7130 & 9.999920e-01_rb,9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb,&
7131 & 9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /)
7132 ssaice2(:, 27) = (/ &
7133 ! band 27
7134 & 9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999982e-01_rb,&
7135 & 9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999970e-01_rb,&
7136 & 9.999967e-01_rb,9.999964e-01_rb,9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,&
7137 & 9.999948e-01_rb,9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb,&
7138 & 9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb,9.999901e-01_rb,&
7139 & 9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb,9.999874e-01_rb,9.999867e-01_rb,&
7140 & 9.999860e-01_rb,9.999853e-01_rb,9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,&
7141 & 9.999821e-01_rb,9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
7142 & 9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /)
7143 ssaice2(:, 28) = (/ &
7144 ! band 28
7145 & 9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,&
7146 & 9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999975e-01_rb,9.999972e-01_rb,&
7147 & 9.999969e-01_rb,9.999966e-01_rb,9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,&
7148 & 9.999950e-01_rb,9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb,&
7149 & 9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999902e-01_rb,&
7150 & 9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb,9.999876e-01_rb,9.999869e-01_rb,&
7151 & 9.999861e-01_rb,9.999854e-01_rb,9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,&
7152 & 9.999822e-01_rb,9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
7153 & 9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /)
7154 ssaice2(:, 29) = (/ &
7155 ! band 29
7156 & 7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb,6.166381e-01_rb,&
7157 & 6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb,5.826968e-01_rb,5.767343e-01_rb,&
7158 & 5.713804e-01_rb,5.665256e-01_rb,5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,&
7159 & 5.506794e-01_rb,5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb,&
7160 & 5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb,5.263988e-01_rb,&
7161 & 5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb,5.182280e-01_rb,5.163410e-01_rb,&
7162 & 5.145062e-01_rb,5.127197e-01_rb,5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,&
7163 & 5.059860e-01_rb,5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb,&
7164 & 4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /)
7166 ! asymmetry factor: unitless
7167 asyice2(:, 16) = (/ &
7168 ! band 16
7169 & 7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb,9.041676e-01_rb,&
7170 & 9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb,9.216573e-01_rb,9.239620e-01_rb,&
7171 & 9.258695e-01_rb,9.274745e-01_rb,9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,&
7172 & 9.319665e-01_rb,9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb,&
7173 & 9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb,9.369722e-01_rb,&
7174 & 9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb,9.382352e-01_rb,9.385010e-01_rb,&
7175 & 9.387505e-01_rb,9.389854e-01_rb,9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,&
7176 & 9.398024e-01_rb,9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb,&
7177 & 9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /)
7178 asyice2(:, 17) = (/ &
7179 ! band 17
7180 & 9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb,9.354632e-01_rb,&
7181 & 9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb,9.446301e-01_rb,9.461351e-01_rb,&
7182 & 9.474555e-01_rb,9.486259e-01_rb,9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,&
7183 & 9.522476e-01_rb,9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb,&
7184 & 9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb,9.570953e-01_rb,&
7185 & 9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb,9.585054e-01_rb,9.588142e-01_rb,&
7186 & 9.591083e-01_rb,9.593888e-01_rb,9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,&
7187 & 9.603952e-01_rb,9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb,&
7188 & 9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /)
7189 asyice2(:, 18) = (/ &
7190 ! band 18
7191 & 8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb,8.789054e-01_rb,&
7192 & 8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb,8.932532e-01_rb,8.955965e-01_rb,&
7193 & 8.976567e-01_rb,8.994887e-01_rb,9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,&
7194 & 9.052237e-01_rb,9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb,&
7195 & 9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb,9.132140e-01_rb,&
7196 & 9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb,9.156524e-01_rb,9.161955e-01_rb,&
7197 & 9.167160e-01_rb,9.172157e-01_rb,9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,&
7198 & 9.190330e-01_rb,9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb,&
7199 & 9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /)
7200 asyice2(:, 19) = (/ &
7201 ! band 19
7202 & 8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb,8.865810e-01_rb,&
7203 & 8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb,9.028980e-01_rb,9.052513e-01_rb,&
7204 & 9.072468e-01_rb,9.089632e-01_rb,9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,&
7205 & 9.139793e-01_rb,9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb,&
7206 & 9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb,9.200455e-01_rb,&
7207 & 9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb,9.216771e-01_rb,9.220262e-01_rb,&
7208 & 9.223560e-01_rb,9.226680e-01_rb,9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,&
7209 & 9.237652e-01_rb,9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb,&
7210 & 9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /)
7211 asyice2(:, 20) = (/ &
7212 ! band 20
7213 & 8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb,8.733206e-01_rb,&
7214 & 8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb,8.862225e-01_rb,8.879904e-01_rb,&
7215 & 8.894682e-01_rb,8.907228e-01_rb,8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,&
7216 & 8.942943e-01_rb,8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb,&
7217 & 8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb,8.983966e-01_rb,&
7218 & 8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb,8.994533e-01_rb,8.996766e-01_rb,&
7219 & 8.998865e-01_rb,9.000843e-01_rb,9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,&
7220 & 9.007731e-01_rb,9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb,&
7221 & 9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /)
7222 asyice2(:, 21) = (/ &
7223 ! band 21
7224 & 8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb,8.758555e-01_rb,&
7225 & 8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb,8.865939e-01_rb,8.880564e-01_rb,&
7226 & 8.892765e-01_rb,8.903105e-01_rb,8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,&
7227 & 8.932419e-01_rb,8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb,&
7228 & 8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb,8.965762e-01_rb,&
7229 & 8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb,8.974255e-01_rb,8.976042e-01_rb,&
7230 & 8.977720e-01_rb,8.979298e-01_rb,8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,&
7231 & 8.984771e-01_rb,8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb,&
7232 & 8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /)
7233 asyice2(:, 22) = (/ &
7234 ! band 22
7235 & 8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb,8.713217e-01_rb,&
7236 & 8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb,8.811370e-01_rb,8.824649e-01_rb,&
7237 & 8.835711e-01_rb,8.845073e-01_rb,8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,&
7238 & 8.871560e-01_rb,8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb,&
7239 & 8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb,8.901612e-01_rb,&
7240 & 8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb,8.909265e-01_rb,8.910876e-01_rb,&
7241 & 8.912388e-01_rb,8.913812e-01_rb,8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,&
7242 & 8.918752e-01_rb,8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb,&
7243 & 8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /)
7244 asyice2(:, 23) = (/ &
7245 ! band 23
7246 & 8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb,8.747605e-01_rb,&
7247 & 8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb,8.821179e-01_rb,8.831583e-01_rb,&
7248 & 8.840361e-01_rb,8.847875e-01_rb,8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,&
7249 & 8.869634e-01_rb,8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb,&
7250 & 8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb,8.895504e-01_rb,&
7251 & 8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb,8.902370e-01_rb,8.903833e-01_rb,&
7252 & 8.905214e-01_rb,8.906518e-01_rb,8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,&
7253 & 8.911094e-01_rb,8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb,&
7254 & 8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /)
7255 asyice2(:, 24) = (/ &
7256 ! band 24
7257 & 8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb,8.776354e-01_rb,&
7258 & 8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb,8.832225e-01_rb,8.840333e-01_rb,&
7259 & 8.847224e-01_rb,8.853162e-01_rb,8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,&
7260 & 8.870595e-01_rb,8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb,&
7261 & 8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb,8.891895e-01_rb,&
7262 & 8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb,8.897683e-01_rb,8.898926e-01_rb,&
7263 & 8.900102e-01_rb,8.901215e-01_rb,8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,&
7264 & 8.905144e-01_rb,8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb,&
7265 & 8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /)
7266 asyice2(:, 25) = (/ &
7267 ! band 25
7268 & 8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb,8.789378e-01_rb,&
7269 & 8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb,8.835480e-01_rb,8.842152e-01_rb,&
7270 & 8.847817e-01_rb,8.852696e-01_rb,8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,&
7271 & 8.866997e-01_rb,8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb,&
7272 & 8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb,8.884418e-01_rb,&
7273 & 8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb,8.889139e-01_rb,8.890152e-01_rb,&
7274 & 8.891110e-01_rb,8.892017e-01_rb,8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,&
7275 & 8.895214e-01_rb,8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb,&
7276 & 8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /)
7277 asyice2(:, 26) = (/ &
7278 ! band 26
7279 & 8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb,8.796983e-01_rb,&
7280 & 8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb,8.829953e-01_rb,8.834501e-01_rb,&
7281 & 8.838310e-01_rb,8.841549e-01_rb,8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,&
7282 & 8.850795e-01_rb,8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb,&
7283 & 8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb,8.861464e-01_rb,&
7284 & 8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb,8.864218e-01_rb,8.864800e-01_rb,&
7285 & 8.865347e-01_rb,8.865863e-01_rb,8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,&
7286 & 8.867658e-01_rb,8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb,&
7287 & 8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /)
7288 asyice2(:, 27) = (/ &
7289 ! band 27
7290 & 8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb,8.768846e-01_rb,&
7291 & 8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb,8.799960e-01_rb,8.804159e-01_rb,&
7292 & 8.807660e-01_rb,8.810626e-01_rb,8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,&
7293 & 8.819057e-01_rb,8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb,&
7294 & 8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb,8.828764e-01_rb,&
7295 & 8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb,8.831283e-01_rb,8.831817e-01_rb,&
7296 & 8.832320e-01_rb,8.832795e-01_rb,8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,&
7297 & 8.834454e-01_rb,8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb,&
7298 & 8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /)
7299 asyice2(:, 28) = (/ &
7300 ! band 28
7301 & 8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb,8.770154e-01_rb,&
7302 & 8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb,8.799348e-01_rb,8.802952e-01_rb,&
7303 & 8.805880e-01_rb,8.808300e-01_rb,8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,&
7304 & 8.814832e-01_rb,8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb,&
7305 & 8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb,8.821573e-01_rb,&
7306 & 8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb,8.823150e-01_rb,8.823474e-01_rb,&
7307 & 8.823775e-01_rb,8.824056e-01_rb,8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,&
7308 & 8.825011e-01_rb,8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb,&
7309 & 8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /)
7310 asyice2(:, 29) = (/ &
7311 ! band 29
7312 & 8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb,9.142334e-01_rb,&
7313 & 9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb,9.375689e-01_rb,9.412085e-01_rb,&
7314 & 9.443604e-01_rb,9.471230e-01_rb,9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,&
7315 & 9.555057e-01_rb,9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb,&
7316 & 9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb,9.664513e-01_rb,&
7317 & 9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb,9.696256e-01_rb,9.703237e-01_rb,&
7318 & 9.709903e-01_rb,9.716280e-01_rb,9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,&
7319 & 9.739336e-01_rb,9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb,&
7320 & 9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /)
7322 ! Hexagonal Ice Particle Parameterization
7323 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
7324 extice3(:, 16) = (/ &
7325 ! band 16
7326 & 5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb,1.499977e-01_rb,&
7327 & 1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb,8.764435e-02_rb,7.939266e-02_rb,&
7328 & 7.256081e-02_rb,6.681137e-02_rb,6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,&
7329 & 5.073102e-02_rb,4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb,&
7330 & 3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb,3.290694e-02_rb,&
7331 & 3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb,2.846172e-02_rb,2.753188e-02_rb,&
7332 & 2.666085e-02_rb,2.584322e-02_rb,2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,&
7333 & 2.301926e-02_rb,2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb,&
7334 & 2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb,1.847607e-02_rb,&
7335 & 1.807956e-02_rb /)
7336 extice3(:, 17) = (/ &
7337 ! band 17
7338 & 4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb,1.445402e-01_rb,&
7339 & 1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb,8.495824e-02_rb,7.704501e-02_rb,&
7340 & 7.048834e-02_rb,6.496693e-02_rb,6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,&
7341 & 4.950698e-02_rb,4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb,&
7342 & 3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb,3.234041e-02_rb,&
7343 & 3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb,2.805413e-02_rb,2.715727e-02_rb,&
7344 & 2.631705e-02_rb,2.552828e-02_rb,2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,&
7345 & 2.280343e-02_rb,2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb,&
7346 & 2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb,1.841781e-02_rb,&
7347 & 1.803494e-02_rb /)
7348 extice3(:, 18) = (/ &
7349 ! band 18
7350 & 5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb,1.487318e-01_rb,&
7351 & 1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb,8.719819e-02_rb,7.902576e-02_rb,&
7352 & 7.225433e-02_rb,6.655206e-02_rb,6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,&
7353 & 5.058572e-02_rb,4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb,&
7354 & 3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb,3.285686e-02_rb,&
7355 & 3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb,2.843018e-02_rb,2.750395e-02_rb,&
7356 & 2.663621e-02_rb,2.582160e-02_rb,2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,&
7357 & 2.300750e-02_rb,2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb,&
7358 & 2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb,1.847823e-02_rb,&
7359 & 1.808281e-02_rb /)
7360 extice3(:, 19) = (/ &
7361 ! band 19
7362 & 4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb,1.443736e-01_rb,&
7363 & 1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb,8.509997e-02_rb,7.722769e-02_rb,&
7364 & 7.070495e-02_rb,6.521211e-02_rb,6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,&
7365 & 4.983217e-02_rb,4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb,&
7366 & 3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb,3.275444e-02_rb,&
7367 & 3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb,2.849034e-02_rb,2.759812e-02_rb,&
7368 & 2.676226e-02_rb,2.597757e-02_rb,2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,&
7369 & 2.326682e-02_rb,2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb,&
7370 & 2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb,1.890389e-02_rb,&
7371 & 1.852300e-02_rb /)
7372 extice3(:, 20) = (/ &
7373 ! band 20
7374 & 5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb,1.497944e-01_rb,&
7375 & 1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb,8.762610e-02_rb,7.936938e-02_rb,&
7376 & 7.252809e-02_rb,6.676701e-02_rb,6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,&
7377 & 5.063598e-02_rb,4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb,&
7378 & 3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb,3.272425e-02_rb,&
7379 & 3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb,2.825191e-02_rb,2.731612e-02_rb,&
7380 & 2.643943e-02_rb,2.561642e-02_rb,2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,&
7381 & 2.277329e-02_rb,2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb,&
7382 & 1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb,1.819730e-02_rb,&
7383 & 1.779781e-02_rb /)
7384 extice3(:, 21) = (/ &
7385 ! band 21
7386 & 5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb,1.479819e-01_rb,&
7387 & 1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb,8.675183e-02_rb,7.861971e-02_rb,&
7388 & 7.188168e-02_rb,6.620754e-02_rb,6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,&
7389 & 5.031995e-02_rb,4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb,&
7390 & 3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb,3.267854e-02_rb,&
7391 & 3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb,2.827370e-02_rb,2.735203e-02_rb,&
7392 & 2.648858e-02_rb,2.567798e-02_rb,2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,&
7393 & 2.287776e-02_rb,2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb,&
7394 & 2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb,1.837083e-02_rb,&
7395 & 1.797737e-02_rb /)
7396 extice3(:, 22) = (/ &
7397 ! band 22
7398 & 4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb,1.460446e-01_rb,&
7399 & 1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb,8.588928e-02_rb,7.789990e-02_rb,&
7400 & 7.128013e-02_rb,6.570559e-02_rb,6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,&
7401 & 5.009688e-02_rb,4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb,&
7402 & 3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb,3.276512e-02_rb,&
7403 & 3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb,2.843759e-02_rb,2.753211e-02_rb,&
7404 & 2.668381e-02_rb,2.588744e-02_rb,2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,&
7405 & 2.313637e-02_rb,2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb,&
7406 & 2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb,1.870855e-02_rb,&
7407 & 1.832199e-02_rb /)
7408 extice3(:, 23) = (/ &
7409 ! band 23
7410 & 5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb,1.485473e-01_rb,&
7411 & 1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb,8.704139e-02_rb,7.887264e-02_rb,&
7412 & 7.210424e-02_rb,6.640454e-02_rb,6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,&
7413 & 5.044537e-02_rb,4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb,&
7414 & 3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb,3.272448e-02_rb,&
7415 & 3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb,2.829979e-02_rb,2.737397e-02_rb,&
7416 & 2.650663e-02_rb,2.569238e-02_rb,2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,&
7417 & 2.287954e-02_rb,2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb,&
7418 & 2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb,1.835231e-02_rb,&
7419 & 1.795707e-02_rb /)
7420 extice3(:, 24) = (/ &
7421 ! band 24
7422 & 5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb,1.482779e-01_rb,&
7423 & 1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb,8.691087e-02_rb,7.876056e-02_rb,&
7424 & 7.200745e-02_rb,6.632062e-02_rb,6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,&
7425 & 5.039749e-02_rb,4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb,&
7426 & 3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb,3.271661e-02_rb,&
7427 & 3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb,2.830191e-02_rb,2.737818e-02_rb,&
7428 & 2.651279e-02_rb,2.570039e-02_rb,2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,&
7429 & 2.289390e-02_rb,2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb,&
7430 & 2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb,1.837688e-02_rb,&
7431 & 1.798254e-02_rb /)
7432 extice3(:, 25) = (/ &
7433 ! band 25
7434 & 5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb,1.477544e-01_rb,&
7435 & 1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb,8.663439e-02_rb,7.851688e-02_rb,&
7436 & 7.179095e-02_rb,6.612700e-02_rb,6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,&
7437 & 5.026796e-02_rb,4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb,&
7438 & 3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb,3.265824e-02_rb,&
7439 & 3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb,2.826131e-02_rb,2.734130e-02_rb,&
7440 & 2.647939e-02_rb,2.567026e-02_rb,2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,&
7441 & 2.287507e-02_rb,2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb,&
7442 & 2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb,1.837623e-02_rb,&
7443 & 1.798348e-02_rb /)
7444 extice3(:, 26) = (/ &
7445 ! band 26
7446 & 5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb,1.489122e-01_rb,&
7447 & 1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb,8.720201e-02_rb,7.900612e-02_rb,&
7448 & 7.221524e-02_rb,6.649660e-02_rb,6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,&
7449 & 5.048442e-02_rb,4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb,&
7450 & 3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb,3.270466e-02_rb,&
7451 & 3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb,2.826527e-02_rb,2.733638e-02_rb,&
7452 & 2.646615e-02_rb,2.564920e-02_rb,2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,&
7453 & 2.282702e-02_rb,2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb,&
7454 & 2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb,1.828474e-02_rb,&
7455 & 1.788819e-02_rb /)
7456 extice3(:, 27) = (/ &
7457 ! band 27
7458 & 5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb,1.491691e-01_rb,&
7459 & 1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb,8.734125e-02_rb,7.912973e-02_rb,&
7460 & 7.232591e-02_rb,6.659637e-02_rb,6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,&
7461 & 5.055367e-02_rb,4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb,&
7462 & 3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb,3.274002e-02_rb,&
7463 & 3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb,2.829216e-02_rb,2.736150e-02_rb,&
7464 & 2.648961e-02_rb,2.567111e-02_rb,2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,&
7465 & 2.284354e-02_rb,2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb,&
7466 & 2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb,1.829261e-02_rb,&
7467 & 1.789531e-02_rb /)
7468 extice3(:, 28) = (/ &
7469 ! band 28
7470 & 5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb,1.487921e-01_rb,&
7471 & 1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb,8.716516e-02_rb,7.898034e-02_rb,&
7472 & 7.219863e-02_rb,6.648771e-02_rb,6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,&
7473 & 5.049716e-02_rb,4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb,&
7474 & 3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb,3.274141e-02_rb,&
7475 & 3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb,2.830801e-02_rb,2.738037e-02_rb,&
7476 & 2.651132e-02_rb,2.569547e-02_rb,2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,&
7477 & 2.287710e-02_rb,2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb,&
7478 & 2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb,1.834096e-02_rb,&
7479 & 1.794495e-02_rb /)
7480 extice3(:, 29) = (/ &
7481 ! band 29
7482 & 1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb,1.343937e-01_rb,&
7483 & 1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb,8.685880e-02_rb,7.948698e-02_rb,&
7484 & 7.319086e-02_rb,6.775669e-02_rb,6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,&
7485 & 5.189810e-02_rb,4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb,&
7486 & 3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb,3.317880e-02_rb,&
7487 & 3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb,2.832256e-02_rb,2.729724e-02_rb,&
7488 & 2.633377e-02_rb,2.542675e-02_rb,2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,&
7489 & 2.227443e-02_rb,2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb,&
7490 & 1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb,1.713899e-02_rb,&
7491 & 1.668704e-02_rb /)
7493 ! single-scattering albedo: unitless
7494 ssaice3(:, 16) = (/ &
7495 ! band 16
7496 & 6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb,6.420046e-01_rb,&
7497 & 6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb,6.186783e-01_rb,6.138395e-01_rb,&
7498 & 6.093543e-01_rb,6.052049e-01_rb,6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,&
7499 & 5.916302e-01_rb,5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb,&
7500 & 5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb,5.744262e-01_rb,&
7501 & 5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb,5.704097e-01_rb,5.695739e-01_rb,&
7502 & 5.687747e-01_rb,5.679964e-01_rb,5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,&
7503 & 5.647860e-01_rb,5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb,&
7504 & 5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb,5.527976e-01_rb,&
7505 & 5.507005e-01_rb /)
7506 ssaice3(:, 17) = (/ &
7507 ! band 17
7508 & 7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb,7.397745e-01_rb,&
7509 & 7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb,7.201945e-01_rb,7.157894e-01_rb,&
7510 & 7.115652e-01_rb,7.075145e-01_rb,7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,&
7511 & 6.929007e-01_rb,6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb,&
7512 & 6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb,6.673637e-01_rb,&
7513 & 6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb,6.582561e-01_rb,6.561163e-01_rb,&
7514 & 6.540182e-01_rb,6.519554e-01_rb,6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,&
7515 & 6.439289e-01_rb,6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb,&
7516 & 6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb,6.254825e-01_rb,&
7517 & 6.232583e-01_rb /)
7518 ssaice3(:, 18) = (/ &
7519 ! band 18
7520 & 9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb,9.763566e-01_rb,&
7521 & 9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb,9.615104e-01_rb,9.579725e-01_rb,&
7522 & 9.544997e-01_rb,9.510901e-01_rb,9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,&
7523 & 9.380415e-01_rb,9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb,&
7524 & 9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb,9.115688e-01_rb,&
7525 & 9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb,9.007846e-01_rb,8.981592e-01_rb,&
7526 & 8.955581e-01_rb,8.929792e-01_rb,8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,&
7527 & 8.828464e-01_rb,8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb,&
7528 & 8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb,8.605744e-01_rb,&
7529 & 8.580989e-01_rb /)
7530 ssaice3(:, 19) = (/ &
7531 ! band 19
7532 & 9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb,9.205529e-01_rb,&
7533 & 9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb,8.843699e-01_rb,8.761992e-01_rb,&
7534 & 8.683536e-01_rb,8.608204e-01_rb,8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,&
7535 & 8.335635e-01_rb,8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb,&
7536 & 8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb,7.856825e-01_rb,&
7537 & 7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb,7.685711e-01_rb,7.645522e-01_rb,&
7538 & 7.606126e-01_rb,7.567404e-01_rb,7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,&
7539 & 7.416844e-01_rb,7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb,&
7540 & 7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb,7.070811e-01_rb,&
7541 & 7.028972e-01_rb /)
7542 ssaice3(:, 20) = (/ &
7543 ! band 20
7544 & 9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb,9.813746e-01_rb,&
7545 & 9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb,9.694553e-01_rb,9.666088e-01_rb,&
7546 & 9.638123e-01_rb,9.610641e-01_rb,9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,&
7547 & 9.505211e-01_rb,9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb,&
7548 & 9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb,9.289731e-01_rb,&
7549 & 9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb,9.201147e-01_rb,9.179496e-01_rb,&
7550 & 9.158008e-01_rb,9.136667e-01_rb,9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,&
7551 & 9.052436e-01_rb,9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb,&
7552 & 8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb,8.864907e-01_rb,&
7553 & 8.843843e-01_rb /)
7554 ssaice3(:, 21) = (/ &
7555 ! band 21
7556 & 9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb,9.800523e-01_rb,&
7557 & 9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb,9.680106e-01_rb,9.651862e-01_rb,&
7558 & 9.624315e-01_rb,9.597439e-01_rb,9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,&
7559 & 9.496177e-01_rb,9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb,&
7560 & 9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb,9.298313e-01_rb,&
7561 & 9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb,9.220198e-01_rb,9.201338e-01_rb,&
7562 & 9.182700e-01_rb,9.164258e-01_rb,9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,&
7563 & 9.091999e-01_rb,9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb,&
7564 & 9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb,8.931888e-01_rb,&
7565 & 8.913770e-01_rb /)
7566 ssaice3(:, 22) = (/ &
7567 ! band 22
7568 & 9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb,9.983724e-01_rb,&
7569 & 9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb,9.972623e-01_rb,9.969849e-01_rb,&
7570 & 9.967077e-01_rb,9.964305e-01_rb,9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,&
7571 & 9.953230e-01_rb,9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb,&
7572 & 9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb,9.928390e-01_rb,&
7573 & 9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb,9.917396e-01_rb,9.914652e-01_rb,&
7574 & 9.911911e-01_rb,9.909171e-01_rb,9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,&
7575 & 9.898237e-01_rb,9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb,&
7576 & 9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb,9.873784e-01_rb,&
7577 & 9.871081e-01_rb /)
7578 ssaice3(:, 23) = (/ &
7579 ! band 23
7580 & 9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb,9.997642e-01_rb,&
7581 & 9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb,9.995949e-01_rb,9.995528e-01_rb,&
7582 & 9.995106e-01_rb,9.994686e-01_rb,9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,&
7583 & 9.993007e-01_rb,9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb,&
7584 & 9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb,9.989260e-01_rb,&
7585 & 9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb,9.987606e-01_rb,9.987194e-01_rb,&
7586 & 9.986782e-01_rb,9.986370e-01_rb,9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,&
7587 & 9.984729e-01_rb,9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb,&
7588 & 9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb,9.981059e-01_rb,&
7589 & 9.980653e-01_rb /)
7590 ssaice3(:, 24) = (/ &
7591 ! band 24
7592 & 9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb,9.999926e-01_rb,&
7593 & 9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb,9.999873e-01_rb,9.999860e-01_rb,&
7594 & 9.999847e-01_rb,9.999834e-01_rb,9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,&
7595 & 9.999782e-01_rb,9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb,&
7596 & 9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb,9.999665e-01_rb,&
7597 & 9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb,9.999613e-01_rb,9.999600e-01_rb,&
7598 & 9.999587e-01_rb,9.999574e-01_rb,9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,&
7599 & 9.999522e-01_rb,9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb,&
7600 & 9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb,9.999405e-01_rb,&
7601 & 9.999392e-01_rb /)
7602 ssaice3(:, 25) = (/ &
7603 ! band 25
7604 & 9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
7605 & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,&
7606 & 9.999980e-01_rb,9.999979e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,&
7607 & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb,&
7608 & 9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999960e-01_rb,&
7609 & 9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb,9.999954e-01_rb,9.999953e-01_rb,&
7610 & 9.999952e-01_rb,9.999950e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,&
7611 & 9.999944e-01_rb,9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,&
7612 & 9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb,9.999931e-01_rb,&
7613 & 9.999930e-01_rb /)
7614 ssaice3(:, 26) = (/ &
7615 ! band 26
7616 & 9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb,9.999987e-01_rb,&
7617 & 9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,&
7618 & 9.999973e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,&
7619 & 9.999963e-01_rb,9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb,&
7620 & 9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb,9.999944e-01_rb,&
7621 & 9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb,9.999935e-01_rb,9.999933e-01_rb,&
7622 & 9.999931e-01_rb,9.999929e-01_rb,9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,&
7623 & 9.999920e-01_rb,9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb,&
7624 & 9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb,9.999900e-01_rb,&
7625 & 9.999897e-01_rb /)
7626 ssaice3(:, 27) = (/ &
7627 ! band 27
7628 & 9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb,9.999968e-01_rb,&
7629 & 9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb,9.999946e-01_rb,9.999940e-01_rb,&
7630 & 9.999934e-01_rb,9.999929e-01_rb,9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,&
7631 & 9.999907e-01_rb,9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb,&
7632 & 9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb,9.999858e-01_rb,&
7633 & 9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb,9.999836e-01_rb,9.999831e-01_rb,&
7634 & 9.999826e-01_rb,9.999820e-01_rb,9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,&
7635 & 9.999798e-01_rb,9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb,&
7636 & 9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb,9.999748e-01_rb,&
7637 & 9.999742e-01_rb /)
7638 ssaice3(:, 28) = (/ &
7639 ! band 28
7640 & 9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb,9.999917e-01_rb,&
7641 & 9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb,9.999859e-01_rb,9.999845e-01_rb,&
7642 & 9.999831e-01_rb,9.999816e-01_rb,9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,&
7643 & 9.999759e-01_rb,9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb,&
7644 & 9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb,9.999631e-01_rb,&
7645 & 9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb,9.999574e-01_rb,9.999560e-01_rb,&
7646 & 9.999546e-01_rb,9.999532e-01_rb,9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,&
7647 & 9.999474e-01_rb,9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb,&
7648 & 9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb,9.999345e-01_rb,&
7649 & 9.999330e-01_rb /)
7650 ssaice3(:, 29) = (/ &
7651 ! band 29
7652 & 4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb,5.485149e-01_rb,&
7653 & 5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb,5.507364e-01_rb,5.503793e-01_rb,&
7654 & 5.498090e-01_rb,5.490612e-01_rb,5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,&
7655 & 5.447878e-01_rb,5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb,&
7656 & 5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb,5.323140e-01_rb,&
7657 & 5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb,5.276704e-01_rb,5.267680e-01_rb,&
7658 & 5.260000e-01_rb,5.253823e-01_rb,5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,&
7659 & 5.247434e-01_rb,5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb,&
7660 & 5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb,5.388676e-01_rb,&
7661 & 5.422146e-01_rb /)
7663 ! asymmetry factor: unitless
7664 asyice3(:, 16) = (/ &
7665 ! band 16
7666 & 8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb,8.660387e-01_rb,&
7667 & 8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb,8.882934e-01_rb,8.927662e-01_rb,&
7668 & 8.968577e-01_rb,9.005914e-01_rb,9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,&
7669 & 9.123836e-01_rb,9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb,&
7670 & 9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb,9.256727e-01_rb,&
7671 & 9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb,9.281156e-01_rb,9.285662e-01_rb,&
7672 & 9.289806e-01_rb,9.293726e-01_rb,9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,&
7673 & 9.309859e-01_rb,9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb,&
7674 & 9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb,9.384329e-01_rb,&
7675 & 9.398744e-01_rb /)
7676 asyice3(:, 17) = (/ &
7677 ! band 17
7678 & 8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb,8.908785e-01_rb,&
7679 & 8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb,9.050582e-01_rb,9.080739e-01_rb,&
7680 & 9.108976e-01_rb,9.135388e-01_rb,9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,&
7681 & 9.224620e-01_rb,9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb,&
7682 & 9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb,9.353013e-01_rb,&
7683 & 9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb,9.389939e-01_rb,9.398145e-01_rb,&
7684 & 9.406092e-01_rb,9.413856e-01_rb,9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,&
7685 & 9.444561e-01_rb,9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb,&
7686 & 9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb,9.531294e-01_rb,&
7687 & 9.544055e-01_rb /)
7688 asyice3(:, 18) = (/ &
7689 ! band 18
7690 & 7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb,8.091495e-01_rb,&
7691 & 8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb,8.258790e-01_rb,8.296792e-01_rb,&
7692 & 8.333355e-01_rb,8.368524e-01_rb,8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,&
7693 & 8.496143e-01_rb,8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb,&
7694 & 8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb,8.718916e-01_rb,&
7695 & 8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb,8.795734e-01_rb,8.813308e-01_rb,&
7696 & 8.830315e-01_rb,8.846799e-01_rb,8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,&
7697 & 8.908350e-01_rb,8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb,&
7698 & 8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb,9.032765e-01_rb,&
7699 & 9.046369e-01_rb /)
7700 asyice3(:, 19) = (/ &
7701 ! band 19
7702 & 7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb,8.094109e-01_rb,&
7703 & 8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb,8.328294e-01_rb,8.380166e-01_rb,&
7704 & 8.429556e-01_rb,8.476556e-01_rb,8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,&
7705 & 8.642481e-01_rb,8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb,&
7706 & 8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb,8.910897e-01_rb,&
7707 & 8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb,8.996311e-01_rb,9.015398e-01_rb,&
7708 & 9.033745e-01_rb,9.051436e-01_rb,9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,&
7709 & 9.117311e-01_rb,9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb,&
7710 & 9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb,9.259476e-01_rb,&
7711 & 9.276661e-01_rb /)
7712 asyice3(:, 20) = (/ &
7713 ! band 20
7714 & 7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb,7.832998e-01_rb,&
7715 & 7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb,8.001765e-01_rb,8.040551e-01_rb,&
7716 & 8.078044e-01_rb,8.114280e-01_rb,8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,&
7717 & 8.247344e-01_rb,8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb,&
7718 & 8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb,8.486568e-01_rb,&
7719 & 8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb,8.571122e-01_rb,8.590558e-01_rb,&
7720 & 8.609378e-01_rb,8.627618e-01_rb,8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,&
7721 & 8.695423e-01_rb,8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb,&
7722 & 8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb,8.826854e-01_rb,&
7723 & 8.840419e-01_rb /)
7724 asyice3(:, 21) = (/ &
7725 ! band 21
7726 & 7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb,7.789452e-01_rb,&
7727 & 7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb,7.953555e-01_rb,7.991290e-01_rb,&
7728 & 8.027777e-01_rb,8.063049e-01_rb,8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,&
7729 & 8.192645e-01_rb,8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb,&
7730 & 8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb,8.425553e-01_rb,&
7731 & 8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb,8.507412e-01_rb,8.526132e-01_rb,&
7732 & 8.544210e-01_rb,8.561675e-01_rb,8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,&
7733 & 8.625951e-01_rb,8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb,&
7734 & 8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb,8.745255e-01_rb,&
7735 & 8.756961e-01_rb /)
7736 asyice3(:, 22) = (/ &
7737 ! band 22
7738 & 7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb,7.715402e-01_rb,&
7739 & 7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb,7.847148e-01_rb,7.877892e-01_rb,&
7740 & 7.907786e-01_rb,7.936846e-01_rb,7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,&
7741 & 8.045011e-01_rb,8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb,&
7742 & 8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb,8.244958e-01_rb,&
7743 & 8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb,8.316580e-01_rb,8.332991e-01_rb,&
7744 & 8.348831e-01_rb,8.364115e-01_rb,8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,&
7745 & 8.419969e-01_rb,8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb,&
7746 & 8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb,8.518561e-01_rb,&
7747 & 8.527528e-01_rb /)
7748 asyice3(:, 23) = (/ &
7749 ! band 23
7750 & 7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb,7.699306e-01_rb,&
7751 & 7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb,7.815060e-01_rb,7.842654e-01_rb,&
7752 & 7.869705e-01_rb,7.896211e-01_rb,7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,&
7753 & 7.996726e-01_rb,8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb,&
7754 & 8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb,8.190001e-01_rb,&
7755 & 8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb,8.260924e-01_rb,8.277186e-01_rb,&
7756 & 8.292856e-01_rb,8.307932e-01_rb,8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,&
7757 & 8.362244e-01_rb,8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb,&
7758 & 8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb,8.448755e-01_rb,&
7759 & 8.455263e-01_rb /)
7760 asyice3(:, 24) = (/ &
7761 ! band 24
7762 & 7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb,7.683337e-01_rb,&
7763 & 7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb,7.792225e-01_rb,7.818494e-01_rb,&
7764 & 7.844362e-01_rb,7.869819e-01_rb,7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,&
7765 & 7.967337e-01_rb,7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb,&
7766 & 8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb,8.158862e-01_rb,&
7767 & 8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb,8.230149e-01_rb,8.246527e-01_rb,&
7768 & 8.262308e-01_rb,8.277483e-01_rb,8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,&
7769 & 8.331929e-01_rb,8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb,&
7770 & 8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb,8.415240e-01_rb,&
7771 & 8.420926e-01_rb /)
7772 asyice3(:, 25) = (/ &
7773 ! band 25
7774 & 7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb,7.655067e-01_rb,&
7775 & 7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb,7.758492e-01_rb,7.783750e-01_rb,&
7776 & 7.808735e-01_rb,7.833430e-01_rb,7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,&
7777 & 7.928983e-01_rb,7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb,&
7778 & 8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb,8.120527e-01_rb,&
7779 & 8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb,8.192776e-01_rb,8.209405e-01_rb,&
7780 & 8.225427e-01_rb,8.240826e-01_rb,8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,&
7781 & 8.295856e-01_rb,8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb,&
7782 & 8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb,8.376710e-01_rb,&
7783 & 8.381633e-01_rb /)
7784 asyice3(:, 26) = (/ &
7785 ! band 26
7786 & 7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb,7.597839e-01_rb,&
7787 & 7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb,7.701303e-01_rb,7.726639e-01_rb,&
7788 & 7.751727e-01_rb,7.776548e-01_rb,7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,&
7789 & 7.872804e-01_rb,7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb,&
7790 & 7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb,8.066715e-01_rb,&
7791 & 8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb,8.140150e-01_rb,8.157072e-01_rb,&
7792 & 8.173382e-01_rb,8.189063e-01_rb,8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,&
7793 & 8.245130e-01_rb,8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb,&
7794 & 8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb,8.327385e-01_rb,&
7795 & 8.332350e-01_rb /)
7796 asyice3(:, 27) = (/ &
7797 ! band 27
7798 & 7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb,7.504362e-01_rb,&
7799 & 7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb,7.609199e-01_rb,7.634888e-01_rb,&
7800 & 7.660332e-01_rb,7.685512e-01_rb,7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,&
7801 & 7.783229e-01_rb,7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb,&
7802 & 7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb,7.980449e-01_rb,&
7803 & 7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb,8.055311e-01_rb,8.072581e-01_rb,&
7804 & 8.089235e-01_rb,8.105255e-01_rb,8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,&
7805 & 8.162626e-01_rb,8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb,&
7806 & 8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb,8.247399e-01_rb,&
7807 & 8.252599e-01_rb /)
7808 asyice3(:, 28) = (/ &
7809 ! band 28
7810 & 7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb,7.332444e-01_rb,&
7811 & 7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb,7.437869e-01_rb,7.463702e-01_rb,&
7812 & 7.489291e-01_rb,7.514616e-01_rb,7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,&
7813 & 7.612933e-01_rb,7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb,&
7814 & 7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb,7.811789e-01_rb,&
7815 & 7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb,7.887597e-01_rb,7.905131e-01_rb,&
7816 & 7.922062e-01_rb,7.938372e-01_rb,7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,&
7817 & 7.997047e-01_rb,8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb,&
7818 & 8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb,8.085768e-01_rb,&
7819 & 8.091507e-01_rb /)
7820 asyice3(:, 29) = (/ &
7821 ! band 29
7822 & 8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb,9.168987e-01_rb,&
7823 & 9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb,9.323000e-01_rb,9.354235e-01_rb,&
7824 & 9.382858e-01_rb,9.408985e-01_rb,9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,&
7825 & 9.490871e-01_rb,9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb,&
7826 & 9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb,9.576692e-01_rb,&
7827 & 9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb,9.590851e-01_rb,9.593729e-01_rb,&
7828 & 9.596632e-01_rb,9.599705e-01_rb,9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,&
7829 & 9.616667e-01_rb,9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb,&
7830 & 9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb,9.724337e-01_rb,&
7831 & 9.746084e-01_rb /)
7833 ! fdelta: unitless
7834 fdlice3(:, 16) = (/ &
7835 ! band 16
7836 & 4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb,3.950191e-02_rb,&
7837 & 3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb,3.154697e-02_rb,2.985578e-02_rb,&
7838 & 2.827395e-02_rb,2.679666e-02_rb,2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,&
7839 & 2.183639e-02_rb,2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb,&
7840 & 1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb,1.490917e-02_rb,&
7841 & 1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb,1.300089e-02_rb,1.258006e-02_rb,&
7842 & 1.217208e-02_rb,1.177212e-02_rb,1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,&
7843 & 1.015596e-02_rb,9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb,&
7844 & 7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb,5.106597e-03_rb,&
7845 & 4.312183e-03_rb /)
7846 fdlice3(:, 17) = (/ &
7847 ! band 17
7848 & 5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb,4.814380e-02_rb,&
7849 & 4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb,4.622662e-02_rb,4.583426e-02_rb,&
7850 & 4.547274e-02_rb,4.514007e-02_rb,4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,&
7851 & 4.405844e-02_rb,4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb,&
7852 & 4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb,4.254248e-02_rb,&
7853 & 4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb,4.198564e-02_rb,4.183462e-02_rb,&
7854 & 4.167494e-02_rb,4.150462e-02_rb,4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,&
7855 & 4.067737e-02_rb,4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb,&
7856 & 3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb,3.742316e-02_rb,&
7857 & 3.689645e-02_rb /)
7858 fdlice3(:, 18) = (/ &
7859 ! band 18
7860 & 1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb,1.073793e-01_rb,&
7861 & 1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb,1.088364e-01_rb,1.092439e-01_rb,&
7862 & 1.096647e-01_rb,1.100970e-01_rb,1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,&
7863 & 1.119004e-01_rb,1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb,&
7864 & 1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb,1.158540e-01_rb,&
7865 & 1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb,1.172741e-01_rb,1.175738e-01_rb,&
7866 & 1.178472e-01_rb,1.180926e-01_rb,1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,&
7867 & 1.187538e-01_rb,1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb,&
7868 & 1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb,1.178282e-01_rb,&
7869 & 1.174731e-01_rb /)
7870 fdlice3(:, 19) = (/ &
7871 ! band 19
7872 & 1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb,1.035099e-01_rb,&
7873 & 1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb,1.000808e-01_rb,9.931116e-02_rb,&
7874 & 9.857151e-02_rb,9.785939e-02_rb,9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,&
7875 & 9.523623e-02_rb,9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb,&
7876 & 9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb,8.996974e-02_rb,&
7877 & 8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb,8.754323e-02_rb,8.689919e-02_rb,&
7878 & 8.623517e-02_rb,8.554869e-02_rb,8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,&
7879 & 8.252807e-02_rb,8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb,&
7880 & 7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb,7.344227e-02_rb,&
7881 & 7.217872e-02_rb /)
7882 fdlice3(:, 20) = (/ &
7883 ! band 20
7884 & 1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb,1.135456e-01_rb,&
7885 & 1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb,1.155623e-01_rb,1.161096e-01_rb,&
7886 & 1.166703e-01_rb,1.172422e-01_rb,1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,&
7887 & 1.196025e-01_rb,1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb,&
7888 & 1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb,1.247926e-01_rb,&
7889 & 1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb,1.267509e-01_rb,1.271836e-01_rb,&
7890 & 1.275896e-01_rb,1.279669e-01_rb,1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,&
7891 & 1.291486e-01_rb,1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb,&
7892 & 1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb,1.293460e-01_rb,&
7893 & 1.291109e-01_rb /)
7894 fdlice3(:, 21) = (/ &
7895 ! band 21
7896 & 1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb,1.148934e-01_rb,&
7897 & 1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb,1.168396e-01_rb,1.173706e-01_rb,&
7898 & 1.179152e-01_rb,1.184715e-01_rb,1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,&
7899 & 1.207720e-01_rb,1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb,&
7900 & 1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb,1.258309e-01_rb,&
7901 & 1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb,1.277257e-01_rb,1.281415e-01_rb,&
7902 & 1.285300e-01_rb,1.288893e-01_rb,1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,&
7903 & 1.299927e-01_rb,1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb,&
7904 & 1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb,1.299638e-01_rb,&
7905 & 1.296983e-01_rb /)
7906 fdlice3(:, 22) = (/ &
7907 ! band 22
7908 & 1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb,1.178666e-01_rb,&
7909 & 1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb,1.215796e-01_rb,1.225522e-01_rb,&
7910 & 1.235383e-01_rb,1.245361e-01_rb,1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,&
7911 & 1.286011e-01_rb,1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb,&
7912 & 1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb,1.376198e-01_rb,&
7913 & 1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb,1.412678e-01_rb,1.421212e-01_rb,&
7914 & 1.429469e-01_rb,1.437430e-01_rb,1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,&
7915 & 1.465899e-01_rb,1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb,&
7916 & 1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb,1.504579e-01_rb,&
7917 & 1.506227e-01_rb /)
7918 fdlice3(:, 23) = (/ &
7919 ! band 23
7920 & 1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb,1.187738e-01_rb,&
7921 & 1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb,1.226099e-01_rb,1.236141e-01_rb,&
7922 & 1.246322e-01_rb,1.256621e-01_rb,1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,&
7923 & 1.298584e-01_rb,1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb,&
7924 & 1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb,1.391820e-01_rb,&
7925 & 1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb,1.429671e-01_rb,1.438547e-01_rb,&
7926 & 1.447146e-01_rb,1.455449e-01_rb,1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,&
7927 & 1.485270e-01_rb,1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb,&
7928 & 1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb,1.526880e-01_rb,&
7929 & 1.528840e-01_rb /)
7930 fdlice3(:, 24) = (/ &
7931 ! band 24
7932 & 1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb,1.195676e-01_rb,&
7933 & 1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb,1.234349e-01_rb,1.244463e-01_rb,&
7934 & 1.254712e-01_rb,1.265078e-01_rb,1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,&
7935 & 1.307287e-01_rb,1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb,&
7936 & 1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb,1.400984e-01_rb,&
7937 & 1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb,1.439016e-01_rb,1.447936e-01_rb,&
7938 & 1.456579e-01_rb,1.464925e-01_rb,1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,&
7939 & 1.494923e-01_rb,1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb,&
7940 & 1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb,1.536969e-01_rb,&
7941 & 1.538984e-01_rb /)
7942 fdlice3(:, 25) = (/ &
7943 ! band 25
7944 & 1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb,1.203867e-01_rb,&
7945 & 1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb,1.242750e-01_rb,1.252903e-01_rb,&
7946 & 1.263187e-01_rb,1.273583e-01_rb,1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,&
7947 & 1.315870e-01_rb,1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb,&
7948 & 1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb,1.409577e-01_rb,&
7949 & 1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb,1.447577e-01_rb,1.456488e-01_rb,&
7950 & 1.465123e-01_rb,1.473461e-01_rb,1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,&
7951 & 1.503439e-01_rb,1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb,&
7952 & 1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb,1.545575e-01_rb,&
7953 & 1.547617e-01_rb /)
7954 fdlice3(:, 26) = (/ &
7955 !band 26
7956 & 1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb,1.216171e-01_rb,&
7957 & 1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb,1.255363e-01_rb,1.265564e-01_rb,&
7958 & 1.275888e-01_rb,1.286313e-01_rb,1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,&
7959 & 1.328643e-01_rb,1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb,&
7960 & 1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb,1.422165e-01_rb,&
7961 & 1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb,1.460058e-01_rb,1.468947e-01_rb,&
7962 & 1.477564e-01_rb,1.485888e-01_rb,1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,&
7963 & 1.515864e-01_rb,1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb,&
7964 & 1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb,1.558490e-01_rb,&
7965 & 1.560645e-01_rb /)
7966 fdlice3(:, 27) = (/ &
7967 ! band 27
7968 & 1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb,1.237059e-01_rb,&
7969 & 1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb,1.276765e-01_rb,1.287041e-01_rb,&
7970 & 1.297420e-01_rb,1.307883e-01_rb,1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,&
7971 & 1.350207e-01_rb,1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb,&
7972 & 1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb,1.443134e-01_rb,&
7973 & 1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb,1.480681e-01_rb,1.489490e-01_rb,&
7974 & 1.498032e-01_rb,1.506286e-01_rb,1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,&
7975 & 1.536070e-01_rb,1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb,&
7976 & 1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb,1.579093e-01_rb,&
7977 & 1.581390e-01_rb /)
7978 fdlice3(:, 28) = (/ &
7979 ! band 28
7980 & 1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb,1.283905e-01_rb,&
7981 & 1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb,1.322964e-01_rb,1.333060e-01_rb,&
7982 & 1.343252e-01_rb,1.353523e-01_rb,1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,&
7983 & 1.395042e-01_rb,1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb,&
7984 & 1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb,1.486157e-01_rb,&
7985 & 1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb,1.523016e-01_rb,1.531673e-01_rb,&
7986 & 1.540073e-01_rb,1.548197e-01_rb,1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,&
7987 & 1.577576e-01_rb,1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb,&
7988 & 1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb,1.620614e-01_rb,&
7989 & 1.623011e-01_rb /)
7990 fdlice3(:, 29) = (/ &
7991 ! band 29
7992 & 1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb,8.165612e-02_rb,&
7993 & 7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb,6.638412e-02_rb,6.308156e-02_rb,&
7994 & 5.996942e-02_rb,5.703979e-02_rb,5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,&
7995 & 4.698880e-02_rb,4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb,&
7996 & 3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb,3.197604e-02_rb,&
7997 & 3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb,2.752050e-02_rb,2.652776e-02_rb,&
7998 & 2.556772e-02_rb,2.463247e-02_rb,2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,&
7999 & 2.098180e-02_rb,2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb,&
8000 & 1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb,1.114319e-02_rb,&
8001 & 9.727157e-03_rb /)
8003 end subroutine swcldpr
8005 end module rrtmg_sw_init
8007 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
8008 ! author: $Author: trn $
8009 ! revision: $Revision: 1.3 $
8010 ! created: $Date: 2009/04/16 19:54:22 $
8011 !
8012 module rrtmg_sw_vrtqdr
8014 ! --------------------------------------------------------------------------
8015 ! | |
8016 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
8017 ! | This software may be used, copied, or redistributed as long as it is |
8018 ! | not sold and this copyright notice is reproduced on each copy made. |
8019 ! | This model is provided as is without any express or implied warranties. |
8020 ! | (http://www.rtweb.aer.com/) |
8021 ! | |
8022 ! --------------------------------------------------------------------------
8024 ! ------- Modules -------
8026 use parkind, only: im => kind_im, rb => kind_rb
8027 ! use parrrsw, only: ngptsw
8029 implicit none
8031 contains
8033 ! --------------------------------------------------------------------------
8034 subroutine vrtqdr_sw(klev, kw, &
8035 pref, prefd, ptra, ptrad, &
8036 pdbt, prdnd, prup, prupd, ptdbt, &
8037 pfd, pfu)
8038 ! --------------------------------------------------------------------------
8040 ! Purpose: This routine performs the vertical quadrature integration
8041 !
8042 ! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
8043 !
8044 ! Modifications.
8045 !
8046 ! Original: H. Barker
8047 ! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
8048 ! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
8049 !
8050 !-----------------------------------------------------------------------
8052 ! ------- Declarations -------
8054 ! Input
8056 integer(kind=im), intent (in) :: klev ! number of model layers
8057 integer(kind=im), intent (in) :: kw ! g-point index
8059 real(kind=rb), intent(in) :: pref(:) ! direct beam reflectivity
8060 ! Dimensions: (nlayers+1)
8061 real(kind=rb), intent(in) :: prefd(:) ! diffuse beam reflectivity
8062 ! Dimensions: (nlayers+1)
8063 real(kind=rb), intent(in) :: ptra(:) ! direct beam transmissivity
8064 ! Dimensions: (nlayers+1)
8065 real(kind=rb), intent(in) :: ptrad(:) ! diffuse beam transmissivity
8066 ! Dimensions: (nlayers+1)
8068 real(kind=rb), intent(in) :: pdbt(:)
8069 ! Dimensions: (nlayers+1)
8070 real(kind=rb), intent(in) :: ptdbt(:)
8071 ! Dimensions: (nlayers+1)
8073 real(kind=rb), intent(inout) :: prdnd(:)
8074 ! Dimensions: (nlayers+1)
8075 real(kind=rb), intent(inout) :: prup(:)
8076 ! Dimensions: (nlayers+1)
8077 real(kind=rb), intent(inout) :: prupd(:)
8078 ! Dimensions: (nlayers+1)
8080 ! Output
8081 real(kind=rb), intent(out) :: pfd(:,:) ! downwelling flux (W/m2)
8082 ! Dimensions: (nlayers+1,ngptsw)
8083 ! unadjusted for earth/sun distance or zenith angle
8084 real(kind=rb), intent(out) :: pfu(:,:) ! upwelling flux (W/m2)
8085 ! Dimensions: (nlayers+1,ngptsw)
8086 ! unadjusted for earth/sun distance or zenith angle
8088 ! Local
8090 integer(kind=im) :: ikp, ikx, jk
8092 real(kind=rb) :: zreflect
8093 real(kind=rb) :: ztdn(klev+1)
8095 ! Definitions
8096 !
8097 ! pref(jk) direct reflectance
8098 ! prefd(jk) diffuse reflectance
8099 ! ptra(jk) direct transmittance
8100 ! ptrad(jk) diffuse transmittance
8101 !
8102 ! pdbt(jk) layer mean direct beam transmittance
8103 ! ptdbt(jk) total direct beam transmittance at levels
8104 !
8105 !-----------------------------------------------------------------------------
8107 ! Link lowest layer with surface
8109 zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
8110 prup(klev) = pref(klev) + (ptrad(klev) * &
8111 ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + &
8112 pdbt(klev) * pref(klev+1))) * zreflect
8113 prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * &
8114 prefd(klev+1) * zreflect
8116 ! Pass from bottom to top
8118 do jk = 1,klev-1
8119 ikp = klev+1-jk
8120 ikx = ikp-1
8121 zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
8122 prup(ikx) = pref(ikx) + (ptrad(ikx) * &
8123 ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + &
8124 pdbt(ikx) * prup(ikp))) * zreflect
8125 prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * &
8126 prupd(ikp) * zreflect
8127 enddo
8129 ! Upper boundary conditions
8131 ztdn(1) = 1._rb
8132 prdnd(1) = 0._rb
8133 ztdn(2) = ptra(1)
8134 prdnd(2) = prefd(1)
8136 ! Pass from top to bottom
8138 do jk = 2,klev
8139 ikp = jk+1
8140 zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
8141 ztdn(ikp) = ptdbt(jk) * ptra(jk) + &
8142 (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + &
8143 ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
8144 prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * &
8145 prdnd(jk) * zreflect
8146 enddo
8148 ! Up and down-welling fluxes at levels
8150 do jk = 1,klev+1
8151 zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
8152 pfu(jk,kw) = (ptdbt(jk) * prup(jk) + &
8153 (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
8154 pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ &
8155 ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
8156 enddo
8158 end subroutine vrtqdr_sw
8160 end module rrtmg_sw_vrtqdr
8162 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
8163 ! author: $Author: trn $
8164 ! revision: $Revision: 1.3 $
8165 ! created: $Date: 2009/04/16 19:54:22 $
8167 module rrtmg_sw_spcvmc
8169 ! --------------------------------------------------------------------------
8170 ! | |
8171 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
8172 ! | This software may be used, copied, or redistributed as long as it is |
8173 ! | not sold and this copyright notice is reproduced on each copy made. |
8174 ! | This model is provided as is without any express or implied warranties. |
8175 ! | (http://www.rtweb.aer.com/) |
8176 ! | |
8177 ! --------------------------------------------------------------------------
8179 ! ------- Modules -------
8181 use parkind, only : im => kind_im, rb => kind_rb
8182 use parrrsw, only : nbndsw, ngptsw, mxmol, jpband
8183 use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
8184 use rrsw_vsn, only : hvrspc, hnamspc
8185 use rrsw_wvn, only : ngc, ngs
8186 use rrtmg_sw_reftra, only: reftra_sw
8187 use rrtmg_sw_taumol, only: taumol_sw
8188 use rrtmg_sw_vrtqdr, only: vrtqdr_sw
8190 implicit none
8192 contains
8194 ! ---------------------------------------------------------------------------
8195 subroutine spcvmc_sw &
8196 (nlayers, istart, iend, icpr, iout, &
8197 pavel, tavel, pz, tz, tbound, palbd, palbp, &
8198 pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
8199 ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, &
8200 laytrop, layswtch, laylow, jp, jt, jt1, &
8201 co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
8202 fac00, fac01, fac10, fac11, &
8203 selffac, selffrac, indself, forfac, forfrac, indfor, &
8204 pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
8205 pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir)
8206 ! ---------------------------------------------------------------------------
8207 !
8208 ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes,
8209 ! using the two-stream method of H. Barker and McICA, the Monte-Carlo
8210 ! Independent Column Approximation, for the representation of
8211 ! sub-grid cloud variability (i.e. cloud overlap).
8212 !
8213 ! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
8214 !
8215 ! Method:
8216 ! Adapted from two-stream model of H. Barker;
8217 ! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
8218 ! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
8219 !
8220 ! Modifications:
8221 !
8222 ! Original: H. Barker
8223 ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003
8224 ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003
8225 ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003
8226 ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004
8227 ! Revision: Code modified so that delta scaling is not done in cloudy profiles
8228 ! if routine cldprop is used; delta scaling can be applied by swithcing
8229 ! code below if cldprop is not used to get cloud properties.
8230 ! AER, Jan 2005
8231 ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005
8232 ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006
8233 ! Revision: Use exponential lookup table for transmittance: MJIacono, AER,
8234 ! Aug 2007
8235 !
8236 ! ------------------------------------------------------------------
8238 ! ------- Declarations ------
8240 ! ------- Input -------
8242 integer(kind=im), intent(in) :: nlayers
8243 integer(kind=im), intent(in) :: istart
8244 integer(kind=im), intent(in) :: iend
8245 integer(kind=im), intent(in) :: icpr
8246 integer(kind=im), intent(in) :: iout
8247 integer(kind=im), intent(in) :: laytrop
8248 integer(kind=im), intent(in) :: layswtch
8249 integer(kind=im), intent(in) :: laylow
8251 integer(kind=im), intent(in) :: indfor(:)
8252 ! Dimensions: (nlayers)
8253 integer(kind=im), intent(in) :: indself(:)
8254 ! Dimensions: (nlayers)
8255 integer(kind=im), intent(in) :: jp(:)
8256 ! Dimensions: (nlayers)
8257 integer(kind=im), intent(in) :: jt(:)
8258 ! Dimensions: (nlayers)
8259 integer(kind=im), intent(in) :: jt1(:)
8260 ! Dimensions: (nlayers)
8262 real(kind=rb), intent(in) :: pavel(:) ! layer pressure (hPa, mb)
8263 ! Dimensions: (nlayers)
8264 real(kind=rb), intent(in) :: tavel(:) ! layer temperature (K)
8265 ! Dimensions: (nlayers)
8266 real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressure (hPa, mb)
8267 ! Dimensions: (0:nlayers)
8268 real(kind=rb), intent(in) :: tz(0:) ! level temperatures (hPa, mb)
8269 ! Dimensions: (0:nlayers)
8270 real(kind=rb), intent(in) :: tbound ! surface temperature (K)
8271 real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm2)
8272 ! Dimensions: (mxmol,nlayers)
8273 real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
8274 ! Dimensions: (nlayers)
8275 real(kind=rb), intent(in) :: colmol(:)
8276 ! Dimensions: (nlayers)
8277 real(kind=rb), intent(in) :: adjflux(:) ! Earth/Sun distance adjustment
8278 ! Dimensions: (jpband)
8280 real(kind=rb), intent(in) :: palbd(:) ! surface albedo (diffuse)
8281 ! Dimensions: (nbndsw)
8282 real(kind=rb), intent(in) :: palbp(:) ! surface albedo (direct)
8283 ! Dimensions: (nbndsw)
8284 real(kind=rb), intent(in) :: prmu0 ! cosine of solar zenith angle
8285 real(kind=rb), intent(in) :: pcldfmc(:,:) ! cloud fraction [mcica]
8286 ! Dimensions: (nlayers,ngptsw)
8287 real(kind=rb), intent(in) :: ptaucmc(:,:) ! cloud optical depth [mcica]
8288 ! Dimensions: (nlayers,ngptsw)
8289 real(kind=rb), intent(in) :: pasycmc(:,:) ! cloud asymmetry parameter [mcica]
8290 ! Dimensions: (nlayers,ngptsw)
8291 real(kind=rb), intent(in) :: pomgcmc(:,:) ! cloud single scattering albedo [mcica]
8292 ! Dimensions: (nlayers,ngptsw)
8293 real(kind=rb), intent(in) :: ptaormc(:,:) ! cloud optical depth, non-delta scaled [mcica]
8294 ! Dimensions: (nlayers,ngptsw)
8295 real(kind=rb), intent(in) :: ptaua(:,:) ! aerosol optical depth
8296 ! Dimensions: (nlayers,nbndsw)
8297 real(kind=rb), intent(in) :: pasya(:,:) ! aerosol asymmetry parameter
8298 ! Dimensions: (nlayers,nbndsw)
8299 real(kind=rb), intent(in) :: pomga(:,:) ! aerosol single scattering albedo
8300 ! Dimensions: (nlayers,nbndsw)
8302 real(kind=rb), intent(in) :: colh2o(:)
8303 ! Dimensions: (nlayers)
8304 real(kind=rb), intent(in) :: colco2(:)
8305 ! Dimensions: (nlayers)
8306 real(kind=rb), intent(in) :: colch4(:)
8307 ! Dimensions: (nlayers)
8308 real(kind=rb), intent(in) :: co2mult(:)
8309 ! Dimensions: (nlayers)
8310 real(kind=rb), intent(in) :: colo3(:)
8311 ! Dimensions: (nlayers)
8312 real(kind=rb), intent(in) :: colo2(:)
8313 ! Dimensions: (nlayers)
8314 real(kind=rb), intent(in) :: coln2o(:)
8315 ! Dimensions: (nlayers)
8317 real(kind=rb), intent(in) :: forfac(:)
8318 ! Dimensions: (nlayers)
8319 real(kind=rb), intent(in) :: forfrac(:)
8320 ! Dimensions: (nlayers)
8321 real(kind=rb), intent(in) :: selffac(:)
8322 ! Dimensions: (nlayers)
8323 real(kind=rb), intent(in) :: selffrac(:)
8324 ! Dimensions: (nlayers)
8325 real(kind=rb), intent(in) :: fac00(:)
8326 ! Dimensions: (nlayers)
8327 real(kind=rb), intent(in) :: fac01(:)
8328 ! Dimensions: (nlayers)
8329 real(kind=rb), intent(in) :: fac10(:)
8330 ! Dimensions: (nlayers)
8331 real(kind=rb), intent(in) :: fac11(:)
8332 ! Dimensions: (nlayers)
8334 ! ------- Output -------
8335 ! All Dimensions: (nlayers+1)
8336 real(kind=rb), intent(out) :: pbbcd(:)
8337 real(kind=rb), intent(out) :: pbbcu(:)
8338 real(kind=rb), intent(out) :: pbbfd(:)
8339 real(kind=rb), intent(out) :: pbbfu(:)
8340 real(kind=rb), intent(out) :: pbbfddir(:)
8341 real(kind=rb), intent(out) :: pbbcddir(:)
8343 real(kind=rb), intent(out) :: puvcd(:)
8344 real(kind=rb), intent(out) :: puvfd(:)
8345 real(kind=rb), intent(out) :: puvcddir(:)
8346 real(kind=rb), intent(out) :: puvfddir(:)
8348 real(kind=rb), intent(out) :: pnicd(:)
8349 real(kind=rb), intent(out) :: pnifd(:)
8350 real(kind=rb), intent(out) :: pnicddir(:)
8351 real(kind=rb), intent(out) :: pnifddir(:)
8353 ! Output - inactive ! All Dimensions: (nlayers+1)
8354 ! real(kind=rb), intent(out) :: puvcu(:)
8355 ! real(kind=rb), intent(out) :: puvfu(:)
8356 ! real(kind=rb), intent(out) :: pnicu(:)
8357 ! real(kind=rb), intent(out) :: pnifu(:)
8358 ! real(kind=rb), intent(out) :: pvscd(:)
8359 ! real(kind=rb), intent(out) :: pvscu(:)
8360 ! real(kind=rb), intent(out) :: pvsfd(:)
8361 ! real(kind=rb), intent(out) :: pvsfu(:)
8363 ! ------- Local -------
8365 logical :: lrtchkclr(nlayers),lrtchkcld(nlayers)
8367 integer(kind=im) :: klev
8368 integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx
8369 integer(kind=im) :: iw, jb, jg, jl, jk
8370 ! integer(kind=im), parameter :: nuv = ??
8371 ! integer(kind=im), parameter :: nvs = ??
8372 integer(kind=im) :: itind
8374 real(kind=rb) :: tblind, ze1
8375 real(kind=rb) :: zclear, zcloud
8376 real(kind=rb) :: zdbt(nlayers+1), zdbt_nodel(nlayers+1)
8377 real(kind=rb) :: zgc(nlayers), zgcc(nlayers), zgco(nlayers)
8378 real(kind=rb) :: zomc(nlayers), zomcc(nlayers), zomco(nlayers)
8379 real(kind=rb) :: zrdnd(nlayers+1), zrdndc(nlayers+1)
8380 real(kind=rb) :: zref(nlayers+1), zrefc(nlayers+1), zrefo(nlayers+1)
8381 real(kind=rb) :: zrefd(nlayers+1), zrefdc(nlayers+1), zrefdo(nlayers+1)
8382 real(kind=rb) :: zrup(nlayers+1), zrupd(nlayers+1)
8383 real(kind=rb) :: zrupc(nlayers+1), zrupdc(nlayers+1)
8384 real(kind=rb) :: zs1(nlayers+1)
8385 real(kind=rb) :: ztauc(nlayers), ztauo(nlayers)
8386 real(kind=rb) :: ztdn(nlayers+1), ztdnd(nlayers+1), ztdbt(nlayers+1)
8387 real(kind=rb) :: ztoc(nlayers), ztor(nlayers)
8388 real(kind=rb) :: ztra(nlayers+1), ztrac(nlayers+1), ztrao(nlayers+1)
8389 real(kind=rb) :: ztrad(nlayers+1), ztradc(nlayers+1), ztrado(nlayers+1)
8390 real(kind=rb) :: zdbtc(nlayers+1), ztdbtc(nlayers+1)
8391 real(kind=rb) :: zincflx(ngptsw), zdbtc_nodel(nlayers+1)
8392 real(kind=rb) :: ztdbt_nodel(nlayers+1), ztdbtc_nodel(nlayers+1)
8394 real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect
8395 real(kind=rb) :: zwf, tauorig, repclc
8396 ! real(kind=rb) :: zincflux ! inactive
8398 ! Arrays from rrtmg_sw_taumoln routines
8400 ! real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16)
8401 ! real(kind=rb) :: zsflxzen(16)
8402 real(kind=rb) :: ztaug(nlayers,ngptsw), ztaur(nlayers,ngptsw)
8403 real(kind=rb) :: zsflxzen(ngptsw)
8405 ! Arrays from rrtmg_sw_vrtqdr routine
8407 real(kind=rb) :: zcd(nlayers+1,ngptsw), zcu(nlayers+1,ngptsw)
8408 real(kind=rb) :: zfd(nlayers+1,ngptsw), zfu(nlayers+1,ngptsw)
8410 ! Inactive arrays
8411 ! real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1)
8412 ! real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1)
8413 ! real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1)
8415 ! ------------------------------------------------------------------
8417 ! Initializations
8419 ib1 = istart
8420 ib2 = iend
8421 klev = nlayers
8422 iw = 0
8423 repclc = 1.e-12_rb
8424 ! zincflux = 0.0_rb
8426 do jk=1,klev+1
8427 pbbcd(jk)=0._rb
8428 pbbcu(jk)=0._rb
8429 pbbfd(jk)=0._rb
8430 pbbfu(jk)=0._rb
8431 pbbcddir(jk)=0._rb
8432 pbbfddir(jk)=0._rb
8433 puvcd(jk)=0._rb
8434 puvfd(jk)=0._rb
8435 puvcddir(jk)=0._rb
8436 puvfddir(jk)=0._rb
8437 pnicd(jk)=0._rb
8438 pnifd(jk)=0._rb
8439 pnicddir(jk)=0._rb
8440 pnifddir(jk)=0._rb
8441 enddo
8444 ! Calculate the optical depths for gaseous absorption and Rayleigh scattering
8446 call taumol_sw(klev, &
8447 colh2o, colco2, colch4, colo2, colo3, colmol, &
8448 laytrop, jp, jt, jt1, &
8449 fac00, fac01, fac10, fac11, &
8450 selffac, selffrac, indself, forfac, forfrac, indfor, &
8451 zsflxzen, ztaug, ztaur)
8453 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
8455 do jb = ib1, ib2
8456 ibm = jb-15
8457 igt = ngc(ibm)
8459 ! Reinitialize g-point counter for each band if output for each band is requested.
8460 if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1)
8462 ! do jk=1,klev+1
8463 ! zbbcd(jk)=0.0_rb
8464 ! zbbcu(jk)=0.0_rb
8465 ! zbbfd(jk)=0.0_rb
8466 ! zbbfu(jk)=0.0_rb
8467 ! enddo
8469 ! Top of g-point interval loop within each band (iw is cumulative counter)
8470 do jg = 1,igt
8471 iw = iw+1
8473 ! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux
8474 zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0
8475 ! zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0 ! inactive
8477 ! Compute layer reflectances and transmittances for direct and diffuse sources,
8478 ! first clear then cloudy
8480 ! zrefc(jk) direct albedo for clear
8481 ! zrefo(jk) direct albedo for cloud
8482 ! zrefdc(jk) diffuse albedo for clear
8483 ! zrefdo(jk) diffuse albedo for cloud
8484 ! ztrac(jk) direct transmittance for clear
8485 ! ztrao(jk) direct transmittance for cloudy
8486 ! ztradc(jk) diffuse transmittance for clear
8487 ! ztrado(jk) diffuse transmittance for cloudy
8488 !
8489 ! zref(jk) direct reflectance
8490 ! zrefd(jk) diffuse reflectance
8491 ! ztra(jk) direct transmittance
8492 ! ztrad(jk) diffuse transmittance
8493 !
8494 ! zdbtc(jk) clear direct beam transmittance
8495 ! zdbto(jk) cloudy direct beam transmittance
8496 ! zdbt(jk) layer mean direct beam transmittance
8497 ! ztdbt(jk) total direct beam transmittance at levels
8499 ! Clear-sky
8500 ! TOA direct beam
8501 ztdbtc(1)=1.0_rb
8502 ztdbtc_nodel(1)=1.0_rb
8503 ! Surface values
8504 zdbtc(klev+1) =0.0_rb
8505 ztrac(klev+1) =0.0_rb
8506 ztradc(klev+1)=0.0_rb
8507 zrefc(klev+1) =palbp(ibm)
8508 zrefdc(klev+1)=palbd(ibm)
8509 zrupc(klev+1) =palbp(ibm)
8510 zrupdc(klev+1)=palbd(ibm)
8512 ! Total sky
8513 ! TOA direct beam
8514 ztdbt(1)=1.0_rb
8515 ztdbt_nodel(1)=1.0_rb
8516 ! Surface values
8517 zdbt(klev+1) =0.0_rb
8518 ztra(klev+1) =0.0_rb
8519 ztrad(klev+1)=0.0_rb
8520 zref(klev+1) =palbp(ibm)
8521 zrefd(klev+1)=palbd(ibm)
8522 zrup(klev+1) =palbp(ibm)
8523 zrupd(klev+1)=palbd(ibm)
8525 ! Top of layer loop
8526 do jk=1,klev
8528 ! Note: two-stream calculations proceed from top to bottom;
8529 ! RRTMG_SW quantities are given bottom to top and are reversed here
8531 ikl=klev+1-jk
8533 ! Set logical flag to do REFTRA calculation
8534 ! Do REFTRA for all clear layers
8535 lrtchkclr(jk)=.true.
8537 ! Do REFTRA only for cloudy layers in profile, since already done for clear layers
8538 lrtchkcld(jk)=.false.
8539 lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc)
8541 ! Clear-sky optical parameters - this section inactive
8542 ! Original
8543 ! ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw)
8544 ! zomcc(jk) = ztaur(ikl,iw) / ztauc(jk)
8545 ! zgcc(jk) = 0.0001_rb
8546 ! Total sky optical parameters
8547 ! ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw)
8548 ! zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw)
8549 ! zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8550 ! ztaur(ikl,iw) * 0.0001_rb) / zomco(jk)
8551 ! zomco(jk) = zomco(jk) / ztauo(jk)
8553 ! Clear-sky optical parameters including aerosols
8554 ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm)
8555 zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
8556 zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
8557 zomcc(jk) = zomcc(jk) / ztauc(jk)
8559 ! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD)
8560 ! \/\/\/ This block of code is only needed for direct beam calculation
8561 !
8562 zclear = 1.0_rb - pcldfmc(ikl,iw)
8563 zcloud = pcldfmc(ikl,iw)
8565 ! Clear
8566 ! zdbtmc = exp(-ztauc(jk) / prmu0)
8568 ! Use exponential lookup table for transmittance, or expansion of
8569 ! exponential for low tau
8570 ze1 = ztauc(jk) / prmu0
8571 if (ze1 .le. od_lo) then
8572 zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8573 else
8574 tblind = ze1 / (bpade + ze1)
8575 itind = tblint * tblind + 0.5_rb
8576 zdbtmc = exp_tbl(itind)
8577 endif
8579 zdbtc_nodel(jk) = zdbtmc
8580 ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk)
8582 ! Clear + Cloud
8583 tauorig = ztauc(jk) + ptaormc(ikl,iw)
8584 ! zdbtmo = exp(-tauorig / prmu0)
8586 ! Use exponential lookup table for transmittance, or expansion of
8587 ! exponential for low tau
8588 ze1 = tauorig / prmu0
8589 if (ze1 .le. od_lo) then
8590 zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8591 else
8592 tblind = ze1 / (bpade + ze1)
8593 itind = tblint * tblind + 0.5_rb
8594 zdbtmo = exp_tbl(itind)
8595 endif
8597 zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo
8598 ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk)
8599 ! /\/\/\ Above code only needed for direct beam calculation
8602 ! Delta scaling - clear
8603 zf = zgcc(jk) * zgcc(jk)
8604 zwf = zomcc(jk) * zf
8605 ztauc(jk) = (1.0_rb - zwf) * ztauc(jk)
8606 zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf)
8607 zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf)
8610 ! Total sky optical parameters (cloud properties already delta-scaled)
8611 ! Use this code if cloud properties are derived in rrtmg_sw_cldprop
8612 if (icpr .ge. 1) then
8613 ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw)
8614 zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw)
8615 zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8616 ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk)
8617 zomco(jk) = zomco(jk) / ztauo(jk)
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 elseif (icpr .eq. 0) then
8622 ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw)
8623 zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + &
8624 ztaur(ikl,iw) * 1.0_rb
8625 zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
8626 ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk)
8627 zomco(jk) = zomco(jk) / ztauo(jk)
8629 ! Delta scaling - clouds
8630 ! Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply delta scaling
8631 zf = zgco(jk) * zgco(jk)
8632 zwf = zomco(jk) * zf
8633 ztauo(jk) = (1._rb - zwf) * ztauo(jk)
8634 zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf)
8635 zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf)
8636 endif
8638 ! End of layer loop
8639 enddo
8641 ! Clear sky reflectivities
8642 call reftra_sw (klev, &
8643 lrtchkclr, zgcc, prmu0, ztauc, zomcc, &
8644 zrefc, zrefdc, ztrac, ztradc)
8646 ! Total sky reflectivities
8647 call reftra_sw (klev, &
8648 lrtchkcld, zgco, prmu0, ztauo, zomco, &
8649 zrefo, zrefdo, ztrao, ztrado)
8651 do jk=1,klev
8653 ! Combine clear and cloudy contributions for total sky
8654 ikl = klev+1-jk
8655 zclear = 1.0_rb - pcldfmc(ikl,iw)
8656 zcloud = pcldfmc(ikl,iw)
8658 zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk)
8659 zrefd(jk)= zclear*zrefdc(jk) + zcloud*zrefdo(jk)
8660 ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk)
8661 ztrad(jk)= zclear*ztradc(jk) + zcloud*ztrado(jk)
8663 ! Direct beam transmittance
8665 ! Clear
8666 ! zdbtmc = exp(-ztauc(jk) / prmu0)
8668 ! Use exponential lookup table for transmittance, or expansion of
8669 ! exponential for low tau
8670 ze1 = ztauc(jk) / prmu0
8671 if (ze1 .le. od_lo) then
8672 zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8673 else
8674 tblind = ze1 / (bpade + ze1)
8675 itind = tblint * tblind + 0.5_rb
8676 zdbtmc = exp_tbl(itind)
8677 endif
8679 zdbtc(jk) = zdbtmc
8680 ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk)
8682 ! Clear + Cloud
8683 ! zdbtmo = exp(-ztauo(jk) / prmu0)
8685 ! Use exponential lookup table for transmittance, or expansion of
8686 ! exponential for low tau
8687 ze1 = ztauo(jk) / prmu0
8688 if (ze1 .le. od_lo) then
8689 zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8690 else
8691 tblind = ze1 / (bpade + ze1)
8692 itind = tblint * tblind + 0.5_rb
8693 zdbtmo = exp_tbl(itind)
8694 endif
8696 zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo
8697 ztdbt(jk+1) = zdbt(jk)*ztdbt(jk)
8699 enddo
8701 ! Vertical quadrature for clear-sky fluxes
8703 call vrtqdr_sw(klev, iw, &
8704 zrefc, zrefdc, ztrac, ztradc, &
8705 zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, &
8706 zcd, zcu)
8708 ! Vertical quadrature for cloudy fluxes
8710 call vrtqdr_sw(klev, iw, &
8711 zref, zrefd, ztra, ztrad, &
8712 zdbt, zrdnd, zrup, zrupd, ztdbt, &
8713 zfd, zfu)
8715 ! Upwelling and downwelling fluxes at levels
8716 ! Two-stream calculations go from top to bottom;
8717 ! layer indexing is reversed to go bottom to top for output arrays
8719 do jk=1,klev+1
8720 ikl=klev+2-jk
8722 ! Accumulate spectral fluxes over bands - inactive
8723 ! zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8724 ! zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8725 ! zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8726 ! zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8727 ! zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8728 ! zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8730 ! Accumulate spectral fluxes over whole spectrum
8731 pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8732 pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8733 pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8734 pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8735 pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8736 pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8738 ! Accumulate direct fluxes for UV/visible bands
8739 if (ibm >= 10 .and. ibm <= 13) then
8740 puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw)
8741 puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw)
8742 puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8743 puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8744 ! Accumulate direct fluxes for near-IR bands
8745 else if (ibm == 14 .or. ibm <= 9) then
8746 pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw)
8747 pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw)
8748 pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8749 pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8750 endif
8752 enddo
8754 ! End loop on jg, g-point interval
8755 enddo
8757 ! End loop on jb, spectral band
8758 enddo
8760 end subroutine spcvmc_sw
8762 end module rrtmg_sw_spcvmc
8764 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
8765 ! author: $Author: trn $
8766 ! revision: $Revision: 1.3 $
8767 ! created: $Date: 2009/04/16 19:54:22 $
8768 !
8769 module rrtmg_sw_rad
8771 ! --------------------------------------------------------------------------
8772 ! | |
8773 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
8774 ! | This software may be used, copied, or redistributed as long as it is |
8775 ! | not sold and this copyright notice is reproduced on each copy made. |
8776 ! | This model is provided as is without any express or implied warranties. |
8777 ! | (http://www.rtweb.aer.com/) |
8778 ! | |
8779 ! --------------------------------------------------------------------------
8780 !
8781 ! ****************************************************************************
8782 ! * *
8783 ! * RRTMG_SW *
8784 ! * *
8785 ! * *
8786 ! * *
8787 ! * a rapid radiative transfer model *
8788 ! * for the solar spectral region *
8789 ! * for application to general circulation models *
8790 ! * *
8791 ! * *
8792 ! * Atmospheric and Environmental Research, Inc. *
8793 ! * 131 Hartwell Avenue *
8794 ! * Lexington, MA 02421 *
8795 ! * *
8796 ! * *
8797 ! * Eli J. Mlawer *
8798 ! * Jennifer S. Delamere *
8799 ! * Michael J. Iacono *
8800 ! * Shepard A. Clough *
8801 ! * *
8802 ! * *
8803 ! * *
8804 ! * *
8805 ! * *
8806 ! * *
8807 ! * email: miacono@aer.com *
8808 ! * email: emlawer@aer.com *
8809 ! * email: jdelamer@aer.com *
8810 ! * *
8811 ! * The authors wish to acknowledge the contributions of the *
8812 ! * following people: Steven J. Taubman, Patrick D. Brown, *
8813 ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
8814 ! * *
8815 ! ****************************************************************************
8817 ! --------- Modules ---------
8819 use parkind, only : im => kind_im, rb => kind_rb
8820 use rrsw_vsn
8821 use mcica_subcol_gen_sw, only: mcica_subcol_sw
8822 use rrtmg_sw_cldprmc, only: cldprmc_sw
8823 ! *** Move the required call to rrtmg_sw_ini below and the following
8824 ! use association to GCM initialization area ***
8825 ! use rrtmg_sw_init, only: rrtmg_sw_ini
8826 use rrtmg_sw_setcoef, only: setcoef_sw
8827 use rrtmg_sw_spcvmc, only: spcvmc_sw
8829 implicit none
8831 ! public interfaces/functions/subroutines
8832 public :: rrtmg_sw, inatm_sw, earth_sun
8834 !------------------------------------------------------------------
8835 contains
8836 !------------------------------------------------------------------
8838 !------------------------------------------------------------------
8839 ! Public subroutines
8840 !------------------------------------------------------------------
8842 subroutine rrtmg_sw &
8843 (ncol ,nlay ,icld , &
8844 play ,plev ,tlay ,tlev ,tsfc , &
8845 h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
8846 asdir ,asdif ,aldir ,aldif , &
8847 coszen ,adjes ,dyofyr ,scon , &
8848 inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
8849 taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
8850 ciwpmcl ,clwpmcl ,cswpmcl ,reicmcl ,relqmcl ,resnmcl, &
8851 tauaer ,ssaaer ,asmaer ,ecaer , &
8852 swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln ,swdflxcln , aer_opt, &
8853 ! --------- Add the following four compenants for ssib shortwave down radiation ---!
8854 ! ------------------- by Zhenxin 2011-06-20 --------------------------------!
8855 sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
8856 ! ---------------------- End, Zhenxin 2011-06-20 --------------------------------!
8857 swdkdir,swdkdif, & ! jararias, 2013/08/10
8858 swdkdirc, & ! PAJ
8859 calc_clean_atm_diag, &
8860 sw_zbbcddir, sw_dirdflux, sw_difdflux & ! WRF-CMAQ twoway coupled model
8861 )
8864 ! ------- Description -------
8866 ! This program is the driver for RRTMG_SW, the AER SW radiation model for
8867 ! application to GCMs, that has been adapted from RRTM_SW for improved
8868 ! efficiency and to provide fractional cloudiness and cloud overlap
8869 ! capability using McICA.
8870 !
8871 ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization
8872 ! area, since this has to be called only once.
8873 !
8874 ! This routine
8875 ! b) calls INATM_SW to read in the atmospheric profile;
8876 ! all layering in RRTMG is ordered from surface to toa.
8877 ! c) calls CLDPRMC_SW to set cloud optical depth for McICA based
8878 ! on input cloud properties
8879 ! d) calls SETCOEF_SW to calculate various quantities needed for
8880 ! the radiative transfer algorithm
8881 ! e) calls SPCVMC to call the two-stream model that in turn
8882 ! calls TAUMOL to calculate gaseous optical depths for each
8883 ! of the 16 spectral bands and to perform the radiative transfer
8884 ! using McICA, the Monte-Carlo Independent Column Approximation,
8885 ! to represent sub-grid scale cloud variability
8886 ! f) passes the calculated fluxes and cooling rates back to GCM
8887 !
8888 ! Two modes of operation are possible:
8889 ! The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use
8890 ! McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM.
8891 !
8892 ! 1) Standard, single forward model calculation (imca = 0); this is
8893 ! valid only for clear sky or fully overcast clouds
8894 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
8895 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
8896 ! This method is valid for clear sky or partial cloud conditions.
8897 !
8898 ! This call to RRTMG_SW must be preceeded by a call to the module
8899 ! mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator,
8900 ! which will provide the cloud physical or cloud optical properties
8901 ! on the RRTMG quadrature point (ngptsw) dimension.
8902 !
8903 ! Two methods of cloud property input are possible:
8904 ! Cloud properties can be input in one of two ways (controlled by input
8905 ! flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions
8906 ! and subroutine rrtmg_sw_cldprop.f90 for further details):
8907 !
8908 ! 1) Input cloud fraction, cloud optical depth, single scattering albedo
8909 ! and asymmetry parameter directly (inflgsw = 0)
8910 ! 2) Input cloud fraction and cloud physical properties: ice fracion,
8911 ! ice and liquid particle sizes (inflgsw = 1 or 2);
8912 ! cloud optical properties are calculated by cldprop or cldprmc based
8913 ! on input settings of iceflgsw and liqflgsw
8914 !
8915 ! Two methods of aerosol property input are possible:
8916 ! Aerosol properties can be input in one of two ways (controlled by input
8917 ! flag iaer, see text file rrtmg_sw_instructions for further details):
8918 !
8919 ! 1) Input aerosol optical depth, single scattering albedo and asymmetry
8920 ! parameter directly by layer and spectral band (iaer=10)
8921 ! 2) Input aerosol optical depth and 0.55 micron directly by layer and use
8922 ! one or more of six ECMWF aerosol types (iaer=6)
8923 !
8924 !
8925 ! ------- Modifications -------
8926 !
8927 ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced
8928 ! set of g-point intervals and a two-stream model for application to GCMs.
8929 !
8930 !-- Original version (derived from RRTM_SW)
8931 ! 2002: AER. Inc.
8932 !-- Conversion to F90 formatting; addition of 2-stream radiative transfer
8933 ! Feb 2003: J.-J. Morcrette, ECMWF
8934 !-- Additional modifications for GCM application
8935 ! Aug 2003: M. J. Iacono, AER Inc.
8936 !-- Total number of g-points reduced from 224 to 112. Original
8937 ! set of 224 can be restored by exchanging code in module parrrsw.f90
8938 ! and in file rrtmg_sw_init.f90.
8939 ! Apr 2004: M. J. Iacono, AER, Inc.
8940 !-- Modifications to include output for direct and diffuse
8941 ! downward fluxes. There are output as "true" fluxes without
8942 ! any delta scaling applied. Code can be commented to exclude
8943 ! this calculation in source file rrtmg_sw_spcvrt.f90.
8944 ! Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc.
8945 !-- Revised to add McICA capability.
8946 ! Nov 2005: M. J. Iacono, AER, Inc.
8947 !-- Reformatted for consistency with rrtmg_lw.
8948 ! Feb 2007: M. J. Iacono, AER, Inc.
8949 !-- Modifications to formatting to use assumed-shape arrays.
8950 ! Aug 2007: M. J. Iacono, AER, Inc.
8952 ! --------- Modules ---------
8954 use parrrsw, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
8955 jpband, jpb1, jpb2
8956 use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
8957 use rrsw_con, only : heatfac, oneminus, pi
8958 use rrsw_wvn, only : wavenum1, wavenum2
8960 ! ------- Declarations
8962 ! ----- Input -----
8964 integer(kind=im), intent(in) :: ncol ! Number of horizontal columns
8965 integer(kind=im), intent(in) :: nlay ! Number of model layers
8966 integer(kind=im), intent(inout) :: icld ! Cloud overlap method
8967 ! 0: Clear only
8968 ! 1: Random
8969 ! 2: Maximum/random
8970 ! 3: Maximum
8971 ! 4: Exponential
8972 ! 5: Exponential/random
8973 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
8974 ! Dimensions: (ncol,nlay)
8975 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
8976 ! Dimensions: (ncol,nlay+1)
8977 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
8978 ! Dimensions: (ncol,nlay)
8979 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
8980 ! Dimensions: (ncol,nlay+1)
8981 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
8982 ! Dimensions: (ncol)
8983 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
8984 ! Dimensions: (ncol,nlay)
8985 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
8986 ! Dimensions: (ncol,nlay)
8987 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
8988 ! Dimensions: (ncol,nlay)
8989 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
8990 ! Dimensions: (ncol,nlay)
8991 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
8992 ! Dimensions: (ncol,nlay)
8993 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
8994 ! Dimensions: (ncol,nlay)
8995 real(kind=rb), intent(in) :: asdir(:) ! UV/vis surface albedo direct rad
8996 ! Dimensions: (ncol)
8997 real(kind=rb), intent(in) :: aldir(:) ! Near-IR surface albedo direct rad
8998 ! Dimensions: (ncol)
8999 real(kind=rb), intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad
9000 ! Dimensions: (ncol)
9001 real(kind=rb), intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad
9002 ! Dimensions: (ncol)
9004 integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
9005 ! distance if adjflx not provided)
9006 real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
9007 real(kind=rb), intent(in) :: coszen(:) ! Cosine of solar zenith angle
9008 ! Dimensions: (ncol)
9009 real(kind=rb), intent(in) :: scon ! Solar constant (W/m2)
9011 integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties
9012 integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification
9013 integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification
9015 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
9016 ! Dimensions: (ngptsw,ncol,nlay)
9017 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
9018 ! Dimensions: (ngptsw,ncol,nlay)
9019 real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
9020 ! Dimensions: (ngptsw,ncol,nlay)
9021 real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
9022 ! Dimensions: (ngptsw,ncol,nlay)
9023 real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction
9024 ! Dimensions: (ngptsw,ncol,nlay)
9025 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
9026 ! Dimensions: (ngptsw,ncol,nlay)
9027 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
9028 ! Dimensions: (ngptsw,ncol,nlay)
9029 real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
9030 ! Dimensions: (ngptsw,ncol,nlay)
9031 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective radius (microns)
9032 ! Dimensions: (ncol,nlay)
9033 ! specific definition of reicmcl depends on setting of iceflglw:
9034 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
9035 ! r_ec must be >= 10.0 microns
9036 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
9037 ! r_ec range is limited to 13.0 to 130.0 microns
9038 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
9039 ! r_k range is limited to 5.0 to 131.0 microns
9040 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
9041 ! dge range is limited to 5.0 to 140.0 microns
9042 ! [dge = 1.0315 * r_ec]
9043 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
9044 ! Dimensions: (ncol,nlay)
9045 real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns)
9046 ! Dimensions: (ncol,nlay)
9047 real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only)
9048 ! Dimensions: (ncol,nlay,nbndsw)
9049 ! (non-delta scaled)
9050 real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only)
9051 ! Dimensions: (ncol,nlay,nbndsw)
9052 ! (non-delta scaled)
9053 real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only)
9054 ! Dimensions: (ncol,nlay,nbndsw)
9055 ! (non-delta scaled)
9056 real(kind=rb), intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only)
9057 ! Dimensions: (ncol,nlay,naerec)
9058 ! (non-delta scaled)
9059 integer, intent(in) :: calc_clean_atm_diag! Control for clean air diagnositic calls for WRF-Chem
9061 ! ----- Output -----
9063 real(kind=rb), intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2)
9064 ! Dimensions: (ncol,nlay+1)
9065 real(kind=rb), intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2)
9066 ! Dimensions: (ncol,nlay+1)
9067 real(kind=rb), intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2)
9068 ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
9069 real(kind=rb), intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2)
9070 ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
9071 real(kind=rb), intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2)
9072 ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
9073 real(kind=rb), intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2)
9074 ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
9075 real(kind=rb), intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d)
9076 ! Dimensions: (ncol,nlay)
9077 real(kind=rb), intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2)
9078 ! Dimensions: (ncol,nlay+1)
9079 real(kind=rb), intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2)
9080 ! Dimensions: (ncol,nlay+1)
9081 real(kind=rb), intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d)
9082 ! Dimensions: (ncol,nlay)
9083 real(kind=rb), intent(out) :: swuflxcln(:,:) ! Clean sky shortwave upward flux (W/m2)
9084 ! Dimensions: (ncol,nlay+1)
9085 real(kind=rb), intent(out) :: swdflxcln(:,:) ! Clean sky shortwave downward flux (W/m2)
9086 ! Dimensions: (ncol,nlay+1)
9088 integer, intent(in) :: aer_opt
9089 real(kind=rb), intent(out) :: &
9090 swdkdir(:,:), & ! Total shortwave downward direct flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10
9091 swdkdif(:,:), & ! Total shortwave downward diffuse flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10
9092 swdkdirc(:,:) ! Total shortwave downward direct flux clear sky (W/m2), Dimensions: (ncol,nlay)
9094 real, intent(out) :: sw_zbbcddir, & ! WRF-CMAQ twoway coupled model
9095 sw_dirdflux, & ! WRF-CMAQ twoway coupled model
9096 sw_difdflux ! WRF-CMAQ twoway coupled model
9102 ! ----- Local -----
9104 ! Control
9105 integer(kind=im) :: nlayers ! total number of layers
9106 integer(kind=im) :: istart ! beginning band of calculation
9107 integer(kind=im) :: iend ! ending band of calculation
9108 integer(kind=im) :: icpr ! cldprop/cldprmc use flag
9109 integer(kind=im) :: iout ! output option flag (inactive)
9110 integer(kind=im) :: iaer ! aerosol option flag
9111 integer(kind=im) :: idelm ! delta-m scaling flag (inactive)
9112 integer(kind=im) :: isccos ! instrumental cosine response flag (inactive)
9113 integer(kind=im) :: iplon ! column loop index
9114 integer(kind=im) :: i ! layer loop index ! jk
9115 integer(kind=im) :: ib ! band loop index ! jsw
9116 integer(kind=im) :: ia, ig ! indices
9117 integer(kind=im) :: k ! layer loop index
9118 integer(kind=im) :: ims ! value for changing mcica permute seed
9119 integer(kind=im) :: imca ! flag for mcica [0=off, 1=on]
9121 real(kind=rb) :: zepsec, zepzen ! epsilon
9122 real(kind=rb) :: zdpgcp ! flux to heating conversion ratio
9124 ! Atmosphere
9125 real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb)
9126 real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K)
9127 real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb)
9128 real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K)
9129 real(kind=rb) :: tbound ! surface temperature (K)
9130 real(kind=rb) :: pdp(nlay+1) ! layer pressure thickness (hPa, mb)
9131 real(kind=rb) :: coldry(nlay+1) ! dry air column amount
9132 real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2)
9134 ! real(kind=rb) :: earth_sun ! function for Earth/Sun distance factor
9135 real(kind=rb) :: cossza ! Cosine of solar zenith angle
9136 real(kind=rb) :: adjflux(jpband) ! adjustment for current Earth/Sun distance
9137 real(kind=rb) :: solvar(jpband) ! solar constant scaling factor from rrtmg_sw
9138 ! default value of 1368.22 Wm-2 at 1 AU
9139 real(kind=rb) :: albdir(nbndsw) ! surface albedo, direct ! zalbp
9140 real(kind=rb) :: albdif(nbndsw) ! surface albedo, diffuse ! zalbd
9142 real(kind=rb) :: taua(nlay+1,nbndsw) ! Aerosol optical depth
9143 real(kind=rb) :: ssaa(nlay+1,nbndsw) ! Aerosol single scattering albedo
9144 real(kind=rb) :: asma(nlay+1,nbndsw) ! Aerosol asymmetry parameter
9146 ! Atmosphere - setcoef
9147 integer(kind=im) :: laytrop ! tropopause layer index
9148 integer(kind=im) :: layswtch ! tropopause layer index
9149 integer(kind=im) :: laylow ! tropopause layer index
9150 integer(kind=im) :: jp(nlay+1) !
9151 integer(kind=im) :: jt(nlay+1) !
9152 integer(kind=im) :: jt1(nlay+1) !
9154 real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o)
9155 real(kind=rb) :: colco2(nlay+1) ! column amount (co2)
9156 real(kind=rb) :: colo3(nlay+1) ! column amount (o3)
9157 real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o)
9158 real(kind=rb) :: colch4(nlay+1) ! column amount (ch4)
9159 real(kind=rb) :: colo2(nlay+1) ! column amount (o2)
9160 real(kind=rb) :: colmol(nlay+1) ! column amount
9161 real(kind=rb) :: co2mult(nlay+1) ! column amount
9163 integer(kind=im) :: indself(nlay+1)
9164 integer(kind=im) :: indfor(nlay+1)
9165 real(kind=rb) :: selffac(nlay+1)
9166 real(kind=rb) :: selffrac(nlay+1)
9167 real(kind=rb) :: forfac(nlay+1)
9168 real(kind=rb) :: forfrac(nlay+1)
9170 real(kind=rb) :: & !
9171 fac00(nlay+1), fac01(nlay+1), &
9172 fac10(nlay+1), fac11(nlay+1)
9174 ! Atmosphere/clouds - cldprop
9175 integer(kind=im) :: ncbands ! number of cloud spectral bands
9176 integer(kind=im) :: inflag ! flag for cloud property method
9177 integer(kind=im) :: iceflag ! flag for ice cloud properties
9178 integer(kind=im) :: liqflag ! flag for liquid cloud properties
9180 ! real(kind=rb) :: cldfrac(nlay+1) ! layer cloud fraction
9181 ! real(kind=rb) :: tauc(nlay+1) ! in-cloud optical depth (non-delta scaled)
9182 ! real(kind=rb) :: ssac(nlay+1) ! in-cloud single scattering albedo (non-delta scaled)
9183 ! real(kind=rb) :: asmc(nlay+1) ! in-cloud asymmetry parameter (non-delta scaled)
9184 ! real(kind=rb) :: fsfc(nlay+1) ! in-cloud forward scattering fraction (non-delta scaled)
9185 ! real(kind=rb) :: ciwp(nlay+1) ! in-cloud ice water path
9186 ! real(kind=rb) :: clwp(nlay+1) ! in-cloud liquid water path
9187 ! real(kind=rb) :: rei(nlay+1) ! cloud ice particle size
9188 ! real(kind=rb) :: rel(nlay+1) ! cloud liquid particle size
9190 ! real(kind=rb) :: taucloud(nlay+1,jpband) ! in-cloud optical depth
9191 ! real(kind=rb) :: taucldorig(nlay+1,jpband)! in-cloud optical depth (non-delta scaled)
9192 ! real(kind=rb) :: ssacloud(nlay+1,jpband) ! in-cloud single scattering albedo
9193 ! real(kind=rb) :: asmcloud(nlay+1,jpband) ! in-cloud asymmetry parameter
9195 ! Atmosphere/clouds - cldprmc [mcica]
9196 real(kind=rb) :: cldfmc(ngptsw,nlay+1) ! cloud fraction [mcica]
9197 real(kind=rb) :: ciwpmc(ngptsw,nlay+1) ! in-cloud ice water path [mcica]
9198 real(kind=rb) :: clwpmc(ngptsw,nlay+1) ! in-cloud liquid water path [mcica]
9199 real(kind=rb) :: cswpmc(ngptsw,nlay+1) ! in-cloud snow water path [mcica]
9200 real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns)
9201 real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns)
9202 real(kind=rb) :: resnmc(nlay+1) ! snow particle effective size (microns)
9203 real(kind=rb) :: taucmc(ngptsw,nlay+1) ! in-cloud optical depth [mcica]
9204 real(kind=rb) :: taormc(ngptsw,nlay+1) ! unscaled in-cloud optical depth [mcica]
9205 real(kind=rb) :: ssacmc(ngptsw,nlay+1) ! in-cloud single scattering albedo [mcica]
9206 real(kind=rb) :: asmcmc(ngptsw,nlay+1) ! in-cloud asymmetry parameter [mcica]
9207 real(kind=rb) :: fsfcmc(ngptsw,nlay+1) ! in-cloud forward scattering fraction [mcica]
9209 ! Atmosphere/clouds/aerosol - spcvrt,spcvmc
9210 real(kind=rb) :: ztauc(nlay+1,nbndsw) ! cloud optical depth
9211 real(kind=rb) :: ztaucorig(nlay+1,nbndsw) ! unscaled cloud optical depth
9212 real(kind=rb) :: zasyc(nlay+1,nbndsw) ! cloud asymmetry parameter
9213 ! (first moment of phase function)
9214 real(kind=rb) :: zomgc(nlay+1,nbndsw) ! cloud single scattering albedo
9215 real(kind=rb) :: ztaua(nlay+1,nbndsw) ! total aerosol optical depth
9216 real(kind=rb) :: ztauacln(nlay+1,nbndsw) ! dummy total aerosol optical depth for clean case (=zero)
9217 real(kind=rb) :: zasya(nlay+1,nbndsw) ! total aerosol asymmetry parameter
9218 real(kind=rb) :: zomga(nlay+1,nbndsw) ! total aerosol single scattering albedo
9220 real(kind=rb) :: zcldfmc(nlay+1,ngptsw) ! cloud fraction [mcica]
9221 real(kind=rb) :: ztaucmc(nlay+1,ngptsw) ! cloud optical depth [mcica]
9222 real(kind=rb) :: ztaormc(nlay+1,ngptsw) ! unscaled cloud optical depth [mcica]
9223 real(kind=rb) :: zasycmc(nlay+1,ngptsw) ! cloud asymmetry parameter [mcica]
9224 real(kind=rb) :: zomgcmc(nlay+1,ngptsw) ! cloud single scattering albedo [mcica]
9226 real(kind=rb) :: zbbfu(nlay+2) ! temporary upward shortwave flux (w/m2)
9227 real(kind=rb) :: zbbfd(nlay+2) ! temporary downward shortwave flux (w/m2)
9228 real(kind=rb) :: zbbcu(nlay+2) ! temporary clear sky upward shortwave flux (w/m2)
9229 real(kind=rb) :: zbbcd(nlay+2) ! temporary clear sky downward shortwave flux (w/m2)
9230 real(kind=rb) :: zbbfddir(nlay+2) ! temporary downward direct shortwave flux (w/m2)
9231 real(kind=rb) :: zbbcddir(nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2)
9232 real(kind=rb) :: zuvfd(nlay+2) ! temporary UV downward shortwave flux (w/m2)
9233 real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2)
9234 real(kind=rb) :: zuvfddir(nlay+2) ! temporary UV downward direct shortwave flux (w/m2)
9235 real(kind=rb) :: zuvcddir(nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2)
9236 real(kind=rb) :: znifd(nlay+2) ! temporary near-IR downward shortwave flux (w/m2)
9237 real(kind=rb) :: znicd(nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2)
9238 real(kind=rb) :: znifddir(nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2)
9239 real(kind=rb) :: znicddir(nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2)
9240 real(kind=rb) :: zbbclnu(nlay+2) ! temporary clean sky upward shortwave flux (w/m2)
9241 real(kind=rb) :: zbbclnd(nlay+2) ! temporary clean sky downward shortwave flux (w/m2)
9242 real(kind=rb) :: zbbclnddir(nlay+2) ! temporary clean sky downward direct shortwave flux (w/m2)
9243 real(kind=rb) :: zuvclnd(nlay+2) ! temporary clean sky UV downward shortwave flux (w/m2)
9244 real(kind=rb) :: zuvclnddir(nlay+2) ! temporary clean sky UV downward direct shortwave flux (w/m2)
9245 real(kind=rb) :: zniclnd(nlay+2) ! temporary clean sky near-IR downward shortwave flux (w/m2)
9246 real(kind=rb) :: zniclnddir(nlay+2) ! temporary clean sky near-IR downward direct shortwave flux (w/m2)
9248 ! Optional output fields
9249 real(kind=rb) :: swnflx(nlay+2) ! Total sky shortwave net flux (W/m2)
9250 real(kind=rb) :: swnflxc(nlay+2) ! Clear sky shortwave net flux (W/m2)
9251 real(kind=rb) :: dirdflux(nlay+2) ! Direct downward shortwave surface flux
9252 real(kind=rb) :: difdflux(nlay+2) ! Diffuse downward shortwave surface flux
9253 real(kind=rb) :: uvdflx(nlay+2) ! Total sky downward shortwave flux, UV/vis
9254 real(kind=rb) :: nidflx(nlay+2) ! Total sky downward shortwave flux, near-IR
9255 real(kind=rb) :: dirdnuv(nlay+2) ! Direct downward shortwave flux, UV/vis
9256 real(kind=rb) :: difdnuv(nlay+2) ! Diffuse downward shortwave flux, UV/vis
9257 real(kind=rb) :: dirdnir(nlay+2) ! Direct downward shortwave flux, near-IR
9258 real(kind=rb) :: difdnir(nlay+2) ! Diffuse downward shortwave flux, near-IR
9260 ! Output - inactive
9261 ! real(kind=rb) :: zuvfu(nlay+2) ! temporary upward UV shortwave flux (w/m2)
9262 ! real(kind=rb) :: zuvfd(nlay+2) ! temporary downward UV shortwave flux (w/m2)
9263 ! real(kind=rb) :: zuvcu(nlay+2) ! temporary clear sky upward UV shortwave flux (w/m2)
9264 ! real(kind=rb) :: zuvcd(nlay+2) ! temporary clear sky downward UV shortwave flux (w/m2)
9265 ! real(kind=rb) :: zvsfu(nlay+2) ! temporary upward visible shortwave flux (w/m2)
9266 ! real(kind=rb) :: zvsfd(nlay+2) ! temporary downward visible shortwave flux (w/m2)
9267 ! real(kind=rb) :: zvscu(nlay+2) ! temporary clear sky upward visible shortwave flux (w/m2)
9268 ! real(kind=rb) :: zvscd(nlay+2) ! temporary clear sky downward visible shortwave flux (w/m2)
9269 ! real(kind=rb) :: znifu(nlay+2) ! temporary upward near-IR shortwave flux (w/m2)
9270 ! real(kind=rb) :: znifd(nlay+2) ! temporary downward near-IR shortwave flux (w/m2)
9271 ! real(kind=rb) :: znicu(nlay+2) ! temporary clear sky upward near-IR shortwave flux (w/m2)
9272 ! real(kind=rb) :: znicd(nlay+2) ! temporary clear sky downward near-IR shortwave flux (w/m2)
9275 ! Initializations
9277 iout = 0 !BSINGH(PNNL) initializing iout to zero(Might be wrong!) as this variable is never initialized but used in spcvmc_sw
9278 zepsec = 1.e-06_rb
9279 zepzen = 1.e-10_rb
9280 !jm not thread safe oneminus = 1.0_rb - zepsec
9281 !jm not thread safe pi = 2._rb * asin(1._rb)
9283 istart = jpb1
9284 iend = jpb2
9285 icpr = 0
9286 ims = 2
9288 ! In a GCM with or without McICA, set nlon to the longitude dimension
9289 !
9290 ! Set imca to select calculation type:
9291 ! imca = 0, use standard forward model calculation (clear and overcast only)
9292 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
9293 ! (clear, overcast or partial cloud conditions)
9295 ! *** This version uses McICA (imca = 1) ***
9297 ! Set icld to select of clear or cloud calculation and cloud
9298 ! overlap method (read by subroutine readprof from input file INPUT_RRTM):
9299 ! icld = 0, clear only
9300 ! icld = 1, with clouds using random cloud overlap (McICA only)
9301 ! icld = 2, with clouds using maximum/random cloud overlap (McICA only)
9302 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
9303 ! icld = 4, with clouds using exponential cloud overlap (McICA only)
9304 ! icld = 5, with clouds using exponential/random cloud overlap (McICA only)
9306 ! Set iaer to select aerosol option
9307 ! iaer = 0, no aerosols
9308 ! iaer = 6, use six ECMWF aerosol types
9309 ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer)
9310 ! iaer = 10, input total aerosol optical depth, single scattering albedo
9311 ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly
9312 if ( aer_opt.eq.0 .or. aer_opt.eq.2 .or. aer_opt.eq.3) then
9313 iaer = 10
9314 else if ( aer_opt .eq. 1 ) then
9315 iaer = 6
9316 endif
9318 ! Call model and data initialization, compute lookup tables, perform
9319 ! reduction of g-points from 224 to 112 for input absorption
9320 ! coefficient data and other arrays.
9321 !
9322 ! In a GCM this call should be placed in the model initialization
9323 ! area, since this has to be called only once.
9324 ! call rrtmg_sw_ini(cpdair)
9326 ! This is the main longitude/column loop in RRTMG.
9327 ! Modify to loop over all columns (nlon) or over daylight columns
9329 do iplon = 1, ncol
9331 ! Prepare atmosphere profile from GCM for use in RRTMG, and define
9332 ! other input parameters
9334 call inatm_sw (iplon, nlay, icld, iaer, &
9335 play, plev, tlay, tlev, tsfc, h2ovmr, &
9336 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
9337 adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
9338 cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
9339 reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
9340 nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
9341 adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
9342 ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
9343 taua, ssaa, asma)
9345 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
9346 ! input cloud physical properties. Select method based on choices described
9347 ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
9348 ! effective radius must be passed in cldprop. Cloud fraction and cloud
9349 ! optical properties are transferred to rrtmg_sw arrays in cldprop.
9351 call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
9352 ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
9353 taormc, taucmc, ssacmc, asmcmc, fsfcmc)
9354 icpr = 1
9356 ! Calculate coefficients for the temperature and pressure dependence of the
9357 ! molecular absorption coefficients by interpolating data from stored
9358 ! reference atmospheres.
9360 call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
9361 laytrop, layswtch, laylow, jp, jt, jt1, &
9362 co2mult, colch4, colco2, colh2o, colmol, coln2o, &
9363 colo2, colo3, fac00, fac01, fac10, fac11, &
9364 selffac, selffrac, indself, forfac, forfrac, indfor)
9367 ! Cosine of the solar zenith angle
9368 ! Prevent using value of zero; ideally, SW model is not called from host model when sun
9369 ! is below horizon
9371 cossza = coszen(iplon)
9372 if (cossza .le. zepzen) cossza = zepzen
9374 ! Transfer albedo, cloud and aerosol properties into arrays for 2-stream radiative transfer
9376 ! Surface albedo
9377 ! Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns
9378 do ib=1,9
9379 albdir(ib) = aldir(iplon)
9380 albdif(ib) = aldif(iplon)
9381 enddo
9382 albdir(nbndsw) = aldir(iplon)
9383 albdif(nbndsw) = aldif(iplon)
9384 ! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
9385 do ib=10,13
9386 albdir(ib) = asdir(iplon)
9387 albdif(ib) = asdif(iplon)
9388 enddo
9391 ! Clouds
9392 if (icld.eq.0) then
9394 zcldfmc(:,:) = 0._rb
9395 ztaucmc(:,:) = 0._rb
9396 ztaormc(:,:) = 0._rb
9397 zasycmc(:,:) = 0._rb
9398 zomgcmc(:,:) = 1._rb
9400 elseif (icld.ge.1) then
9401 do i=1,nlayers
9402 do ig=1,ngptsw
9403 zcldfmc(i,ig) = cldfmc(ig,i)
9404 ztaucmc(i,ig) = taucmc(ig,i)
9405 ztaormc(i,ig) = taormc(ig,i)
9406 zasycmc(i,ig) = asmcmc(ig,i)
9407 zomgcmc(i,ig) = ssacmc(ig,i)
9408 enddo
9409 enddo
9411 endif
9413 ! Aerosol
9414 ! IAER = 0: no aerosols
9415 if (iaer.eq.0) then
9417 ztaua(:,:) = 0._rb
9418 zasya(:,:) = 0._rb
9419 zomga(:,:) = 1._rb
9421 ! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details.
9422 ! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer),
9423 ! or set manually here for each aerosol and layer.
9424 elseif (iaer.eq.6) then
9426 ! do i = 1, nlayers
9427 ! do ia = 1, naerec
9428 ! ecaer(iplon,i,ia) = 1.0e-15_rb
9429 ! enddo
9430 ! enddo
9432 do i = 1, nlayers
9433 do ib = 1, nbndsw
9434 ztaua(i,ib) = 0._rb
9435 zasya(i,ib) = 0._rb
9436 zomga(i,ib) = 0._rb
9437 do ia = 1, naerec
9438 ztaua(i,ib) = ztaua(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia)
9439 zomga(i,ib) = zomga(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
9440 rsrpiza(ib,ia)
9441 zasya(i,ib) = zasya(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
9442 rsrpiza(ib,ia) * rsrasya(ib,ia)
9443 enddo
9444 if (zomga(i,ib) /= 0._rb) then
9445 zasya(i,ib) = zasya(i,ib) / zomga(i,ib)
9446 endif
9447 if (ztaua(i,ib) /= 0._rb) then
9448 zomga(i,ib) = zomga(i,ib) / ztaua(i,ib)
9449 endif
9450 enddo
9451 enddo
9453 ! IAER=10: Direct specification of aerosol optical properties from GCM
9454 elseif (iaer.eq.10) then
9456 do i = 1 ,nlayers
9457 do ib = 1 ,nbndsw
9458 ztaua(i,ib) = taua(i,ib)
9459 ztauacln(i,ib) = 0.0
9460 zasya(i,ib) = asma(i,ib)
9461 zomga(i,ib) = ssaa(i,ib)
9462 enddo
9463 enddo
9465 endif
9468 ! Call the 2-stream radiation transfer model
9470 do i=1,nlayers+1
9471 zbbcu(i) = 0._rb
9472 zbbcd(i) = 0._rb
9473 zbbfu(i) = 0._rb
9474 zbbfd(i) = 0._rb
9475 zbbcddir(i) = 0._rb
9476 zbbfddir(i) = 0._rb
9477 zuvcd(i) = 0._rb
9478 zuvfd(i) = 0._rb
9479 zuvcddir(i) = 0._rb
9480 zuvfddir(i) = 0._rb
9481 znicd(i) = 0._rb
9482 znifd(i) = 0._rb
9483 znicddir(i) = 0._rb
9484 znifddir(i) = 0._rb
9485 enddo
9487 call spcvmc_sw &
9488 (nlayers, istart, iend, icpr, iout, &
9489 pavel, tavel, pz, tz, tbound, albdif, albdir, &
9490 zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
9491 ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, &
9492 laytrop, layswtch, laylow, jp, jt, jt1, &
9493 co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
9494 fac00, fac01, fac10, fac11, &
9495 selffac, selffrac, indself, forfac, forfrac, indfor, &
9496 zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, &
9497 zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir)
9499 ! Transfer up and down, clear and total sky fluxes to output arrays.
9500 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
9502 do i = 1, nlayers+1
9503 swuflxc(iplon,i) = zbbcu(i)
9504 swdflxc(iplon,i) = zbbcd(i)
9505 swuflx(iplon,i) = zbbfu(i)
9506 swdflx(iplon,i) = zbbfd(i)
9507 uvdflx(i) = zuvfd(i)
9508 nidflx(i) = znifd(i)
9510 ! Direct/diffuse fluxes
9511 dirdflux(i) = zbbfddir(i)
9512 difdflux(i) = swdflx(iplon,i) - dirdflux(i)
9513 swdkdir(iplon,i) = dirdflux(i) ! all-sky direct flux jararias, 2013/08/10
9514 swdkdif(iplon,i) = difdflux(i) ! all-sky diffuse flux jararias, 2013/08/10
9515 swdkdirc(iplon,i) = zbbcddir(i) ! PAJ: clear-sky direct flux
9517 ! UV/visible direct/diffuse fluxes
9518 dirdnuv(i) = zuvfddir(i)
9519 difdnuv(i) = zuvfd(i) - dirdnuv(i)
9520 ! ------- Zhenxin add vis/uv downwards dir or dif here --!
9521 sibvisdir(iplon,i) = dirdnuv(i)
9522 sibvisdif(iplon,i) = difdnuv(i)
9523 ! ----- End of Zhenxin addition ------------!
9524 ! Near-IR direct/diffuse fluxes
9525 dirdnir(i) = znifddir(i)
9526 difdnir(i) = znifd(i) - dirdnir(i)
9527 ! ---------Zhenxin add nir downwards dir and dif here --!
9528 sibnirdir(iplon,i) = dirdnir(i)
9529 sibnirdif(iplon,i) = difdnir(i)
9530 ! -------- End of Zhenxin addition 2011-05 ---------!
9531 enddo
9533 ! Total and clear sky net fluxes
9534 do i = 1, nlayers+1
9535 swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i)
9536 swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i)
9537 enddo
9539 ! Total and clear sky heating rates
9540 do i = 1, nlayers
9541 zdpgcp = heatfac / pdp(i)
9542 swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp
9543 swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp
9544 enddo
9545 swhrc(iplon,nlayers) = 0._rb
9546 swhr(iplon,nlayers) = 0._rb
9548 #if (WRF_CHEM == 1)
9549 ! Repeat call to 2-stream radiation model using "clean sky"
9550 ! variables and aerosol tau set to 0
9551 if(calc_clean_atm_diag .gt. 0)then
9552 do i=1,nlayers+1
9553 zbbcu(i) = 0._rb
9554 zbbcd(i) = 0._rb
9555 zbbclnu(i) = 0._rb
9556 zbbclnd(i) = 0._rb
9557 zbbcddir(i) = 0._rb
9558 zbbclnddir(i) = 0._rb
9559 zuvcd(i) = 0._rb
9560 zuvclnd(i) = 0._rb
9561 zuvcddir(i) = 0._rb
9562 zuvclnddir(i) = 0._rb
9563 znicd(i) = 0._rb
9564 zniclnd(i) = 0._rb
9565 znicddir(i) = 0._rb
9566 zniclnddir(i) = 0._rb
9567 enddo
9569 call spcvmc_sw &
9570 (nlayers, istart, iend, icpr, iout, &
9571 pavel, tavel, pz, tz, tbound, albdif, albdir, &
9572 zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
9573 ztauacln, zasya, zomga, cossza, coldry, wkl, adjflux, &
9574 laytrop, layswtch, laylow, jp, jt, jt1, &
9575 co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
9576 fac00, fac01, fac10, fac11, &
9577 selffac, selffrac, indself, forfac, forfrac, indfor, &
9578 zbbclnd, zbbclnu, zbbcd, zbbcu, zuvclnd, zuvcd, zniclnd, znicd, &
9579 zbbclnddir, zbbcddir, zuvclnddir, zuvcddir, zniclnddir, znicddir)
9581 do i = 1, nlayers+1
9582 swuflxcln(iplon,i) = zbbclnu(i)
9583 swdflxcln(iplon,i) = zbbclnd(i)
9584 enddo
9585 else
9586 do i = 1, nlayers+1
9587 swuflxcln(iplon,i) = 0.0
9588 swdflxcln(iplon,i) = 0.0
9589 enddo
9590 end if
9592 #else
9593 do i = 1, nlayers+1
9594 swuflxcln(iplon,i) = 0.0
9595 swdflxcln(iplon,i) = 0.0
9596 enddo
9598 #endif
9599 ! End longitude loop
9600 enddo
9602 ! begin WRF-CMAQ twoway coupled model block
9603 sw_zbbcddir = zbbcddir(1)
9604 sw_dirdflux = dirdflux(1)
9605 sw_difdflux = difdflux(1)
9606 ! end WRF-CMAQ twoway coupled model block
9608 end subroutine rrtmg_sw
9610 !*************************************************************************
9611 real(kind=rb) function earth_sun(idn)
9612 !*************************************************************************
9613 !
9614 ! Purpose: Function to calculate the correction factor of Earth's orbit
9615 ! for current day of the year
9617 ! idn : Day of the year
9618 ! earth_sun : square of the ratio of mean to actual Earth-Sun distance
9620 ! ------- Modules -------
9622 use rrsw_con, only : pi
9624 integer(kind=im), intent(in) :: idn
9626 real(kind=rb) :: gamma
9628 gamma = 2._rb*pi*(idn-1)/365._rb
9630 ! Use Iqbal's equation 1.2.1
9632 earth_sun = 1.000110_rb + .034221_rb * cos(gamma) + .001289_rb * sin(gamma) + &
9633 .000719_rb * cos(2._rb*gamma) + .000077_rb * sin(2._rb*gamma)
9635 end function earth_sun
9637 !***************************************************************************
9638 subroutine inatm_sw (iplon, nlay, icld, iaer, &
9639 play, plev, tlay, tlev, tsfc, h2ovmr, &
9640 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
9641 adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
9642 cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
9643 reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
9644 nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
9645 adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
9646 ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
9647 taua, ssaa, asma)
9648 !***************************************************************************
9649 !
9650 ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
9651 ! Set other RRTMG_SW input parameters.
9652 !
9653 !***************************************************************************
9655 ! --------- Modules ----------
9657 use parrrsw, only : nbndsw, ngptsw, nstr, nmol, mxmol, &
9658 jpband, jpb1, jpb2, rrsw_scon
9659 use rrsw_con, only : heatfac, oneminus, pi, grav, avogad
9660 use rrsw_wvn, only : ng, nspa, nspb, wavenum1, wavenum2, delwave
9662 ! ------- Declarations -------
9664 ! ----- Input -----
9665 integer(kind=im), intent(in) :: iplon ! column loop index
9666 integer(kind=im), intent(in) :: nlay ! number of model layers
9667 integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag
9668 integer(kind=im), intent(in) :: iaer ! aerosol option flag
9670 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
9671 ! Dimensions: (ncol,nlay)
9672 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
9673 ! Dimensions: (ncol,nlay+1)
9674 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
9675 ! Dimensions: (ncol,nlay)
9676 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
9677 ! Dimensions: (ncol,nlay+1)
9678 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
9679 ! Dimensions: (ncol)
9680 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
9681 ! Dimensions: (ncol,nlay)
9682 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
9683 ! Dimensions: (ncol,nlay)
9684 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
9685 ! Dimensions: (ncol,nlay)
9686 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
9687 ! Dimensions: (ncol,nlay)
9688 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
9689 ! Dimensions: (ncol,nlay)
9690 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
9691 ! Dimensions: (ncol,nlay)
9693 integer(kind=im), intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
9694 ! distance if adjflx not provided)
9695 real(kind=rb), intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
9696 real(kind=rb), intent(in) :: scon ! Solar constant (W/m2)
9698 integer(kind=im), intent(in) :: inflgsw ! Flag for cloud optical properties
9699 integer(kind=im), intent(in) :: iceflgsw ! Flag for ice particle specification
9700 integer(kind=im), intent(in) :: liqflgsw ! Flag for liquid droplet specification
9702 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
9703 ! Dimensions: (ngptsw,ncol,nlay)
9704 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth (optional)
9705 ! Dimensions: (ngptsw,ncol,nlay)
9706 real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
9707 ! Dimensions: (ngptsw,ncol,nlay)
9708 real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
9709 ! Dimensions: (ngptsw,ncol,nlay)
9710 real(kind=rb), intent(in) :: fsfcmcl(:,:,:) ! In-cloud forward scattering fraction
9711 ! Dimensions: (ngptsw,ncol,nlay)
9712 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
9713 ! Dimensions: (ngptsw,ncol,nlay)
9714 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
9715 ! Dimensions: (ngptsw,ncol,nlay)
9716 real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
9717 ! Dimensions: (ngptsw,ncol,nlay)
9718 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns)
9719 ! Dimensions: (ncol,nlay)
9720 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
9721 ! Dimensions: (ncol,nlay)
9722 real(kind=rb), intent(in) :: resnmcl(:,:) ! Cloud snow effective radius (microns)
9723 ! Dimensions: (ncol,nlay)
9725 real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth
9726 ! Dimensions: (ncol,nlay,nbndsw)
9727 real(kind=rb), intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo
9728 ! Dimensions: (ncol,nlay,nbndsw)
9729 real(kind=rb), intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter
9730 ! Dimensions: (ncol,nlay,nbndsw)
9732 ! Atmosphere
9733 integer(kind=im), intent(out) :: nlayers ! number of layers
9735 real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb)
9736 ! Dimensions: (nlay)
9737 real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K)
9738 ! Dimensions: (nlay)
9739 real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb)
9740 ! Dimensions: (0:nlay)
9741 real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K)
9742 ! Dimensions: (0:nlay)
9743 real(kind=rb), intent(out) :: tbound ! surface temperature (K)
9744 real(kind=rb), intent(out) :: pdp(:) ! layer pressure thickness (hPa, mb)
9745 ! Dimensions: (nlay)
9746 real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2)
9747 ! Dimensions: (nlay)
9748 real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2)
9749 ! Dimensions: (mxmol,nlay)
9751 real(kind=rb), intent(out) :: adjflux(:) ! adjustment for current Earth/Sun distance
9752 ! Dimensions: (jpband)
9753 real(kind=rb), intent(out) :: solvar(:) ! solar constant scaling factor from rrtmg_sw
9754 ! Dimensions: (jpband)
9755 ! default value of 1368.22 Wm-2 at 1 AU
9756 real(kind=rb), intent(out) :: taua(:,:) ! Aerosol optical depth
9757 ! Dimensions: (nlay,nbndsw)
9758 real(kind=rb), intent(out) :: ssaa(:,:) ! Aerosol single scattering albedo
9759 ! Dimensions: (nlay,nbndsw)
9760 real(kind=rb), intent(out) :: asma(:,:) ! Aerosol asymmetry parameter
9761 ! Dimensions: (nlay,nbndsw)
9763 ! Atmosphere/clouds - cldprop
9764 integer(kind=im), intent(out) :: inflag ! flag for cloud property method
9765 integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties
9766 integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties
9768 real(kind=rb), intent(out) :: cldfmc(:,:) ! layer cloud fraction
9769 ! Dimensions: (ngptsw,nlay)
9770 real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth (non-delta scaled)
9771 ! Dimensions: (ngptsw,nlay)
9772 real(kind=rb), intent(out) :: ssacmc(:,:) ! in-cloud single scattering albedo (non-delta-scaled)
9773 ! Dimensions: (ngptsw,nlay)
9774 real(kind=rb), intent(out) :: asmcmc(:,:) ! in-cloud asymmetry parameter (non-delta scaled)
9775 ! Dimensions: (ngptsw,nlay)
9776 real(kind=rb), intent(out) :: fsfcmc(:,:) ! in-cloud forward scattering fraction (non-delta scaled)
9777 ! Dimensions: (ngptsw,nlay)
9778 real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path
9779 ! Dimensions: (ngptsw,nlay)
9780 real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path
9781 ! Dimensions: (ngptsw,nlay)
9782 real(kind=rb), intent(out) :: cswpmc(:,:) ! in-cloud snow path
9783 ! Dimensions: (ngptsw,nlay)
9784 real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns)
9785 ! Dimensions: (nlay)
9786 real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns)
9787 ! Dimensions: (nlay)
9788 real(kind=rb), intent(out) :: resnmc(:) ! snow particle effective size (microns)
9789 ! Dimensions: (nlay)
9791 ! ----- Local -----
9792 real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol)
9793 real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol)
9794 ! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol)
9795 ! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol)
9796 ! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol)
9797 ! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
9798 ! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
9800 ! Set molecular weight ratios (for converting mmr to vmr)
9801 ! e.g. h2ovmr = h2ommr * amdw)
9802 real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor
9803 real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide
9804 real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone
9805 real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane
9806 real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide
9807 real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
9809 real(kind=rb), parameter :: sbc = 5.67e-08_rb ! Stefan-Boltzmann constant (W/m2K4)
9811 integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices
9812 real(kind=rb) :: amm, summol !
9813 real(kind=rb) :: adjflx ! flux adjustment for Earth/Sun distance
9814 ! real(kind=rb) :: earth_sun ! function for Earth/Sun distance adjustment
9816 nlayers = nlay
9818 ! Initialize all molecular amounts to zero here, then pass input amounts
9819 ! into RRTM array WKL below.
9821 wkl(:,:) = 0.0_rb
9822 cldfmc(:,:) = 0.0_rb
9823 taucmc(:,:) = 0.0_rb
9824 ssacmc(:,:) = 1.0_rb
9825 asmcmc(:,:) = 0.0_rb
9826 fsfcmc(:,:) = 0.0_rb
9827 ciwpmc(:,:) = 0.0_rb
9828 clwpmc(:,:) = 0.0_rb
9829 cswpmc(:,:) = 0.0_rb
9830 reicmc(:) = 0.0_rb
9831 relqmc(:) = 0.0_rb
9832 resnmc(:) = 0.0_rb
9833 taua(:,:) = 0.0_rb
9834 ssaa(:,:) = 1.0_rb
9835 asma(:,:) = 0.0_rb
9837 ! Set flux adjustment for current Earth/Sun distance (two options).
9838 ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes);
9839 adjflx = adjes
9840 !
9841 ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year.
9842 ! (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU).
9843 if (dyofyr .gt. 0) then
9844 adjflx = earth_sun(dyofyr)
9845 endif
9847 ! Set incoming solar flux adjustment to include adjustment for
9848 ! current Earth/Sun distance (ADJFLX) and scaling of default internal
9849 ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR). SOLVAR can be set
9850 ! to a single scaling factor as needed, or to a different value in each
9851 ! band, which may be necessary for paleoclimate simulations.
9852 !
9853 do ib = jpb1,jpb2
9854 ! solvar(ib) = 1._rb
9855 solvar(ib) = scon / rrsw_scon
9856 adjflux(ib) = adjflx * solvar(ib)
9857 enddo
9859 ! Set surface temperature.
9860 tbound = tsfc(iplon)
9862 ! Install input GCM arrays into RRTMG_SW arrays for pressure, temperature,
9863 ! and molecular amounts.
9864 ! Pressures are input in mb, or are converted to mb here.
9865 ! Molecular amounts are input in volume mixing ratio, or are converted from
9866 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
9867 ! here. These are then converted to molecular amount (molec/cm2) below.
9868 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
9869 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
9870 ! correction to account for h2o in the layer. The molecular weight of moist
9871 ! air (amm) is calculated for each layer.
9872 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
9873 ! assumes GCM input fields are also bottom to top. Input layer indexing
9874 ! from GCM fields should be reversed here if necessary.
9876 pz(0) = plev(iplon,1)
9877 tz(0) = tlev(iplon,1)
9878 do l = 1, nlayers
9879 pavel(l) = play(iplon,l)
9880 tavel(l) = tlay(iplon,l)
9881 pz(l) = plev(iplon,l+1)
9882 tz(l) = tlev(iplon,l+1)
9883 pdp(l) = pz(l-1) - pz(l)
9884 ! For h2o input in vmr:
9885 wkl(1,l) = h2ovmr(iplon,l)
9886 ! For h2o input in mmr:
9887 ! wkl(1,l) = h2o(iplon,l)*amdw
9888 ! For h2o input in specific humidity;
9889 ! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
9890 wkl(2,l) = co2vmr(iplon,l)
9891 wkl(3,l) = o3vmr(iplon,l)
9892 wkl(4,l) = n2ovmr(iplon,l)
9893 wkl(6,l) = ch4vmr(iplon,l)
9894 wkl(7,l) = o2vmr(iplon,l)
9895 amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
9896 coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
9897 (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
9898 enddo
9900 ! The following section can be used to set values for an additional layer (from
9901 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
9902 ! Temperature and molecular amounts in the extra model layer are set to
9903 ! their values in the top GCM model layer, though these can be modified
9904 ! here if necessary.
9905 ! If this feature is utilized, increase nlayers by one above, limit the two
9906 ! loops above to (nlayers-1), and set the top most (nlayers) layer values here.
9908 ! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
9909 ! tavel(nlayers) = tavel(nlayers-1)
9910 ! pz(nlayers) = 1.e-4_rb
9911 ! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
9912 ! tz(nlayers) = tz(nlayers-1)
9913 ! pdp(nlayers) = pz(nlayers-1) - pz(nlayers)
9914 ! wkl(1,nlayers) = wkl(1,nlayers-1)
9915 ! wkl(2,nlayers) = wkl(2,nlayers-1)
9916 ! wkl(3,nlayers) = wkl(3,nlayers-1)
9917 ! wkl(4,nlayers) = wkl(4,nlayers-1)
9918 ! wkl(6,nlayers) = wkl(6,nlayers-1)
9919 ! wkl(7,nlayers) = wkl(7,nlayers-1)
9920 ! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
9921 ! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
9922 ! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
9924 ! At this point all molecular amounts in wkl are in volume mixing ratio;
9925 ! convert to molec/cm2 based on coldry for use in rrtm.
9927 do l = 1, nlayers
9928 do imol = 1, nmol
9929 wkl(imol,l) = coldry(l) * wkl(imol,l)
9930 enddo
9931 enddo
9933 ! Transfer aerosol optical properties to RRTM variables;
9934 ! modify to reverse layer indexing here if necessary.
9936 if (iaer .ge. 1) then
9937 do l = 1, nlayers
9938 do ib = 1, nbndsw
9939 taua(l,ib) = tauaer(iplon,l,ib)
9940 ssaa(l,ib) = ssaaer(iplon,l,ib)
9941 asma(l,ib) = asmaer(iplon,l,ib)
9942 enddo
9943 enddo
9944 endif
9946 ! Transfer cloud fraction and cloud optical properties to RRTM variables;
9947 ! modify to reverse layer indexing here if necessary.
9949 if (icld .ge. 1) then
9950 inflag = inflgsw
9951 iceflag = iceflgsw
9952 liqflag = liqflgsw
9954 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
9955 ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflgsw)
9957 do l = 1, nlayers
9958 do ig = 1, ngptsw
9959 cldfmc(ig,l) = cldfmcl(ig,iplon,l)
9960 taucmc(ig,l) = taucmcl(ig,iplon,l)
9961 ssacmc(ig,l) = ssacmcl(ig,iplon,l)
9962 asmcmc(ig,l) = asmcmcl(ig,iplon,l)
9963 fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
9964 ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
9965 clwpmc(ig,l) = clwpmcl(ig,iplon,l)
9966 if (iceflag.eq.5) then
9967 cswpmc(ig,l)=cswpmcl(ig,iplon,l)
9968 endif
9969 enddo
9970 reicmc(l) = reicmcl(iplon,l)
9971 relqmc(l) = relqmcl(iplon,l)
9972 if (iceflag.eq.5) then
9973 resnmc(l) = resnmcl(iplon,l)
9974 endif
9975 enddo
9977 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
9979 ! cldfmc(:,nlayers) = 0.0_rb
9980 ! taucmc(:,nlayers) = 0.0_rb
9981 ! ssacmc(:,nlayers) = 1.0_rb
9982 ! asmcmc(:,nlayers) = 0.0_rb
9983 ! fsfcmc(:,nlayers) = 0.0_rb
9984 ! ciwpmc(:,nlayers) = 0.0_rb
9985 ! clwpmc(:,nlayers) = 0.0_rb
9986 ! reicmc(nlayers) = 0.0_rb
9987 ! relqmc(nlayers) = 0.0_rb
9989 endif
9991 end subroutine inatm_sw
9993 end module rrtmg_sw_rad
9995 !------------------------------------------------------------------
9996 MODULE module_ra_rrtmg_sw
9998 use module_model_constants, only : cp
9999 USE module_wrf_error
10000 #if (HWRF == 1)
10001 USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF
10002 #else
10003 USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT
10004 #endif
10005 !USE module_dm
10007 use parrrsw, only : nbndsw, ngptsw, naerec
10008 use rrtmg_sw_init, only: rrtmg_sw_ini
10009 use rrtmg_sw_rad, only: rrtmg_sw
10010 use mcica_subcol_gen_sw, only: mcica_subcol_sw
10012 use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc, retab
10013 ! mcica_random_numbers, randomNumberSequence, &
10014 ! new_RandomNumberSequence, getRandomReal
10015 use module_ra_rrtmg_sw_cmaq
10017 CONTAINS
10019 !------------------------------------------------------------------
10020 SUBROUTINE RRTMG_SWRAD( &
10021 rthratensw, &
10022 rthratenswc, &
10023 swupt, swuptc, swuptcln, swdnt, swdntc, swdntcln, &
10024 swupb, swupbc, swupbcln, swdnb, swdnbc, swdnbcln, &
10025 ! swupflx, swupflxc, swdnflx, swdnflxc, &
10026 swcf, gsw, &
10027 xtime, gmt, xlat, xlong, &
10028 radt, degrad, declin, &
10029 coszr, julday, solcon, &
10030 albedo, t3d, t8w, tsk, &
10031 p3d, p8w, pi3d, rho3d, &
10032 dz8w, cldfra3d, lradius, iradius, &
10033 is_cammgmp_used, r, g, &
10034 re_cloud,re_ice,re_snow, &
10035 has_reqc,has_reqi,has_reqs, &
10036 icloud, warm_rain, &
10037 cldovrlp,idcor, & ! J. Henderson AER: cldovrlp namelist value
10038 f_ice_phy, f_rain_phy, &
10039 xland, xice, snow, &
10040 qv3d, qc3d, qr3d, &
10041 qi3d, qs3d, qg3d, &
10042 o3input, o33d, &
10043 aer_opt, aerod, no_src, &
10044 alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011)
10045 alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011)
10046 swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011)
10047 swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011)
10048 sf_surface_physics, & !Zhenxin
10049 f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
10050 tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
10051 gaer300,gaer400,gaer600,gaer999, & ! czhao
10052 waer300,waer400,waer600,waer999, & ! czhao
10053 aer_ra_feedback, &
10054 !jdfcz progn,prescribe, &
10055 progn,calc_clean_atm_diag, &
10056 qndrop3d,f_qndrop, & !czhao
10057 mp_physics, & !wang 2014/12
10058 ids,ide, jds,jde, kds,kde, &
10059 ims,ime, jms,jme, kms,kme, &
10060 its,ite, jts,jte, kts,kte, &
10061 swupflx, swupflxc, &
10062 swdnflx, swdnflxc, &
10063 tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11
10064 swddir, swddni, swddif, & ! jararias 2013/08
10065 swdownc, swddnic, swddirc, & ! PAJ
10066 xcoszen,yr,julian,ghg_input, & ! jararias 2013/08
10067 obscur, & ! amontornes-bcodina 2015/09 solar eclipses
10068 proceed_cmaq_sw, & ! WRF-CMAQ twoway coupled model
10069 nmode, & ! WRF-CMAQ twoway coupled model
10070 mass_ws_i, mass_ws_j, mass_ws_k, & ! WRF-CMAQ twoway coupled model
10071 mass_in_i, mass_in_j, mass_in_k, & ! WRF-CMAQ twoway coupled model
10072 mass_ec_i, mass_ec_j, mass_ec_k, & ! WRF-CMAQ twoway coupled model
10073 mass_ss_i, mass_ss_j, mass_ss_k, & ! WRF-CMAQ twoway coupled model
10074 mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! WRF-CMAQ twoway coupled model
10075 dgn_i, dgn_j, dgn_k, & ! WRF-CMAQ twoway coupled model
10076 sig_i, sig_j, sig_k, & ! WRF-CMAQ twoway coupled model
10077 gtauxar_01, gtauxar_02, gtauxar_03, & ! WRF-CMAQ twoway coupled model
10078 gtauxar_04, gtauxar_05, & ! WRF-CMAQ twoway coupled model
10079 asy_fac_01, asy_fac_02, asy_fac_03, & ! WRF-CMAQ twoway coupled model
10080 asy_fac_04, asy_fac_05, & ! WRF-CMAQ twoway coupled model
10081 ssa_01, ssa_02, ssa_03, & ! WRF-CMAQ twoway coupled model
10082 ssa_04, ssa_05 & ! WRF-CMAQ twoway coupled model
10083 ,sw_zbbcddir & ! WRF-CMAQ twoway coupled model
10084 ,sw_dirdflux & ! WRF-CMAQ twoway coupled model
10085 ,sw_difdflux & ! WRF-CMAQ twoway coupled model
10086 )
10087 !------------------------------------------------------------------
10088 USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
10089 IMPLICIT NONE
10090 !------------------------------------------------------------------
10091 LOGICAL, INTENT(IN ) :: warm_rain
10092 LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
10093 !
10094 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
10095 ims,ime, jms,jme, kms,kme, &
10096 its,ite, jts,jte, kts,kte
10098 INTEGER, INTENT(IN ) :: ICLOUD, GHG_INPUT
10099 INTEGER, INTENT(IN ) :: MP_PHYSICS
10100 !
10101 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
10102 INTENT(IN ) :: dz8w, &
10103 t3d, &
10104 t8w, &
10105 p3d, &
10106 p8w, &
10107 pi3d, &
10108 rho3d
10110 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
10111 INTENT(INOUT) :: RTHRATENSW, &
10112 RTHRATENSWC
10114 REAL, DIMENSION( ims:ime, jms:jme ) , &
10115 INTENT(INOUT) :: GSW, &
10116 SWCF, &
10117 COSZR
10119 INTEGER, INTENT(IN ) :: JULDAY
10120 REAL, INTENT(IN ) :: RADT,DEGRAD, &
10121 XTIME,DECLIN,SOLCON,GMT
10123 REAL, DIMENSION( ims:ime, jms:jme ) , &
10124 INTENT(IN ) :: XLAT, &
10125 XLONG, &
10126 XLAND, &
10127 XICE, &
10128 SNOW, &
10129 TSK, &
10130 ALBEDO
10131 !
10132 !!! ------------------- Zhenxin (2011-06/20) ------------------
10133 REAL, DIMENSION( ims:ime, jms:jme ) , &
10134 OPTIONAL , &
10135 INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw
10136 ALSWVISDIF, &
10137 ALSWNIRDIR, &
10138 ALSWNIRDIF
10140 REAL, DIMENSION( ims:ime, jms:jme ) , &
10141 OPTIONAL , &
10142 INTENT(OUT) :: SWVISDIR, &
10143 SWVISDIF, &
10144 SWNIRDIR, &
10145 SWNIRDIF ! ssib sw dir and diff rad
10146 INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para
10148 ! ----------------------- end Zhenxin --------------------------
10149 !
10151 ! ------------------------ jararias 2013/08/10 -----------------
10152 real, dimension(ims:ime,jms:jme), intent(out) :: &
10153 swddir, & ! All-sky broadband surface direct horiz irradiance
10154 swddni, & ! All-sky broadband surface direct normal irradiance
10155 swddif, & ! All-sky broadband surface diffuse irradiance
10156 swdownc, & ! Clear sky GHI
10157 swddnic, & ! Clear ski DNI
10158 swddirc ! Clear ski direct horizontal irradiance
10160 integer, intent(in) :: yr
10161 real, optional, intent(in) :: &
10162 julian ! julian day (1-366)
10163 real, dimension(ims:ime,jms:jme), intent(in) :: &
10164 xcoszen ! cosine of the solar zenith angle
10165 real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw
10166 ! ------------------------ jararias end snippet -----------------
10168 REAL, INTENT(IN ) :: R,G
10169 !
10170 ! Optional
10171 !
10172 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
10173 OPTIONAL , &
10174 INTENT(IN ) :: &
10175 CLDFRA3D, &
10176 LRADIUS, &
10177 IRADIUS, &
10178 QV3D, &
10179 QC3D, &
10180 QR3D, &
10181 QI3D, &
10182 QS3D, &
10183 QG3D, &
10184 QNDROP3D
10186 !..Added by G. Thompson to couple cloud physics effective radii.
10187 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
10188 RE_CLOUD, &
10189 RE_ICE, &
10190 RE_SNOW
10191 INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
10193 real pi,third,relconst,lwpmin,rhoh2o
10195 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
10196 OPTIONAL , &
10197 INTENT(IN ) :: &
10198 F_ICE_PHY, &
10199 F_RAIN_PHY
10201 LOGICAL, OPTIONAL, INTENT(IN) :: &
10202 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
10204 ! Optional
10205 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
10206 INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
10207 gaer300,gaer400,gaer600,gaer999, & ! czhao
10208 waer300,waer400,waer600,waer999 ! czhao
10210 INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
10211 !jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
10212 INTEGER, INTENT(IN ), OPTIONAL :: progn
10213 INTEGER, INTENT(IN ) :: calc_clean_atm_diag
10215 ! Ozone
10216 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
10217 OPTIONAL , &
10218 INTENT(IN ) :: O33D
10219 INTEGER, OPTIONAL, INTENT(IN ) :: o3input
10220 ! EC aerosol: no_src = naerec = 6
10221 INTEGER, INTENT(IN ) :: no_src
10222 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , &
10223 OPTIONAL , &
10224 INTENT(IN ) :: aerod
10225 INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
10227 !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
10228 real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
10229 data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
10230 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
10231 real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
10232 data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
10233 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
10234 real wavemid(nbndsw) ! Mid wavelength (um) of interval
10235 real, parameter :: thresh=1.e-9
10236 real ang,slope
10237 character(len=200) :: msg
10239 ! Top of atmosphere and surface shortwave fluxes (W m-2)
10240 REAL, DIMENSION( ims:ime, jms:jme ), &
10241 OPTIONAL, INTENT(INOUT) :: &
10242 SWUPT,SWUPTC,SWUPTCLN,SWDNT,SWDNTC,SWDNTCLN, &
10243 SWUPB,SWUPBC,SWUPBCLN,SWDNB,SWDNBC,SWDNBCLN
10245 ! Layer shortwave fluxes (including extra layer above model top)
10246 ! Vertical ordering is from bottom to top (W m-2)
10247 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
10248 OPTIONAL, INTENT(OUT) :: &
10249 SWUPFLX,SWUPFLXC, &
10250 SWDNFLX,SWDNFLXC
10252 ! amontornes-bcodina 2015/09 solar eclipses
10253 ! obscur --> degree of obscuration for solar eclipses prediction (2D)
10254 REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: obscur
10256 ! begin WRF-CMAQ twoway coupled model block
10257 LOGICAL, INTENT(IN) :: proceed_cmaq_sw
10259 ! ** FSB items needed for new aerosol code from CMAQ
10260 integer, optional, intent(in) :: nmode ! number of log-normal modes
10262 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: &
10263 mass_ws_i, mass_ws_j, mass_ws_k, & ! mass cocentrations in [ ug/m**3 ] for water
10264 ! soluble species in each mode
10265 mass_in_i, mass_in_j, mass_in_k, & ! mass cocentrations in [ ug/m**3 ] for water
10266 ! insoluble species in each mode
10267 mass_ec_i, mass_ec_j, mass_ec_k, & ! mass cocentrations in [ ug/m**3 ] for elemental
10268 ! carbon species in each mode
10269 mass_ss_i, mass_ss_j, mass_ss_k, & ! mass cocentrations in [ ug/m**3 ] for aerosol
10270 ! water species in each mode
10271 mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! mass cocentrations in [ ug/m**3 ] for sea
10272 ! salt species in each mode
10273 dgn_i, dgn_j, dgn_k, & ! geometric mean diameter of each mode [ m ]
10274 sig_i, sig_j, sig_k ! geometric standard deviation of each mode
10276 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(out) :: &
10277 gtauxar_01, & ! Aerosol optical depth of RRTMG SW band 11
10278 gtauxar_02, & ! Aerosol optical depth of RRTMG SW band 10
10279 gtauxar_03, & ! Aerosol optical depth of RRTMG SW band 9
10280 gtauxar_04, & ! Aerosol optical depth of RRTMG SW band 8
10281 gtauxar_05, & ! Aerosol optical depth of RRTMG SW band 7
10282 asy_fac_01, & ! asymmetry factor of RRTMG SW band 11
10283 asy_fac_02, & ! asymmetry factor of RRTMG SW band 10
10284 asy_fac_03, & ! asymmetry factor of RRTMG SW band 9
10285 asy_fac_04, & ! asymmetry factor of RRTMG SW band 8
10286 asy_fac_05, & ! asymmetry factor of RRTMG SW band 7
10287 ssa_01, & ! single scattering albedo of RRTMG SW band 11
10288 ssa_02, & ! single scattering albedo of RRTMG SW band 10
10289 ssa_03, & ! single scattering albedo of RRTMG SW band 9
10290 ssa_04, & ! single scattering albedo of RRTMG SW band 8
10291 ssa_05 ! single scattering albedo of RRTMG SW band 7
10293 REAL, DIMENSION( ims:ime, jms:jme ), optional, INTENT(OUT) :: &
10294 sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
10295 sw_dirdflux, & ! Direct downward shortwave surface flux
10296 sw_difdflux ! Diffuse downward shortwave surface flux
10297 ! end WRF-CMAQ twoway coupled model block
10299 ! LOCAL VARS
10301 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
10302 Tw1D
10304 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
10305 CLDFRA1D, &
10306 DZ1D, &
10307 P1D, &
10308 T1D, &
10309 QV1D, &
10310 QC1D, &
10311 QR1D, &
10312 QI1D, &
10313 RHO1D, &
10314 QS1D, &
10315 QG1D, &
10316 O31D, &
10317 qndrop1d
10319 !BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996)
10320 real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, &
10321 re_30C=1250.0/9.208, re_20C=1250.0/9.387
10323 ! Added local arrays for RRTMG
10324 integer :: ncol, &
10325 nlay, &
10326 icld, &
10327 cldovrlp, & ! J. Henderson AER
10328 idcor, &
10329 juldat, &
10330 inflgsw, &
10331 iceflgsw, &
10332 liqflgsw
10333 ! Latitude
10334 real :: lat
10336 ! Dimension with extra layer from model top to TOA
10337 real, dimension( 1, kts:kte+2 ) :: plev, &
10338 tlev
10339 real, dimension( 1, kts:kte+1 ) :: play, &
10340 tlay, &
10341 h2ovmr, &
10342 o3vmr, &
10343 co2vmr, &
10344 o2vmr, &
10345 ch4vmr, &
10346 n2ovmr
10347 real, dimension( kts:kte+1 ) :: o3mmr
10348 ! mji - Add height of each layer for exponential-random cloud overlap
10349 ! This will be derived below from the dz in each layer
10350 real, dimension( 1, kts:kte+1 ) :: hgt
10351 real :: dzsum
10352 ! Surface albedo (for UV/visible and near-IR spectral regions,
10353 ! and for direct and diffuse radiation)
10354 real, dimension( 1 ) :: asdir, &
10355 asdif, &
10356 aldir, &
10357 aldif
10358 ! Dimension with extra layer from model top to TOA,
10359 ! though no clouds are allowed in extra layer
10360 real, dimension( 1, kts:kte+1 ) :: clwpth, &
10361 ciwpth, &
10362 cswpth, &
10363 rel, &
10364 rei, &
10365 res, &
10366 cldfrac, &
10367 relqmcl, &
10368 reicmcl, &
10369 resnmcl
10370 real, dimension( nbndsw, 1, kts:kte+1 ) :: taucld, &
10371 ssacld, &
10372 asmcld, &
10373 fsfcld
10374 real, dimension( ngptsw, 1, kts:kte+1 ) :: cldfmcl, &
10375 clwpmcl, &
10376 ciwpmcl, &
10377 cswpmcl, &
10378 taucmcl, &
10379 ssacmcl, &
10380 asmcmcl, &
10381 fsfcmcl
10382 real, dimension( 1, kts:kte+1, nbndsw ) :: tauaer, &
10383 ssaaer, &
10384 asmaer
10385 real, dimension( 1, kts:kte+1, naerec ) :: ecaer
10387 ! Output arrays contain extra layer from model top to TOA
10388 real, dimension( 1, kts:kte+2 ) :: swuflx, &
10389 swdflx, &
10390 swuflxc, &
10391 swdflxc, &
10392 swuflxcln, &
10393 swdflxcln, &
10394 sibvisdir, & ! Zhenxin 2011-06-20
10395 sibvisdif, &
10396 sibnirdir, &
10397 sibnirdif ! Zhenxin 2011-06-20
10399 real, dimension( 1, kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10
10400 swdkdif, & ! jararias, 2013/08/10
10401 swdkdirc ! PAJ
10403 real, dimension( 1, kts:kte+1 ) :: swhr, &
10404 swhrc
10406 real, dimension ( 1 ) :: tsfc, &
10407 ps, &
10408 coszen
10409 real :: ro, &
10410 dz, &
10411 adjes, &
10412 scon, &
10413 snow_mass_factor
10414 integer :: dyofyr
10416 integer:: idx_rei
10417 real:: corr
10419 ! Using data from CAMtr_volume_mixing_ratio data file
10420 real(kind=8) :: co2, n2o, ch4, cfc11, cfc12
10421 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
10422 real :: o2
10423 data o2 / 0.209488 /
10425 integer :: iplon, irng, permuteseed
10426 integer :: nb
10428 ! For old lw cloud property specification
10429 ! Cloud and precipitation absorption coefficients
10430 ! real :: abcw,abice,abrn,absn
10431 ! data abcw /0.144/
10432 ! data abice /0.0735/
10433 ! data abrn /0.330e-3/
10434 ! data absn /2.34e-3/
10436 ! Molecular weights and ratios for converting mmr to vmr units
10437 ! real :: amd ! Effective molecular weight of dry air (g/mol)
10438 ! real :: amw ! Molecular weight of water vapor (g/mol)
10439 ! real :: amo ! Molecular weight of ozone (g/mol)
10440 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
10441 ! Atomic weights for conversion from mass to volume mixing ratios
10442 ! data amd / 28.9660 /
10443 ! data amw / 18.0160 /
10444 ! data amo / 47.9998 /
10445 ! data amo2 / 31.9999 /
10447 real :: amdw ! Molecular weight of dry air / water vapor
10448 real :: amdo ! Molecular weight of dry air / ozone
10449 real :: amdo2 ! Molecular weight of dry air / oxygen
10450 data amdw / 1.607793 /
10451 data amdo / 0.603461 /
10452 data amdo2 / 0.905190 /
10454 !!
10455 real, dimension(1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
10457 real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
10458 cliqwp, & ! in-cloud cloud liquid water path
10459 csnowp, & ! in-cloud snow water path
10460 reliq, & ! effective drop radius (microns)
10461 reice ! ice effective drop size (microns)
10462 real, dimension(1, 1:kte-kts+1):: recloud1d, &
10463 reice1d, &
10464 resnow1d
10465 real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3
10467 !
10468 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
10469 REAL :: FP
10471 ! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
10472 real :: coszrs ! Cosine of solar zenith angle for present latitude
10473 logical :: dorrsw ! Flag to allow shortwave calculation
10475 real, dimension (1) :: landfrac, landm, snowh, icefrac
10477 integer :: pcols, pver
10479 INTEGER :: i,j,K, na
10480 LOGICAL :: predicate
10482 REAL :: da, eot ! jararias, 14/08/2013
10484 ! begin WRF-CMAQ twoway coupled model block
10485 #if ( WRF_CMAQ == 1 )
10486 REAL, DIMENSION (3) :: INMASS_ws, & ! holds mass cocentrations in [ ug/m**3 ] for
10487 ! water soluble species in all three modes
10488 INMASS_in, & ! holds mass cocentrations in [ ug/m**3 ] for
10489 ! water insoluble species in all three modes
10490 INMASS_ec, & ! holds mass cocentrations in [ ug/m**3 ] for
10491 ! elemental carbon species in all three modes
10492 INMASS_ss, & ! holds mass cocentrations in [ ug/m**3 ] for
10493 ! aerosol water species in all three modes
10494 INMASS_h2o, & ! holds mass cocentrations in [ ug/m**3 ] for
10495 ! sea salt species in all three modes
10496 INDGN, & ! holds geometric mean diameter in all three modes
10497 INSIG ! holds geometric standard deviation in all three modes
10498 #endif
10499 REAL :: xtauaer, & ! temporary variable for Aerosol Optical Depth
10500 waer, & ! temporary variable for single scattering albedo
10501 gaer, & ! temporary variable for symmetry factor
10502 delta_z, & ! layer thickness
10503 loc_sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
10504 loc_sw_dirdflux, & ! Direct downward shortwave surface flux
10505 loc_sw_difdflux ! Diffuse downward shortwave surface flux
10507 INTEGER :: modes ! number of modes
10509 character (len = 50) :: mystr ! temporary character string
10510 ! end WRF-CMAQ twoway coupled model block
10512 CHARACTER(LEN=256) :: message
10513 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
10515 !------------------------------------------------------------------
10516 #if ( WRF_CHEM == 1 )
10517 IF ( aer_ra_feedback == 1) then
10518 IF ( .NOT. &
10519 ( PRESENT(tauaer300) .AND. &
10520 PRESENT(tauaer400) .AND. &
10521 PRESENT(tauaer600) .AND. &
10522 PRESENT(tauaer999) .AND. &
10523 PRESENT(gaer300) .AND. &
10524 PRESENT(gaer400) .AND. &
10525 PRESENT(gaer600) .AND. &
10526 PRESENT(gaer999) .AND. &
10527 PRESENT(waer300) .AND. &
10528 PRESENT(waer400) .AND. &
10529 PRESENT(waer600) .AND. &
10530 PRESENT(waer999) ) ) THEN
10531 CALL wrf_error_fatal &
10532 ('Warning: missing fields required for aerosol radiation' )
10533 ENDIF
10534 ENDIF
10535 #endif
10537 !-----CALCULATE SHORT WAVE RADIATION
10538 !
10539 ! Read time-varying trace gases concentrations and interpolate them to run date
10540 IF ( GHG_INPUT .EQ. 1 ) THEN
10541 CALL read_CAMgases(yr,julian,.false.,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
10542 IF ( wrf_dm_on_monitor() ) THEN
10543 WRITE(message,*)'RRTMG SW CLWRF interpolated GHG values year:',yr,' julian day:',julian
10544 call wrf_debug( 1, message)
10545 WRITE(message,*)' co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12
10546 call wrf_debug( 1, message)
10547 END IF
10548 ELSE
10549 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
10550 ! Annual function for co2 in WRF v4.2
10551 co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
10552 ! co2 = 379.e-6
10553 ch4 = 1774.e-9
10554 n2o = 319.e-9
10555 END IF
10557 ! All fields are ordered vertically from bottom to top
10558 ! Pressures are in mb
10560 ! latitude loop
10561 j_loop: do j = jts,jte
10563 ! longitude loop
10564 i_loop: do i = its,ite
10565 rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized
10566 !
10567 ! Do shortwave by default, deactivate below if sun below horizon
10568 dorrsw = .true.
10570 ! Cosine solar zenith angle for current time step
10571 !
10572 ! jararias, 14/08/2013
10573 coszr(i,j)=xcoszen(i,j)
10574 coszrs=xcoszen(i,j)
10576 ! Set flag to prevent shortwave calculation when sun below horizon
10577 if (coszrs.le.0.0) dorrsw = .false.
10578 ! Perform shortwave calculation if sun above horizon
10579 if (dorrsw) then
10581 do k=kts,kte+1
10582 Pw1D(K) = p8w(I,K,J)/100.
10583 Tw1D(K) = t8w(I,K,J)
10584 enddo
10586 DO K=kts,kte
10587 QV1D(K)=0.
10588 QC1D(K)=0.
10589 QR1D(K)=0.
10590 QI1D(K)=0.
10591 QS1D(K)=0.
10592 CLDFRA1D(k)=0.
10593 QNDROP1D(k)=0.
10594 ENDDO
10596 DO K=kts,kte
10597 QV1D(K)=QV3D(I,K,J)
10598 QV1D(K)=max(0.,QV1D(K))
10599 ENDDO
10601 IF (PRESENT(O33D)) THEN
10602 DO K=kts,kte
10603 O31D(K)=O33D(I,K,J)
10604 ENDDO
10605 ELSE
10606 DO K=kts,kte
10607 O31D(K)=0.0
10608 ENDDO
10609 ENDIF
10611 DO K=kts,kte
10612 TTEN1D(K)=0.
10613 T1D(K)=t3d(I,K,J)
10614 P1D(K)=p3d(I,K,J)/100.
10615 DZ1D(K)=dz8w(I,K,J)
10616 ENDDO
10618 ! moist variables
10620 IF (ICLOUD .ne. 0) THEN
10621 IF ( PRESENT( CLDFRA3D ) ) THEN
10622 DO K=kts,kte
10623 CLDFRA1D(k)=CLDFRA3D(I,K,J)
10624 ENDDO
10625 ENDIF
10627 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
10628 IF ( F_QC) THEN
10629 DO K=kts,kte
10630 QC1D(K)=QC3D(I,K,J)
10631 QC1D(K)=max(0.,QC1D(K))
10632 ENDDO
10633 ENDIF
10634 ENDIF
10636 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
10637 IF ( F_QR) THEN
10638 DO K=kts,kte
10639 QR1D(K)=QR3D(I,K,J)
10640 QR1D(K)=max(0.,QR1D(K))
10641 ENDDO
10642 ENDIF
10643 ENDIF
10645 IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
10646 IF (F_QNDROP) THEN
10647 DO K=kts,kte
10648 qndrop1d(K)=qndrop3d(I,K,J)
10649 ENDDO
10650 ENDIF
10651 ENDIF
10653 ! This logic is tortured because cannot test F_QI unless
10654 ! it is present, and order of evaluation of expressions
10655 ! is not specified in Fortran
10657 IF ( PRESENT ( F_QI ) ) THEN
10658 predicate = F_QI
10659 ELSE
10660 predicate = .FALSE.
10661 ENDIF
10663 ! For MP option 3
10664 IF (.NOT. predicate .and. .not. warm_rain) THEN
10665 DO K=kts,kte
10666 IF (T1D(K) .lt. 273.15) THEN
10667 QI1D(K)=QC1D(K)
10668 QS1D(K)=QR1D(K)
10669 QC1D(K)=0.
10670 QR1D(K)=0.
10671 ENDIF
10672 ENDDO
10673 ENDIF
10675 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
10676 IF (F_QI) THEN
10677 DO K=kts,kte
10678 QI1D(K)=QI3D(I,K,J)
10679 QI1D(K)=max(0.,QI1D(K))
10680 ENDDO
10681 ENDIF
10682 ENDIF
10684 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
10685 IF (F_QS) THEN
10686 DO K=kts,kte
10687 QS1D(K)=QS3D(I,K,J)
10688 QS1D(K)=max(0.,QS1D(K))
10689 ENDDO
10690 ENDIF
10691 ENDIF
10693 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
10694 IF (F_QG) THEN
10695 DO K=kts,kte
10696 QG1D(K)=QG3D(I,K,J)
10697 QG1D(K)=max(0.,QG1D(K))
10698 ENDDO
10699 ENDIF
10700 ENDIF
10702 ! mji - For MP option 5
10703 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
10704 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
10705 DO K=kts,kte
10706 qi1d(k) = 0.1*qs3d(i,k,j)
10707 qs1d(k) = 0.9*qs3d(i,k,j)
10708 qc1d(k) = qc3d(i,k,j)
10709 qi1d(k) = max(0.,qi1d(k))
10710 qc1d(k) = max(0.,qc1d(k))
10711 ENDDO
10712 ENDIF
10713 ENDIF
10715 ENDIF
10716 ! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires
10717 ! scheme), QI3D saves all frozen water (ice+snow)
10718 #if (HWRF == 1)
10719 IF ( mp_physics == FER_MP_HIRES .OR. &
10720 mp_physics == FER_MP_HIRES_ADVECT .OR. &
10721 mp_physics == ETAMP_HWRF ) THEN
10722 #else
10723 IF ( mp_physics == FER_MP_HIRES .OR. &
10724 mp_physics == FER_MP_HIRES_ADVECT) THEN
10725 #endif
10726 DO K=kts,kte
10727 qi1d(k) = qi3d(i,k,j)
10728 qs1d(k) = 0.0
10729 qc1d(k) = qc3d(i,k,j)
10730 qi1d(k) = max(0.,qi1d(k))
10731 qc1d(k) = max(0.,qc1d(k))
10732 ENDDO
10733 ENDIF
10734 !
10735 ! EMISS0=EMISS(I,J)
10736 ! GLW0=0.
10737 ! OLR0=0.
10738 ! TSFC=TSK(I,J)
10739 DO K=kts,kte
10740 QV1D(K)=AMAX1(QV1D(K),1.E-12)
10741 ENDDO
10743 ! Set up input for shortwave
10744 ncol = 1
10745 ! Add extra layer from top of model to top of atmosphere
10746 nlay = (kte - kts + 1) + 1
10748 ! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random
10749 icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld
10750 ! Set julian date
10751 juldat = julian
10753 ! Select cloud liquid and ice optics parameterization options
10754 ! For passing in cloud optical properties directly:
10755 ! inflgsw = 0
10756 ! iceflgsw = 0
10757 ! liqflgsw = 0
10758 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
10759 inflgsw = 2
10760 iceflgsw = 3
10761 liqflgsw = 1
10763 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
10764 IF (ICLOUD .ne. 0) THEN
10765 IF ( has_reqc .ne. 0) THEN
10766 inflgsw = 3
10767 DO K=kts,kte
10768 recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
10769 if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
10770 & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
10771 recloud1D(ncol,K) = 10.5
10772 elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
10773 & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
10774 recloud1D(ncol,K) = 7.5
10775 endif
10776 ENDDO
10777 ELSE
10778 DO K=kts,kte
10779 #if (EM_CORE==1)
10780 recloud1D(ncol,K) = 5.0
10781 #else
10782 recloud1D(ncol,K) = 10.0 ! was 5.0
10783 #endif
10784 ENDDO
10785 ENDIF
10787 IF ( has_reqi .ne. 0) THEN
10788 inflgsw = 4
10789 iceflgsw = 4
10790 DO K=kts,kte
10791 reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6)
10792 if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
10793 idx_rei = int(t3d(i,k,j)-179.)
10794 idx_rei = min(max(idx_rei,1),75)
10795 corr = t3d(i,k,j) - int(t3d(i,k,j))
10796 reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + &
10797 & retab(idx_rei+1)*corr
10798 reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0)
10799 endif
10800 ENDDO
10801 ELSE
10802 DO K=kts,kte
10803 reice1D(ncol,K) = 10.
10804 ENDDO
10805 ENDIF
10807 IF ( has_reqs .ne. 0) THEN
10808 inflgsw = 5
10809 iceflgsw = 5
10810 DO K=kts,kte
10811 resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
10812 ENDDO
10813 ELSE
10814 DO K=kts,kte
10815 #if (EM_CORE==1)
10816 resnow1D(ncol,K) = 10.0
10817 #else
10818 tem2 = 25.0 !- was 10.0
10819 tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3)
10820 if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3
10821 tem1=t1d(k)-273.15
10822 if (tem1 < -50.0) then
10823 tem2 = re_50C*tem3**0.109
10824 elseif (tem1 < -40.0) then
10825 tem2 = re_40C*tem3**0.08
10826 elseif (tem1 < -30.0) then
10827 tem2 = re_30C*tem3**0.055
10828 else
10829 tem2 = re_20C*tem3**0.031
10830 endif
10831 tem2 = max(25.,tem2)
10832 endif
10833 reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns
10834 #endif
10835 ENDDO
10836 ENDIF
10838 ! special case for P3 microphysics
10839 ! put ice into snow category for optics, then set ice to zero
10840 IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
10841 inflgsw = 5
10842 iceflgsw = 5
10843 DO K=kts,kte
10844 resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
10845 QS1D(K)=QI3D(I,K,J)
10846 QI1D(K)=0.
10847 reice1D(ncol,K)=10.
10848 END DO
10850 END IF
10852 ENDIF
10854 ! Set cosine of solar zenith angle
10855 coszen(ncol) = coszrs
10856 ! Set solar constant (original) amontornes-bcodina 2015/09
10857 ! scon = solcon
10858 ! amontornes-bcodina 2015/09 solar eclipses
10859 scon = solcon*(1-obscur(i,j))
10861 ! For Earth/Sun distance adjustment in RRTMG
10862 ! dyofyr = julday
10863 ! adjes = 0.0
10864 ! For WRF, solar constant is already provided with eccentricity adjustment,
10865 ! so do not do this in RRTMG
10866 dyofyr = 0
10867 adjes = 1.0
10869 ! Layer indexing goes bottom to top here for all fields.
10870 ! Water vapor and ozone are converted from mmr to vmr.
10871 ! Pressures are in units of mb here.
10872 plev(ncol,1) = pw1d(1)
10873 tlev(ncol,1) = tw1d(1)
10874 tsfc(ncol) = tsk(i,j)
10875 do k = kts, kte
10876 play(ncol,k) = p1d(k)
10877 plev(ncol,k+1) = pw1d(k+1)
10878 pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
10879 tlay(ncol,k) = t1d(k)
10880 tlev(ncol,k+1) = tw1d(k+1)
10881 h2ovmr(ncol,k) = qv1d(k) * amdw
10882 co2vmr(ncol,k) = co2
10883 o2vmr(ncol,k) = o2
10884 ch4vmr(ncol,k) = ch4
10885 n2ovmr(ncol,k) = n2o
10886 enddo
10888 ! mji - Derive height of each layer mid-point from layer thickness.
10889 ! Needed for exponential (icld=4) and exponential-random overlap option (icld=5) only.
10890 dzsum = 0.0
10891 do k = kts, kte
10892 dz = dz1d(k)
10893 hgt(ncol,k) = dzsum + 0.5*dz
10894 dzsum = dzsum + dz
10895 enddo
10897 ! Define profile values for extra layer from model top to top of atmosphere.
10898 ! The top layer temperature for all gridpoints is set to the top layer-1
10899 ! temperature plus a constant (0 K) that represents an isothermal layer
10900 ! above ptop. Top layer interface temperatures are linearly interpolated
10901 ! from the layer temperatures.
10903 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
10904 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
10905 plev(ncol,kte+2) = 1.0e-5
10906 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10907 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10908 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
10909 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10910 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
10911 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
10912 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
10914 ! mji - Fill in height array above model top to top of atmosphere using
10915 ! dz from model top layer for completeness, though this information is not
10916 ! likely to be used by the exponential-random cloud overlap method.
10917 hgt(ncol,kte+1) = dzsum + 0.5*dz
10919 ! Get ozone profile including amount in extra layer above model top
10920 call inirad (o3mmr,plev,kts,kte)
10922 if(present(o33d)) then
10923 do k = kts, kte+1
10924 o3vmr(ncol,k) = o3mmr(k) * amdo
10925 IF ( PRESENT( O33D ) ) THEN
10926 if(o3input .eq. 2)then
10927 if(k.le.kte)then
10928 o3vmr(ncol,k) = o31d(k)
10929 else
10930 ! apply shifted climatology profile above model top
10931 o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
10932 if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
10933 endif
10934 endif
10935 ENDIF
10936 enddo
10937 else
10938 do k = kts, kte+1
10939 o3vmr(ncol,k) = o3mmr(k) * amdo
10940 enddo
10941 endif
10943 ! Set surface albedo for direct and diffuse radiation in UV/visible and
10944 ! near-IR spectral regions
10945 ! -------------- Zhenxin 2011-06-20 ----------- !
10947 ! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
10948 ! asdir(ncol) = albedo(i,j)
10949 ! asdif(ncol) = albedo(i,j)
10950 ! aldir(ncol) = albedo(i,j)
10951 ! aldif(ncol) = albedo(i,j)
10952 ! ------- End of Comments ------ !
10954 ! ------- 2. New Addiation ------ !
10955 IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
10956 asdir(ncol) = ALSWVISDIR(I,J)
10957 asdif(ncol) = ALSWVISDIF(I,J)
10958 aldir(ncol) = ALSWNIRDIR(I,J)
10959 aldif(ncol) = ALSWNIRDIF(I,J)
10960 ELSE
10961 asdir(ncol) = albedo(i,j)
10962 asdif(ncol) = albedo(i,j)
10963 aldir(ncol) = albedo(i,j)
10964 aldif(ncol) = albedo(i,j)
10965 ENDIF
10967 ! ---------- End of Addiation ------!
10968 ! ---------- End of fds_Zhenxin 2011-06-20 --------------!
10970 ! Define cloud optical properties for radiation (inflgsw = 0)
10971 ! This option is not currently active
10972 ! Cloud and precipitation paths in g/m2
10973 ! qi=0 if no ice phase
10974 ! qs=0 if no ice phase
10975 if (inflgsw .eq. 0) then
10977 ! Set cloud fraction and cloud optical properties here; not yet active
10978 do k = kts, kte
10979 cldfrac(ncol,k) = cldfra1d(k)
10980 do nb = 1, nbndsw
10981 taucld(nb,ncol,k) = 0.0
10982 ssacld(nb,ncol,k) = 1.0
10983 asmcld(nb,ncol,k) = 0.0
10984 fsfcld(nb,ncol,k) = 0.0
10985 enddo
10986 enddo
10988 ! Zero out cloud physical property arrays; not used when passing optical properties
10989 ! into radiation
10990 do k = kts, kte
10991 clwpth(ncol,k) = 0.0
10992 ciwpth(ncol,k) = 0.0
10993 rel(ncol,k) = 10.0
10994 rei(ncol,k) = 10.
10995 enddo
10996 endif
10998 ! Define cloud physical properties for radiation (inflgsw = 1 or 2)
10999 ! Cloud fraction
11000 ! Set cloud arrays if passing cloud physical properties into radiation
11001 if (inflgsw .gt. 0) then
11002 do k = kts, kte
11003 cldfrac(ncol,k) = cldfra1d(k)
11004 enddo
11006 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
11007 pcols = ncol
11008 pver = kte - kts + 1
11009 gravmks = g
11010 landfrac(ncol) = 2.-XLAND(I,J)
11011 landm(ncol) = landfrac(ncol)
11012 snowh(ncol) = 0.001*SNOW(I,J)
11013 icefrac(ncol) = XICE(I,J)
11015 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
11016 ! pdel is in mb here; convert back to Pa (*100.)
11017 ! Water paths are in units of g/m2
11018 ! snow added as ice cloud (JD 091022)
11019 do k = kts, kte
11020 gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
11021 gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
11022 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
11023 cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
11024 end do
11026 ! Mukul
11027 !..The ice water path is already sum of cloud ice and snow, but when we have explicit
11028 !.. ice effective radius, overwrite the ice path with only the cloud ice variable,
11029 !.. leaving out the snow for its own effect.
11030 if(iceflgsw.ge.4)then
11031 do k = kts, kte
11032 gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
11033 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
11034 end do
11035 end if
11037 !..Here the snow path is adjusted if (radiation) effective radius of snow is
11038 !.. larger than what we currently have in the lookup tables. Since mass goes
11039 !.. rather close to diameter squared, adjust the mixing ratio of snow used
11040 !.. to compute its water path in combination with the max diameter. Not a
11041 !.. perfect fix, but certainly better than using all snow mass when diameter is
11042 !.. far larger than table currently contains and crystal sizes much larger than
11043 !.. about 140 microns have lesser impact than those much smaller sizes.
11045 if(iceflgsw.eq.5)then
11046 do k = kts, kte
11047 snow_mass_factor = 0.99 ! Assume 1% of snow overlaps the cloud ice category
11048 gicewp = gicewp + (qs1d(k)*(1.0-snow_mass_factor) * pdel(ncol,k)*100.0 / gravmks * 1000.0)
11049 if (resnow1d(ncol,k) .gt. 130.)then
11050 snow_mass_factor = MIN(snow_mass_factor, &
11051 & (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)))
11052 resnow1d(ncol,k) = 130.0
11053 endif
11054 gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
11055 csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
11056 end do
11057 end if
11060 !link the aerosol feedback to cloud -czhao
11061 if( PRESENT( progn ) ) then
11062 if (progn == 1) then
11063 !jdfcz if(prescribe==0) then
11065 pi = 4.*atan(1.0)
11066 third=1./3.
11067 rhoh2o=1.e3
11068 relconst=3/(4.*pi*rhoh2o)
11069 ! minimun liquid water path to calculate rel
11070 ! corresponds to optical depth of 1.e-3 for radius 4 microns.
11071 lwpmin=3.e-5
11072 do k = kts, kte
11073 reliq(ncol,k) = 10.
11074 if( PRESENT( F_QNDROP ) ) then
11075 if( F_QNDROP ) then
11076 if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
11077 qndrop1d(k).gt.1000. ) then
11078 reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
11079 ! apply scaling from Martin et al., JAS 51, 1830.
11080 reliq(ncol,k)=1.1*reliq(ncol,k)
11081 reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
11082 reliq(ncol,k)=max(reliq(ncol,k),4.)
11083 reliq(ncol,k)=min(reliq(ncol,k),20.)
11084 end if
11085 end if
11086 end if
11087 end do
11088 !jdfcz else ! prescribe
11089 ! following Kiehl
11090 ! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11091 ! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
11092 !jdfcz endif
11093 else ! progn (progn=1)
11094 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11095 endif
11096 else !progn (PRESENT)
11097 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11098 endif
11100 ! following Kristjansson and Mitchell
11101 call reicalc(ncol, pcols, pver, tlay, reice)
11105 !..If we already have effective radius of cloud and ice, then just overwrite what
11106 !.. was computed in the relcalc and reicalc subroutines above.
11108 if (inflgsw .ge. 3) then
11109 do k = kts, kte
11110 reliq(ncol,k) = recloud1d(ncol,k)
11111 end do
11112 endif
11113 #if (EM_CORE==1)
11114 if (iceflgsw .ge. 4) then
11115 #else
11116 if (iceflgsw .ge. 3) then !BSF: was .ge. 4
11117 #endif
11118 do k = kts, kte
11119 reice(ncol,k) = reice1d(ncol,k)
11120 end do
11121 endif
11124 #if 0
11125 if (i==80.and.j==30) then
11126 #if defined( DM_PARALLEL ) && ! defined( STUBMPI)
11127 if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
11128 write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
11129 write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
11130 #endif
11131 endif
11132 #endif
11135 ! Limit upper bound of reice for Fu ice parameterization and convert
11136 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
11137 if (iceflgsw .eq. 3) then
11138 do k = kts, kte
11139 reice(ncol,k) = reice(ncol,k) * 1.0315
11140 reice(ncol,k) = min(140.0,reice(ncol,k))
11141 end do
11142 endif
11144 !if CAMMGMP is used, use output from CAMMGMP
11145 !PMA
11146 if(is_CAMMGMP_used) then
11147 do k = kts, kte
11148 if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
11149 reice(ncol,k) = iradius(i,k,j)
11150 else
11151 reice(ncol,k) = 25.
11152 end if
11153 reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
11154 if ( qc1d(k) .gt. 1.e-20) then
11155 reliq(ncol,k) = lradius(i,k,j)
11156 else
11157 reliq(ncol,k) = 10.
11158 end if
11159 reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
11160 enddo
11161 endif
11163 ! Set cloud physical property arrays
11164 do k = kts, kte
11165 clwpth(ncol,k) = cliqwp(ncol,k)
11166 ciwpth(ncol,k) = cicewp(ncol,k)
11167 rel(ncol,k) = reliq(ncol,k)
11168 rei(ncol,k) = reice(ncol,k)
11169 enddo
11171 !Mukul
11172 if (inflgsw .eq. 5) then
11173 do k = kts, kte
11174 cswpth(ncol,k) = csnowp(ncol,k)
11175 res(ncol,k) = resnow1d(ncol,k)
11176 end do
11177 else
11178 do k = kts, kte
11179 cswpth(ncol,k) = 0.0
11180 res(ncol,k) = 10.0
11181 end do
11182 endif
11184 ! Zero out cloud optical properties here, calculated in radiation
11185 do k = kts, kte
11186 do nb = 1, nbndsw
11187 taucld(nb,ncol,k) = 0.0
11188 ssacld(nb,ncol,k) = 1.0
11189 asmcld(nb,ncol,k) = 0.0
11190 fsfcld(nb,ncol,k) = 0.0
11191 enddo
11192 enddo
11193 endif
11195 ! No clouds are allowed in the extra layer from model top to TOA
11196 clwpth(ncol,kte+1) = 0.
11197 ciwpth(ncol,kte+1) = 0.
11198 cswpth(ncol,kte+1) = 0.
11199 rel(ncol,kte+1) = 10.
11200 rei(ncol,kte+1) = 10.
11201 res(ncol,kte+1) = 10.
11202 cldfrac(ncol,kte+1) = 0.
11203 do nb = 1, nbndsw
11204 taucld(nb,ncol,kte+1) = 0.
11205 ssacld(nb,ncol,kte+1) = 1.
11206 asmcld(nb,ncol,kte+1) = 0.
11207 fsfcld(nb,ncol,kte+1) = 0.
11208 enddo
11210 iplon = 1
11211 irng = 0
11212 permuteseed = 1
11214 ! Sub-column generator for McICA
11215 lat = XLAT(i,j) !retrieve scalar latitude for column calculation
11216 call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
11217 cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
11218 hgt, idcor, juldat, lat, &
11219 cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
11220 taucmcl, ssacmcl, asmcmcl, fsfcmcl)
11223 !--------------------------------------------------------------------------
11224 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
11225 !--------------------------------------------------------------------------
11226 ! by layer for each RRTMG shortwave band
11227 ! No aerosols in top layer above model top (kte+1).
11228 !cz do nb = 1, nbndsw
11229 !cz do k = kts, kte+1
11230 !cz tauaer(ncol,k,nb) = 0.
11231 !cz ssaaer(ncol,k,nb) = 1.
11232 !cz asmaer(ncol,k,nb) = 0.
11233 !cz enddo
11234 !cz enddo
11236 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
11237 !
11238 #if ( WRF_CMAQ == 1 )
11239 do nb = 1, nbndsw
11240 do k = kts,kte+1
11241 tauaer(ncol,k,nb) = 0.
11242 ssaaer(ncol,k,nb) = 1.
11243 asmaer(ncol,k,nb) = 0.
11245 if (proceed_cmaq_sw) then
11246 INMASS_ws(1) = mass_ws_i(i,k,j)
11247 INMASS_ws(2) = mass_ws_j(i,k,j)
11248 INMASS_ws(3) = mass_ws_k(i,k,j)
11249 INMASS_in(1) = mass_in_i(i,k,j)
11250 INMASS_in(2) = mass_in_j(i,k,j)
11251 INMASS_in(3) = mass_in_k(i,k,j)
11252 INMASS_ec(1) = mass_ec_i(i,k,j)
11253 INMASS_ec(2) = mass_ec_j(i,k,j)
11254 INMASS_ec(3) = mass_ec_k(i,k,j)
11255 INMASS_ss(1) = mass_ss_i(i,k,j)
11256 INMASS_ss(2) = mass_ss_j(i,k,j)
11257 INMASS_ss(3) = mass_ss_k(i,k,j)
11258 INMASS_h2o(1) = mass_h2o_i(i,k,j)
11259 INMASS_h2o(2) = mass_h2o_j(i,k,j)
11260 INMASS_h2o(3) = mass_h2o_k(i,k,j)
11261 INDGN(1) = dgn_i(i,k,j)
11262 INDGN(2) = dgn_j(i,k,j)
11263 INDGN(3) = dgn_k(i,k,j)
11264 INSIG(1) = sig_i(i,k,j)
11265 INSIG(2) = sig_j(i,k,j)
11266 INSIG(3) = sig_k(i,k,j)
11268 delta_z = dz8w(i,k,j)
11270 call get_aerosol_Optics_RRTMG_SW( nb,nmode,delta_z, &
11271 INMASS_ws, INMASS_in, INMASS_ec, INMASS_ss, &
11272 INMASS_h2o, INDGN, INSIG, &
11273 xtauaer, waer, gaer )
11275 write (mystr, *) xtauaer
11276 if (trim(mystr) == ' NaN') then
11277 write (6, '(a13, 2i5)') ' ==d== ', nb, nmode
11278 write (6, '(a13, 5e18.10)') ' ==d== delta ', delta_z
11279 write (6, '(a13, 5e18.10)') ' ==d== ws ', INMASS_ws
11280 write (6, '(a13, 5e18.10)') ' ==d== in ', INMASS_in
11281 write (6, '(a13, 5e18.10)') ' ==d== ec ', INMASS_ec
11282 write (6, '(a13, 5e18.10)') ' ==d== ss ', INMASS_ss
11283 write (6, '(a13, 5e18.10)') ' ==d== h2o ', INMASS_h2o
11284 write (6, '(a13, 5e18.10)') ' ==d== indgn ', INDGN
11285 write (6, '(a13, 5e18.10)') ' ==d== insig ', INSIG
11286 end if
11288 if (nb == 11) then
11289 gtauxar_01 (i,k,j) = xtauaer
11290 asy_fac_01 (i,k,j) = gaer
11291 ssa_01 (i,k,j) = waer
11292 else if (nb == 10) then
11293 gtauxar_02 (i,k,j) = xtauaer
11294 asy_fac_02 (i,k,j) = gaer
11295 ssa_02 (i,k,j) = waer
11296 else if (nb == 9) then
11297 gtauxar_03 (i,k,j) = xtauaer
11298 asy_fac_03 (i,k,j) = gaer
11299 ssa_03 (i,k,j) = waer
11300 else if (nb == 8) then
11301 gtauxar_04 (i,k,j) = xtauaer
11302 asy_fac_04 (i,k,j) = gaer
11303 ssa_04 (i,k,j) = waer
11304 else if (nb == 7) then
11305 gtauxar_05 (i,k,j) = xtauaer
11306 asy_fac_05 (i,k,j) = gaer
11307 ssa_05 (i,k,j) = waer
11308 end if
11310 tauaer(ncol,k,nb) = xtauaer
11311 ssaaer(ncol,k,nb) = waer
11312 asmaer(ncol,k,nb) = gaer
11313 end if
11314 enddo ! loop over layers
11315 if (proceed_cmaq_sw) then
11316 ! No aerosols in top layer above model top (kte+1).
11317 tauaer(ncol, kte+1 ,nb) = 0.
11318 ssaaer(ncol, kte+1 ,nb) = 1.
11319 asmaer(ncol, kte+1 ,nb) = 0.
11320 end if
11321 enddo ! loop over wavelengths
11322 #else
11323 do nb = 1, nbndsw
11324 do k = kts,kte+1
11325 tauaer(ncol,k,nb) = 0.
11326 ssaaer(ncol,k,nb) = 1.
11327 asmaer(ncol,k,nb) = 0.
11328 end do
11329 end do
11331 if ( associated (tauaer3d_sw) ) then
11332 ! ---- jararias 11/2012
11333 do nb=1,nbndsw
11334 do k=kts,kte
11335 tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb)
11336 ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb)
11337 asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb)
11338 end do
11339 end do
11340 end if
11341 #endif
11343 #if ( WRF_CHEM == 1 )
11344 IF ( AER_RA_FEEDBACK == 1) then
11345 do nb = 1, nbndsw
11346 wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
11347 do k = kts,kte !wig
11349 ! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
11350 ! tauaer - use angstrom exponent
11351 if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
11352 ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
11353 tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11354 !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
11355 if (i==30.and.j==49.and.k==2.and.nb==12) then
11356 write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
11357 print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
11358 write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11359 print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11360 endif
11361 ! ssa - linear interpolation; extrapolation
11362 slope=(waer600(i,k,j)-waer400(i,k,j))/.2
11363 ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
11364 if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
11365 if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
11366 ! g - linear interpolation;extrapolation
11367 slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
11368 asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
11369 if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
11370 if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
11371 endif
11372 end do ! k
11373 end do ! nb
11375 !wig beg
11376 do nb = 1, nbndsw
11377 slope = 0. !use slope as a sum holder
11378 do k = kts,kte
11379 slope = slope + tauaer(ncol,k,nb)
11380 end do
11381 if( slope < 0. ) then
11382 write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
11383 call wrf_error_fatal(msg)
11384 else if( slope > 6. ) then
11385 call wrf_message("-------------------------")
11386 write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
11387 call wrf_message(msg)
11389 call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
11390 do k=kts,kte
11391 write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
11392 tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
11393 call wrf_message(msg)
11394 !czhao set an up-limit here to avoid segmentation fault
11395 !from extreme AOD
11396 tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope
11397 end do
11399 call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
11400 do k=kts,kte
11401 write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
11402 gaer600(i,k,j), gaer999(i,k,j)
11403 call wrf_message(msg)
11404 end do
11406 call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
11407 do k=kts,kte
11408 write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
11409 waer600(i,k,j), waer999(i,k,j)
11410 call wrf_message(msg)
11411 end do
11413 call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
11414 do k=kts-1,kte
11415 write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
11416 call wrf_message(msg)
11417 end do
11418 call wrf_message("-------------------------")
11419 endif
11420 enddo ! nb
11421 endif ! aer_ra_feedback
11422 #endif
11425 ! Zero array for input of aerosol optical thickness for use with
11426 ! ECMWF aerosol types (not used)
11427 do na = 1, naerec
11428 do k = kts, kte+1
11429 ecaer(ncol,k,na) = 0.
11430 enddo
11431 enddo
11433 IF ( PRESENT( aerod ) ) THEN
11434 if ( aer_opt .eq. 0 ) then
11435 do na = 1, naerec
11436 do k = kts, kte+1
11437 ecaer(ncol,k,na) = 0.
11438 enddo
11439 enddo
11440 else if ( aer_opt .eq. 1 ) then
11441 do na = 1, naerec
11442 do k = kts, kte
11443 ecaer(ncol,k,na) = aerod(i,k,j,na)
11444 enddo
11445 ! assuming 0 or same value at the top?
11446 ! ecaer(ncol,kte+1,na) = ecaer(ncol,kte,na)
11447 ecaer(ncol,kte+1,na) = 0.
11448 enddo
11449 endif
11450 ENDIF
11452 ! Call RRTMG shortwave radiation model
11454 call rrtmg_sw &
11455 (ncol ,nlay ,icld , &
11456 play ,plev ,tlay ,tlev ,tsfc , &
11457 h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
11458 asdir ,asdif ,aldir ,aldif , &
11459 coszen ,adjes ,dyofyr ,scon , &
11460 inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
11461 taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
11462 ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, &
11463 tauaer ,ssaaer ,asmaer ,ecaer , &
11464 swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln, swdflxcln, aer_opt, &
11465 ! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
11466 sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
11467 ! -------------------- End of addiation by Zhenxin 2011-06-20 ------!
11468 swdkdir, swdkdif, & ! jararias, 2012/08/10
11469 swdkdirc & ! PAJ
11470 ,calc_clean_atm_diag &
11471 ,loc_sw_zbbcddir & ! WRF-CMAQ twoway coupled model
11472 ,loc_sw_dirdflux & ! WRF-CMAQ twoway coupled model
11473 ,loc_sw_difdflux & ! WRF-CMAQ twoway coupled model
11474 )
11476 ! WRF-CMAQ twoway coupled model
11477 if (present(sw_zbbcddir)) then
11478 sw_zbbcddir(i,j) = loc_sw_zbbcddir
11479 sw_dirdflux(i,j) = loc_sw_dirdflux
11480 sw_difdflux(i,j) = loc_sw_difdflux
11481 end if
11483 ! Output net absorbed shortwave surface flux and shortwave cloud forcing
11484 ! at the top of atmosphere (W/m2)
11485 gsw(i,j) = swdflx(1,1) - swuflx(1,1)
11486 swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2))
11488 if (present(swupt)) then
11489 ! Output up and down toa fluxes for total and clear sky
11490 swupt(i,j) = swuflx(1,kte+2)
11491 swuptc(i,j) = swuflxc(1,kte+2)
11492 swdnt(i,j) = swdflx(1,kte+2)
11493 swdntc(i,j) = swdflxc(1,kte+2)
11494 ! Output up and down surface fluxes for total and clear sky
11495 swupb(i,j) = swuflx(1,1)
11496 swupbc(i,j) = swuflxc(1,1)
11497 swdnb(i,j) = swdflx(1,1)
11498 ! Added by Zhenxin for 4 compenants of swdown radiation
11499 swvisdir(i,j) = sibvisdir(1,1)
11500 swvisdif(i,j) = sibvisdif(1,1)
11501 swnirdir(i,j) = sibnirdir(1,1)
11502 swnirdif(i,j) = sibnirdif(1,1)
11503 ! Ended, Zhenxin (2011/06/20)
11504 swdnbc(i,j) = swdflxc(1,1)
11505 if(calc_clean_atm_diag .gt. 0)then
11506 swuptcln(i,j) = swuflxcln(1,kte+2)
11507 swdntcln(i,j) = swdflxcln(1,kte+2)
11508 swupbcln(i,j) = swuflxcln(1,1)
11509 swdnbcln(i,j) = swdflxcln(1,1)
11510 end if
11511 endif
11512 swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10
11513 swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10
11514 swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10
11515 swdownc(i, j) = swdflxc(1,1) ! PAJ: clear-sky GHI
11516 swddirc(i,j) = swdkdirc(1,1) ! PAJ: clear-sky direct normal irradiance
11517 swddnic(i,j) = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance
11519 ! Output up and down layer fluxes for total and clear sky.
11520 ! Vertical ordering is from bottom to top in units of W m-2.
11521 if ( present (swupflx) ) then
11522 do k=kts,kte+2
11523 swupflx(i,k,j) = swuflx(1,k)
11524 swupflxc(i,k,j) = swuflxc(1,k)
11525 swdnflx(i,k,j) = swdflx(1,k)
11526 swdnflxc(i,k,j) = swdflxc(1,k)
11527 enddo
11528 endif
11530 ! Output heating rate tendency; convert heating rate from K/d to K/s
11531 ! Heating rate arrays are ordered vertically from bottom to top here.
11532 do k=kts,kte
11533 tten1d(k) = swhr(ncol,k)/86400.
11534 rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
11535 tten1d(k) = swhrc(ncol,k)/86400.
11536 rthratenswc(i,k,j) = tten1d(k)/pi3d(i,k,j)
11537 enddo
11538 else
11540 if (proceed_cmaq_sw) then ! this is for WRF-CMAQ twoway coupled model
11541 gtauxar_01 (i,:,j) = 0.0
11542 gtauxar_02 (i,:,j) = 0.0
11543 gtauxar_03 (i,:,j) = 0.0
11544 gtauxar_04 (i,:,j) = 0.0
11545 gtauxar_05 (i,:,j) = 0.0
11546 asy_fac_01 (i,:,j) = 0.0
11547 asy_fac_02 (i,:,j) = 0.0
11548 asy_fac_03 (i,:,j) = 0.0
11549 asy_fac_04 (i,:,j) = 0.0
11550 asy_fac_05 (i,:,j) = 0.0
11551 ssa_01 (i,:,j) = 0.0
11552 ssa_02 (i,:,j) = 0.0
11553 ssa_04 (i,:,j) = 0.0
11554 ssa_04 (i,:,j) = 0.0
11555 ssa_05 (i,:,j) = 0.0
11556 end if
11558 if (present(swupt)) then
11559 ! Output up and down toa fluxes for total and clear sky
11560 swupt(i,j) = 0.
11561 swuptc(i,j) = 0.
11562 swdnt(i,j) = 0.
11563 swdntc(i,j) = 0.
11564 ! Output up and down surface fluxes for total and clear sky
11565 swupb(i,j) = 0.
11566 swupbc(i,j) = 0.
11567 swdnb(i,j) = 0.
11568 swdnbc(i,j) = 0.
11569 swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
11570 swvisdif(i,j) = 0.
11571 swnirdir(i,j) = 0.
11572 swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
11573 if(calc_clean_atm_diag .gt. 0)then
11574 swuptcln(i,j) = 0.
11575 swdntcln(i,j) = 0.
11576 swupbcln(i,j) = 0.
11577 swdnbcln(i,j) = 0.
11578 end if
11579 endif
11580 swddir(i,j) = 0. ! jararias 2013/08/10
11581 swddni(i,j) = 0. ! jararias 2013/08/10
11582 swddif(i,j) = 0. ! jararias 2013/08/10
11583 swdownc(i, j) = 0.0 ! PAJ
11584 swddnic(i,j) = 0.0 ! PAJ
11585 swddirc(i,j) = 0.0 ! PAJ
11586 swcf(i,j) = 0.
11588 endif
11589 !
11590 end do i_loop
11591 end do j_loop
11594 !-------------------------------------------------------------------
11596 END SUBROUTINE RRTMG_SWRAD
11599 !====================================================================
11600 SUBROUTINE rrtmg_swinit( &
11601 allowed_to_read , &
11602 ids, ide, jds, jde, kds, kde, &
11603 ims, ime, jms, jme, kms, kme, &
11604 its, ite, jts, jte, kts, kte )
11605 !--------------------------------------------------------------------
11606 IMPLICIT NONE
11607 !--------------------------------------------------------------------
11609 LOGICAL , INTENT(IN) :: allowed_to_read
11610 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
11611 ims, ime, jms, jme, kms, kme, &
11612 its, ite, jts, jte, kts, kte
11614 ! Read in absorption coefficients and other data
11615 IF ( allowed_to_read ) THEN
11616 CALL rrtmg_swlookuptable
11617 ENDIF
11619 ! Perform g-point reduction and other initializations
11620 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
11621 call rrtmg_sw_ini(cp)
11623 END SUBROUTINE rrtmg_swinit
11626 ! **************************************************************************
11627 SUBROUTINE rrtmg_swlookuptable
11628 ! **************************************************************************
11630 IMPLICIT NONE
11632 ! Local
11633 INTEGER :: i
11634 LOGICAL :: opened
11635 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
11637 CHARACTER*80 errmess
11638 INTEGER rrtmg_unit
11640 IF ( wrf_dm_on_monitor() ) THEN
11641 DO i = 10,99
11642 INQUIRE ( i , OPENED = opened )
11643 IF ( .NOT. opened ) THEN
11644 rrtmg_unit = i
11645 GOTO 2010
11646 ENDIF
11647 ENDDO
11648 rrtmg_unit = -1
11649 2010 CONTINUE
11650 ENDIF
11651 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
11652 IF ( rrtmg_unit < 0 ) THEN
11653 CALL wrf_error_fatal ( 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// &
11654 'find unused fortran unit to read in lookup table.' )
11655 ENDIF
11657 IF ( wrf_dm_on_monitor() ) THEN
11658 OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA', &
11659 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
11660 ENDIF
11662 call sw_kgb16(rrtmg_unit)
11663 call sw_kgb17(rrtmg_unit)
11664 call sw_kgb18(rrtmg_unit)
11665 call sw_kgb19(rrtmg_unit)
11666 call sw_kgb20(rrtmg_unit)
11667 call sw_kgb21(rrtmg_unit)
11668 call sw_kgb22(rrtmg_unit)
11669 call sw_kgb23(rrtmg_unit)
11670 call sw_kgb24(rrtmg_unit)
11671 call sw_kgb25(rrtmg_unit)
11672 call sw_kgb26(rrtmg_unit)
11673 call sw_kgb27(rrtmg_unit)
11674 call sw_kgb28(rrtmg_unit)
11675 call sw_kgb29(rrtmg_unit)
11677 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
11679 RETURN
11680 9009 CONTINUE
11681 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
11682 CALL wrf_error_fatal(errmess)
11684 END SUBROUTINE rrtmg_swlookuptable
11686 ! **************************************************************************
11687 ! RRTMG Shortwave Radiative Transfer Model
11688 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
11689 !
11690 ! Original by J.Delamere, Atmospheric & Environmental Research.
11691 ! Reformatted for F90: JJMorcrette, ECMWF
11692 ! Revision for GCMs: Michael J. Iacono, AER, July 2002
11693 ! Further F90 reformatting: Michael J. Iacono, AER, June 2006
11694 !
11695 ! This file contains 14 READ statements that include the
11696 ! absorption coefficients and other data for each of the 14 shortwave
11697 ! spectral bands used in RRTMG_SW. Here, the data are defined for 16
11698 ! g-points, or sub-intervals, per band. These data are combined and
11699 ! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
11700 ! the total number of g-points from 224 to 112 for use in the GCM.
11701 ! **************************************************************************
11703 ! **************************************************************************
11704 subroutine sw_kgb16(rrtmg_unit)
11705 ! **************************************************************************
11707 use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11708 rayl, strrat1, layreffr
11710 implicit none
11711 save
11713 ! Input
11714 integer, intent(in) :: rrtmg_unit
11716 ! Local
11717 character*80 errmess
11718 logical, external :: wrf_dm_on_monitor
11720 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11722 ! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
11724 ! The array KAO contains absorption coefs at the 16 chosen g-values
11725 ! for a range of pressure levels> ~100mb, temperatures, and binary
11726 ! species parameters (see taumol.f for definition). The first
11727 ! index in the array, JS, runs from 1 to 9, and corresponds to
11728 ! different values of the binary species parameter. For instance,
11729 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11730 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11731 ! in the array, JT, which runs from 1 to 5, corresponds to different
11732 ! temperatures. More specifically, JT = 3 means that the data are for
11733 ! the reference temperature TREF for this pressure level, JT = 2 refers
11734 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11735 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11736 ! to the JPth reference pressure level (see taumol.f for these levels
11737 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11738 ! which g-interval the absorption coefficients are for.
11740 ! The array KBO contains absorption coefs at the 16 chosen g-values
11741 ! for a range of pressure levels < ~100mb and temperatures. The first
11742 ! index in the array, JT, which runs from 1 to 5, corresponds to
11743 ! different temperatures. More specifically, JT = 3 means that the
11744 ! data are for the reference temperature TREF for this pressure
11745 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11746 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11747 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11748 ! reference pressure level (see taumol.f for the value of these
11749 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11750 ! and tells us which g-interval the absorption coefficients are for.
11752 ! The array FORREFO contains the coefficient of the water vapor
11753 ! foreign-continuum (including the energy term). The first
11754 ! index refers to reference temperature (296,260,224,260) and
11755 ! pressure (970,475,219,3 mbar) levels. The second index
11756 ! runs over the g-channel (1 to 16).
11758 ! The array SELFREFO contains the coefficient of the water vapor
11759 ! self-continuum (including the energy term). The first index
11760 ! refers to temperature in 7.2 degree increments. For instance,
11761 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11762 ! etc. The second index runs over the g-channel (1 to 16).
11764 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11765 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11766 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11768 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11769 rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11770 DM_BCAST_REAL(rayl)
11771 DM_BCAST_REAL(strrat1)
11772 DM_BCAST_INTEGER(layreffr)
11773 DM_BCAST_MACRO(kao)
11774 DM_BCAST_MACRO(kbo)
11775 DM_BCAST_MACRO(selfrefo)
11776 DM_BCAST_MACRO(forrefo)
11777 DM_BCAST_MACRO(sfluxrefo)
11779 RETURN
11780 9010 CONTINUE
11781 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11782 CALL wrf_error_fatal(errmess)
11784 end subroutine sw_kgb16
11786 ! **************************************************************************
11787 subroutine sw_kgb17(rrtmg_unit)
11788 ! **************************************************************************
11790 use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11791 rayl, strrat, layreffr
11793 implicit none
11794 save
11796 ! Input
11797 integer, intent(in) :: rrtmg_unit
11799 ! Local
11800 character*80 errmess
11801 logical, external :: wrf_dm_on_monitor
11803 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11805 ! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
11807 ! The array KAO contains absorption coefs at the 16 chosen g-values
11808 ! for a range of pressure levels> ~100mb, temperatures, and binary
11809 ! species parameters (see taumol.f for definition). The first
11810 ! index in the array, JS, runs from 1 to 9, and corresponds to
11811 ! different values of the binary species parameter. For instance,
11812 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11813 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11814 ! in the array, JT, which runs from 1 to 5, corresponds to different
11815 ! temperatures. More specifically, JT = 3 means that the data are for
11816 ! the reference temperature TREF for this pressure level, JT = 2 refers
11817 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11818 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11819 ! to the JPth reference pressure level (see taumol.f for these levels
11820 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11821 ! which g-interval the absorption coefficients are for.
11823 ! The array KBO contains absorption coefs at the 16 chosen g-values
11824 ! for a range of pressure levels < ~100mb and temperatures. The first
11825 ! index in the array, JT, which runs from 1 to 5, corresponds to
11826 ! different temperatures. More specifically, JT = 3 means that the
11827 ! data are for the reference temperature TREF for this pressure
11828 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11829 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11830 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11831 ! reference pressure level (see taumol.f for the value of these
11832 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11833 ! and tells us which g-interval the absorption coefficients are for.
11835 ! The array FORREFO contains the coefficient of the water vapor
11836 ! foreign-continuum (including the energy term). The first
11837 ! index refers to reference temperature (296,260,224,260) and
11838 ! pressure (970,475,219,3 mbar) levels. The second index
11839 ! runs over the g-channel (1 to 16).
11841 ! The array SELFREFO contains the coefficient of the water vapor
11842 ! self-continuum (including the energy term). The first index
11843 ! refers to temperature in 7.2 degree increments. For instance,
11844 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11845 ! etc. The second index runs over the g-channel (1 to 16).
11847 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11848 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11849 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11851 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11852 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11853 DM_BCAST_REAL(rayl)
11854 DM_BCAST_REAL(strrat)
11855 DM_BCAST_INTEGER(layreffr)
11856 DM_BCAST_MACRO(kao)
11857 DM_BCAST_MACRO(kbo)
11858 DM_BCAST_MACRO(selfrefo)
11859 DM_BCAST_MACRO(forrefo)
11860 DM_BCAST_MACRO(sfluxrefo)
11862 RETURN
11863 9010 CONTINUE
11864 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11865 CALL wrf_error_fatal(errmess)
11867 end subroutine sw_kgb17
11869 ! **************************************************************************
11870 subroutine sw_kgb18(rrtmg_unit)
11871 ! **************************************************************************
11873 use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11874 rayl, strrat, layreffr
11876 implicit none
11877 save
11879 ! Input
11880 integer, intent(in) :: rrtmg_unit
11882 ! Local
11883 character*80 errmess
11884 logical, external :: wrf_dm_on_monitor
11886 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11888 ! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
11890 ! The array KAO contains absorption coefs at the 16 chosen g-values
11891 ! for a range of pressure levels> ~100mb, temperatures, and binary
11892 ! species parameters (see taumol.f for definition). The first
11893 ! index in the array, JS, runs from 1 to 9, and corresponds to
11894 ! different values of the binary species parameter. For instance,
11895 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11896 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11897 ! in the array, JT, which runs from 1 to 5, corresponds to different
11898 ! temperatures. More specifically, JT = 3 means that the data are for
11899 ! the reference temperature TREF for this pressure level, JT = 2 refers
11900 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11901 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11902 ! to the JPth reference pressure level (see taumol.f for these levels
11903 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11904 ! which g-interval the absorption coefficients are for.
11906 ! The array KBO contains absorption coefs at the 16 chosen g-values
11907 ! for a range of pressure levels < ~100mb and temperatures. The first
11908 ! index in the array, JT, which runs from 1 to 5, corresponds to
11909 ! different temperatures. More specifically, JT = 3 means that the
11910 ! data are for the reference temperature TREF for this pressure
11911 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11912 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11913 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11914 ! reference pressure level (see taumol.f for the value of these
11915 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11916 ! and tells us which g-interval the absorption coefficients are for.
11918 ! The array FORREFO contains the coefficient of the water vapor
11919 ! foreign-continuum (including the energy term). The first
11920 ! index refers to reference temperature (296,260,224,260) and
11921 ! pressure (970,475,219,3 mbar) levels. The second index
11922 ! runs over the g-channel (1 to 16).
11924 ! The array SELFREFO contains the coefficient of the water vapor
11925 ! self-continuum (including the energy term). The first index
11926 ! refers to temperature in 7.2 degree increments. For instance,
11927 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11928 ! etc. The second index runs over the g-channel (1 to 16).
11930 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11931 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11932 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11934 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11935 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11936 DM_BCAST_REAL(rayl)
11937 DM_BCAST_REAL(strrat)
11938 DM_BCAST_INTEGER(layreffr)
11939 DM_BCAST_MACRO(kao)
11940 DM_BCAST_MACRO(kbo)
11941 DM_BCAST_MACRO(selfrefo)
11942 DM_BCAST_MACRO(forrefo)
11943 DM_BCAST_MACRO(sfluxrefo)
11945 RETURN
11946 9010 CONTINUE
11947 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11948 CALL wrf_error_fatal(errmess)
11950 end subroutine sw_kgb18
11952 ! **************************************************************************
11953 subroutine sw_kgb19(rrtmg_unit)
11954 ! **************************************************************************
11956 use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11957 rayl, strrat, layreffr
11959 implicit none
11960 save
11962 ! Input
11963 integer, intent(in) :: rrtmg_unit
11965 ! Local
11966 character*80 errmess
11967 logical, external :: wrf_dm_on_monitor
11969 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11971 ! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
11973 ! The array KAO contains absorption coefs at the 16 chosen g-values
11974 ! for a range of pressure levels> ~100mb, temperatures, and binary
11975 ! species parameters (see taumol.f for definition). The first
11976 ! index in the array, JS, runs from 1 to 9, and corresponds to
11977 ! different values of the binary species parameter. For instance,
11978 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11979 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11980 ! in the array, JT, which runs from 1 to 5, corresponds to different
11981 ! temperatures. More specifically, JT = 3 means that the data are for
11982 ! the reference temperature TREF for this pressure level, JT = 2 refers
11983 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11984 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11985 ! to the JPth reference pressure level (see taumol.f for these levels
11986 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11987 ! which g-interval the absorption coefficients are for.
11989 ! The array KBO contains absorption coefs at the 16 chosen g-values
11990 ! for a range of pressure levels < ~100mb and temperatures. The first
11991 ! index in the array, JT, which runs from 1 to 5, corresponds to
11992 ! different temperatures. More specifically, JT = 3 means that the
11993 ! data are for the reference temperature TREF for this pressure
11994 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11995 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11996 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11997 ! reference pressure level (see taumol.f for the value of these
11998 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11999 ! and tells us which g-interval the absorption coefficients are for.
12001 ! The array FORREFO contains the coefficient of the water vapor
12002 ! foreign-continuum (including the energy term). The first
12003 ! index refers to reference temperature (296,260,224,260) and
12004 ! pressure (970,475,219,3 mbar) levels. The second index
12005 ! runs over the g-channel (1 to 16).
12007 ! The array SELFREFO contains the coefficient of the water vapor
12008 ! self-continuum (including the energy term). The first index
12009 ! refers to temperature in 7.2 degree increments. For instance,
12010 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12011 ! etc. The second index runs over the g-channel (1 to 16).
12013 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12014 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12015 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12017 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12018 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12019 DM_BCAST_REAL(rayl)
12020 DM_BCAST_REAL(strrat)
12021 DM_BCAST_INTEGER(layreffr)
12022 DM_BCAST_MACRO(kao)
12023 DM_BCAST_MACRO(kbo)
12024 DM_BCAST_MACRO(selfrefo)
12025 DM_BCAST_MACRO(forrefo)
12026 DM_BCAST_MACRO(sfluxrefo)
12028 RETURN
12029 9010 CONTINUE
12030 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12031 CALL wrf_error_fatal(errmess)
12033 end subroutine sw_kgb19
12035 ! **************************************************************************
12036 subroutine sw_kgb20(rrtmg_unit)
12037 ! **************************************************************************
12039 use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12040 absch4o, rayl, layreffr
12042 implicit none
12043 save
12045 ! Input
12046 integer, intent(in) :: rrtmg_unit
12048 ! Local
12049 character*80 errmess
12050 logical, external :: wrf_dm_on_monitor
12052 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12054 ! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
12056 ! Array absch4o contains the absorption coefficients for methane.
12058 ! The array KAO contains absorption coefs at the 16 chosen g-values
12059 ! for a range of pressure levels> ~100mb, temperatures, and binary
12060 ! species parameters (see taumol.f for definition). The first
12061 ! index in the array, JS, runs from 1 to 9, and corresponds to
12062 ! different values of the binary species parameter. For instance,
12063 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12064 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12065 ! in the array, JT, which runs from 1 to 5, corresponds to different
12066 ! temperatures. More specifically, JT = 3 means that the data are for
12067 ! the reference temperature TREF for this pressure level, JT = 2 refers
12068 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12069 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12070 ! to the JPth reference pressure level (see taumol.f for these levels
12071 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12072 ! which g-interval the absorption coefficients are for.
12074 ! The array KBO contains absorption coefs at the 16 chosen g-values
12075 ! for a range of pressure levels < ~100mb and temperatures. The first
12076 ! index in the array, JT, which runs from 1 to 5, corresponds to
12077 ! different temperatures. More specifically, JT = 3 means that the
12078 ! data are for the reference temperature TREF for this pressure
12079 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12080 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12081 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12082 ! reference pressure level (see taumol.f for the value of these
12083 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12084 ! and tells us which g-interval the absorption coefficients are for.
12086 ! The array FORREFO contains the coefficient of the water vapor
12087 ! foreign-continuum (including the energy term). The first
12088 ! index refers to reference temperature (296,260,224,260) and
12089 ! pressure (970,475,219,3 mbar) levels. The second index
12090 ! runs over the g-channel (1 to 16).
12092 ! The array SELFREFO contains the coefficient of the water vapor
12093 ! self-continuum (including the energy term). The first index
12094 ! refers to temperature in 7.2 degree increments. For instance,
12095 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12096 ! etc. The second index runs over the g-channel (1 to 16).
12098 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12099 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12100 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12102 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12103 rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
12104 DM_BCAST_REAL(rayl)
12105 DM_BCAST_INTEGER(layreffr)
12106 DM_BCAST_MACRO(absch4o)
12107 DM_BCAST_MACRO(kao)
12108 DM_BCAST_MACRO(kbo)
12109 DM_BCAST_MACRO(selfrefo)
12110 DM_BCAST_MACRO(forrefo)
12111 DM_BCAST_MACRO(sfluxrefo)
12113 RETURN
12114 9010 CONTINUE
12115 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12116 CALL wrf_error_fatal(errmess)
12118 end subroutine sw_kgb20
12120 ! **************************************************************************
12121 subroutine sw_kgb21(rrtmg_unit)
12122 ! **************************************************************************
12124 use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12125 rayl, strrat, layreffr
12127 implicit none
12128 save
12130 ! Input
12131 integer, intent(in) :: rrtmg_unit
12133 ! Local
12134 character*80 errmess
12135 logical, external :: wrf_dm_on_monitor
12137 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12139 ! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
12141 ! The array KAO contains absorption coefs at the 16 chosen g-values
12142 ! for a range of pressure levels> ~100mb, temperatures, and binary
12143 ! species parameters (see taumol.f for definition). The first
12144 ! index in the array, JS, runs from 1 to 9, and corresponds to
12145 ! different values of the binary species parameter. For instance,
12146 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12147 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12148 ! in the array, JT, which runs from 1 to 5, corresponds to different
12149 ! temperatures. More specifically, JT = 3 means that the data are for
12150 ! the reference temperature TREF for this pressure level, JT = 2 refers
12151 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12152 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12153 ! to the JPth reference pressure level (see taumol.f for these levels
12154 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12155 ! which g-interval the absorption coefficients are for.
12157 ! The array KBO contains absorption coefs at the 16 chosen g-values
12158 ! for a range of pressure levels < ~100mb and temperatures. The first
12159 ! index in the array, JT, which runs from 1 to 5, corresponds to
12160 ! different temperatures. More specifically, JT = 3 means that the
12161 ! data are for the reference temperature TREF for this pressure
12162 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12163 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12164 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12165 ! reference pressure level (see taumol.f for the value of these
12166 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12167 ! and tells us which g-interval the absorption coefficients are for.
12169 ! The array FORREFO contains the coefficient of the water vapor
12170 ! foreign-continuum (including the energy term). The first
12171 ! index refers to reference temperature (296,260,224,260) and
12172 ! pressure (970,475,219,3 mbar) levels. The second index
12173 ! runs over the g-channel (1 to 16).
12175 ! The array SELFREFO contains the coefficient of the water vapor
12176 ! self-continuum (including the energy term). The first index
12177 ! refers to temperature in 7.2 degree increments. For instance,
12178 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12179 ! etc. The second index runs over the g-channel (1 to 16).
12181 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12182 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12183 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12185 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12186 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12187 DM_BCAST_REAL(rayl)
12188 DM_BCAST_REAL(strrat)
12189 DM_BCAST_INTEGER(layreffr)
12190 DM_BCAST_MACRO(kao)
12191 DM_BCAST_MACRO(kbo)
12192 DM_BCAST_MACRO(selfrefo)
12193 DM_BCAST_MACRO(forrefo)
12194 DM_BCAST_MACRO(sfluxrefo)
12196 RETURN
12197 9010 CONTINUE
12198 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12199 CALL wrf_error_fatal(errmess)
12201 end subroutine sw_kgb21
12203 ! **************************************************************************
12204 subroutine sw_kgb22(rrtmg_unit)
12205 ! **************************************************************************
12207 use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12208 rayl, strrat, layreffr
12210 implicit none
12211 save
12213 ! Input
12214 integer, intent(in) :: rrtmg_unit
12216 ! Local
12217 character*80 errmess
12218 logical, external :: wrf_dm_on_monitor
12220 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12222 ! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
12224 ! The array KAO contains absorption coefs at the 16 chosen g-values
12225 ! for a range of pressure levels> ~100mb, temperatures, and binary
12226 ! species parameters (see taumol.f for definition). The first
12227 ! index in the array, JS, runs from 1 to 9, and corresponds to
12228 ! different values of the binary species parameter. For instance,
12229 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12230 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12231 ! in the array, JT, which runs from 1 to 5, corresponds to different
12232 ! temperatures. More specifically, JT = 3 means that the data are for
12233 ! the reference temperature TREF for this pressure level, JT = 2 refers
12234 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12235 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12236 ! to the JPth reference pressure level (see taumol.f for these levels
12237 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12238 ! which g-interval the absorption coefficients are for.
12240 ! The array KBO contains absorption coefs at the 16 chosen g-values
12241 ! for a range of pressure levels < ~100mb and temperatures. The first
12242 ! index in the array, JT, which runs from 1 to 5, corresponds to
12243 ! different temperatures. More specifically, JT = 3 means that the
12244 ! data are for the reference temperature TREF for this pressure
12245 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12246 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12247 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12248 ! reference pressure level (see taumol.f for the value of these
12249 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12250 ! and tells us which g-interval the absorption coefficients are for.
12252 ! The array FORREFO contains the coefficient of the water vapor
12253 ! foreign-continuum (including the energy term). The first
12254 ! index refers to reference temperature (296_rb,260_rb,224,260) and
12255 ! pressure (970,475,219,3 mbar) levels. The second index
12256 ! runs over the g-channel (1 to 16).
12258 ! The array SELFREFO contains the coefficient of the water vapor
12259 ! self-continuum (including the energy term). The first index
12260 ! refers to temperature in 7.2 degree increments. For instance,
12261 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12262 ! etc. The second index runs over the g-channel (1 to 16).
12264 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12265 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12266 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12268 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12269 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12270 DM_BCAST_REAL(rayl)
12271 DM_BCAST_REAL(strrat)
12272 DM_BCAST_INTEGER(layreffr)
12273 DM_BCAST_MACRO(kao)
12274 DM_BCAST_MACRO(kbo)
12275 DM_BCAST_MACRO(selfrefo)
12276 DM_BCAST_MACRO(forrefo)
12277 DM_BCAST_MACRO(sfluxrefo)
12279 RETURN
12280 9010 CONTINUE
12281 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12282 CALL wrf_error_fatal(errmess)
12284 end subroutine sw_kgb22
12286 ! **************************************************************************
12287 subroutine sw_kgb23(rrtmg_unit)
12288 ! **************************************************************************
12290 use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, &
12291 raylo, givfac, layreffr
12293 implicit none
12294 save
12296 ! Input
12297 integer, intent(in) :: rrtmg_unit
12299 ! Local
12300 character*80 errmess
12301 logical, external :: wrf_dm_on_monitor
12303 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12305 ! Array raylo contains the Rayleigh extinction coefficient at all v for this band
12307 ! Array givfac is the average Giver et al. correction factor for this band.
12309 ! The array KAO contains absorption coefs at the 16 chosen g-values
12310 ! for a range of pressure levels> ~100mb, temperatures, and binary
12311 ! species parameters (see taumol.f for definition). The first
12312 ! index in the array, JS, runs from 1 to 9, and corresponds to
12313 ! different values of the binary species parameter. For instance,
12314 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12315 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12316 ! in the array, JT, which runs from 1 to 5, corresponds to different
12317 ! temperatures. More specifically, JT = 3 means that the data are for
12318 ! the reference temperature TREF for this pressure level, JT = 2 refers
12319 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12320 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12321 ! to the JPth reference pressure level (see taumol.f for these levels
12322 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12323 ! which g-interval the absorption coefficients are for.
12325 ! The array FORREFO contains the coefficient of the water vapor
12326 ! foreign-continuum (including the energy term). The first
12327 ! index refers to reference temperature (296,260,224,260) and
12328 ! pressure (970,475,219,3 mbar) levels. The second index
12329 ! runs over the g-channel (1 to 16).
12331 ! The array SELFREFO contains the coefficient of the water vapor
12332 ! self-continuum (including the energy term). The first index
12333 ! refers to temperature in 7.2 degree increments. For instance,
12334 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12335 ! etc. The second index runs over the g-channel (1 to 16).
12337 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12338 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12339 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12341 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12342 raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
12343 DM_BCAST_MACRO(raylo)
12344 DM_BCAST_REAL(givfac)
12345 DM_BCAST_INTEGER(layreffr)
12346 DM_BCAST_MACRO(kao)
12347 DM_BCAST_MACRO(selfrefo)
12348 DM_BCAST_MACRO(forrefo)
12349 DM_BCAST_MACRO(sfluxrefo)
12351 RETURN
12352 9010 CONTINUE
12353 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12354 CALL wrf_error_fatal(errmess)
12356 end subroutine sw_kgb23
12358 ! **************************************************************************
12359 subroutine sw_kgb24(rrtmg_unit)
12360 ! **************************************************************************
12362 use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12363 raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
12365 implicit none
12366 save
12368 ! Input
12369 integer, intent(in) :: rrtmg_unit
12371 ! Local
12372 character*80 errmess
12373 logical, external :: wrf_dm_on_monitor
12375 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12377 ! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
12378 ! all v for this band for the upper and lower atmosphere.
12380 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
12381 ! all v for this band for the upper and lower atmosphere.
12383 ! The array KAO contains absorption coefs at the 16 chosen g-values
12384 ! for a range of pressure levels> ~100mb, temperatures, and binary
12385 ! species parameters (see taumol.f for definition). The first
12386 ! index in the array, JS, runs from 1 to 9, and corresponds to
12387 ! different values of the binary species parameter. For instance,
12388 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12389 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12390 ! in the array, JT, which runs from 1 to 5, corresponds to different
12391 ! temperatures. More specifically, JT = 3 means that the data are for
12392 ! the reference temperature TREF for this pressure level, JT = 2 refers
12393 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12394 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12395 ! to the JPth reference pressure level (see taumol.f for these levels
12396 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12397 ! which g-interval the absorption coefficients are for.
12399 ! The array KBO contains absorption coefs at the 16 chosen g-values
12400 ! for a range of pressure levels < ~100mb and temperatures. The first
12401 ! index in the array, JT, which runs from 1 to 5, corresponds to
12402 ! different temperatures. More specifically, JT = 3 means that the
12403 ! data are for the reference temperature TREF for this pressure
12404 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12405 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12406 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12407 ! reference pressure level (see taumol.f for the value of these
12408 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12409 ! and tells us which g-interval the absorption coefficients are for.
12411 ! The array FORREFO contains the coefficient of the water vapor
12412 ! foreign-continuum (including the energy term). The first
12413 ! index refers to reference temperature (296,260,224,260) and
12414 ! pressure (970,475,219,3 mbar) levels. The second index
12415 ! runs over the g-channel (1 to 16).
12417 ! The array SELFREFO contains the coefficient of the water vapor
12418 ! self-continuum (including the energy term). The first index
12419 ! refers to temperature in 7.2 degree increments. For instance,
12420 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12421 ! etc. The second index runs over the g-channel (1 to 16).
12423 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12424 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12425 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12427 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12428 raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
12429 forrefo, sfluxrefo
12430 DM_BCAST_MACRO(raylao)
12431 DM_BCAST_MACRO(raylbo)
12432 DM_BCAST_REAL(strrat)
12433 DM_BCAST_INTEGER(layreffr)
12434 DM_BCAST_MACRO(abso3ao)
12435 DM_BCAST_MACRO(abso3bo)
12436 DM_BCAST_MACRO(kao)
12437 DM_BCAST_MACRO(kbo)
12438 DM_BCAST_MACRO(selfrefo)
12439 DM_BCAST_MACRO(forrefo)
12440 DM_BCAST_MACRO(sfluxrefo)
12442 RETURN
12443 9010 CONTINUE
12444 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12445 CALL wrf_error_fatal(errmess)
12447 end subroutine sw_kgb24
12449 ! **************************************************************************
12450 subroutine sw_kgb25(rrtmg_unit)
12451 ! **************************************************************************
12453 use rrsw_kg25, only : kao, sfluxrefo, &
12454 raylo, abso3ao, abso3bo, layreffr
12456 implicit none
12457 save
12459 ! Input
12460 integer, intent(in) :: rrtmg_unit
12462 ! Local
12463 character*80 errmess
12464 logical, external :: wrf_dm_on_monitor
12466 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12468 ! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
12470 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
12471 ! all v for this band for the upper and lower atmosphere.
12473 ! The array KAO contains absorption coefs at the 16 chosen g-values
12474 ! for a range of pressure levels> ~100mb, temperatures, and binary
12475 ! species parameters (see taumol.f for definition). The first
12476 ! index in the array, JS, runs from 1 to 9, and corresponds to
12477 ! different values of the binary species parameter. For instance,
12478 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12479 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12480 ! in the array, JT, which runs from 1 to 5, corresponds to different
12481 ! temperatures. More specifically, JT = 3 means that the data are for
12482 ! the reference temperature TREF for this pressure level, JT = 2 refers
12483 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12484 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12485 ! to the JPth reference pressure level (see taumol.f for these levels
12486 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12487 ! which g-interval the absorption coefficients are for.
12489 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12490 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12492 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12493 raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
12494 DM_BCAST_MACRO(raylo)
12495 DM_BCAST_INTEGER(layreffr)
12496 DM_BCAST_MACRO(abso3ao)
12497 DM_BCAST_MACRO(abso3bo)
12498 DM_BCAST_MACRO(kao)
12499 DM_BCAST_MACRO(sfluxrefo)
12501 RETURN
12502 9010 CONTINUE
12503 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12504 CALL wrf_error_fatal(errmess)
12506 end subroutine sw_kgb25
12508 ! **************************************************************************
12509 subroutine sw_kgb26(rrtmg_unit)
12510 ! **************************************************************************
12512 use rrsw_kg26, only : sfluxrefo, raylo
12514 implicit none
12515 save
12517 ! Input
12518 integer, intent(in) :: rrtmg_unit
12520 ! Local
12521 character*80 errmess
12522 logical, external :: wrf_dm_on_monitor
12524 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12526 ! Array raylo contains the Rayleigh extinction coefficient at all v for this band.
12528 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12530 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12531 raylo, sfluxrefo
12532 DM_BCAST_MACRO(raylo)
12533 DM_BCAST_MACRO(sfluxrefo)
12535 RETURN
12536 9010 CONTINUE
12537 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12538 CALL wrf_error_fatal(errmess)
12540 end subroutine sw_kgb26
12542 ! **************************************************************************
12543 subroutine sw_kgb27(rrtmg_unit)
12544 ! **************************************************************************
12546 use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
12547 scalekur, layreffr
12549 implicit none
12550 save
12552 ! Input
12553 integer, intent(in) :: rrtmg_unit
12555 ! Local
12556 character*80 errmess
12557 logical, external :: wrf_dm_on_monitor
12559 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12560 ! The values in array sfluxrefo were obtained using the "low resolution"
12561 ! version of the Kurucz solar source function. For unknown reasons,
12562 ! the total irradiance in this band differs from the corresponding
12563 ! total in the "high-resolution" version of the Kurucz function.
12564 ! Therefore, these values are scaled by the factor SCALEKUR.
12566 ! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
12568 ! The array KAO contains absorption coefs at the 16 chosen g-values
12569 ! for a range of pressure levels> ~100mb, temperatures, and binary
12570 ! species parameters (see taumol.f for definition). The first
12571 ! index in the array, JS, runs from 1 to 9, and corresponds to
12572 ! different values of the binary species parameter. For instance,
12573 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12574 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12575 ! in the array, JT, which runs from 1 to 5, corresponds to different
12576 ! temperatures. More specifically, JT = 3 means that the data are for
12577 ! the reference temperature TREF for this pressure level, JT = 2 refers
12578 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12579 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12580 ! to the JPth reference pressure level (see taumol.f for these levels
12581 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12582 ! which g-interval the absorption coefficients are for.
12584 ! The array KBO contains absorption coefs at the 16 chosen g-values
12585 ! for a range of pressure levels < ~100mb and temperatures. The first
12586 ! index in the array, JT, which runs from 1 to 5, corresponds to
12587 ! different temperatures. More specifically, JT = 3 means that the
12588 ! data are for the reference temperature TREF for this pressure
12589 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12590 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12591 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12592 ! reference pressure level (see taumol.f for the value of these
12593 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12594 ! and tells us which g-interval the absorption coefficients are for.
12596 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12597 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12598 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12600 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12601 raylo, scalekur, layreffr, kao, kbo, sfluxrefo
12602 DM_BCAST_MACRO(raylo)
12603 DM_BCAST_REAL(scalekur)
12604 DM_BCAST_INTEGER(layreffr)
12605 DM_BCAST_MACRO(kao)
12606 DM_BCAST_MACRO(kbo)
12607 DM_BCAST_MACRO(sfluxrefo)
12609 RETURN
12610 9010 CONTINUE
12611 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12612 CALL wrf_error_fatal(errmess)
12614 end subroutine sw_kgb27
12616 ! **************************************************************************
12617 subroutine sw_kgb28(rrtmg_unit)
12618 ! **************************************************************************
12620 use rrsw_kg28, only : kao, kbo, sfluxrefo, &
12621 rayl, strrat, layreffr
12623 implicit none
12624 save
12626 ! Input
12627 integer, intent(in) :: rrtmg_unit
12629 ! Local
12630 character*80 errmess
12631 logical, external :: wrf_dm_on_monitor
12633 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12635 ! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
12637 ! The array KAO contains absorption coefs at the 16 chosen g-values
12638 ! for a range of pressure levels> ~100mb, temperatures, and binary
12639 ! species parameters (see taumol.f for definition). The first
12640 ! index in the array, JS, runs from 1 to 9, and corresponds to
12641 ! different values of the binary species parameter. For instance,
12642 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12643 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12644 ! in the array, JT, which runs from 1 to 5, corresponds to different
12645 ! temperatures. More specifically, JT = 3 means that the data are for
12646 ! the reference temperature TREF for this pressure level, JT = 2 refers
12647 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12648 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12649 ! to the JPth reference pressure level (see taumol.f for these levels
12650 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12651 ! which g-interval the absorption coefficients are for.
12653 ! The array KBO contains absorption coefs at the 16 chosen g-values
12654 ! for a range of pressure levels < ~100mb and temperatures. The first
12655 ! index in the array, JT, which runs from 1 to 5, corresponds to
12656 ! different temperatures. More specifically, JT = 3 means that the
12657 ! data are for the reference temperature TREF for this pressure
12658 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12659 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12660 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12661 ! reference pressure level (see taumol.f for the value of these
12662 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12663 ! and tells us which g-interval the absorption coefficients are for.
12665 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12666 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12667 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12669 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12670 rayl, strrat, layreffr, kao, kbo, sfluxrefo
12671 DM_BCAST_REAL(rayl)
12672 DM_BCAST_REAL(strrat)
12673 DM_BCAST_INTEGER(layreffr)
12674 DM_BCAST_MACRO(kao)
12675 DM_BCAST_MACRO(kbo)
12676 DM_BCAST_MACRO(sfluxrefo)
12678 RETURN
12679 9010 CONTINUE
12680 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12681 CALL wrf_error_fatal(errmess)
12683 end subroutine sw_kgb28
12685 ! **************************************************************************
12686 subroutine sw_kgb29(rrtmg_unit)
12687 ! **************************************************************************
12689 use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12690 absh2oo, absco2o, rayl, layreffr
12692 implicit none
12693 save
12695 ! Input
12696 integer, intent(in) :: rrtmg_unit
12698 ! Local
12699 character*80 errmess
12700 logical, external :: wrf_dm_on_monitor
12702 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12704 ! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
12706 ! Array absh2oo contains the water vapor absorption coefficient for this band.
12708 ! Array absco2o contains the carbon dioxide absorption coefficient for this band.
12710 ! The array KAO contains absorption coefs at the 16 chosen g-values
12711 ! for a range of pressure levels> ~100mb, temperatures, and binary
12712 ! species parameters (see taumol.f for definition). The first
12713 ! index in the array, JS, runs from 1 to 9, and corresponds to
12714 ! different values of the binary species parameter. For instance,
12715 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12716 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12717 ! in the array, JT, which runs from 1 to 5, corresponds to different
12718 ! temperatures. More specifically, JT = 3 means that the data are for
12719 ! the reference temperature TREF for this pressure level, JT = 2 refers
12720 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12721 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12722 ! to the JPth reference pressure level (see taumol.f for these levels
12723 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12724 ! which g-interval the absorption coefficients are for.
12726 ! The array KBO contains absorption coefs at the 16 chosen g-values
12727 ! for a range of pressure levels < ~100mb and temperatures. The first
12728 ! index in the array, JT, which runs from 1 to 5, corresponds to
12729 ! different temperatures. More specifically, JT = 3 means that the
12730 ! data are for the reference temperature TREF for this pressure
12731 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12732 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12733 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12734 ! reference pressure level (see taumol.f for the value of these
12735 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12736 ! and tells us which g-interval the absorption coefficients are for.
12738 ! The array FORREFO contains the coefficient of the water vapor
12739 ! foreign-continuum (including the energy term). The first
12740 ! index refers to reference temperature (296,260,224,260) and
12741 ! pressure (970,475,219,3 mbar) levels. The second index
12742 ! runs over the g-channel (1 to 16).
12744 ! The array SELFREFO contains the coefficient of the water vapor
12745 ! self-continuum (including the energy term). The first index
12746 ! refers to temperature in 7.2 degree increments. For instance,
12747 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12748 ! etc. The second index runs over the g-channel (1 to 16).
12750 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12751 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12752 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12754 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12755 rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
12756 DM_BCAST_REAL(rayl)
12757 DM_BCAST_INTEGER(layreffr)
12758 DM_BCAST_MACRO(absh2oo)
12759 DM_BCAST_MACRO(absco2o)
12760 DM_BCAST_MACRO(kao)
12761 DM_BCAST_MACRO(kbo)
12762 DM_BCAST_MACRO(selfrefo)
12763 DM_BCAST_MACRO(forrefo)
12764 DM_BCAST_MACRO(sfluxrefo)
12766 RETURN
12767 9010 CONTINUE
12768 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12769 CALL wrf_error_fatal(errmess)
12771 end subroutine sw_kgb29
12773 !------------------------------------------------------------------
12775 END MODULE module_ra_rrtmg_sw
12776 !***********************************************************************