| blob | c0eb328a4d5948f5ac899c18d0ff18b9edc57c39 |
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 INTENT(INOUT) :: O33D
10218 INTEGER, INTENT(IN ) :: o3input
10219 ! EC aerosol: no_src = naerec = 6
10220 INTEGER, INTENT(IN ) :: no_src
10221 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , &
10222 OPTIONAL , &
10223 INTENT(IN ) :: aerod
10224 INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
10226 !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
10227 real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
10228 data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
10229 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
10230 real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
10231 data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
10232 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
10233 real wavemid(nbndsw) ! Mid wavelength (um) of interval
10234 real, parameter :: thresh=1.e-9
10235 real ang,slope
10236 character(len=200) :: msg
10238 ! Top of atmosphere and surface shortwave fluxes (W m-2)
10239 REAL, DIMENSION( ims:ime, jms:jme ), &
10240 OPTIONAL, INTENT(INOUT) :: &
10241 SWUPT,SWUPTC,SWUPTCLN,SWDNT,SWDNTC,SWDNTCLN, &
10242 SWUPB,SWUPBC,SWUPBCLN,SWDNB,SWDNBC,SWDNBCLN
10244 ! Layer shortwave fluxes (including extra layer above model top)
10245 ! Vertical ordering is from bottom to top (W m-2)
10246 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
10247 OPTIONAL, INTENT(OUT) :: &
10248 SWUPFLX,SWUPFLXC, &
10249 SWDNFLX,SWDNFLXC
10251 ! amontornes-bcodina 2015/09 solar eclipses
10252 ! obscur --> degree of obscuration for solar eclipses prediction (2D)
10253 REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: obscur
10255 ! begin WRF-CMAQ twoway coupled model block
10256 LOGICAL, INTENT(IN) :: proceed_cmaq_sw
10258 ! ** FSB items needed for new aerosol code from CMAQ
10259 integer, optional, intent(in) :: nmode ! number of log-normal modes
10261 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: &
10262 mass_ws_i, mass_ws_j, mass_ws_k, & ! mass cocentrations in [ ug/m**3 ] for water
10263 ! soluble species in each mode
10264 mass_in_i, mass_in_j, mass_in_k, & ! mass cocentrations in [ ug/m**3 ] for water
10265 ! insoluble species in each mode
10266 mass_ec_i, mass_ec_j, mass_ec_k, & ! mass cocentrations in [ ug/m**3 ] for elemental
10267 ! carbon species in each mode
10268 mass_ss_i, mass_ss_j, mass_ss_k, & ! mass cocentrations in [ ug/m**3 ] for aerosol
10269 ! water species in each mode
10270 mass_h2o_i, mass_h2o_j, mass_h2o_k, & ! mass cocentrations in [ ug/m**3 ] for sea
10271 ! salt species in each mode
10272 dgn_i, dgn_j, dgn_k, & ! geometric mean diameter of each mode [ m ]
10273 sig_i, sig_j, sig_k ! geometric standard deviation of each mode
10275 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(out) :: &
10276 gtauxar_01, & ! Aerosol optical depth of RRTMG SW band 11
10277 gtauxar_02, & ! Aerosol optical depth of RRTMG SW band 10
10278 gtauxar_03, & ! Aerosol optical depth of RRTMG SW band 9
10279 gtauxar_04, & ! Aerosol optical depth of RRTMG SW band 8
10280 gtauxar_05, & ! Aerosol optical depth of RRTMG SW band 7
10281 asy_fac_01, & ! asymmetry factor of RRTMG SW band 11
10282 asy_fac_02, & ! asymmetry factor of RRTMG SW band 10
10283 asy_fac_03, & ! asymmetry factor of RRTMG SW band 9
10284 asy_fac_04, & ! asymmetry factor of RRTMG SW band 8
10285 asy_fac_05, & ! asymmetry factor of RRTMG SW band 7
10286 ssa_01, & ! single scattering albedo of RRTMG SW band 11
10287 ssa_02, & ! single scattering albedo of RRTMG SW band 10
10288 ssa_03, & ! single scattering albedo of RRTMG SW band 9
10289 ssa_04, & ! single scattering albedo of RRTMG SW band 8
10290 ssa_05 ! single scattering albedo of RRTMG SW band 7
10292 REAL, DIMENSION( ims:ime, jms:jme ), optional, INTENT(OUT) :: &
10293 sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
10294 sw_dirdflux, & ! Direct downward shortwave surface flux
10295 sw_difdflux ! Diffuse downward shortwave surface flux
10296 ! end WRF-CMAQ twoway coupled model block
10298 ! LOCAL VARS
10300 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
10301 Tw1D
10303 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
10304 CLDFRA1D, &
10305 DZ1D, &
10306 P1D, &
10307 T1D, &
10308 QV1D, &
10309 QC1D, &
10310 QR1D, &
10311 QI1D, &
10312 RHO1D, &
10313 QS1D, &
10314 QG1D, &
10315 O31D, &
10316 qndrop1d
10318 !BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996)
10319 real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, &
10320 re_30C=1250.0/9.208, re_20C=1250.0/9.387
10322 ! Added local arrays for RRTMG
10323 integer :: ncol, &
10324 nlay, &
10325 icld, &
10326 cldovrlp, & ! J. Henderson AER
10327 idcor, &
10328 juldat, &
10329 inflgsw, &
10330 iceflgsw, &
10331 liqflgsw
10332 ! Latitude
10333 real :: lat
10335 ! Dimension with extra layer from model top to TOA
10336 real, dimension( 1, kts:kte+2 ) :: plev, &
10337 tlev
10338 real, dimension( 1, kts:kte+1 ) :: play, &
10339 tlay, &
10340 h2ovmr, &
10341 o3vmr, &
10342 co2vmr, &
10343 o2vmr, &
10344 ch4vmr, &
10345 n2ovmr
10346 real, dimension( kts:kte+1 ) :: o3mmr
10347 ! mji - Add height of each layer for exponential-random cloud overlap
10348 ! This will be derived below from the dz in each layer
10349 real, dimension( 1, kts:kte+1 ) :: hgt
10350 real :: dzsum
10351 ! Surface albedo (for UV/visible and near-IR spectral regions,
10352 ! and for direct and diffuse radiation)
10353 real, dimension( 1 ) :: asdir, &
10354 asdif, &
10355 aldir, &
10356 aldif
10357 ! Dimension with extra layer from model top to TOA,
10358 ! though no clouds are allowed in extra layer
10359 real, dimension( 1, kts:kte+1 ) :: clwpth, &
10360 ciwpth, &
10361 cswpth, &
10362 rel, &
10363 rei, &
10364 res, &
10365 cldfrac, &
10366 relqmcl, &
10367 reicmcl, &
10368 resnmcl
10369 real, dimension( nbndsw, 1, kts:kte+1 ) :: taucld, &
10370 ssacld, &
10371 asmcld, &
10372 fsfcld
10373 real, dimension( ngptsw, 1, kts:kte+1 ) :: cldfmcl, &
10374 clwpmcl, &
10375 ciwpmcl, &
10376 cswpmcl, &
10377 taucmcl, &
10378 ssacmcl, &
10379 asmcmcl, &
10380 fsfcmcl
10381 real, dimension( 1, kts:kte+1, nbndsw ) :: tauaer, &
10382 ssaaer, &
10383 asmaer
10384 real, dimension( 1, kts:kte+1, naerec ) :: ecaer
10386 ! Output arrays contain extra layer from model top to TOA
10387 real, dimension( 1, kts:kte+2 ) :: swuflx, &
10388 swdflx, &
10389 swuflxc, &
10390 swdflxc, &
10391 swuflxcln, &
10392 swdflxcln, &
10393 sibvisdir, & ! Zhenxin 2011-06-20
10394 sibvisdif, &
10395 sibnirdir, &
10396 sibnirdif ! Zhenxin 2011-06-20
10398 real, dimension( 1, kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10
10399 swdkdif, & ! jararias, 2013/08/10
10400 swdkdirc ! PAJ
10402 real, dimension( 1, kts:kte+1 ) :: swhr, &
10403 swhrc
10405 real, dimension ( 1 ) :: tsfc, &
10406 ps, &
10407 coszen
10408 real :: ro, &
10409 dz, &
10410 adjes, &
10411 scon, &
10412 snow_mass_factor
10413 integer :: dyofyr
10415 integer:: idx_rei
10416 real:: corr
10418 ! Using data from CAMtr_volume_mixing_ratio data file
10419 real(kind=8) :: co2, n2o, ch4, cfc11, cfc12
10420 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
10421 real :: o2
10422 data o2 / 0.209488 /
10424 integer :: iplon, irng, permuteseed
10425 integer :: nb
10427 ! For old lw cloud property specification
10428 ! Cloud and precipitation absorption coefficients
10429 ! real :: abcw,abice,abrn,absn
10430 ! data abcw /0.144/
10431 ! data abice /0.0735/
10432 ! data abrn /0.330e-3/
10433 ! data absn /2.34e-3/
10435 ! Molecular weights and ratios for converting mmr to vmr units
10436 ! real :: amd ! Effective molecular weight of dry air (g/mol)
10437 ! real :: amw ! Molecular weight of water vapor (g/mol)
10438 ! real :: amo ! Molecular weight of ozone (g/mol)
10439 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
10440 ! Atomic weights for conversion from mass to volume mixing ratios
10441 ! data amd / 28.9660 /
10442 ! data amw / 18.0160 /
10443 ! data amo / 47.9998 /
10444 ! data amo2 / 31.9999 /
10446 real :: amdw ! Molecular weight of dry air / water vapor
10447 real :: amdo ! Molecular weight of dry air / ozone
10448 real :: amdo2 ! Molecular weight of dry air / oxygen
10449 data amdw / 1.607793 /
10450 data amdo / 0.603461 /
10451 data amdo2 / 0.905190 /
10453 !!
10454 real, dimension(1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
10456 real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
10457 cliqwp, & ! in-cloud cloud liquid water path
10458 csnowp, & ! in-cloud snow water path
10459 reliq, & ! effective drop radius (microns)
10460 reice ! ice effective drop size (microns)
10461 real, dimension(1, 1:kte-kts+1):: recloud1d, &
10462 reice1d, &
10463 resnow1d
10464 real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3
10466 !
10467 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
10468 REAL :: FP
10470 ! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
10471 real :: coszrs ! Cosine of solar zenith angle for present latitude
10472 logical :: dorrsw ! Flag to allow shortwave calculation
10474 real, dimension (1) :: landfrac, landm, snowh, icefrac
10476 integer :: pcols, pver
10478 INTEGER :: i,j,K, na
10479 LOGICAL :: predicate
10481 REAL :: da, eot ! jararias, 14/08/2013
10483 ! begin WRF-CMAQ twoway coupled model block
10484 #if ( WRF_CMAQ == 1 )
10485 REAL, DIMENSION (3) :: INMASS_ws, & ! holds mass cocentrations in [ ug/m**3 ] for
10486 ! water soluble species in all three modes
10487 INMASS_in, & ! holds mass cocentrations in [ ug/m**3 ] for
10488 ! water insoluble species in all three modes
10489 INMASS_ec, & ! holds mass cocentrations in [ ug/m**3 ] for
10490 ! elemental carbon species in all three modes
10491 INMASS_ss, & ! holds mass cocentrations in [ ug/m**3 ] for
10492 ! aerosol water species in all three modes
10493 INMASS_h2o, & ! holds mass cocentrations in [ ug/m**3 ] for
10494 ! sea salt species in all three modes
10495 INDGN, & ! holds geometric mean diameter in all three modes
10496 INSIG ! holds geometric standard deviation in all three modes
10497 #endif
10498 REAL :: xtauaer, & ! temporary variable for Aerosol Optical Depth
10499 waer, & ! temporary variable for single scattering albedo
10500 gaer, & ! temporary variable for symmetry factor
10501 delta_z, & ! layer thickness
10502 loc_sw_zbbcddir, & ! clearsky downward direct shortwave flux (w/m2)
10503 loc_sw_dirdflux, & ! Direct downward shortwave surface flux
10504 loc_sw_difdflux ! Diffuse downward shortwave surface flux
10506 INTEGER :: modes ! number of modes
10508 character (len = 50) :: mystr ! temporary character string
10509 ! end WRF-CMAQ twoway coupled model block
10511 CHARACTER(LEN=256) :: message
10512 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
10514 !------------------------------------------------------------------
10515 #if ( WRF_CHEM == 1 )
10516 IF ( aer_ra_feedback == 1) then
10517 IF ( .NOT. &
10518 ( PRESENT(tauaer300) .AND. &
10519 PRESENT(tauaer400) .AND. &
10520 PRESENT(tauaer600) .AND. &
10521 PRESENT(tauaer999) .AND. &
10522 PRESENT(gaer300) .AND. &
10523 PRESENT(gaer400) .AND. &
10524 PRESENT(gaer600) .AND. &
10525 PRESENT(gaer999) .AND. &
10526 PRESENT(waer300) .AND. &
10527 PRESENT(waer400) .AND. &
10528 PRESENT(waer600) .AND. &
10529 PRESENT(waer999) ) ) THEN
10530 CALL wrf_error_fatal &
10531 ('Warning: missing fields required for aerosol radiation' )
10532 ENDIF
10533 ENDIF
10534 #endif
10536 !-----CALCULATE SHORT WAVE RADIATION
10537 !
10538 ! Read time-varying trace gases concentrations and interpolate them to run date
10539 IF ( GHG_INPUT .EQ. 1 ) THEN
10540 CALL read_CAMgases(yr,julian,.false.,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
10541 IF ( wrf_dm_on_monitor() ) THEN
10542 WRITE(message,*)'RRTMG SW CLWRF interpolated GHG values year:',yr,' julian day:',julian
10543 call wrf_debug( 1, message)
10544 WRITE(message,*)' co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12
10545 call wrf_debug( 1, message)
10546 END IF
10547 ELSE
10548 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
10549 ! Annual function for co2 in WRF v4.2
10550 co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
10551 ! co2 = 379.e-6
10552 ch4 = 1774.e-9
10553 n2o = 319.e-9
10554 END IF
10556 ! All fields are ordered vertically from bottom to top
10557 ! Pressures are in mb
10559 ! latitude loop
10560 j_loop: do j = jts,jte
10562 ! longitude loop
10563 i_loop: do i = its,ite
10564 rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized
10565 !
10566 ! Do shortwave by default, deactivate below if sun below horizon
10567 dorrsw = .true.
10569 ! Cosine solar zenith angle for current time step
10570 !
10571 ! jararias, 14/08/2013
10572 coszr(i,j)=xcoszen(i,j)
10573 coszrs=xcoszen(i,j)
10575 ! Set flag to prevent shortwave calculation when sun below horizon
10576 if (coszrs.le.0.0) dorrsw = .false.
10577 ! Perform shortwave calculation if sun above horizon
10578 if (dorrsw) then
10580 do k=kts,kte+1
10581 Pw1D(K) = p8w(I,K,J)/100.
10582 Tw1D(K) = t8w(I,K,J)
10583 enddo
10585 DO K=kts,kte
10586 QV1D(K)=0.
10587 QC1D(K)=0.
10588 QR1D(K)=0.
10589 QI1D(K)=0.
10590 QS1D(K)=0.
10591 CLDFRA1D(k)=0.
10592 QNDROP1D(k)=0.
10593 ENDDO
10595 DO K=kts,kte
10596 QV1D(K)=QV3D(I,K,J)
10597 QV1D(K)=max(0.,QV1D(K))
10598 ENDDO
10600 IF (o3input.eq.2) THEN
10601 DO K=kts,kte
10602 O31D(K)=O33D(I,K,J)
10603 ENDDO
10604 ELSE
10605 DO K=kts,kte
10606 O31D(K)=0.0
10607 ENDDO
10608 ENDIF
10610 DO K=kts,kte
10611 TTEN1D(K)=0.
10612 T1D(K)=t3d(I,K,J)
10613 P1D(K)=p3d(I,K,J)/100.
10614 DZ1D(K)=dz8w(I,K,J)
10615 ENDDO
10617 ! moist variables
10619 IF (ICLOUD .ne. 0) THEN
10620 IF ( PRESENT( CLDFRA3D ) ) THEN
10621 DO K=kts,kte
10622 CLDFRA1D(k)=CLDFRA3D(I,K,J)
10623 ENDDO
10624 ENDIF
10626 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
10627 IF ( F_QC) THEN
10628 DO K=kts,kte
10629 QC1D(K)=QC3D(I,K,J)
10630 QC1D(K)=max(0.,QC1D(K))
10631 ENDDO
10632 ENDIF
10633 ENDIF
10635 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
10636 IF ( F_QR) THEN
10637 DO K=kts,kte
10638 QR1D(K)=QR3D(I,K,J)
10639 QR1D(K)=max(0.,QR1D(K))
10640 ENDDO
10641 ENDIF
10642 ENDIF
10644 IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
10645 IF (F_QNDROP) THEN
10646 DO K=kts,kte
10647 qndrop1d(K)=qndrop3d(I,K,J)
10648 ENDDO
10649 ENDIF
10650 ENDIF
10652 ! This logic is tortured because cannot test F_QI unless
10653 ! it is present, and order of evaluation of expressions
10654 ! is not specified in Fortran
10656 IF ( PRESENT ( F_QI ) ) THEN
10657 predicate = F_QI
10658 ELSE
10659 predicate = .FALSE.
10660 ENDIF
10662 ! For MP option 3
10663 IF (.NOT. predicate .and. .not. warm_rain) THEN
10664 DO K=kts,kte
10665 IF (T1D(K) .lt. 273.15) THEN
10666 QI1D(K)=QC1D(K)
10667 QS1D(K)=QR1D(K)
10668 QC1D(K)=0.
10669 QR1D(K)=0.
10670 ENDIF
10671 ENDDO
10672 ENDIF
10674 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
10675 IF (F_QI) THEN
10676 DO K=kts,kte
10677 QI1D(K)=QI3D(I,K,J)
10678 QI1D(K)=max(0.,QI1D(K))
10679 ENDDO
10680 ENDIF
10681 ENDIF
10683 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
10684 IF (F_QS) THEN
10685 DO K=kts,kte
10686 QS1D(K)=QS3D(I,K,J)
10687 QS1D(K)=max(0.,QS1D(K))
10688 ENDDO
10689 ENDIF
10690 ENDIF
10692 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
10693 IF (F_QG) THEN
10694 DO K=kts,kte
10695 QG1D(K)=QG3D(I,K,J)
10696 QG1D(K)=max(0.,QG1D(K))
10697 ENDDO
10698 ENDIF
10699 ENDIF
10701 ! mji - For MP option 5
10702 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
10703 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
10704 DO K=kts,kte
10705 qi1d(k) = 0.1*qs3d(i,k,j)
10706 qs1d(k) = 0.9*qs3d(i,k,j)
10707 qc1d(k) = qc3d(i,k,j)
10708 qi1d(k) = max(0.,qi1d(k))
10709 qc1d(k) = max(0.,qc1d(k))
10710 ENDDO
10711 ENDIF
10712 ENDIF
10714 ENDIF
10715 ! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires
10716 ! scheme), QI3D saves all frozen water (ice+snow)
10717 #if (HWRF == 1)
10718 IF ( mp_physics == FER_MP_HIRES .OR. &
10719 mp_physics == FER_MP_HIRES_ADVECT .OR. &
10720 mp_physics == ETAMP_HWRF ) THEN
10721 #else
10722 IF ( mp_physics == FER_MP_HIRES .OR. &
10723 mp_physics == FER_MP_HIRES_ADVECT) THEN
10724 #endif
10725 DO K=kts,kte
10726 qi1d(k) = qi3d(i,k,j)
10727 qs1d(k) = 0.0
10728 qc1d(k) = qc3d(i,k,j)
10729 qi1d(k) = max(0.,qi1d(k))
10730 qc1d(k) = max(0.,qc1d(k))
10731 ENDDO
10732 ENDIF
10733 !
10734 ! EMISS0=EMISS(I,J)
10735 ! GLW0=0.
10736 ! OLR0=0.
10737 ! TSFC=TSK(I,J)
10738 DO K=kts,kte
10739 QV1D(K)=AMAX1(QV1D(K),1.E-12)
10740 ENDDO
10742 ! Set up input for shortwave
10743 ncol = 1
10744 ! Add extra layer from top of model to top of atmosphere
10745 nlay = (kte - kts + 1) + 1
10747 ! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random
10748 icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld
10749 ! Set julian date
10750 juldat = julian
10752 ! Select cloud liquid and ice optics parameterization options
10753 ! For passing in cloud optical properties directly:
10754 ! inflgsw = 0
10755 ! iceflgsw = 0
10756 ! liqflgsw = 0
10757 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
10758 inflgsw = 2
10759 iceflgsw = 3
10760 liqflgsw = 1
10762 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
10763 IF (ICLOUD .ne. 0) THEN
10764 IF ( has_reqc .ne. 0) THEN
10765 inflgsw = 3
10766 DO K=kts,kte
10767 recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
10768 if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
10769 & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
10770 recloud1D(ncol,K) = 10.5
10771 elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
10772 & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
10773 recloud1D(ncol,K) = 7.5
10774 endif
10775 ENDDO
10776 ELSE
10777 DO K=kts,kte
10778 #if (EM_CORE==1)
10779 recloud1D(ncol,K) = 5.0
10780 #else
10781 recloud1D(ncol,K) = 10.0 ! was 5.0
10782 #endif
10783 ENDDO
10784 ENDIF
10786 IF ( has_reqi .ne. 0) THEN
10787 inflgsw = 4
10788 iceflgsw = 4
10789 DO K=kts,kte
10790 reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6)
10791 if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
10792 idx_rei = int(t3d(i,k,j)-179.)
10793 idx_rei = min(max(idx_rei,1),75)
10794 corr = t3d(i,k,j) - int(t3d(i,k,j))
10795 reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + &
10796 & retab(idx_rei+1)*corr
10797 reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0)
10798 endif
10799 ENDDO
10800 ELSE
10801 DO K=kts,kte
10802 reice1D(ncol,K) = 10.
10803 ENDDO
10804 ENDIF
10806 IF ( has_reqs .ne. 0) THEN
10807 inflgsw = 5
10808 iceflgsw = 5
10809 DO K=kts,kte
10810 resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
10811 ENDDO
10812 ELSE
10813 DO K=kts,kte
10814 #if (EM_CORE==1)
10815 resnow1D(ncol,K) = 10.0
10816 #else
10817 tem2 = 25.0 !- was 10.0
10818 tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3)
10819 if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3
10820 tem1=t1d(k)-273.15
10821 if (tem1 < -50.0) then
10822 tem2 = re_50C*tem3**0.109
10823 elseif (tem1 < -40.0) then
10824 tem2 = re_40C*tem3**0.08
10825 elseif (tem1 < -30.0) then
10826 tem2 = re_30C*tem3**0.055
10827 else
10828 tem2 = re_20C*tem3**0.031
10829 endif
10830 tem2 = max(25.,tem2)
10831 endif
10832 reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns
10833 #endif
10834 ENDDO
10835 ENDIF
10837 ! special case for P3 microphysics
10838 ! put ice into snow category for optics, then set ice to zero
10839 IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
10840 inflgsw = 5
10841 iceflgsw = 5
10842 DO K=kts,kte
10843 resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
10844 QS1D(K)=QI3D(I,K,J)
10845 QI1D(K)=0.
10846 reice1D(ncol,K)=10.
10847 END DO
10849 END IF
10851 ENDIF
10853 ! Set cosine of solar zenith angle
10854 coszen(ncol) = coszrs
10855 ! Set solar constant (original) amontornes-bcodina 2015/09
10856 ! scon = solcon
10857 ! amontornes-bcodina 2015/09 solar eclipses
10858 scon = solcon*(1-obscur(i,j))
10860 ! For Earth/Sun distance adjustment in RRTMG
10861 ! dyofyr = julday
10862 ! adjes = 0.0
10863 ! For WRF, solar constant is already provided with eccentricity adjustment,
10864 ! so do not do this in RRTMG
10865 dyofyr = 0
10866 adjes = 1.0
10868 ! Layer indexing goes bottom to top here for all fields.
10869 ! Water vapor and ozone are converted from mmr to vmr.
10870 ! Pressures are in units of mb here.
10871 plev(ncol,1) = pw1d(1)
10872 tlev(ncol,1) = tw1d(1)
10873 tsfc(ncol) = tsk(i,j)
10874 do k = kts, kte
10875 play(ncol,k) = p1d(k)
10876 plev(ncol,k+1) = pw1d(k+1)
10877 pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
10878 tlay(ncol,k) = t1d(k)
10879 tlev(ncol,k+1) = tw1d(k+1)
10880 h2ovmr(ncol,k) = qv1d(k) * amdw
10881 co2vmr(ncol,k) = co2
10882 o2vmr(ncol,k) = o2
10883 ch4vmr(ncol,k) = ch4
10884 n2ovmr(ncol,k) = n2o
10885 enddo
10887 ! mji - Derive height of each layer mid-point from layer thickness.
10888 ! Needed for exponential (icld=4) and exponential-random overlap option (icld=5) only.
10889 dzsum = 0.0
10890 do k = kts, kte
10891 dz = dz1d(k)
10892 hgt(ncol,k) = dzsum + 0.5*dz
10893 dzsum = dzsum + dz
10894 enddo
10896 ! Define profile values for extra layer from model top to top of atmosphere.
10897 ! The top layer temperature for all gridpoints is set to the top layer-1
10898 ! temperature plus a constant (0 K) that represents an isothermal layer
10899 ! above ptop. Top layer interface temperatures are linearly interpolated
10900 ! from the layer temperatures.
10902 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
10903 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
10904 plev(ncol,kte+2) = 1.0e-5
10905 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10906 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10907 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
10908 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10909 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
10910 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
10911 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
10913 ! mji - Fill in height array above model top to top of atmosphere using
10914 ! dz from model top layer for completeness, though this information is not
10915 ! likely to be used by the exponential-random cloud overlap method.
10916 hgt(ncol,kte+1) = dzsum + 0.5*dz
10918 ! Get ozone profile including amount in extra layer above model top
10919 call inirad (o3mmr,plev,kts,kte)
10921 if(o3input.eq.2) then
10922 do k = kts, kte+1
10923 o3vmr(ncol,k) = o3mmr(k) * amdo
10924 if(k.le.kte)then
10925 o3vmr(ncol,k) = o31d(k)
10926 else
10927 ! apply shifted climatology profile above model top
10928 o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
10929 if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
10930 endif
10931 enddo
10932 else
10933 do k = kts, kte+1
10934 o3vmr(ncol,k) = o3mmr(k) * amdo
10935 o31d(k) = o3vmr(ncol,k)
10936 enddo
10937 endif
10939 ! Set surface albedo for direct and diffuse radiation in UV/visible and
10940 ! near-IR spectral regions
10941 ! -------------- Zhenxin 2011-06-20 ----------- !
10943 ! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
10944 ! asdir(ncol) = albedo(i,j)
10945 ! asdif(ncol) = albedo(i,j)
10946 ! aldir(ncol) = albedo(i,j)
10947 ! aldif(ncol) = albedo(i,j)
10948 ! ------- End of Comments ------ !
10950 ! ------- 2. New Addiation ------ !
10951 IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
10952 asdir(ncol) = ALSWVISDIR(I,J)
10953 asdif(ncol) = ALSWVISDIF(I,J)
10954 aldir(ncol) = ALSWNIRDIR(I,J)
10955 aldif(ncol) = ALSWNIRDIF(I,J)
10956 ELSE
10957 asdir(ncol) = albedo(i,j)
10958 asdif(ncol) = albedo(i,j)
10959 aldir(ncol) = albedo(i,j)
10960 aldif(ncol) = albedo(i,j)
10961 ENDIF
10963 ! ---------- End of Addiation ------!
10964 ! ---------- End of fds_Zhenxin 2011-06-20 --------------!
10966 ! Define cloud optical properties for radiation (inflgsw = 0)
10967 ! This option is not currently active
10968 ! Cloud and precipitation paths in g/m2
10969 ! qi=0 if no ice phase
10970 ! qs=0 if no ice phase
10971 if (inflgsw .eq. 0) then
10973 ! Set cloud fraction and cloud optical properties here; not yet active
10974 do k = kts, kte
10975 cldfrac(ncol,k) = cldfra1d(k)
10976 do nb = 1, nbndsw
10977 taucld(nb,ncol,k) = 0.0
10978 ssacld(nb,ncol,k) = 1.0
10979 asmcld(nb,ncol,k) = 0.0
10980 fsfcld(nb,ncol,k) = 0.0
10981 enddo
10982 enddo
10984 ! Zero out cloud physical property arrays; not used when passing optical properties
10985 ! into radiation
10986 do k = kts, kte
10987 clwpth(ncol,k) = 0.0
10988 ciwpth(ncol,k) = 0.0
10989 rel(ncol,k) = 10.0
10990 rei(ncol,k) = 10.
10991 enddo
10992 endif
10994 ! Define cloud physical properties for radiation (inflgsw = 1 or 2)
10995 ! Cloud fraction
10996 ! Set cloud arrays if passing cloud physical properties into radiation
10997 if (inflgsw .gt. 0) then
10998 do k = kts, kte
10999 cldfrac(ncol,k) = cldfra1d(k)
11000 enddo
11002 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
11003 pcols = ncol
11004 pver = kte - kts + 1
11005 gravmks = g
11006 landfrac(ncol) = 2.-XLAND(I,J)
11007 landm(ncol) = landfrac(ncol)
11008 snowh(ncol) = 0.001*SNOW(I,J)
11009 icefrac(ncol) = XICE(I,J)
11011 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
11012 ! pdel is in mb here; convert back to Pa (*100.)
11013 ! Water paths are in units of g/m2
11014 ! snow added as ice cloud (JD 091022)
11015 do k = kts, kte
11016 gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
11017 gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
11018 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
11019 cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
11020 end do
11022 ! Mukul
11023 !..The ice water path is already sum of cloud ice and snow, but when we have explicit
11024 !.. ice effective radius, overwrite the ice path with only the cloud ice variable,
11025 !.. leaving out the snow for its own effect.
11026 if(iceflgsw.ge.4)then
11027 do k = kts, kte
11028 gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
11029 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
11030 end do
11031 end if
11033 !..Here the snow path is adjusted if (radiation) effective radius of snow is
11034 !.. larger than what we currently have in the lookup tables. Since mass goes
11035 !.. rather close to diameter squared, adjust the mixing ratio of snow used
11036 !.. to compute its water path in combination with the max diameter. Not a
11037 !.. perfect fix, but certainly better than using all snow mass when diameter is
11038 !.. far larger than table currently contains and crystal sizes much larger than
11039 !.. about 140 microns have lesser impact than those much smaller sizes.
11041 if(iceflgsw.eq.5)then
11042 do k = kts, kte
11043 snow_mass_factor = 0.99 ! Assume 1% of snow overlaps the cloud ice category
11044 gicewp = gicewp + (qs1d(k)*(1.0-snow_mass_factor) * pdel(ncol,k)*100.0 / gravmks * 1000.0)
11045 if (resnow1d(ncol,k) .gt. 130.)then
11046 snow_mass_factor = MIN(snow_mass_factor, &
11047 & (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)))
11048 resnow1d(ncol,k) = 130.0
11049 endif
11050 gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
11051 csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
11052 end do
11053 end if
11056 !link the aerosol feedback to cloud -czhao
11057 if( PRESENT( progn ) ) then
11058 if (progn == 1) then
11059 !jdfcz if(prescribe==0) then
11061 pi = 4.*atan(1.0)
11062 third=1./3.
11063 rhoh2o=1.e3
11064 relconst=3/(4.*pi*rhoh2o)
11065 ! minimun liquid water path to calculate rel
11066 ! corresponds to optical depth of 1.e-3 for radius 4 microns.
11067 lwpmin=3.e-5
11068 do k = kts, kte
11069 reliq(ncol,k) = 10.
11070 if( PRESENT( F_QNDROP ) ) then
11071 if( F_QNDROP ) then
11072 if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
11073 qndrop1d(k).gt.1000. ) then
11074 reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
11075 ! apply scaling from Martin et al., JAS 51, 1830.
11076 reliq(ncol,k)=1.1*reliq(ncol,k)
11077 reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
11078 reliq(ncol,k)=max(reliq(ncol,k),4.)
11079 reliq(ncol,k)=min(reliq(ncol,k),20.)
11080 end if
11081 end if
11082 end if
11083 end do
11084 !jdfcz else ! prescribe
11085 ! following Kiehl
11086 ! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11087 ! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
11088 !jdfcz endif
11089 else ! progn (progn=1)
11090 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11091 endif
11092 else !progn (PRESENT)
11093 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11094 endif
11096 ! following Kristjansson and Mitchell
11097 call reicalc(ncol, pcols, pver, tlay, reice)
11101 !..If we already have effective radius of cloud and ice, then just overwrite what
11102 !.. was computed in the relcalc and reicalc subroutines above.
11104 if (inflgsw .ge. 3) then
11105 do k = kts, kte
11106 reliq(ncol,k) = recloud1d(ncol,k)
11107 end do
11108 endif
11109 #if (EM_CORE==1)
11110 if (iceflgsw .ge. 4) then
11111 #else
11112 if (iceflgsw .ge. 3) then !BSF: was .ge. 4
11113 #endif
11114 do k = kts, kte
11115 reice(ncol,k) = reice1d(ncol,k)
11116 end do
11117 endif
11120 #if 0
11121 if (i==80.and.j==30) then
11122 #if defined( DM_PARALLEL ) && ! defined( STUBMPI)
11123 if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
11124 write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
11125 write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
11126 #endif
11127 endif
11128 #endif
11131 ! Limit upper bound of reice for Fu ice parameterization and convert
11132 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
11133 if (iceflgsw .eq. 3) then
11134 do k = kts, kte
11135 reice(ncol,k) = reice(ncol,k) * 1.0315
11136 reice(ncol,k) = min(140.0,reice(ncol,k))
11137 end do
11138 endif
11140 !if CAMMGMP is used, use output from CAMMGMP
11141 !PMA
11142 if(is_CAMMGMP_used) then
11143 do k = kts, kte
11144 if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
11145 reice(ncol,k) = iradius(i,k,j)
11146 else
11147 reice(ncol,k) = 25.
11148 end if
11149 reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
11150 if ( qc1d(k) .gt. 1.e-20) then
11151 reliq(ncol,k) = lradius(i,k,j)
11152 else
11153 reliq(ncol,k) = 10.
11154 end if
11155 reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
11156 enddo
11157 endif
11159 ! Set cloud physical property arrays
11160 do k = kts, kte
11161 clwpth(ncol,k) = cliqwp(ncol,k)
11162 ciwpth(ncol,k) = cicewp(ncol,k)
11163 rel(ncol,k) = reliq(ncol,k)
11164 rei(ncol,k) = reice(ncol,k)
11165 enddo
11167 !Mukul
11168 if (inflgsw .eq. 5) then
11169 do k = kts, kte
11170 cswpth(ncol,k) = csnowp(ncol,k)
11171 res(ncol,k) = resnow1d(ncol,k)
11172 end do
11173 else
11174 do k = kts, kte
11175 cswpth(ncol,k) = 0.0
11176 res(ncol,k) = 10.0
11177 end do
11178 endif
11180 ! Zero out cloud optical properties here, calculated in radiation
11181 do k = kts, kte
11182 do nb = 1, nbndsw
11183 taucld(nb,ncol,k) = 0.0
11184 ssacld(nb,ncol,k) = 1.0
11185 asmcld(nb,ncol,k) = 0.0
11186 fsfcld(nb,ncol,k) = 0.0
11187 enddo
11188 enddo
11189 endif
11191 ! No clouds are allowed in the extra layer from model top to TOA
11192 clwpth(ncol,kte+1) = 0.
11193 ciwpth(ncol,kte+1) = 0.
11194 cswpth(ncol,kte+1) = 0.
11195 rel(ncol,kte+1) = 10.
11196 rei(ncol,kte+1) = 10.
11197 res(ncol,kte+1) = 10.
11198 cldfrac(ncol,kte+1) = 0.
11199 do nb = 1, nbndsw
11200 taucld(nb,ncol,kte+1) = 0.
11201 ssacld(nb,ncol,kte+1) = 1.
11202 asmcld(nb,ncol,kte+1) = 0.
11203 fsfcld(nb,ncol,kte+1) = 0.
11204 enddo
11206 iplon = 1
11207 irng = 0
11208 permuteseed = 1
11210 ! Sub-column generator for McICA
11211 lat = XLAT(i,j) !retrieve scalar latitude for column calculation
11212 call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
11213 cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
11214 hgt, idcor, juldat, lat, &
11215 cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
11216 taucmcl, ssacmcl, asmcmcl, fsfcmcl)
11219 !--------------------------------------------------------------------------
11220 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
11221 !--------------------------------------------------------------------------
11222 ! by layer for each RRTMG shortwave band
11223 ! No aerosols in top layer above model top (kte+1).
11224 !cz do nb = 1, nbndsw
11225 !cz do k = kts, kte+1
11226 !cz tauaer(ncol,k,nb) = 0.
11227 !cz ssaaer(ncol,k,nb) = 1.
11228 !cz asmaer(ncol,k,nb) = 0.
11229 !cz enddo
11230 !cz enddo
11232 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
11233 !
11234 #if ( WRF_CMAQ == 1 )
11235 do nb = 1, nbndsw
11236 do k = kts,kte+1
11237 tauaer(ncol,k,nb) = 0.
11238 ssaaer(ncol,k,nb) = 1.
11239 asmaer(ncol,k,nb) = 0.
11241 if (proceed_cmaq_sw) then
11242 INMASS_ws(1) = mass_ws_i(i,k,j)
11243 INMASS_ws(2) = mass_ws_j(i,k,j)
11244 INMASS_ws(3) = mass_ws_k(i,k,j)
11245 INMASS_in(1) = mass_in_i(i,k,j)
11246 INMASS_in(2) = mass_in_j(i,k,j)
11247 INMASS_in(3) = mass_in_k(i,k,j)
11248 INMASS_ec(1) = mass_ec_i(i,k,j)
11249 INMASS_ec(2) = mass_ec_j(i,k,j)
11250 INMASS_ec(3) = mass_ec_k(i,k,j)
11251 INMASS_ss(1) = mass_ss_i(i,k,j)
11252 INMASS_ss(2) = mass_ss_j(i,k,j)
11253 INMASS_ss(3) = mass_ss_k(i,k,j)
11254 INMASS_h2o(1) = mass_h2o_i(i,k,j)
11255 INMASS_h2o(2) = mass_h2o_j(i,k,j)
11256 INMASS_h2o(3) = mass_h2o_k(i,k,j)
11257 INDGN(1) = dgn_i(i,k,j)
11258 INDGN(2) = dgn_j(i,k,j)
11259 INDGN(3) = dgn_k(i,k,j)
11260 INSIG(1) = sig_i(i,k,j)
11261 INSIG(2) = sig_j(i,k,j)
11262 INSIG(3) = sig_k(i,k,j)
11264 delta_z = dz8w(i,k,j)
11266 call get_aerosol_Optics_RRTMG_SW( nb,nmode,delta_z, &
11267 INMASS_ws, INMASS_in, INMASS_ec, INMASS_ss, &
11268 INMASS_h2o, INDGN, INSIG, &
11269 xtauaer, waer, gaer )
11271 write (mystr, *) xtauaer
11272 if (trim(mystr) == ' NaN') then
11273 write (6, '(a13, 2i5)') ' ==d== ', nb, nmode
11274 write (6, '(a13, 5e18.10)') ' ==d== delta ', delta_z
11275 write (6, '(a13, 5e18.10)') ' ==d== ws ', INMASS_ws
11276 write (6, '(a13, 5e18.10)') ' ==d== in ', INMASS_in
11277 write (6, '(a13, 5e18.10)') ' ==d== ec ', INMASS_ec
11278 write (6, '(a13, 5e18.10)') ' ==d== ss ', INMASS_ss
11279 write (6, '(a13, 5e18.10)') ' ==d== h2o ', INMASS_h2o
11280 write (6, '(a13, 5e18.10)') ' ==d== indgn ', INDGN
11281 write (6, '(a13, 5e18.10)') ' ==d== insig ', INSIG
11282 end if
11284 if (nb == 11) then
11285 gtauxar_01 (i,k,j) = xtauaer
11286 asy_fac_01 (i,k,j) = gaer
11287 ssa_01 (i,k,j) = waer
11288 else if (nb == 10) then
11289 gtauxar_02 (i,k,j) = xtauaer
11290 asy_fac_02 (i,k,j) = gaer
11291 ssa_02 (i,k,j) = waer
11292 else if (nb == 9) then
11293 gtauxar_03 (i,k,j) = xtauaer
11294 asy_fac_03 (i,k,j) = gaer
11295 ssa_03 (i,k,j) = waer
11296 else if (nb == 8) then
11297 gtauxar_04 (i,k,j) = xtauaer
11298 asy_fac_04 (i,k,j) = gaer
11299 ssa_04 (i,k,j) = waer
11300 else if (nb == 7) then
11301 gtauxar_05 (i,k,j) = xtauaer
11302 asy_fac_05 (i,k,j) = gaer
11303 ssa_05 (i,k,j) = waer
11304 end if
11306 tauaer(ncol,k,nb) = xtauaer
11307 ssaaer(ncol,k,nb) = waer
11308 asmaer(ncol,k,nb) = gaer
11309 end if
11310 enddo ! loop over layers
11311 if (proceed_cmaq_sw) then
11312 ! No aerosols in top layer above model top (kte+1).
11313 tauaer(ncol, kte+1 ,nb) = 0.
11314 ssaaer(ncol, kte+1 ,nb) = 1.
11315 asmaer(ncol, kte+1 ,nb) = 0.
11316 end if
11317 enddo ! loop over wavelengths
11318 #else
11319 do nb = 1, nbndsw
11320 do k = kts,kte+1
11321 tauaer(ncol,k,nb) = 0.
11322 ssaaer(ncol,k,nb) = 1.
11323 asmaer(ncol,k,nb) = 0.
11324 end do
11325 end do
11327 if ( associated (tauaer3d_sw) ) then
11328 ! ---- jararias 11/2012
11329 do nb=1,nbndsw
11330 do k=kts,kte
11331 tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb)
11332 ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb)
11333 asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb)
11334 end do
11335 end do
11336 end if
11337 #endif
11339 #if ( WRF_CHEM == 1 )
11340 IF ( AER_RA_FEEDBACK == 1) then
11341 do nb = 1, nbndsw
11342 wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
11343 do k = kts,kte !wig
11345 ! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
11346 ! tauaer - use angstrom exponent
11347 if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
11348 ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
11349 tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11350 !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
11351 if (i==30.and.j==49.and.k==2.and.nb==12) then
11352 write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
11353 print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
11354 write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11355 print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
11356 endif
11357 ! ssa - linear interpolation; extrapolation
11358 slope=(waer600(i,k,j)-waer400(i,k,j))/.2
11359 ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
11360 if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
11361 if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
11362 ! g - linear interpolation;extrapolation
11363 slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
11364 asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
11365 if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
11366 if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
11367 endif
11368 end do ! k
11369 end do ! nb
11371 !wig beg
11372 do nb = 1, nbndsw
11373 slope = 0. !use slope as a sum holder
11374 do k = kts,kte
11375 slope = slope + tauaer(ncol,k,nb)
11376 end do
11377 if( slope < 0. ) then
11378 write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
11379 call wrf_error_fatal(msg)
11380 else if( slope > 6. ) then
11381 call wrf_message("-------------------------")
11382 write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
11383 call wrf_message(msg)
11385 call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
11386 do k=kts,kte
11387 write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
11388 tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
11389 call wrf_message(msg)
11390 !czhao set an up-limit here to avoid segmentation fault
11391 !from extreme AOD
11392 tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope
11393 end do
11395 call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
11396 do k=kts,kte
11397 write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
11398 gaer600(i,k,j), gaer999(i,k,j)
11399 call wrf_message(msg)
11400 end do
11402 call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
11403 do k=kts,kte
11404 write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
11405 waer600(i,k,j), waer999(i,k,j)
11406 call wrf_message(msg)
11407 end do
11409 call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
11410 do k=kts-1,kte
11411 write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
11412 call wrf_message(msg)
11413 end do
11414 call wrf_message("-------------------------")
11415 endif
11416 enddo ! nb
11417 endif ! aer_ra_feedback
11418 #endif
11421 ! Zero array for input of aerosol optical thickness for use with
11422 ! ECMWF aerosol types (not used)
11423 do na = 1, naerec
11424 do k = kts, kte+1
11425 ecaer(ncol,k,na) = 0.
11426 enddo
11427 enddo
11429 IF ( PRESENT( aerod ) ) THEN
11430 if ( aer_opt .eq. 0 ) then
11431 do na = 1, naerec
11432 do k = kts, kte+1
11433 ecaer(ncol,k,na) = 0.
11434 enddo
11435 enddo
11436 else if ( aer_opt .eq. 1 ) then
11437 do na = 1, naerec
11438 do k = kts, kte
11439 ecaer(ncol,k,na) = aerod(i,k,j,na)
11440 enddo
11441 ! assuming 0 or same value at the top?
11442 ! ecaer(ncol,kte+1,na) = ecaer(ncol,kte,na)
11443 ecaer(ncol,kte+1,na) = 0.
11444 enddo
11445 endif
11446 ENDIF
11448 ! Call RRTMG shortwave radiation model
11450 call rrtmg_sw &
11451 (ncol ,nlay ,icld , &
11452 play ,plev ,tlay ,tlev ,tsfc , &
11453 h2ovmr , o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
11454 asdir ,asdif ,aldir ,aldif , &
11455 coszen ,adjes ,dyofyr ,scon , &
11456 inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
11457 taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
11458 ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, &
11459 tauaer ,ssaaer ,asmaer ,ecaer , &
11460 swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, swuflxcln, swdflxcln, aer_opt, &
11461 ! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
11462 sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
11463 ! -------------------- End of addiation by Zhenxin 2011-06-20 ------!
11464 swdkdir, swdkdif, & ! jararias, 2012/08/10
11465 swdkdirc & ! PAJ
11466 ,calc_clean_atm_diag &
11467 ,loc_sw_zbbcddir & ! WRF-CMAQ twoway coupled model
11468 ,loc_sw_dirdflux & ! WRF-CMAQ twoway coupled model
11469 ,loc_sw_difdflux & ! WRF-CMAQ twoway coupled model
11470 )
11472 ! WRF-CMAQ twoway coupled model
11473 if (present(sw_zbbcddir)) then
11474 sw_zbbcddir(i,j) = loc_sw_zbbcddir
11475 sw_dirdflux(i,j) = loc_sw_dirdflux
11476 sw_difdflux(i,j) = loc_sw_difdflux
11477 end if
11479 ! Output net absorbed shortwave surface flux and shortwave cloud forcing
11480 ! at the top of atmosphere (W/m2)
11481 gsw(i,j) = swdflx(1,1) - swuflx(1,1)
11482 swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2))
11484 if (present(swupt)) then
11485 ! Output up and down toa fluxes for total and clear sky
11486 swupt(i,j) = swuflx(1,kte+2)
11487 swuptc(i,j) = swuflxc(1,kte+2)
11488 swdnt(i,j) = swdflx(1,kte+2)
11489 swdntc(i,j) = swdflxc(1,kte+2)
11490 ! Output up and down surface fluxes for total and clear sky
11491 swupb(i,j) = swuflx(1,1)
11492 swupbc(i,j) = swuflxc(1,1)
11493 swdnb(i,j) = swdflx(1,1)
11494 ! Added by Zhenxin for 4 compenants of swdown radiation
11495 swvisdir(i,j) = sibvisdir(1,1)
11496 swvisdif(i,j) = sibvisdif(1,1)
11497 swnirdir(i,j) = sibnirdir(1,1)
11498 swnirdif(i,j) = sibnirdif(1,1)
11499 ! Ended, Zhenxin (2011/06/20)
11500 swdnbc(i,j) = swdflxc(1,1)
11501 if(calc_clean_atm_diag .gt. 0)then
11502 swuptcln(i,j) = swuflxcln(1,kte+2)
11503 swdntcln(i,j) = swdflxcln(1,kte+2)
11504 swupbcln(i,j) = swuflxcln(1,1)
11505 swdnbcln(i,j) = swdflxcln(1,1)
11506 end if
11507 endif
11508 swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10
11509 swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10
11510 swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10
11511 swdownc(i, j) = swdflxc(1,1) ! PAJ: clear-sky GHI
11512 swddirc(i,j) = swdkdirc(1,1) ! PAJ: clear-sky direct normal irradiance
11513 swddnic(i,j) = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance
11515 ! Output up and down layer fluxes for total and clear sky.
11516 ! Vertical ordering is from bottom to top in units of W m-2.
11517 if ( present (swupflx) ) then
11518 do k=kts,kte+2
11519 swupflx(i,k,j) = swuflx(1,k)
11520 swupflxc(i,k,j) = swuflxc(1,k)
11521 swdnflx(i,k,j) = swdflx(1,k)
11522 swdnflxc(i,k,j) = swdflxc(1,k)
11523 enddo
11524 endif
11526 ! Output heating rate tendency; convert heating rate from K/d to K/s
11527 ! Heating rate arrays are ordered vertically from bottom to top here.
11528 do k=kts,kte
11529 tten1d(k) = swhr(ncol,k)/86400.
11530 rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
11531 tten1d(k) = swhrc(ncol,k)/86400.
11532 rthratenswc(i,k,j) = tten1d(k)/pi3d(i,k,j)
11533 enddo
11534 else
11536 if (proceed_cmaq_sw) then ! this is for WRF-CMAQ twoway coupled model
11537 gtauxar_01 (i,:,j) = 0.0
11538 gtauxar_02 (i,:,j) = 0.0
11539 gtauxar_03 (i,:,j) = 0.0
11540 gtauxar_04 (i,:,j) = 0.0
11541 gtauxar_05 (i,:,j) = 0.0
11542 asy_fac_01 (i,:,j) = 0.0
11543 asy_fac_02 (i,:,j) = 0.0
11544 asy_fac_03 (i,:,j) = 0.0
11545 asy_fac_04 (i,:,j) = 0.0
11546 asy_fac_05 (i,:,j) = 0.0
11547 ssa_01 (i,:,j) = 0.0
11548 ssa_02 (i,:,j) = 0.0
11549 ssa_04 (i,:,j) = 0.0
11550 ssa_04 (i,:,j) = 0.0
11551 ssa_05 (i,:,j) = 0.0
11552 end if
11554 if (present(swupt)) then
11555 ! Output up and down toa fluxes for total and clear sky
11556 swupt(i,j) = 0.
11557 swuptc(i,j) = 0.
11558 swdnt(i,j) = 0.
11559 swdntc(i,j) = 0.
11560 ! Output up and down surface fluxes for total and clear sky
11561 swupb(i,j) = 0.
11562 swupbc(i,j) = 0.
11563 swdnb(i,j) = 0.
11564 swdnbc(i,j) = 0.
11565 swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
11566 swvisdif(i,j) = 0.
11567 swnirdir(i,j) = 0.
11568 swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
11569 if(calc_clean_atm_diag .gt. 0)then
11570 swuptcln(i,j) = 0.
11571 swdntcln(i,j) = 0.
11572 swupbcln(i,j) = 0.
11573 swdnbcln(i,j) = 0.
11574 end if
11575 endif
11576 swddir(i,j) = 0. ! jararias 2013/08/10
11577 swddni(i,j) = 0. ! jararias 2013/08/10
11578 swddif(i,j) = 0. ! jararias 2013/08/10
11579 swdownc(i, j) = 0.0 ! PAJ
11580 swddnic(i,j) = 0.0 ! PAJ
11581 swddirc(i,j) = 0.0 ! PAJ
11582 swcf(i,j) = 0.
11584 endif
11585 !
11586 end do i_loop
11587 end do j_loop
11590 !-------------------------------------------------------------------
11592 END SUBROUTINE RRTMG_SWRAD
11595 !====================================================================
11596 SUBROUTINE rrtmg_swinit( &
11597 allowed_to_read , &
11598 ids, ide, jds, jde, kds, kde, &
11599 ims, ime, jms, jme, kms, kme, &
11600 its, ite, jts, jte, kts, kte )
11601 !--------------------------------------------------------------------
11602 IMPLICIT NONE
11603 !--------------------------------------------------------------------
11605 LOGICAL , INTENT(IN) :: allowed_to_read
11606 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
11607 ims, ime, jms, jme, kms, kme, &
11608 its, ite, jts, jte, kts, kte
11610 ! Read in absorption coefficients and other data
11611 IF ( allowed_to_read ) THEN
11612 CALL rrtmg_swlookuptable
11613 ENDIF
11615 ! Perform g-point reduction and other initializations
11616 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
11617 call rrtmg_sw_ini(cp)
11619 END SUBROUTINE rrtmg_swinit
11622 ! **************************************************************************
11623 SUBROUTINE rrtmg_swlookuptable
11624 ! **************************************************************************
11626 IMPLICIT NONE
11628 ! Local
11629 INTEGER :: i
11630 LOGICAL :: opened
11631 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
11633 CHARACTER*80 errmess
11634 INTEGER rrtmg_unit
11636 IF ( wrf_dm_on_monitor() ) THEN
11637 DO i = 10,99
11638 INQUIRE ( i , OPENED = opened )
11639 IF ( .NOT. opened ) THEN
11640 rrtmg_unit = i
11641 GOTO 2010
11642 ENDIF
11643 ENDDO
11644 rrtmg_unit = -1
11645 2010 CONTINUE
11646 ENDIF
11647 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
11648 IF ( rrtmg_unit < 0 ) THEN
11649 CALL wrf_error_fatal ( 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// &
11650 'find unused fortran unit to read in lookup table.' )
11651 ENDIF
11653 IF ( wrf_dm_on_monitor() ) THEN
11654 OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA', &
11655 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
11656 ENDIF
11658 call sw_kgb16(rrtmg_unit)
11659 call sw_kgb17(rrtmg_unit)
11660 call sw_kgb18(rrtmg_unit)
11661 call sw_kgb19(rrtmg_unit)
11662 call sw_kgb20(rrtmg_unit)
11663 call sw_kgb21(rrtmg_unit)
11664 call sw_kgb22(rrtmg_unit)
11665 call sw_kgb23(rrtmg_unit)
11666 call sw_kgb24(rrtmg_unit)
11667 call sw_kgb25(rrtmg_unit)
11668 call sw_kgb26(rrtmg_unit)
11669 call sw_kgb27(rrtmg_unit)
11670 call sw_kgb28(rrtmg_unit)
11671 call sw_kgb29(rrtmg_unit)
11673 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
11675 RETURN
11676 9009 CONTINUE
11677 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
11678 CALL wrf_error_fatal(errmess)
11680 END SUBROUTINE rrtmg_swlookuptable
11682 ! **************************************************************************
11683 ! RRTMG Shortwave Radiative Transfer Model
11684 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
11685 !
11686 ! Original by J.Delamere, Atmospheric & Environmental Research.
11687 ! Reformatted for F90: JJMorcrette, ECMWF
11688 ! Revision for GCMs: Michael J. Iacono, AER, July 2002
11689 ! Further F90 reformatting: Michael J. Iacono, AER, June 2006
11690 !
11691 ! This file contains 14 READ statements that include the
11692 ! absorption coefficients and other data for each of the 14 shortwave
11693 ! spectral bands used in RRTMG_SW. Here, the data are defined for 16
11694 ! g-points, or sub-intervals, per band. These data are combined and
11695 ! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
11696 ! the total number of g-points from 224 to 112 for use in the GCM.
11697 ! **************************************************************************
11699 ! **************************************************************************
11700 subroutine sw_kgb16(rrtmg_unit)
11701 ! **************************************************************************
11703 use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11704 rayl, strrat1, layreffr
11706 implicit none
11707 save
11709 ! Input
11710 integer, intent(in) :: rrtmg_unit
11712 ! Local
11713 character*80 errmess
11714 logical, external :: wrf_dm_on_monitor
11716 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11718 ! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
11720 ! The array KAO contains absorption coefs at the 16 chosen g-values
11721 ! for a range of pressure levels> ~100mb, temperatures, and binary
11722 ! species parameters (see taumol.f for definition). The first
11723 ! index in the array, JS, runs from 1 to 9, and corresponds to
11724 ! different values of the binary species parameter. For instance,
11725 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11726 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11727 ! in the array, JT, which runs from 1 to 5, corresponds to different
11728 ! temperatures. More specifically, JT = 3 means that the data are for
11729 ! the reference temperature TREF for this pressure level, JT = 2 refers
11730 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11731 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11732 ! to the JPth reference pressure level (see taumol.f for these levels
11733 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11734 ! which g-interval the absorption coefficients are for.
11736 ! The array KBO contains absorption coefs at the 16 chosen g-values
11737 ! for a range of pressure levels < ~100mb and temperatures. The first
11738 ! index in the array, JT, which runs from 1 to 5, corresponds to
11739 ! different temperatures. More specifically, JT = 3 means that the
11740 ! data are for the reference temperature TREF for this pressure
11741 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11742 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11743 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11744 ! reference pressure level (see taumol.f for the value of these
11745 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11746 ! and tells us which g-interval the absorption coefficients are for.
11748 ! The array FORREFO contains the coefficient of the water vapor
11749 ! foreign-continuum (including the energy term). The first
11750 ! index refers to reference temperature (296,260,224,260) and
11751 ! pressure (970,475,219,3 mbar) levels. The second index
11752 ! runs over the g-channel (1 to 16).
11754 ! The array SELFREFO contains the coefficient of the water vapor
11755 ! self-continuum (including the energy term). The first index
11756 ! refers to temperature in 7.2 degree increments. For instance,
11757 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11758 ! etc. The second index runs over the g-channel (1 to 16).
11760 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11761 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11762 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11764 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11765 rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11766 DM_BCAST_REAL(rayl)
11767 DM_BCAST_REAL(strrat1)
11768 DM_BCAST_INTEGER(layreffr)
11769 DM_BCAST_MACRO(kao)
11770 DM_BCAST_MACRO(kbo)
11771 DM_BCAST_MACRO(selfrefo)
11772 DM_BCAST_MACRO(forrefo)
11773 DM_BCAST_MACRO(sfluxrefo)
11775 RETURN
11776 9010 CONTINUE
11777 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11778 CALL wrf_error_fatal(errmess)
11780 end subroutine sw_kgb16
11782 ! **************************************************************************
11783 subroutine sw_kgb17(rrtmg_unit)
11784 ! **************************************************************************
11786 use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11787 rayl, strrat, layreffr
11789 implicit none
11790 save
11792 ! Input
11793 integer, intent(in) :: rrtmg_unit
11795 ! Local
11796 character*80 errmess
11797 logical, external :: wrf_dm_on_monitor
11799 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11801 ! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
11803 ! The array KAO contains absorption coefs at the 16 chosen g-values
11804 ! for a range of pressure levels> ~100mb, temperatures, and binary
11805 ! species parameters (see taumol.f for definition). The first
11806 ! index in the array, JS, runs from 1 to 9, and corresponds to
11807 ! different values of the binary species parameter. For instance,
11808 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11809 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11810 ! in the array, JT, which runs from 1 to 5, corresponds to different
11811 ! temperatures. More specifically, JT = 3 means that the data are for
11812 ! the reference temperature TREF for this pressure level, JT = 2 refers
11813 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11814 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11815 ! to the JPth reference pressure level (see taumol.f for these levels
11816 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11817 ! which g-interval the absorption coefficients are for.
11819 ! The array KBO contains absorption coefs at the 16 chosen g-values
11820 ! for a range of pressure levels < ~100mb and temperatures. The first
11821 ! index in the array, JT, which runs from 1 to 5, corresponds to
11822 ! different temperatures. More specifically, JT = 3 means that the
11823 ! data are for the reference temperature TREF for this pressure
11824 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11825 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11826 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11827 ! reference pressure level (see taumol.f for the value of these
11828 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11829 ! and tells us which g-interval the absorption coefficients are for.
11831 ! The array FORREFO contains the coefficient of the water vapor
11832 ! foreign-continuum (including the energy term). The first
11833 ! index refers to reference temperature (296,260,224,260) and
11834 ! pressure (970,475,219,3 mbar) levels. The second index
11835 ! runs over the g-channel (1 to 16).
11837 ! The array SELFREFO contains the coefficient of the water vapor
11838 ! self-continuum (including the energy term). The first index
11839 ! refers to temperature in 7.2 degree increments. For instance,
11840 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11841 ! etc. The second index runs over the g-channel (1 to 16).
11843 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11844 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11845 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11847 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11848 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11849 DM_BCAST_REAL(rayl)
11850 DM_BCAST_REAL(strrat)
11851 DM_BCAST_INTEGER(layreffr)
11852 DM_BCAST_MACRO(kao)
11853 DM_BCAST_MACRO(kbo)
11854 DM_BCAST_MACRO(selfrefo)
11855 DM_BCAST_MACRO(forrefo)
11856 DM_BCAST_MACRO(sfluxrefo)
11858 RETURN
11859 9010 CONTINUE
11860 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11861 CALL wrf_error_fatal(errmess)
11863 end subroutine sw_kgb17
11865 ! **************************************************************************
11866 subroutine sw_kgb18(rrtmg_unit)
11867 ! **************************************************************************
11869 use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11870 rayl, strrat, layreffr
11872 implicit none
11873 save
11875 ! Input
11876 integer, intent(in) :: rrtmg_unit
11878 ! Local
11879 character*80 errmess
11880 logical, external :: wrf_dm_on_monitor
11882 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11884 ! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
11886 ! The array KAO contains absorption coefs at the 16 chosen g-values
11887 ! for a range of pressure levels> ~100mb, temperatures, and binary
11888 ! species parameters (see taumol.f for definition). The first
11889 ! index in the array, JS, runs from 1 to 9, and corresponds to
11890 ! different values of the binary species parameter. For instance,
11891 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11892 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11893 ! in the array, JT, which runs from 1 to 5, corresponds to different
11894 ! temperatures. More specifically, JT = 3 means that the data are for
11895 ! the reference temperature TREF for this pressure level, JT = 2 refers
11896 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11897 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11898 ! to the JPth reference pressure level (see taumol.f for these levels
11899 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11900 ! which g-interval the absorption coefficients are for.
11902 ! The array KBO contains absorption coefs at the 16 chosen g-values
11903 ! for a range of pressure levels < ~100mb and temperatures. The first
11904 ! index in the array, JT, which runs from 1 to 5, corresponds to
11905 ! different temperatures. More specifically, JT = 3 means that the
11906 ! data are for the reference temperature TREF for this pressure
11907 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11908 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11909 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11910 ! reference pressure level (see taumol.f for the value of these
11911 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11912 ! and tells us which g-interval the absorption coefficients are for.
11914 ! The array FORREFO contains the coefficient of the water vapor
11915 ! foreign-continuum (including the energy term). The first
11916 ! index refers to reference temperature (296,260,224,260) and
11917 ! pressure (970,475,219,3 mbar) levels. The second index
11918 ! runs over the g-channel (1 to 16).
11920 ! The array SELFREFO contains the coefficient of the water vapor
11921 ! self-continuum (including the energy term). The first index
11922 ! refers to temperature in 7.2 degree increments. For instance,
11923 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11924 ! etc. The second index runs over the g-channel (1 to 16).
11926 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
11927 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
11928 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
11930 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
11931 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11932 DM_BCAST_REAL(rayl)
11933 DM_BCAST_REAL(strrat)
11934 DM_BCAST_INTEGER(layreffr)
11935 DM_BCAST_MACRO(kao)
11936 DM_BCAST_MACRO(kbo)
11937 DM_BCAST_MACRO(selfrefo)
11938 DM_BCAST_MACRO(forrefo)
11939 DM_BCAST_MACRO(sfluxrefo)
11941 RETURN
11942 9010 CONTINUE
11943 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11944 CALL wrf_error_fatal(errmess)
11946 end subroutine sw_kgb18
11948 ! **************************************************************************
11949 subroutine sw_kgb19(rrtmg_unit)
11950 ! **************************************************************************
11952 use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
11953 rayl, strrat, layreffr
11955 implicit none
11956 save
11958 ! Input
11959 integer, intent(in) :: rrtmg_unit
11961 ! Local
11962 character*80 errmess
11963 logical, external :: wrf_dm_on_monitor
11965 ! Array sfluxrefo contains the Kurucz solar source function for this band.
11967 ! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
11969 ! The array KAO contains absorption coefs at the 16 chosen g-values
11970 ! for a range of pressure levels> ~100mb, temperatures, and binary
11971 ! species parameters (see taumol.f for definition). The first
11972 ! index in the array, JS, runs from 1 to 9, and corresponds to
11973 ! different values of the binary species parameter. For instance,
11974 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11975 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
11976 ! in the array, JT, which runs from 1 to 5, corresponds to different
11977 ! temperatures. More specifically, JT = 3 means that the data are for
11978 ! the reference temperature TREF for this pressure level, JT = 2 refers
11979 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11980 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
11981 ! to the JPth reference pressure level (see taumol.f for these levels
11982 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
11983 ! which g-interval the absorption coefficients are for.
11985 ! The array KBO contains absorption coefs at the 16 chosen g-values
11986 ! for a range of pressure levels < ~100mb and temperatures. The first
11987 ! index in the array, JT, which runs from 1 to 5, corresponds to
11988 ! different temperatures. More specifically, JT = 3 means that the
11989 ! data are for the reference temperature TREF for this pressure
11990 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11991 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11992 ! The second index, JP, runs from 13 to 59 and refers to the JPth
11993 ! reference pressure level (see taumol.f for the value of these
11994 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
11995 ! and tells us which g-interval the absorption coefficients are for.
11997 ! The array FORREFO contains the coefficient of the water vapor
11998 ! foreign-continuum (including the energy term). The first
11999 ! index refers to reference temperature (296,260,224,260) and
12000 ! pressure (970,475,219,3 mbar) levels. The second index
12001 ! runs over the g-channel (1 to 16).
12003 ! The array SELFREFO contains the coefficient of the water vapor
12004 ! self-continuum (including the energy term). The first index
12005 ! refers to temperature in 7.2 degree increments. For instance,
12006 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12007 ! etc. The second index runs over the g-channel (1 to 16).
12009 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12010 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12011 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12013 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12014 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12015 DM_BCAST_REAL(rayl)
12016 DM_BCAST_REAL(strrat)
12017 DM_BCAST_INTEGER(layreffr)
12018 DM_BCAST_MACRO(kao)
12019 DM_BCAST_MACRO(kbo)
12020 DM_BCAST_MACRO(selfrefo)
12021 DM_BCAST_MACRO(forrefo)
12022 DM_BCAST_MACRO(sfluxrefo)
12024 RETURN
12025 9010 CONTINUE
12026 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12027 CALL wrf_error_fatal(errmess)
12029 end subroutine sw_kgb19
12031 ! **************************************************************************
12032 subroutine sw_kgb20(rrtmg_unit)
12033 ! **************************************************************************
12035 use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12036 absch4o, rayl, layreffr
12038 implicit none
12039 save
12041 ! Input
12042 integer, intent(in) :: rrtmg_unit
12044 ! Local
12045 character*80 errmess
12046 logical, external :: wrf_dm_on_monitor
12048 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12050 ! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
12052 ! Array absch4o contains the absorption coefficients for methane.
12054 ! The array KAO contains absorption coefs at the 16 chosen g-values
12055 ! for a range of pressure levels> ~100mb, temperatures, and binary
12056 ! species parameters (see taumol.f for definition). The first
12057 ! index in the array, JS, runs from 1 to 9, and corresponds to
12058 ! different values of the binary species parameter. For instance,
12059 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12060 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12061 ! in the array, JT, which runs from 1 to 5, corresponds to different
12062 ! temperatures. More specifically, JT = 3 means that the data are for
12063 ! the reference temperature TREF for this pressure level, JT = 2 refers
12064 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12065 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12066 ! to the JPth reference pressure level (see taumol.f for these levels
12067 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12068 ! which g-interval the absorption coefficients are for.
12070 ! The array KBO contains absorption coefs at the 16 chosen g-values
12071 ! for a range of pressure levels < ~100mb and temperatures. The first
12072 ! index in the array, JT, which runs from 1 to 5, corresponds to
12073 ! different temperatures. More specifically, JT = 3 means that the
12074 ! data are for the reference temperature TREF for this pressure
12075 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12076 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12077 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12078 ! reference pressure level (see taumol.f for the value of these
12079 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12080 ! and tells us which g-interval the absorption coefficients are for.
12082 ! The array FORREFO contains the coefficient of the water vapor
12083 ! foreign-continuum (including the energy term). The first
12084 ! index refers to reference temperature (296,260,224,260) and
12085 ! pressure (970,475,219,3 mbar) levels. The second index
12086 ! runs over the g-channel (1 to 16).
12088 ! The array SELFREFO contains the coefficient of the water vapor
12089 ! self-continuum (including the energy term). The first index
12090 ! refers to temperature in 7.2 degree increments. For instance,
12091 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12092 ! etc. The second index runs over the g-channel (1 to 16).
12094 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12095 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12096 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12098 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12099 rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
12100 DM_BCAST_REAL(rayl)
12101 DM_BCAST_INTEGER(layreffr)
12102 DM_BCAST_MACRO(absch4o)
12103 DM_BCAST_MACRO(kao)
12104 DM_BCAST_MACRO(kbo)
12105 DM_BCAST_MACRO(selfrefo)
12106 DM_BCAST_MACRO(forrefo)
12107 DM_BCAST_MACRO(sfluxrefo)
12109 RETURN
12110 9010 CONTINUE
12111 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12112 CALL wrf_error_fatal(errmess)
12114 end subroutine sw_kgb20
12116 ! **************************************************************************
12117 subroutine sw_kgb21(rrtmg_unit)
12118 ! **************************************************************************
12120 use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12121 rayl, strrat, layreffr
12123 implicit none
12124 save
12126 ! Input
12127 integer, intent(in) :: rrtmg_unit
12129 ! Local
12130 character*80 errmess
12131 logical, external :: wrf_dm_on_monitor
12133 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12135 ! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
12137 ! The array KAO contains absorption coefs at the 16 chosen g-values
12138 ! for a range of pressure levels> ~100mb, temperatures, and binary
12139 ! species parameters (see taumol.f for definition). The first
12140 ! index in the array, JS, runs from 1 to 9, and corresponds to
12141 ! different values of the binary species parameter. For instance,
12142 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12143 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12144 ! in the array, JT, which runs from 1 to 5, corresponds to different
12145 ! temperatures. More specifically, JT = 3 means that the data are for
12146 ! the reference temperature TREF for this pressure level, JT = 2 refers
12147 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12148 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12149 ! to the JPth reference pressure level (see taumol.f for these levels
12150 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12151 ! which g-interval the absorption coefficients are for.
12153 ! The array KBO contains absorption coefs at the 16 chosen g-values
12154 ! for a range of pressure levels < ~100mb and temperatures. The first
12155 ! index in the array, JT, which runs from 1 to 5, corresponds to
12156 ! different temperatures. More specifically, JT = 3 means that the
12157 ! data are for the reference temperature TREF for this pressure
12158 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12159 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12160 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12161 ! reference pressure level (see taumol.f for the value of these
12162 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12163 ! and tells us which g-interval the absorption coefficients are for.
12165 ! The array FORREFO contains the coefficient of the water vapor
12166 ! foreign-continuum (including the energy term). The first
12167 ! index refers to reference temperature (296,260,224,260) and
12168 ! pressure (970,475,219,3 mbar) levels. The second index
12169 ! runs over the g-channel (1 to 16).
12171 ! The array SELFREFO contains the coefficient of the water vapor
12172 ! self-continuum (including the energy term). The first index
12173 ! refers to temperature in 7.2 degree increments. For instance,
12174 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12175 ! etc. The second index runs over the g-channel (1 to 16).
12177 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12178 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12179 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12181 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12182 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12183 DM_BCAST_REAL(rayl)
12184 DM_BCAST_REAL(strrat)
12185 DM_BCAST_INTEGER(layreffr)
12186 DM_BCAST_MACRO(kao)
12187 DM_BCAST_MACRO(kbo)
12188 DM_BCAST_MACRO(selfrefo)
12189 DM_BCAST_MACRO(forrefo)
12190 DM_BCAST_MACRO(sfluxrefo)
12192 RETURN
12193 9010 CONTINUE
12194 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12195 CALL wrf_error_fatal(errmess)
12197 end subroutine sw_kgb21
12199 ! **************************************************************************
12200 subroutine sw_kgb22(rrtmg_unit)
12201 ! **************************************************************************
12203 use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12204 rayl, strrat, layreffr
12206 implicit none
12207 save
12209 ! Input
12210 integer, intent(in) :: rrtmg_unit
12212 ! Local
12213 character*80 errmess
12214 logical, external :: wrf_dm_on_monitor
12216 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12218 ! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
12220 ! The array KAO contains absorption coefs at the 16 chosen g-values
12221 ! for a range of pressure levels> ~100mb, temperatures, and binary
12222 ! species parameters (see taumol.f for definition). The first
12223 ! index in the array, JS, runs from 1 to 9, and corresponds to
12224 ! different values of the binary species parameter. For instance,
12225 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12226 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12227 ! in the array, JT, which runs from 1 to 5, corresponds to different
12228 ! temperatures. More specifically, JT = 3 means that the data are for
12229 ! the reference temperature TREF for this pressure level, JT = 2 refers
12230 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12231 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12232 ! to the JPth reference pressure level (see taumol.f for these levels
12233 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12234 ! which g-interval the absorption coefficients are for.
12236 ! The array KBO contains absorption coefs at the 16 chosen g-values
12237 ! for a range of pressure levels < ~100mb and temperatures. The first
12238 ! index in the array, JT, which runs from 1 to 5, corresponds to
12239 ! different temperatures. More specifically, JT = 3 means that the
12240 ! data are for the reference temperature TREF for this pressure
12241 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12242 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12243 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12244 ! reference pressure level (see taumol.f for the value of these
12245 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12246 ! and tells us which g-interval the absorption coefficients are for.
12248 ! The array FORREFO contains the coefficient of the water vapor
12249 ! foreign-continuum (including the energy term). The first
12250 ! index refers to reference temperature (296_rb,260_rb,224,260) and
12251 ! pressure (970,475,219,3 mbar) levels. The second index
12252 ! runs over the g-channel (1 to 16).
12254 ! The array SELFREFO contains the coefficient of the water vapor
12255 ! self-continuum (including the energy term). The first index
12256 ! refers to temperature in 7.2 degree increments. For instance,
12257 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12258 ! etc. The second index runs over the g-channel (1 to 16).
12260 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12261 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12262 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12264 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12265 rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12266 DM_BCAST_REAL(rayl)
12267 DM_BCAST_REAL(strrat)
12268 DM_BCAST_INTEGER(layreffr)
12269 DM_BCAST_MACRO(kao)
12270 DM_BCAST_MACRO(kbo)
12271 DM_BCAST_MACRO(selfrefo)
12272 DM_BCAST_MACRO(forrefo)
12273 DM_BCAST_MACRO(sfluxrefo)
12275 RETURN
12276 9010 CONTINUE
12277 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12278 CALL wrf_error_fatal(errmess)
12280 end subroutine sw_kgb22
12282 ! **************************************************************************
12283 subroutine sw_kgb23(rrtmg_unit)
12284 ! **************************************************************************
12286 use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, &
12287 raylo, givfac, layreffr
12289 implicit none
12290 save
12292 ! Input
12293 integer, intent(in) :: rrtmg_unit
12295 ! Local
12296 character*80 errmess
12297 logical, external :: wrf_dm_on_monitor
12299 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12301 ! Array raylo contains the Rayleigh extinction coefficient at all v for this band
12303 ! Array givfac is the average Giver et al. correction factor for this band.
12305 ! The array KAO contains absorption coefs at the 16 chosen g-values
12306 ! for a range of pressure levels> ~100mb, temperatures, and binary
12307 ! species parameters (see taumol.f for definition). The first
12308 ! index in the array, JS, runs from 1 to 9, and corresponds to
12309 ! different values of the binary species parameter. For instance,
12310 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12311 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12312 ! in the array, JT, which runs from 1 to 5, corresponds to different
12313 ! temperatures. More specifically, JT = 3 means that the data are for
12314 ! the reference temperature TREF for this pressure level, JT = 2 refers
12315 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12316 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12317 ! to the JPth reference pressure level (see taumol.f for these levels
12318 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12319 ! which g-interval the absorption coefficients are for.
12321 ! The array FORREFO contains the coefficient of the water vapor
12322 ! foreign-continuum (including the energy term). The first
12323 ! index refers to reference temperature (296,260,224,260) and
12324 ! pressure (970,475,219,3 mbar) levels. The second index
12325 ! runs over the g-channel (1 to 16).
12327 ! The array SELFREFO contains the coefficient of the water vapor
12328 ! self-continuum (including the energy term). The first index
12329 ! refers to temperature in 7.2 degree increments. For instance,
12330 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12331 ! etc. The second index runs over the g-channel (1 to 16).
12333 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12334 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12335 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12337 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12338 raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
12339 DM_BCAST_MACRO(raylo)
12340 DM_BCAST_REAL(givfac)
12341 DM_BCAST_INTEGER(layreffr)
12342 DM_BCAST_MACRO(kao)
12343 DM_BCAST_MACRO(selfrefo)
12344 DM_BCAST_MACRO(forrefo)
12345 DM_BCAST_MACRO(sfluxrefo)
12347 RETURN
12348 9010 CONTINUE
12349 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12350 CALL wrf_error_fatal(errmess)
12352 end subroutine sw_kgb23
12354 ! **************************************************************************
12355 subroutine sw_kgb24(rrtmg_unit)
12356 ! **************************************************************************
12358 use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12359 raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
12361 implicit none
12362 save
12364 ! Input
12365 integer, intent(in) :: rrtmg_unit
12367 ! Local
12368 character*80 errmess
12369 logical, external :: wrf_dm_on_monitor
12371 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12373 ! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
12374 ! all v for this band for the upper and lower atmosphere.
12376 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
12377 ! all v for this band for the upper and lower atmosphere.
12379 ! The array KAO contains absorption coefs at the 16 chosen g-values
12380 ! for a range of pressure levels> ~100mb, temperatures, and binary
12381 ! species parameters (see taumol.f for definition). The first
12382 ! index in the array, JS, runs from 1 to 9, and corresponds to
12383 ! different values of the binary species parameter. For instance,
12384 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12385 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12386 ! in the array, JT, which runs from 1 to 5, corresponds to different
12387 ! temperatures. More specifically, JT = 3 means that the data are for
12388 ! the reference temperature TREF for this pressure level, JT = 2 refers
12389 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12390 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12391 ! to the JPth reference pressure level (see taumol.f for these levels
12392 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12393 ! which g-interval the absorption coefficients are for.
12395 ! The array KBO contains absorption coefs at the 16 chosen g-values
12396 ! for a range of pressure levels < ~100mb and temperatures. The first
12397 ! index in the array, JT, which runs from 1 to 5, corresponds to
12398 ! different temperatures. More specifically, JT = 3 means that the
12399 ! data are for the reference temperature TREF for this pressure
12400 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12401 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12402 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12403 ! reference pressure level (see taumol.f for the value of these
12404 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12405 ! and tells us which g-interval the absorption coefficients are for.
12407 ! The array FORREFO contains the coefficient of the water vapor
12408 ! foreign-continuum (including the energy term). The first
12409 ! index refers to reference temperature (296,260,224,260) and
12410 ! pressure (970,475,219,3 mbar) levels. The second index
12411 ! runs over the g-channel (1 to 16).
12413 ! The array SELFREFO contains the coefficient of the water vapor
12414 ! self-continuum (including the energy term). The first index
12415 ! refers to temperature in 7.2 degree increments. For instance,
12416 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12417 ! etc. The second index runs over the g-channel (1 to 16).
12419 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12420 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12421 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12423 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12424 raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
12425 forrefo, sfluxrefo
12426 DM_BCAST_MACRO(raylao)
12427 DM_BCAST_MACRO(raylbo)
12428 DM_BCAST_REAL(strrat)
12429 DM_BCAST_INTEGER(layreffr)
12430 DM_BCAST_MACRO(abso3ao)
12431 DM_BCAST_MACRO(abso3bo)
12432 DM_BCAST_MACRO(kao)
12433 DM_BCAST_MACRO(kbo)
12434 DM_BCAST_MACRO(selfrefo)
12435 DM_BCAST_MACRO(forrefo)
12436 DM_BCAST_MACRO(sfluxrefo)
12438 RETURN
12439 9010 CONTINUE
12440 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12441 CALL wrf_error_fatal(errmess)
12443 end subroutine sw_kgb24
12445 ! **************************************************************************
12446 subroutine sw_kgb25(rrtmg_unit)
12447 ! **************************************************************************
12449 use rrsw_kg25, only : kao, sfluxrefo, &
12450 raylo, abso3ao, abso3bo, layreffr
12452 implicit none
12453 save
12455 ! Input
12456 integer, intent(in) :: rrtmg_unit
12458 ! Local
12459 character*80 errmess
12460 logical, external :: wrf_dm_on_monitor
12462 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12464 ! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
12466 ! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
12467 ! all v for this band for the upper and lower atmosphere.
12469 ! The array KAO contains absorption coefs at the 16 chosen g-values
12470 ! for a range of pressure levels> ~100mb, temperatures, and binary
12471 ! species parameters (see taumol.f for definition). The first
12472 ! index in the array, JS, runs from 1 to 9, and corresponds to
12473 ! different values of the binary species parameter. For instance,
12474 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12475 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12476 ! in the array, JT, which runs from 1 to 5, corresponds to different
12477 ! temperatures. More specifically, JT = 3 means that the data are for
12478 ! the reference temperature TREF for this pressure level, JT = 2 refers
12479 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12480 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12481 ! to the JPth reference pressure level (see taumol.f for these levels
12482 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12483 ! which g-interval the absorption coefficients are for.
12485 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12486 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12488 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12489 raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
12490 DM_BCAST_MACRO(raylo)
12491 DM_BCAST_INTEGER(layreffr)
12492 DM_BCAST_MACRO(abso3ao)
12493 DM_BCAST_MACRO(abso3bo)
12494 DM_BCAST_MACRO(kao)
12495 DM_BCAST_MACRO(sfluxrefo)
12497 RETURN
12498 9010 CONTINUE
12499 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12500 CALL wrf_error_fatal(errmess)
12502 end subroutine sw_kgb25
12504 ! **************************************************************************
12505 subroutine sw_kgb26(rrtmg_unit)
12506 ! **************************************************************************
12508 use rrsw_kg26, only : sfluxrefo, raylo
12510 implicit none
12511 save
12513 ! Input
12514 integer, intent(in) :: rrtmg_unit
12516 ! Local
12517 character*80 errmess
12518 logical, external :: wrf_dm_on_monitor
12520 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12522 ! Array raylo contains the Rayleigh extinction coefficient at all v for this band.
12524 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12526 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12527 raylo, sfluxrefo
12528 DM_BCAST_MACRO(raylo)
12529 DM_BCAST_MACRO(sfluxrefo)
12531 RETURN
12532 9010 CONTINUE
12533 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12534 CALL wrf_error_fatal(errmess)
12536 end subroutine sw_kgb26
12538 ! **************************************************************************
12539 subroutine sw_kgb27(rrtmg_unit)
12540 ! **************************************************************************
12542 use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
12543 scalekur, layreffr
12545 implicit none
12546 save
12548 ! Input
12549 integer, intent(in) :: rrtmg_unit
12551 ! Local
12552 character*80 errmess
12553 logical, external :: wrf_dm_on_monitor
12555 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12556 ! The values in array sfluxrefo were obtained using the "low resolution"
12557 ! version of the Kurucz solar source function. For unknown reasons,
12558 ! the total irradiance in this band differs from the corresponding
12559 ! total in the "high-resolution" version of the Kurucz function.
12560 ! Therefore, these values are scaled by the factor SCALEKUR.
12562 ! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
12564 ! The array KAO contains absorption coefs at the 16 chosen g-values
12565 ! for a range of pressure levels> ~100mb, temperatures, and binary
12566 ! species parameters (see taumol.f for definition). The first
12567 ! index in the array, JS, runs from 1 to 9, and corresponds to
12568 ! different values of the binary species parameter. For instance,
12569 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12570 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12571 ! in the array, JT, which runs from 1 to 5, corresponds to different
12572 ! temperatures. More specifically, JT = 3 means that the data are for
12573 ! the reference temperature TREF for this pressure level, JT = 2 refers
12574 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12575 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12576 ! to the JPth reference pressure level (see taumol.f for these levels
12577 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12578 ! which g-interval the absorption coefficients are for.
12580 ! The array KBO contains absorption coefs at the 16 chosen g-values
12581 ! for a range of pressure levels < ~100mb and temperatures. The first
12582 ! index in the array, JT, which runs from 1 to 5, corresponds to
12583 ! different temperatures. More specifically, JT = 3 means that the
12584 ! data are for the reference temperature TREF for this pressure
12585 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12586 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12587 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12588 ! reference pressure level (see taumol.f for the value of these
12589 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12590 ! and tells us which g-interval the absorption coefficients are for.
12592 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12593 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12594 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12596 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12597 raylo, scalekur, layreffr, kao, kbo, sfluxrefo
12598 DM_BCAST_MACRO(raylo)
12599 DM_BCAST_REAL(scalekur)
12600 DM_BCAST_INTEGER(layreffr)
12601 DM_BCAST_MACRO(kao)
12602 DM_BCAST_MACRO(kbo)
12603 DM_BCAST_MACRO(sfluxrefo)
12605 RETURN
12606 9010 CONTINUE
12607 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12608 CALL wrf_error_fatal(errmess)
12610 end subroutine sw_kgb27
12612 ! **************************************************************************
12613 subroutine sw_kgb28(rrtmg_unit)
12614 ! **************************************************************************
12616 use rrsw_kg28, only : kao, kbo, sfluxrefo, &
12617 rayl, strrat, layreffr
12619 implicit none
12620 save
12622 ! Input
12623 integer, intent(in) :: rrtmg_unit
12625 ! Local
12626 character*80 errmess
12627 logical, external :: wrf_dm_on_monitor
12629 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12631 ! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
12633 ! The array KAO contains absorption coefs at the 16 chosen g-values
12634 ! for a range of pressure levels> ~100mb, temperatures, and binary
12635 ! species parameters (see taumol.f for definition). The first
12636 ! index in the array, JS, runs from 1 to 9, and corresponds to
12637 ! different values of the binary species parameter. For instance,
12638 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12639 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12640 ! in the array, JT, which runs from 1 to 5, corresponds to different
12641 ! temperatures. More specifically, JT = 3 means that the data are for
12642 ! the reference temperature TREF for this pressure level, JT = 2 refers
12643 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12644 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12645 ! to the JPth reference pressure level (see taumol.f for these levels
12646 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12647 ! which g-interval the absorption coefficients are for.
12649 ! The array KBO contains absorption coefs at the 16 chosen g-values
12650 ! for a range of pressure levels < ~100mb and temperatures. The first
12651 ! index in the array, JT, which runs from 1 to 5, corresponds to
12652 ! different temperatures. More specifically, JT = 3 means that the
12653 ! data are for the reference temperature TREF for this pressure
12654 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12655 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12656 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12657 ! reference pressure level (see taumol.f for the value of these
12658 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12659 ! and tells us which g-interval the absorption coefficients are for.
12661 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12662 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12663 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12665 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12666 rayl, strrat, layreffr, kao, kbo, sfluxrefo
12667 DM_BCAST_REAL(rayl)
12668 DM_BCAST_REAL(strrat)
12669 DM_BCAST_INTEGER(layreffr)
12670 DM_BCAST_MACRO(kao)
12671 DM_BCAST_MACRO(kbo)
12672 DM_BCAST_MACRO(sfluxrefo)
12674 RETURN
12675 9010 CONTINUE
12676 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12677 CALL wrf_error_fatal(errmess)
12679 end subroutine sw_kgb28
12681 ! **************************************************************************
12682 subroutine sw_kgb29(rrtmg_unit)
12683 ! **************************************************************************
12685 use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12686 absh2oo, absco2o, rayl, layreffr
12688 implicit none
12689 save
12691 ! Input
12692 integer, intent(in) :: rrtmg_unit
12694 ! Local
12695 character*80 errmess
12696 logical, external :: wrf_dm_on_monitor
12698 ! Array sfluxrefo contains the Kurucz solar source function for this band.
12700 ! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
12702 ! Array absh2oo contains the water vapor absorption coefficient for this band.
12704 ! Array absco2o contains the carbon dioxide absorption coefficient for this band.
12706 ! The array KAO contains absorption coefs at the 16 chosen g-values
12707 ! for a range of pressure levels> ~100mb, temperatures, and binary
12708 ! species parameters (see taumol.f for definition). The first
12709 ! index in the array, JS, runs from 1 to 9, and corresponds to
12710 ! different values of the binary species parameter. For instance,
12711 ! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12712 ! JS = 3 corresponds to the parameter value 2/8, etc. The second index
12713 ! in the array, JT, which runs from 1 to 5, corresponds to different
12714 ! temperatures. More specifically, JT = 3 means that the data are for
12715 ! the reference temperature TREF for this pressure level, JT = 2 refers
12716 ! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12717 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12718 ! to the JPth reference pressure level (see taumol.f for these levels
12719 ! in mb). The fourth index, IG, goes from 1 to 16, and indicates
12720 ! which g-interval the absorption coefficients are for.
12722 ! The array KBO contains absorption coefs at the 16 chosen g-values
12723 ! for a range of pressure levels < ~100mb and temperatures. The first
12724 ! index in the array, JT, which runs from 1 to 5, corresponds to
12725 ! different temperatures. More specifically, JT = 3 means that the
12726 ! data are for the reference temperature TREF for this pressure
12727 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12728 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12729 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12730 ! reference pressure level (see taumol.f for the value of these
12731 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12732 ! and tells us which g-interval the absorption coefficients are for.
12734 ! The array FORREFO contains the coefficient of the water vapor
12735 ! foreign-continuum (including the energy term). The first
12736 ! index refers to reference temperature (296,260,224,260) and
12737 ! pressure (970,475,219,3 mbar) levels. The second index
12738 ! runs over the g-channel (1 to 16).
12740 ! The array SELFREFO contains the coefficient of the water vapor
12741 ! self-continuum (including the energy term). The first index
12742 ! refers to temperature in 7.2 degree increments. For instance,
12743 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12744 ! etc. The second index runs over the g-channel (1 to 16).
12746 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12747 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12748 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12750 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12751 rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
12752 DM_BCAST_REAL(rayl)
12753 DM_BCAST_INTEGER(layreffr)
12754 DM_BCAST_MACRO(absh2oo)
12755 DM_BCAST_MACRO(absco2o)
12756 DM_BCAST_MACRO(kao)
12757 DM_BCAST_MACRO(kbo)
12758 DM_BCAST_MACRO(selfrefo)
12759 DM_BCAST_MACRO(forrefo)
12760 DM_BCAST_MACRO(sfluxrefo)
12762 RETURN
12763 9010 CONTINUE
12764 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12765 CALL wrf_error_fatal(errmess)
12767 end subroutine sw_kgb29
12769 !------------------------------------------------------------------
12771 END MODULE module_ra_rrtmg_sw
12772 !***********************************************************************