| blob | 48d6474b88464f5a446d8de577b2abe8f05f0603 |
1 !MODULE module_ra_rrtmg_lw
3 module parkind
4 ! implicit none
5 save
7 !------------------------------------------------------------------
8 ! rrtmg kinds
9 ! Define integer and real kinds for various types.
10 !
11 ! Initial version: MJIacono, AER, jun2006
12 ! Revised: MJIacono, AER, aug2008
13 !------------------------------------------------------------------
15 !
16 ! integer kinds
17 ! -------------
18 !
19 integer, parameter :: kind_ib = selected_int_kind(13) ! 8 byte integer
20 integer, parameter :: kind_im = selected_int_kind(6) ! 4 byte integer
21 integer, parameter :: kind_in = kind(1) ! native integer
23 !
24 ! real kinds
25 ! ----------
26 !
27 ! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
28 ! integer, parameter :: kind_rm = selected_real_kind(6) ! 4 byte real
29 ! integer, parameter :: kind_rn = kind(1.0) ! native real
31 ! Modified for WRF:
32 #if (RWORDSIZE == 8)
33 integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
34 #endif
35 #if (RWORDSIZE == 4)
36 integer, parameter :: kind_rb = selected_real_kind(6) ! 4 byte real
37 #endif
38 ! integer, parameter :: kind_rb = kind(1.0) ! native real
40 end module parkind
42 module parrrtm
44 use parkind ,only : im => kind_im
46 ! implicit none
47 save
49 !------------------------------------------------------------------
50 ! rrtmg_lw main parameters
51 !
52 ! Initial version: JJMorcrette, ECMWF, Jul 1998
53 ! Revised: MJIacono, AER, Jun 2006
54 ! Revised: MJIacono, AER, Aug 2007
55 ! Revised: MJIacono, AER, Aug 2008
56 !------------------------------------------------------------------
58 ! name type purpose
59 ! ----- : ---- : ----------------------------------------------
60 ! mxlay : integer: maximum number of layers
61 ! mg : integer: number of original g-intervals per spectral band
62 ! nbndlw : integer: number of spectral bands
63 ! maxxsec: integer: maximum number of cross-section molecules
64 ! (e.g. cfcs)
65 ! maxinpx: integer:
66 ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw
67 ! ngNN : integer: number of reduced g-intervals per spectral band
68 ! ngsNN : integer: cumulative number of g-intervals per band
69 !------------------------------------------------------------------
71 integer(kind=im), parameter :: mxlay = 203
72 integer(kind=im), parameter :: mg = 16
73 integer(kind=im), parameter :: nbndlw = 16
74 integer(kind=im), parameter :: maxxsec= 4
75 integer(kind=im), parameter :: mxmol = 38
76 integer(kind=im), parameter :: maxinpx= 38
77 integer(kind=im), parameter :: nmol = 7
78 ! Use for 140 g-point model
79 integer(kind=im), parameter :: ngptlw = 140
80 ! Use for 256 g-point model
81 ! integer(kind=im), parameter :: ngptlw = 256
83 ! Use for 140 g-point model
84 integer(kind=im), parameter :: ng1 = 10
85 integer(kind=im), parameter :: ng2 = 12
86 integer(kind=im), parameter :: ng3 = 16
87 integer(kind=im), parameter :: ng4 = 14
88 integer(kind=im), parameter :: ng5 = 16
89 integer(kind=im), parameter :: ng6 = 8
90 integer(kind=im), parameter :: ng7 = 12
91 integer(kind=im), parameter :: ng8 = 8
92 integer(kind=im), parameter :: ng9 = 12
93 integer(kind=im), parameter :: ng10 = 6
94 integer(kind=im), parameter :: ng11 = 8
95 integer(kind=im), parameter :: ng12 = 8
96 integer(kind=im), parameter :: ng13 = 4
97 integer(kind=im), parameter :: ng14 = 2
98 integer(kind=im), parameter :: ng15 = 2
99 integer(kind=im), parameter :: ng16 = 2
101 integer(kind=im), parameter :: ngs1 = 10
102 integer(kind=im), parameter :: ngs2 = 22
103 integer(kind=im), parameter :: ngs3 = 38
104 integer(kind=im), parameter :: ngs4 = 52
105 integer(kind=im), parameter :: ngs5 = 68
106 integer(kind=im), parameter :: ngs6 = 76
107 integer(kind=im), parameter :: ngs7 = 88
108 integer(kind=im), parameter :: ngs8 = 96
109 integer(kind=im), parameter :: ngs9 = 108
110 integer(kind=im), parameter :: ngs10 = 114
111 integer(kind=im), parameter :: ngs11 = 122
112 integer(kind=im), parameter :: ngs12 = 130
113 integer(kind=im), parameter :: ngs13 = 134
114 integer(kind=im), parameter :: ngs14 = 136
115 integer(kind=im), parameter :: ngs15 = 138
117 ! Use for 256 g-point model
118 ! integer(kind=im), parameter :: ng1 = 16
119 ! integer(kind=im), parameter :: ng2 = 16
120 ! integer(kind=im), parameter :: ng3 = 16
121 ! integer(kind=im), parameter :: ng4 = 16
122 ! integer(kind=im), parameter :: ng5 = 16
123 ! integer(kind=im), parameter :: ng6 = 16
124 ! integer(kind=im), parameter :: ng7 = 16
125 ! integer(kind=im), parameter :: ng8 = 16
126 ! integer(kind=im), parameter :: ng9 = 16
127 ! integer(kind=im), parameter :: ng10 = 16
128 ! integer(kind=im), parameter :: ng11 = 16
129 ! integer(kind=im), parameter :: ng12 = 16
130 ! integer(kind=im), parameter :: ng13 = 16
131 ! integer(kind=im), parameter :: ng14 = 16
132 ! integer(kind=im), parameter :: ng15 = 16
133 ! integer(kind=im), parameter :: ng16 = 16
135 ! integer(kind=im), parameter :: ngs1 = 16
136 ! integer(kind=im), parameter :: ngs2 = 32
137 ! integer(kind=im), parameter :: ngs3 = 48
138 ! integer(kind=im), parameter :: ngs4 = 64
139 ! integer(kind=im), parameter :: ngs5 = 80
140 ! integer(kind=im), parameter :: ngs6 = 96
141 ! integer(kind=im), parameter :: ngs7 = 112
142 ! integer(kind=im), parameter :: ngs8 = 128
143 ! integer(kind=im), parameter :: ngs9 = 144
144 ! integer(kind=im), parameter :: ngs10 = 160
145 ! integer(kind=im), parameter :: ngs11 = 176
146 ! integer(kind=im), parameter :: ngs12 = 192
147 ! integer(kind=im), parameter :: ngs13 = 208
148 ! integer(kind=im), parameter :: ngs14 = 224
149 ! integer(kind=im), parameter :: ngs15 = 240
150 ! integer(kind=im), parameter :: ngs16 = 256
152 end module parrrtm
154 module rrlw_cld
156 use parkind, only : rb => kind_rb
158 ! implicit none
159 save
161 !------------------------------------------------------------------
162 ! rrtmg_lw cloud property coefficients
164 ! Revised: MJIacono, AER, jun2006
165 ! Revised: MJIacono, AER, aug2008
166 !------------------------------------------------------------------
168 ! name type purpose
169 ! ----- : ---- : ----------------------------------------------
170 ! abscld1: real :
171 ! absice0: real :
172 ! absice1: real :
173 ! absice2: real :
174 ! absice3: real :
175 ! absliq0: real :
176 ! absliq1: real :
177 !------------------------------------------------------------------
179 real(kind=rb) :: abscld1
180 real(kind=rb) , dimension(2) :: absice0
181 real(kind=rb) , dimension(2,5) :: absice1
182 real(kind=rb) , dimension(43,16) :: absice2
183 real(kind=rb) , dimension(46,16) :: absice3
184 real(kind=rb) :: absliq0
185 real(kind=rb) , dimension(58,16) :: absliq1
187 end module rrlw_cld
189 module rrlw_con
191 use parkind, only : rb => kind_rb
193 ! implicit none
194 save
196 !------------------------------------------------------------------
197 ! rrtmg_lw constants
199 ! Initial version: MJIacono, AER, jun2006
200 ! Revised: MJIacono, AER, aug2008
201 !------------------------------------------------------------------
203 ! name type purpose
204 ! ----- : ---- : ----------------------------------------------
205 ! fluxfac: real : radiance to flux conversion factor
206 ! heatfac: real : flux to heating rate conversion factor
207 !oneminus: real : 1.-1.e-6
208 ! pi : real : pi
209 ! grav : real : acceleration of gravity
210 ! planck : real : planck constant
211 ! boltz : real : boltzmann constant
212 ! clight : real : speed of light
213 ! avogad : real : avogadro constant
214 ! alosmt : real : loschmidt constant
215 ! gascon : real : molar gas constant
216 ! radcn1 : real : first radiation constant
217 ! radcn2 : real : second radiation constant
218 ! sbcnst : real : stefan-boltzmann constant
219 ! secdy : real : seconds per day
220 !------------------------------------------------------------------
222 real(kind=rb) :: fluxfac, heatfac
223 real(kind=rb) :: oneminus, pi, grav
224 real(kind=rb) :: planck, boltz, clight
225 real(kind=rb) :: avogad, alosmt, gascon
226 real(kind=rb) :: radcn1, radcn2
227 real(kind=rb) :: sbcnst, secdy
229 end module rrlw_con
231 module rrlw_kg01
233 use parkind ,only : im => kind_im, rb => kind_rb
235 ! implicit none
236 save
238 !-----------------------------------------------------------------
239 ! rrtmg_lw ORIGINAL abs. coefficients for interval 1
240 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
241 !
242 ! Initial version: JJMorcrette, ECMWF, jul1998
243 ! Revised: MJIacono, AER, jun2006
244 ! Revised: MJIacono, AER, aug2008
245 !-----------------------------------------------------------------
246 !
247 ! name type purpose
248 ! ---- : ---- : ---------------------------------------------
249 !fracrefao: real
250 !fracrefbo: real
251 ! kao : real
252 ! kbo : real
253 ! kao_mn2 : real
254 ! kbo_mn2 : real
255 ! selfrefo: real
256 ! forrefo : real
257 !-----------------------------------------------------------------
259 integer(kind=im), parameter :: no1 = 16
261 real(kind=rb) :: fracrefao(no1) , fracrefbo(no1)
262 real(kind=rb) :: kao(5,13,no1)
263 real(kind=rb) :: kbo(5,13:59,no1)
264 real(kind=rb) :: kao_mn2(19,no1) , kbo_mn2(19,no1)
265 real(kind=rb) :: selfrefo(10,no1), forrefo(4,no1)
267 !-----------------------------------------------------------------
268 ! rrtmg_lw COMBINED abs. coefficients for interval 1
269 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
270 !
271 ! Initial version: JJMorcrette, ECMWF, jul1998
272 ! Revised: MJIacono, AER, jun2006
273 ! Revised: MJIacono, AER, aug2008
274 !-----------------------------------------------------------------
275 !
276 ! name type purpose
277 ! ---- : ---- : ---------------------------------------------
278 !fracrefa : real
279 !fracrefb : real
280 ! ka : real
281 ! kb : real
282 ! absa : real
283 ! absb : real
284 ! ka_mn2 : real
285 ! kb_mn2 : real
286 ! selfref : real
287 ! forref : real
288 !-----------------------------------------------------------------
290 integer(kind=im), parameter :: ng1 = 10
292 real(kind=rb) :: fracrefa(ng1) , fracrefb(ng1)
293 real(kind=rb) :: ka(5,13,ng1) , absa(65,ng1)
294 real(kind=rb) :: kb(5,13:59,ng1), absb(235,ng1)
295 real(kind=rb) :: ka_mn2(19,ng1) , kb_mn2(19,ng1)
296 real(kind=rb) :: selfref(10,ng1), forref(4,ng1)
298 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
300 end module rrlw_kg01
302 module rrlw_kg02
304 use parkind ,only : im => kind_im, rb => kind_rb
306 ! implicit none
307 save
309 !-----------------------------------------------------------------
310 ! rrtmg_lw ORIGINAL abs. coefficients for interval 2
311 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
312 !
313 ! Initial version: JJMorcrette, ECMWF, jul1998
314 ! Revised: MJIacono, AER, jun2006
315 ! Revised: MJIacono, AER, aug2008
316 !-----------------------------------------------------------------
317 !
318 ! name type purpose
319 ! ---- : ---- : ---------------------------------------------
320 !fracrefao: real
321 !fracrefbo: real
322 ! kao : real
323 ! kbo : real
324 ! selfrefo: real
325 ! forrefo : real
326 !-----------------------------------------------------------------
328 integer(kind=im), parameter :: no2 = 16
330 real(kind=rb) :: fracrefao(no2) , fracrefbo(no2)
331 real(kind=rb) :: kao(5,13,no2)
332 real(kind=rb) :: kbo(5,13:59,no2)
333 real(kind=rb) :: selfrefo(10,no2) , forrefo(4,no2)
335 !-----------------------------------------------------------------
336 ! rrtmg_lw COMBINED abs. coefficients for interval 2
337 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
338 !
339 ! Initial version: JJMorcrette, ECMWF, jul1998
340 ! Revised: MJIacono, AER, jun2006
341 ! Revised: MJIacono, AER, aug2008
342 !-----------------------------------------------------------------
343 !
344 ! name type purpose
345 ! ---- : ---- : ---------------------------------------------
346 !fracrefa : real
347 !fracrefb : real
348 ! ka : real
349 ! kb : real
350 ! absa : real
351 ! absb : real
352 ! selfref : real
353 ! forref : real
354 !
355 ! refparam: real
356 !-----------------------------------------------------------------
358 integer(kind=im), parameter :: ng2 = 12
360 real(kind=rb) :: fracrefa(ng2) , fracrefb(ng2)
361 real(kind=rb) :: ka(5,13,ng2) , absa(65,ng2)
362 real(kind=rb) :: kb(5,13:59,ng2), absb(235,ng2)
363 real(kind=rb) :: selfref(10,ng2), forref(4,ng2)
365 real(kind=rb) :: refparam(13)
367 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
369 end module rrlw_kg02
371 module rrlw_kg03
373 use parkind ,only : im => kind_im, rb => kind_rb
375 ! implicit none
376 save
378 !-----------------------------------------------------------------
379 ! rrtmg_lw ORIGINAL abs. coefficients for interval 3
380 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
381 !
382 ! Initial version: JJMorcrette, ECMWF, jul1998
383 ! Revised: MJIacono, AER, jun2006
384 ! Revised: MJIacono, AER, aug2008
385 !-----------------------------------------------------------------
386 !
387 ! name type purpose
388 ! ---- : ---- : ---------------------------------------------
389 !fracrefao: real
390 !fracrefbo: real
391 ! kao : real
392 ! kbo : real
393 ! kao_mn2o: real
394 ! kbo_mn2o: real
395 ! selfrefo: real
396 ! forrefo : real
397 !-----------------------------------------------------------------
399 integer(kind=im), parameter :: no3 = 16
401 real(kind=rb) :: fracrefao(no3,10) ,fracrefbo(no3,5)
402 real(kind=rb) :: kao(9,5,13,no3)
403 real(kind=rb) :: kbo(5,5,13:59,no3)
404 real(kind=rb) :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3)
405 real(kind=rb) :: selfrefo(10,no3)
406 real(kind=rb) :: forrefo(4,no3)
408 !-----------------------------------------------------------------
409 ! rrtmg_lw COMBINED abs. coefficients for interval 3
410 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
411 !
412 ! Initial version: JJMorcrette, ECMWF, jul1998
413 ! Revised: MJIacono, AER, jun2006
414 ! Revised: MJIacono, AER, aug2008
415 !-----------------------------------------------------------------
416 !
417 ! name type purpose
418 ! ---- : ---- : ---------------------------------------------
419 !fracrefa : real
420 !fracrefb : real
421 ! ka : real
422 ! kb : real
423 ! ka_mn2o : real
424 ! kb_mn2o : real
425 ! selfref : real
426 ! forref : real
427 !
428 ! absa : real
429 ! absb : real
430 !-----------------------------------------------------------------
432 integer(kind=im), parameter :: ng3 = 16
434 real(kind=rb) :: fracrefa(ng3,10) ,fracrefb(ng3,5)
435 real(kind=rb) :: ka(9,5,13,ng3) ,absa(585,ng3)
436 real(kind=rb) :: kb(5,5,13:59,ng3),absb(1175,ng3)
437 real(kind=rb) :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3)
438 real(kind=rb) :: selfref(10,ng3)
439 real(kind=rb) :: forref(4,ng3)
441 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
443 end module rrlw_kg03
445 module rrlw_kg04
447 use parkind ,only : im => kind_im, rb => kind_rb
449 ! implicit none
450 save
452 !-----------------------------------------------------------------
453 ! rrtmg_lw ORIGINAL abs. coefficients for interval 4
454 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
455 !
456 ! Initial version: JJMorcrette, ECMWF, jul1998
457 ! Revised: MJIacono, AER, jun2006
458 ! Revised: MJIacono, AER, aug2008
459 !-----------------------------------------------------------------
460 !
461 ! name type purpose
462 ! ---- : ---- : ---------------------------------------------
463 !fracrefao: real
464 !fracrefbo: real
465 ! kao : real
466 ! kbo : real
467 ! selfrefo: real
468 ! forrefo : real
469 !-----------------------------------------------------------------
471 integer(kind=im), parameter :: no4 = 16
473 real(kind=rb) :: fracrefao(no4,9) ,fracrefbo(no4,6)
474 real(kind=rb) :: kao(9,5,13,no4)
475 real(kind=rb) :: kbo(5,5,13:59,no4)
476 real(kind=rb) :: selfrefo(10,no4) ,forrefo(4,no4)
478 !-----------------------------------------------------------------
479 ! rrtmg_lw COMBINED abs. coefficients for interval 4
480 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
481 !
482 ! Initial version: JJMorcrette, ECMWF, jul1998
483 ! Revised: MJIacono, AER, jun2006
484 ! Revised: MJIacono, AER, aug2008
485 !-----------------------------------------------------------------
486 !
487 ! name type purpose
488 ! ---- : ---- : ---------------------------------------------
489 ! absa : real
490 ! absb : real
491 !fracrefa : real
492 !fracrefb : real
493 ! ka : real
494 ! kb : real
495 ! selfref : real
496 ! forref : real
497 !-----------------------------------------------------------------
499 integer(kind=im), parameter :: ng4 = 14
501 real(kind=rb) :: fracrefa(ng4,9) ,fracrefb(ng4,6)
502 real(kind=rb) :: ka(9,5,13,ng4) ,absa(585,ng4)
503 real(kind=rb) :: kb(5,5,13:59,ng4),absb(1175,ng4)
504 real(kind=rb) :: selfref(10,ng4) ,forref(4,ng4)
506 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
508 end module rrlw_kg04
510 module rrlw_kg05
512 use parkind ,only : im => kind_im, rb => kind_rb
514 ! implicit none
515 save
517 !-----------------------------------------------------------------
518 ! rrtmg_lw ORIGINAL abs. coefficients for interval 5
519 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
520 !
521 ! Initial version: JJMorcrette, ECMWF, jul1998
522 ! Revised: MJIacono, AER, jun2006
523 ! Revised: MJIacono, AER, aug2008
524 !-----------------------------------------------------------------
525 !
526 ! name type purpose
527 ! ---- : ---- : ---------------------------------------------
528 !fracrefao: real
529 !fracrefbo: real
530 ! kao : real
531 ! kbo : real
532 ! kao_mo3 : real
533 ! selfrefo: real
534 ! forrefo : real
535 ! ccl4o : real
536 !-----------------------------------------------------------------
538 integer(kind=im), parameter :: no5 = 16
540 real(kind=rb) :: fracrefao(no5,9) ,fracrefbo(no5,5)
541 real(kind=rb) :: kao(9,5,13,no5)
542 real(kind=rb) :: kbo(5,5,13:59,no5)
543 real(kind=rb) :: kao_mo3(9,19,no5)
544 real(kind=rb) :: selfrefo(10,no5)
545 real(kind=rb) :: forrefo(4,no5)
546 real(kind=rb) :: ccl4o(no5)
548 !-----------------------------------------------------------------
549 ! rrtmg_lw COMBINED abs. coefficients for interval 5
550 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
551 !
552 ! Initial version: JJMorcrette, ECMWF, jul1998
553 ! Revised: MJIacono, AER, jun2006
554 ! Revised: MJIacono, AER, aug2008
555 !-----------------------------------------------------------------
556 !
557 ! name type purpose
558 ! ---- : ---- : ---------------------------------------------
559 !fracrefa : real
560 !fracrefb : real
561 ! ka : real
562 ! kb : real
563 ! ka_mo3 : real
564 ! selfref : real
565 ! forref : real
566 ! ccl4 : real
567 !
568 ! absa : real
569 ! absb : real
570 !-----------------------------------------------------------------
572 integer(kind=im), parameter :: ng5 = 16
574 real(kind=rb) :: fracrefa(ng5,9) ,fracrefb(ng5,5)
575 real(kind=rb) :: ka(9,5,13,ng5) ,absa(585,ng5)
576 real(kind=rb) :: kb(5,5,13:59,ng5),absb(1175,ng5)
577 real(kind=rb) :: ka_mo3(9,19,ng5)
578 real(kind=rb) :: selfref(10,ng5)
579 real(kind=rb) :: forref(4,ng5)
580 real(kind=rb) :: ccl4(ng5)
582 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
584 end module rrlw_kg05
586 module rrlw_kg06
588 use parkind ,only : im => kind_im, rb => kind_rb
590 ! implicit none
591 save
593 !-----------------------------------------------------------------
594 ! rrtmg_lw ORIGINAL abs. coefficients for interval 6
595 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
596 !
597 ! Initial version: JJMorcrette, ECMWF, jul1998
598 ! Revised: MJIacono, AER, jun2006
599 ! Revised: MJIacono, AER, aug2008
600 !-----------------------------------------------------------------
601 !
602 ! name type purpose
603 ! ---- : ---- : ---------------------------------------------
604 !fracrefao: real
605 ! kao : real
606 ! kao_mco2: real
607 ! selfrefo: real
608 ! forrefo : real
609 !cfc11adjo: real
610 ! cfc12o : real
611 !-----------------------------------------------------------------
613 integer(kind=im), parameter :: no6 = 16
615 real(kind=rb) , dimension(no6) :: fracrefao
616 real(kind=rb) :: kao(5,13,no6)
617 real(kind=rb) :: kao_mco2(19,no6)
618 real(kind=rb) :: selfrefo(10,no6)
619 real(kind=rb) :: forrefo(4,no6)
621 real(kind=rb) , dimension(no6) :: cfc11adjo
622 real(kind=rb) , dimension(no6) :: cfc12o
624 !-----------------------------------------------------------------
625 ! rrtmg_lw COMBINED abs. coefficients for interval 6
626 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
627 !
628 ! Initial version: JJMorcrette, ECMWF, jul1998
629 ! Revised: MJIacono, AER, jun2006
630 ! Revised: MJIacono, AER, aug2008
631 !-----------------------------------------------------------------
632 !
633 ! name type purpose
634 ! ---- : ---- : ---------------------------------------------
635 !fracrefa : real
636 ! ka : real
637 ! ka_mco2 : real
638 ! selfref : real
639 ! forref : real
640 !cfc11adj : real
641 ! cfc12 : real
642 !
643 ! absa : real
644 !-----------------------------------------------------------------
646 integer(kind=im), parameter :: ng6 = 8
648 real(kind=rb) , dimension(ng6) :: fracrefa
649 real(kind=rb) :: ka(5,13,ng6),absa(65,ng6)
650 real(kind=rb) :: ka_mco2(19,ng6)
651 real(kind=rb) :: selfref(10,ng6)
652 real(kind=rb) :: forref(4,ng6)
654 real(kind=rb) , dimension(ng6) :: cfc11adj
655 real(kind=rb) , dimension(ng6) :: cfc12
657 equivalence (ka(1,1,1),absa(1,1))
659 end module rrlw_kg06
661 module rrlw_kg07
663 use parkind ,only : im => kind_im, rb => kind_rb
665 ! implicit none
666 save
668 !-----------------------------------------------------------------
669 ! rrtmg_lw ORIGINAL abs. coefficients for interval 7
670 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
671 !
672 ! Initial version: JJMorcrette, ECMWF, jul1998
673 ! Revised: MJIacono, AER, jun2006
674 ! Revised: MJIacono, AER, aug2008
675 !-----------------------------------------------------------------
676 !
677 ! name type purpose
678 ! ---- : ---- : ---------------------------------------------
679 !fracrefao: real
680 !fracrefbo: real
681 ! kao : real
682 ! kbo : real
683 ! kao_mco2: real
684 ! kbo_mco2: real
685 ! selfrefo: real
686 ! forrefo : real
687 !-----------------------------------------------------------------
689 integer(kind=im), parameter :: no7 = 16
691 real(kind=rb) , dimension(no7) :: fracrefbo
692 real(kind=rb) :: fracrefao(no7,9)
693 real(kind=rb) :: kao(9,5,13,no7)
694 real(kind=rb) :: kbo(5,13:59,no7)
695 real(kind=rb) :: kao_mco2(9,19,no7)
696 real(kind=rb) :: kbo_mco2(19,no7)
697 real(kind=rb) :: selfrefo(10,no7)
698 real(kind=rb) :: forrefo(4,no7)
700 !-----------------------------------------------------------------
701 ! rrtmg_lw COMBINED abs. coefficients for interval 7
702 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
703 !
704 ! Initial version: JJMorcrette, ECMWF, jul1998
705 ! Revised: MJIacono, AER, jun2006
706 ! Revised: MJIacono, AER, aug2008
707 !-----------------------------------------------------------------
708 !
709 ! name type purpose
710 ! ---- : ---- : ---------------------------------------------
711 !fracrefa : real
712 !fracrefb : real
713 ! ka : real
714 ! kb : real
715 ! ka_mco2 : real
716 ! kb_mco2 : real
717 ! selfref : real
718 ! forref : real
719 !
720 ! absa : real
721 !-----------------------------------------------------------------
723 integer(kind=im), parameter :: ng7 = 12
725 real(kind=rb) , dimension(ng7) :: fracrefb
726 real(kind=rb) :: fracrefa(ng7,9)
727 real(kind=rb) :: ka(9,5,13,ng7) ,absa(585,ng7)
728 real(kind=rb) :: kb(5,13:59,ng7),absb(235,ng7)
729 real(kind=rb) :: ka_mco2(9,19,ng7)
730 real(kind=rb) :: kb_mco2(19,ng7)
731 real(kind=rb) :: selfref(10,ng7)
732 real(kind=rb) :: forref(4,ng7)
734 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
736 end module rrlw_kg07
738 module rrlw_kg08
740 use parkind ,only : im => kind_im, rb => kind_rb
742 ! implicit none
743 save
745 !-----------------------------------------------------------------
746 ! rrtmg_lw ORIGINAL abs. coefficients for interval 8
747 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
748 !
749 ! Initial version: JJMorcrette, ECMWF, jul1998
750 ! Revised: MJIacono, AER, jun2006
751 ! Revised: MJIacono, AER, aug2008
752 !-----------------------------------------------------------------
753 !
754 ! name type purpose
755 ! ---- : ---- : ---------------------------------------------
756 !fracrefao: real
757 !fracrefbo: real
758 ! kao : real
759 ! kbo : real
760 ! kao_mco2: real
761 ! kbo_mco2: real
762 ! kao_mn2o: real
763 ! kbo_mn2o: real
764 ! kao_mo3 : real
765 ! selfrefo: real
766 ! forrefo : real
767 ! cfc12o : real
768 !cfc22adjo: real
769 !-----------------------------------------------------------------
771 integer(kind=im), parameter :: no8 = 16
773 real(kind=rb) , dimension(no8) :: fracrefao
774 real(kind=rb) , dimension(no8) :: fracrefbo
775 real(kind=rb) , dimension(no8) :: cfc12o
776 real(kind=rb) , dimension(no8) :: cfc22adjo
778 real(kind=rb) :: kao(5,13,no8)
779 real(kind=rb) :: kao_mco2(19,no8)
780 real(kind=rb) :: kao_mn2o(19,no8)
781 real(kind=rb) :: kao_mo3(19,no8)
782 real(kind=rb) :: kbo(5,13:59,no8)
783 real(kind=rb) :: kbo_mco2(19,no8)
784 real(kind=rb) :: kbo_mn2o(19,no8)
785 real(kind=rb) :: selfrefo(10,no8)
786 real(kind=rb) :: forrefo(4,no8)
788 !-----------------------------------------------------------------
789 ! rrtmg_lw COMBINED abs. coefficients for interval 8
790 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
791 !
792 ! Initial version: JJMorcrette, ECMWF, jul1998
793 ! Revised: MJIacono, AER, jun2006
794 ! Revised: MJIacono, AER, aug2008
795 !-----------------------------------------------------------------
796 !
797 ! name type purpose
798 ! ---- : ---- : ---------------------------------------------
799 !fracrefa : real
800 !fracrefb : real
801 ! ka : real
802 ! kb : real
803 ! ka_mco2 : real
804 ! kb_mco2 : real
805 ! ka_mn2o : real
806 ! kb_mn2o : real
807 ! ka_mo3 : real
808 ! selfref : real
809 ! forref : real
810 ! cfc12 : real
811 ! cfc22adj: real
812 !
813 ! absa : real
814 ! absb : real
815 !-----------------------------------------------------------------
817 integer(kind=im), parameter :: ng8 = 8
819 real(kind=rb) , dimension(ng8) :: fracrefa
820 real(kind=rb) , dimension(ng8) :: fracrefb
821 real(kind=rb) , dimension(ng8) :: cfc12
822 real(kind=rb) , dimension(ng8) :: cfc22adj
824 real(kind=rb) :: ka(5,13,ng8) ,absa(65,ng8)
825 real(kind=rb) :: kb(5,13:59,ng8) ,absb(235,ng8)
826 real(kind=rb) :: ka_mco2(19,ng8)
827 real(kind=rb) :: ka_mn2o(19,ng8)
828 real(kind=rb) :: ka_mo3(19,ng8)
829 real(kind=rb) :: kb_mco2(19,ng8)
830 real(kind=rb) :: kb_mn2o(19,ng8)
831 real(kind=rb) :: selfref(10,ng8)
832 real(kind=rb) :: forref(4,ng8)
834 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
836 end module rrlw_kg08
838 module rrlw_kg09
840 use parkind ,only : im => kind_im, rb => kind_rb
842 ! implicit none
843 save
845 !-----------------------------------------------------------------
846 ! rrtmg_lw ORIGINAL abs. coefficients for interval 9
847 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
848 !
849 ! Initial version: JJMorcrette, ECMWF, jul1998
850 ! Revised: MJIacono, AER, jun2006
851 ! Revised: MJIacono, AER, aug2008
852 !-----------------------------------------------------------------
853 !
854 ! name type purpose
855 ! ---- : ---- : ---------------------------------------------
856 !fracrefao: real
857 !fracrefbo: real
858 ! kao : real
859 ! kbo : real
860 ! kao_mn2o: real
861 ! kbo_mn2o: real
862 ! selfrefo: real
863 ! forrefo : real
864 !-----------------------------------------------------------------
866 integer(kind=im), parameter :: no9 = 16
868 real(kind=rb) , dimension(no9) :: fracrefbo
870 real(kind=rb) :: fracrefao(no9,9)
871 real(kind=rb) :: kao(9,5,13,no9)
872 real(kind=rb) :: kbo(5,13:59,no9)
873 real(kind=rb) :: kao_mn2o(9,19,no9)
874 real(kind=rb) :: kbo_mn2o(19,no9)
875 real(kind=rb) :: selfrefo(10,no9)
876 real(kind=rb) :: forrefo(4,no9)
878 !-----------------------------------------------------------------
879 ! rrtmg_lw COMBINED abs. coefficients for interval 9
880 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
881 !
882 ! Initial version: JJMorcrette, ECMWF, jul1998
883 ! Revised: MJIacono, AER, jun2006
884 ! Revised: MJIacono, AER, aug2008
885 !-----------------------------------------------------------------
886 !
887 ! name type purpose
888 ! ---- : ---- : ---------------------------------------------
889 !fracrefa : real
890 !fracrefb : real
891 ! ka : real
892 ! kb : real
893 ! ka_mn2o : real
894 ! kb_mn2o : real
895 ! selfref : real
896 ! forref : real
897 !
898 ! absa : real
899 ! absb : real
900 !-----------------------------------------------------------------
902 integer(kind=im), parameter :: ng9 = 12
904 real(kind=rb) , dimension(ng9) :: fracrefb
905 real(kind=rb) :: fracrefa(ng9,9)
906 real(kind=rb) :: ka(9,5,13,ng9) ,absa(585,ng9)
907 real(kind=rb) :: kb(5,13:59,ng9) ,absb(235,ng9)
908 real(kind=rb) :: ka_mn2o(9,19,ng9)
909 real(kind=rb) :: kb_mn2o(19,ng9)
910 real(kind=rb) :: selfref(10,ng9)
911 real(kind=rb) :: forref(4,ng9)
913 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
915 end module rrlw_kg09
917 module rrlw_kg10
919 use parkind ,only : im => kind_im, rb => kind_rb
921 ! implicit none
922 save
924 !-----------------------------------------------------------------
925 ! rrtmg_lw ORIGINAL abs. coefficients for interval 10
926 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
927 !
928 ! Initial version: JJMorcrette, ECMWF, jul1998
929 ! Revised: MJIacono, AER, jun2006
930 ! Revised: MJIacono, AER, aug2008
931 !-----------------------------------------------------------------
932 !
933 ! name type purpose
934 ! ---- : ---- : ---------------------------------------------
935 !fracrefao: real
936 !fracrefbo: real
937 ! kao : real
938 ! kbo : real
939 ! selfrefo: real
940 ! forrefo : real
941 !-----------------------------------------------------------------
943 integer(kind=im), parameter :: no10 = 16
945 real(kind=rb) , dimension(no10) :: fracrefao
946 real(kind=rb) , dimension(no10) :: fracrefbo
948 real(kind=rb) :: kao(5,13,no10)
949 real(kind=rb) :: kbo(5,13:59,no10)
950 real(kind=rb) :: selfrefo(10,no10)
951 real(kind=rb) :: forrefo(4,no10)
953 !-----------------------------------------------------------------
954 ! rrtmg_lw COMBINED abs. coefficients for interval 10
955 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
956 !
957 ! Initial version: JJMorcrette, ECMWF, jul1998
958 ! Revised: MJIacono, AER, jun2006
959 ! Revised: MJIacono, AER, aug2008
960 !-----------------------------------------------------------------
961 !
962 ! name type purpose
963 ! ---- : ---- : ---------------------------------------------
964 !fracrefao: real
965 !fracrefbo: real
966 ! kao : real
967 ! kbo : real
968 ! selfref : real
969 ! forref : real
970 !
971 ! absa : real
972 ! absb : real
973 !-----------------------------------------------------------------
975 integer(kind=im), parameter :: ng10 = 6
977 real(kind=rb) , dimension(ng10) :: fracrefa
978 real(kind=rb) , dimension(ng10) :: fracrefb
980 real(kind=rb) :: ka(5,13,ng10) , absa(65,ng10)
981 real(kind=rb) :: kb(5,13:59,ng10), absb(235,ng10)
982 real(kind=rb) :: selfref(10,ng10)
983 real(kind=rb) :: forref(4,ng10)
985 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
987 end module rrlw_kg10
989 module rrlw_kg11
991 use parkind ,only : im => kind_im, rb => kind_rb
993 ! implicit none
994 save
996 !-----------------------------------------------------------------
997 ! rrtmg_lw ORIGINAL abs. coefficients for interval 11
998 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
999 !
1000 ! Initial version: JJMorcrette, ECMWF, jul1998
1001 ! Revised: MJIacono, AER, jun2006
1002 ! Revised: MJIacono, AER, aug2008
1003 !-----------------------------------------------------------------
1004 !
1005 ! name type purpose
1006 ! ---- : ---- : ---------------------------------------------
1007 !fracrefao: real
1008 !fracrefbo: real
1009 ! kao : real
1010 ! kbo : real
1011 ! kao_mo2 : real
1012 ! kbo_mo2 : real
1013 ! selfrefo: real
1014 ! forrefo : real
1015 !-----------------------------------------------------------------
1017 integer(kind=im), parameter :: no11 = 16
1019 real(kind=rb) , dimension(no11) :: fracrefao
1020 real(kind=rb) , dimension(no11) :: fracrefbo
1022 real(kind=rb) :: kao(5,13,no11)
1023 real(kind=rb) :: kbo(5,13:59,no11)
1024 real(kind=rb) :: kao_mo2(19,no11)
1025 real(kind=rb) :: kbo_mo2(19,no11)
1026 real(kind=rb) :: selfrefo(10,no11)
1027 real(kind=rb) :: forrefo(4,no11)
1029 !-----------------------------------------------------------------
1030 ! rrtmg_lw COMBINED abs. coefficients for interval 11
1031 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
1032 !
1033 ! Initial version: JJMorcrette, ECMWF, jul1998
1034 ! Revised: MJIacono, AER, jun2006
1035 ! Revised: MJIacono, AER, aug2008
1036 !-----------------------------------------------------------------
1037 !
1038 ! name type purpose
1039 ! ---- : ---- : ---------------------------------------------
1040 !fracrefa : real
1041 !fracrefb : real
1042 ! ka : real
1043 ! kb : real
1044 ! ka_mo2 : real
1045 ! kb_mo2 : real
1046 ! selfref : real
1047 ! forref : real
1048 !
1049 ! absa : real
1050 ! absb : real
1051 !-----------------------------------------------------------------
1053 integer(kind=im), parameter :: ng11 = 8
1055 real(kind=rb) , dimension(ng11) :: fracrefa
1056 real(kind=rb) , dimension(ng11) :: fracrefb
1058 real(kind=rb) :: ka(5,13,ng11) , absa(65,ng11)
1059 real(kind=rb) :: kb(5,13:59,ng11), absb(235,ng11)
1060 real(kind=rb) :: ka_mo2(19,ng11)
1061 real(kind=rb) :: kb_mo2(19,ng11)
1062 real(kind=rb) :: selfref(10,ng11)
1063 real(kind=rb) :: forref(4,ng11)
1065 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1067 end module rrlw_kg11
1069 module rrlw_kg12
1071 use parkind ,only : im => kind_im, rb => kind_rb
1073 ! implicit none
1074 save
1076 !-----------------------------------------------------------------
1077 ! rrtmg_lw ORIGINAL abs. coefficients for interval 12
1078 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1079 !
1080 ! Initial version: JJMorcrette, ECMWF, jul1998
1081 ! Revised: MJIacono, AER, jun2006
1082 ! Revised: MJIacono, AER, aug2008
1083 !-----------------------------------------------------------------
1084 !
1085 ! name type purpose
1086 ! ---- : ---- : ---------------------------------------------
1087 !fracrefao: real
1088 ! kao : real
1089 ! selfrefo: real
1090 ! forrefo : real
1091 !-----------------------------------------------------------------
1093 integer(kind=im), parameter :: no12 = 16
1095 real(kind=rb) :: fracrefao(no12,9)
1096 real(kind=rb) :: kao(9,5,13,no12)
1097 real(kind=rb) :: selfrefo(10,no12)
1098 real(kind=rb) :: forrefo(4,no12)
1100 !-----------------------------------------------------------------
1101 ! rrtmg_lw COMBINED abs. coefficients for interval 12
1102 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1103 !
1104 ! Initial version: JJMorcrette, ECMWF, jul1998
1105 ! Revised: MJIacono, AER, jun2006
1106 ! Revised: MJIacono, AER, aug2008
1107 !-----------------------------------------------------------------
1108 !
1109 ! name type purpose
1110 ! ---- : ---- : ---------------------------------------------
1111 !fracrefa : real
1112 ! ka : real
1113 ! selfref : real
1114 ! forref : real
1115 !
1116 ! absa : real
1117 !-----------------------------------------------------------------
1119 integer(kind=im), parameter :: ng12 = 8
1121 real(kind=rb) :: fracrefa(ng12,9)
1122 real(kind=rb) :: ka(9,5,13,ng12) ,absa(585,ng12)
1123 real(kind=rb) :: selfref(10,ng12)
1124 real(kind=rb) :: forref(4,ng12)
1126 equivalence (ka(1,1,1,1),absa(1,1))
1128 end module rrlw_kg12
1130 module rrlw_kg13
1132 use parkind ,only : im => kind_im, rb => kind_rb
1134 ! implicit none
1135 save
1137 !-----------------------------------------------------------------
1138 ! rrtmg_lw ORIGINAL abs. coefficients for interval 13
1139 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1140 !
1141 ! Initial version: JJMorcrette, ECMWF, jul1998
1142 ! Revised: MJIacono, AER, jun2006
1143 ! Revised: MJIacono, AER, aug2008
1144 !-----------------------------------------------------------------
1145 !
1146 ! name type purpose
1147 ! ---- : ---- : ---------------------------------------------
1148 !fracrefao: real
1149 ! kao : real
1150 ! kao_mco2: real
1151 ! kao_mco : real
1152 ! kbo_mo3 : real
1153 ! selfrefo: real
1154 ! forrefo : real
1155 !-----------------------------------------------------------------
1157 integer(kind=im), parameter :: no13 = 16
1159 real(kind=rb) , dimension(no13) :: fracrefbo
1161 real(kind=rb) :: fracrefao(no13,9)
1162 real(kind=rb) :: kao(9,5,13,no13)
1163 real(kind=rb) :: kao_mco2(9,19,no13)
1164 real(kind=rb) :: kao_mco(9,19,no13)
1165 real(kind=rb) :: kbo_mo3(19,no13)
1166 real(kind=rb) :: selfrefo(10,no13)
1167 real(kind=rb) :: forrefo(4,no13)
1169 !-----------------------------------------------------------------
1170 ! rrtmg_lw COMBINED abs. coefficients for interval 13
1171 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1172 !
1173 ! Initial version: JJMorcrette, ECMWF, jul1998
1174 ! Revised: MJIacono, AER, jun2006
1175 ! Revised: MJIacono, AER, aug2008
1176 !-----------------------------------------------------------------
1177 !
1178 ! name type purpose
1179 ! ---- : ---- : ---------------------------------------------
1180 !fracrefa : real
1181 ! ka : real
1182 ! ka_mco2 : real
1183 ! ka_mco : real
1184 ! kb_mo3 : real
1185 ! selfref : real
1186 ! forref : real
1187 !
1188 ! absa : real
1189 !-----------------------------------------------------------------
1191 integer(kind=im), parameter :: ng13 = 4
1193 real(kind=rb) , dimension(ng13) :: fracrefb
1195 real(kind=rb) :: fracrefa(ng13,9)
1196 real(kind=rb) :: ka(9,5,13,ng13) ,absa(585,ng13)
1197 real(kind=rb) :: ka_mco2(9,19,ng13)
1198 real(kind=rb) :: ka_mco(9,19,ng13)
1199 real(kind=rb) :: kb_mo3(19,ng13)
1200 real(kind=rb) :: selfref(10,ng13)
1201 real(kind=rb) :: forref(4,ng13)
1203 equivalence (ka(1,1,1,1),absa(1,1))
1205 end module rrlw_kg13
1207 module rrlw_kg14
1209 use parkind ,only : im => kind_im, rb => kind_rb
1211 ! implicit none
1212 save
1214 !-----------------------------------------------------------------
1215 ! rrtmg_lw ORIGINAL abs. coefficients for interval 14
1216 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1217 !
1218 ! Initial version: JJMorcrette, ECMWF, jul1998
1219 ! Revised: MJIacono, AER, jun2006
1220 ! Revised: MJIacono, AER, aug2008
1221 !-----------------------------------------------------------------
1222 !
1223 ! name type purpose
1224 ! ---- : ---- : ---------------------------------------------
1225 !fracrefao: real
1226 !fracrefbo: real
1227 ! kao : real
1228 ! kbo : real
1229 ! selfrefo: real
1230 ! forrefo : real
1231 !-----------------------------------------------------------------
1233 integer(kind=im), parameter :: no14 = 16
1235 real(kind=rb) , dimension(no14) :: fracrefao
1236 real(kind=rb) , dimension(no14) :: fracrefbo
1238 real(kind=rb) :: kao(5,13,no14)
1239 real(kind=rb) :: kbo(5,13:59,no14)
1240 real(kind=rb) :: selfrefo(10,no14)
1241 real(kind=rb) :: forrefo(4,no14)
1243 !-----------------------------------------------------------------
1244 ! rrtmg_lw COMBINED abs. coefficients for interval 14
1245 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1246 !
1247 ! Initial version: JJMorcrette, ECMWF, jul1998
1248 ! Revised: MJIacono, AER, jun2006
1249 ! Revised: MJIacono, AER, aug2008
1250 !-----------------------------------------------------------------
1251 !
1252 ! name type purpose
1253 ! ---- : ---- : ---------------------------------------------
1254 !fracrefa : real
1255 !fracrefb : real
1256 ! ka : real
1257 ! kb : real
1258 ! selfref : real
1259 ! forref : real
1260 !
1261 ! absa : real
1262 ! absb : real
1263 !-----------------------------------------------------------------
1265 integer(kind=im), parameter :: ng14 = 2
1267 real(kind=rb) , dimension(ng14) :: fracrefa
1268 real(kind=rb) , dimension(ng14) :: fracrefb
1270 real(kind=rb) :: ka(5,13,ng14) ,absa(65,ng14)
1271 real(kind=rb) :: kb(5,13:59,ng14),absb(235,ng14)
1272 real(kind=rb) :: selfref(10,ng14)
1273 real(kind=rb) :: forref(4,ng14)
1275 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1277 end module rrlw_kg14
1279 module rrlw_kg15
1281 use parkind ,only : im => kind_im, rb => kind_rb
1283 ! implicit none
1284 save
1286 !-----------------------------------------------------------------
1287 ! rrtmg_lw ORIGINAL abs. coefficients for interval 15
1288 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1289 !
1290 ! Initial version: JJMorcrette, ECMWF, jul1998
1291 ! Revised: MJIacono, AER, jun2006
1292 ! Revised: MJIacono, AER, aug2008
1293 !-----------------------------------------------------------------
1294 !
1295 ! name type purpose
1296 ! ---- : ---- : ---------------------------------------------
1297 !fracrefao: real
1298 ! kao : real
1299 ! kao_mn2 : real
1300 ! selfrefo: real
1301 ! forrefo : real
1302 !-----------------------------------------------------------------
1304 integer(kind=im), parameter :: no15 = 16
1306 real(kind=rb) :: fracrefao(no15,9)
1307 real(kind=rb) :: kao(9,5,13,no15)
1308 real(kind=rb) :: kao_mn2(9,19,no15)
1309 real(kind=rb) :: selfrefo(10,no15)
1310 real(kind=rb) :: forrefo(4,no15)
1313 !-----------------------------------------------------------------
1314 ! rrtmg_lw COMBINED abs. coefficients for interval 15
1315 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1316 !
1317 ! Initial version: JJMorcrette, ECMWF, jul1998
1318 ! Revised: MJIacono, AER, jun2006
1319 ! Revised: MJIacono, AER, aug2008
1320 !-----------------------------------------------------------------
1321 !
1322 ! name type purpose
1323 ! ---- : ---- : ---------------------------------------------
1324 !fracrefa : real
1325 ! ka : real
1326 ! ka_mn2 : real
1327 ! selfref : real
1328 ! forref : real
1329 !
1330 ! absa : real
1331 !-----------------------------------------------------------------
1333 integer(kind=im), parameter :: ng15 = 2
1335 real(kind=rb) :: fracrefa(ng15,9)
1336 real(kind=rb) :: ka(9,5,13,ng15) ,absa(585,ng15)
1337 real(kind=rb) :: ka_mn2(9,19,ng15)
1338 real(kind=rb) :: selfref(10,ng15)
1339 real(kind=rb) :: forref(4,ng15)
1341 equivalence (ka(1,1,1,1),absa(1,1))
1343 end module rrlw_kg15
1345 module rrlw_kg16
1347 use parkind ,only : im => kind_im, rb => kind_rb
1349 ! implicit none
1350 save
1352 !-----------------------------------------------------------------
1353 ! rrtmg_lw ORIGINAL abs. coefficients for interval 16
1354 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1355 !
1356 ! Initial version: JJMorcrette, ECMWF, jul1998
1357 ! Revised: MJIacono, AER, jun2006
1358 ! Revised: MJIacono, AER, aug2008
1359 !-----------------------------------------------------------------
1360 !
1361 ! name type purpose
1362 ! ---- : ---- : ---------------------------------------------
1363 !fracrefao: real
1364 ! kao : real
1365 ! kbo : real
1366 ! selfrefo: real
1367 ! forrefo : real
1368 !-----------------------------------------------------------------
1370 integer(kind=im), parameter :: no16 = 16
1372 real(kind=rb) , dimension(no16) :: fracrefbo
1374 real(kind=rb) :: fracrefao(no16,9)
1375 real(kind=rb) :: kao(9,5,13,no16)
1376 real(kind=rb) :: kbo(5,13:59,no16)
1377 real(kind=rb) :: selfrefo(10,no16)
1378 real(kind=rb) :: forrefo(4,no16)
1380 !-----------------------------------------------------------------
1381 ! rrtmg_lw COMBINED abs. coefficients for interval 16
1382 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1383 !
1384 ! Initial version: JJMorcrette, ECMWF, jul1998
1385 ! Revised: MJIacono, AER, jun2006
1386 ! Revised: MJIacono, AER, aug2008
1387 !-----------------------------------------------------------------
1388 !
1389 ! name type purpose
1390 ! ---- : ---- : ---------------------------------------------
1391 !fracrefa : real
1392 ! ka : real
1393 ! kb : real
1394 ! selfref : real
1395 ! forref : real
1396 !
1397 ! absa : real
1398 ! absb : real
1399 !-----------------------------------------------------------------
1401 integer(kind=im), parameter :: ng16 = 2
1403 real(kind=rb) , dimension(ng16) :: fracrefb
1405 real(kind=rb) :: fracrefa(ng16,9)
1406 real(kind=rb) :: ka(9,5,13,ng16) ,absa(585,ng16)
1407 real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
1408 real(kind=rb) :: selfref(10,ng16)
1409 real(kind=rb) :: forref(4,ng16)
1411 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1413 end module rrlw_kg16
1416 module rrlw_ref
1418 use parkind, only : im => kind_im, rb => kind_rb
1420 ! implicit none
1421 save
1423 !------------------------------------------------------------------
1424 ! rrtmg_lw reference atmosphere
1425 ! Based on standard mid-latitude summer profile
1426 !
1427 ! Initial version: JJMorcrette, ECMWF, jul1998
1428 ! Revised: MJIacono, AER, jun2006
1429 ! Revised: MJIacono, AER, aug2008
1430 !------------------------------------------------------------------
1432 ! name type purpose
1433 ! ----- : ---- : ----------------------------------------------
1434 ! pref : real : Reference pressure levels
1435 ! preflog: real : Reference pressure levels, ln(pref)
1436 ! tref : real : Reference temperature levels for MLS profile
1437 ! chi_mls: real :
1438 !------------------------------------------------------------------
1440 real(kind=rb) , dimension(59) :: pref
1441 real(kind=rb) , dimension(59) :: preflog
1442 real(kind=rb) , dimension(59) :: tref
1443 real(kind=rb) :: chi_mls(7,59)
1445 end module rrlw_ref
1447 module rrlw_tbl
1449 use parkind, only : im => kind_im, rb => kind_rb
1451 ! implicit none
1452 save
1454 !------------------------------------------------------------------
1455 ! rrtmg_lw exponential lookup table arrays
1457 ! Initial version: JJMorcrette, ECMWF, jul1998
1458 ! Revised: MJIacono, AER, Jun 2006
1459 ! Revised: MJIacono, AER, Aug 2007
1460 ! Revised: MJIacono, AER, Aug 2008
1461 !------------------------------------------------------------------
1463 ! name type purpose
1464 ! ----- : ---- : ----------------------------------------------
1465 ! ntbl : integer: Lookup table dimension
1466 ! tblint : real : Lookup table conversion factor
1467 ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative
1468 ! transfer)
1469 ! exp_tbl: real : Transmittance lookup table
1470 ! tfn_tbl: real : Tau transition function; i.e. the transition of
1471 ! the Planck function from that for the mean layer
1472 ! temperature to that for the layer boundary
1473 ! temperature as a function of optical depth.
1474 ! The "linear in tau" method is used to make
1475 ! the table.
1476 ! pade : real : Pade constant
1477 ! bpade : real : Inverse of Pade constant
1478 !------------------------------------------------------------------
1480 integer(kind=im), parameter :: ntbl = 10000
1482 real(kind=rb), parameter :: tblint = 10000.0_rb
1484 real(kind=rb) , dimension(0:ntbl) :: tau_tbl
1485 real(kind=rb) , dimension(0:ntbl) :: exp_tbl
1486 real(kind=rb) , dimension(0:ntbl) :: tfn_tbl
1488 real(kind=rb), parameter :: pade = 0.278_rb
1489 real(kind=rb) :: bpade
1491 end module rrlw_tbl
1493 module rrlw_vsn
1495 ! implicit none
1496 save
1498 !------------------------------------------------------------------
1499 ! rrtmg_lw version information
1501 ! Initial version: JJMorcrette, ECMWF, jul1998
1502 ! Revised: MJIacono, AER, jun2006
1503 ! Revised: MJIacono, AER, aug2008
1504 !------------------------------------------------------------------
1506 ! name type purpose
1507 ! ----- : ---- : ----------------------------------------------
1508 !hnamrtm :character:
1509 !hnamini :character:
1510 !hnamcld :character:
1511 !hnamclc :character:
1512 !hnamrtr :character:
1513 !hnamrtx :character:
1514 !hnamrtc :character:
1515 !hnamset :character:
1516 !hnamtau :character:
1517 !hnamatm :character:
1518 !hnamutl :character:
1519 !hnamext :character:
1520 !hnamkg :character:
1521 !
1522 ! hvrrtm :character:
1523 ! hvrini :character:
1524 ! hvrcld :character:
1525 ! hvrclc :character:
1526 ! hvrrtr :character:
1527 ! hvrrtx :character:
1528 ! hvrrtc :character:
1529 ! hvrset :character:
1530 ! hvrtau :character:
1531 ! hvratm :character:
1532 ! hvrutl :character:
1533 ! hvrext :character:
1534 ! hvrkg :character:
1535 !------------------------------------------------------------------
1537 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, &
1538 hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
1539 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, &
1540 hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
1542 character*18 hvrkg
1543 character*20 hnamkg
1545 end module rrlw_vsn
1547 module rrlw_wvn
1549 use parkind, only : im => kind_im, rb => kind_rb
1550 use parrrtm, only : nbndlw, mg, ngptlw, maxinpx
1552 ! implicit none
1553 save
1555 !------------------------------------------------------------------
1556 ! rrtmg_lw spectral information
1558 ! Initial version: JJMorcrette, ECMWF, jul1998
1559 ! Revised: MJIacono, AER, jun2006
1560 ! Revised: MJIacono, AER, aug2008
1561 !------------------------------------------------------------------
1563 ! name type purpose
1564 ! ----- : ---- : ----------------------------------------------
1565 ! ng : integer: Number of original g-intervals in each spectral band
1566 ! nspa : integer: For the lower atmosphere, the number of reference
1567 ! atmospheres that are stored for each spectral band
1568 ! per pressure level and temperature. Each of these
1569 ! atmospheres has different relative amounts of the
1570 ! key species for the band (i.e. different binary
1571 ! species parameters).
1572 ! nspb : integer: Same as nspa for the upper atmosphere
1573 !wavenum1: real : Spectral band lower boundary in wavenumbers
1574 !wavenum2: real : Spectral band upper boundary in wavenumbers
1575 ! delwave: real : Spectral band width in wavenumbers
1576 ! totplnk: real : Integrated Planck value for each band; (band 16
1577 ! includes total from 2600 cm-1 to infinity)
1578 ! Used for calculation across total spectrum
1579 !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1)
1580 ! Used for calculation in band 16 only if
1581 ! individual band output requested
1582 !
1583 ! ngc : integer: The number of new g-intervals in each band
1584 ! ngs : integer: The cumulative sum of new g-intervals for each band
1585 ! ngm : integer: The index of each new g-interval relative to the
1586 ! original 16 g-intervals in each band
1587 ! ngn : integer: The number of original g-intervals that are
1588 ! combined to make each new g-intervals in each band
1589 ! ngb : integer: The band index for each new g-interval
1590 ! wt : real : RRTM weights for the original 16 g-intervals
1591 ! rwgt : real : Weights for combining original 16 g-intervals
1592 ! (256 total) into reduced set of g-intervals
1593 ! (140 total)
1594 ! nxmol : integer: Number of cross-section molecules
1595 ! ixindx : integer: Flag for active cross-sections in calculation
1596 !------------------------------------------------------------------
1598 integer(kind=im) :: ng(nbndlw)
1599 integer(kind=im) :: nspa(nbndlw)
1600 integer(kind=im) :: nspb(nbndlw)
1602 real(kind=rb) :: wavenum1(nbndlw)
1603 real(kind=rb) :: wavenum2(nbndlw)
1604 real(kind=rb) :: delwave(nbndlw)
1606 real(kind=rb) :: totplnk(181,nbndlw)
1607 real(kind=rb) :: totplk16(181)
1609 integer(kind=im) :: ngc(nbndlw)
1610 integer(kind=im) :: ngs(nbndlw)
1611 integer(kind=im) :: ngn(ngptlw)
1612 integer(kind=im) :: ngb(ngptlw)
1613 integer(kind=im) :: ngm(nbndlw*mg)
1615 real(kind=rb) :: wt(mg)
1616 real(kind=rb) :: rwgt(nbndlw*mg)
1618 integer(kind=im) :: nxmol
1619 integer(kind=im) :: ixindx(maxinpx)
1621 end module rrlw_wvn
1623 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
1624 ! author: $Author: trn $
1625 ! revision: $Revision: 1.3 $
1626 ! created: $Date: 2009/04/16 19:54:22 $
1627 !
1629 ! Fortran-95 implementation of the Mersenne Twister 19937, following
1630 ! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10),
1631 ! adapted cosmetically by making the names more general.
1632 ! Users must declare one or more variables of type randomNumberSequence in the calling
1633 ! procedure which are then initialized using a required seed. If the
1634 ! variable is not initialized the random numbers will all be 0.
1635 ! For example:
1636 ! program testRandoms
1637 ! use RandomNumbers
1638 ! type(randomNumberSequence) :: randomNumbers
1639 ! integer :: i
1640 !
1641 ! randomNumbers = new_RandomNumberSequence(seed = 100)
1642 ! do i = 1, 10
1643 ! print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
1644 ! end do
1645 ! end program testRandoms
1646 !
1647 ! Fortran-95 implementation by
1648 ! Robert Pincus
1649 ! NOAA-CIRES Climate Diagnostics Center
1650 ! Boulder, CO 80305
1651 ! email: Robert.Pincus@colorado.edu
1652 !
1653 ! This documentation in the original C program reads:
1654 ! -------------------------------------------------------------
1655 ! A C-program for MT19937, with initialization improved 2002/2/10.
1656 ! Coded by Takuji Nishimura and Makoto Matsumoto.
1657 ! This is a faster version by taking Shawn Cokus's optimization,
1658 ! Matthe Bellew's simplification, Isaku Wada's real version.
1659 !
1660 ! Before using, initialize the state by using init_genrand(seed)
1661 ! or init_by_array(init_key, key_length).
1662 !
1663 ! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
1664 ! All rights reserved.
1665 !
1666 ! Redistribution and use in source and binary forms, with or without
1667 ! modification, are permitted provided that the following conditions
1668 ! are met:
1669 !
1670 ! 1. Redistributions of source code must retain the above copyright
1671 ! notice, this list of conditions and the following disclaimer.
1672 !
1673 ! 2. Redistributions in binary form must reproduce the above copyright
1674 ! notice, this list of conditions and the following disclaimer in the
1675 ! documentation and/or other materials provided with the distribution.
1676 !
1677 ! 3. The names of its contributors may not be used to endorse or promote
1678 ! products derived from this software without specific prior written
1679 ! permission.
1680 !
1681 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1682 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1683 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1684 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
1685 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
1686 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
1687 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
1688 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1689 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1690 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
1691 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1692 !
1693 !
1694 ! Any feedback is very welcome.
1695 ! http://www.math.keio.ac.jp/matumoto/emt.html
1696 ! email: matumoto@math.keio.ac.jp
1697 ! -------------------------------------------------------------
1699 module MersenneTwister
1700 ! -------------------------------------------------------------
1702 use parkind, only : im => kind_im, rb => kind_rb
1704 implicit none
1705 private
1707 ! Algorithm parameters
1708 ! -------
1709 ! Period parameters
1710 integer(kind=im), parameter :: blockSize = 624, &
1711 M = 397, &
1712 MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL)
1713 UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL)
1714 LMASK = 2147483647 ! least significant r bits (0x7fffffffUL)
1715 ! Tempering parameters
1716 integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
1717 TMASKC= -272236544 ! (0xefc60000UL)
1718 ! -------
1720 ! The type containing the state variable
1721 type randomNumberSequence
1722 integer(kind=im) :: currentElement ! = blockSize
1723 integer(kind=im), dimension(0:blockSize -1) :: state ! = 0
1724 end type randomNumberSequence
1726 interface new_RandomNumberSequence
1727 module procedure initialize_scalar, initialize_vector
1728 end interface new_RandomNumberSequence
1730 public :: randomNumberSequence
1731 public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
1732 getRandomInt, getRandomPositiveInt, getRandomReal
1733 ! -------------------------------------------------------------
1734 contains
1735 ! -------------------------------------------------------------
1736 ! Private functions
1737 ! ---------------------------
1738 function mixbits(u, v)
1739 integer(kind=im), intent( in) :: u, v
1740 integer(kind=im) :: mixbits
1742 mixbits = ior(iand(u, UMASK), iand(v, LMASK))
1743 end function mixbits
1744 ! ---------------------------
1745 function twist(u, v)
1746 integer(kind=im), intent( in) :: u, v
1747 integer(kind=im) :: twist
1749 ! Local variable
1750 integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /)
1752 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1753 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1754 end function twist
1755 ! ---------------------------
1756 subroutine nextState(twister)
1757 type(randomNumberSequence), intent(inout) :: twister
1759 ! Local variables
1760 integer(kind=im) :: k
1762 do k = 0, blockSize - M - 1
1763 twister%state(k) = ieor(twister%state(k + M), &
1764 twist(twister%state(k), twister%state(k + 1_im)))
1765 end do
1766 do k = blockSize - M, blockSize - 2
1767 twister%state(k) = ieor(twister%state(k + M - blockSize), &
1768 twist(twister%state(k), twister%state(k + 1_im)))
1769 end do
1770 twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), &
1771 twist(twister%state(blockSize - 1_im), twister%state(0_im)))
1772 twister%currentElement = 0_im
1774 end subroutine nextState
1775 ! ---------------------------
1776 elemental function temper(y)
1777 integer(kind=im), intent(in) :: y
1778 integer(kind=im) :: temper
1780 integer(kind=im) :: x
1782 ! Tempering
1783 x = ieor(y, ishft(y, -11))
1784 x = ieor(x, iand(ishft(x, 7), TMASKB))
1785 x = ieor(x, iand(ishft(x, 15), TMASKC))
1786 temper = ieor(x, ishft(x, -18))
1787 end function temper
1788 ! -------------------------------------------------------------
1789 ! Public (but hidden) functions
1790 ! --------------------
1791 function initialize_scalar(seed) result(twister)
1792 integer(kind=im), intent(in ) :: seed
1793 type(randomNumberSequence) :: twister
1795 integer(kind=im) :: i
1796 ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions,
1797 ! MSBs of the seed affect only MSBs of the array state[].
1798 ! 2002/01/09 modified by Makoto Matsumoto
1800 twister%state(0) = iand(seed, -1_im)
1801 do i = 1, blockSize - 1 ! ubound(twister%state)
1802 twister%state(i) = 1812433253_im * ieor(twister%state(i-1), &
1803 ishft(twister%state(i-1), -30_im)) + i
1804 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1805 end do
1806 twister%currentElement = blockSize
1807 end function initialize_scalar
1808 ! -------------------------------------------------------------
1809 function initialize_vector(seed) result(twister)
1810 integer(kind=im), dimension(0:), intent(in) :: seed
1811 type(randomNumberSequence) :: twister
1813 integer(kind=im) :: i, j, k, nFirstLoop, nWraps
1815 nWraps = 0
1816 twister = initialize_scalar(19650218_im)
1818 nFirstLoop = max(blockSize, size(seed))
1819 do k = 1, nFirstLoop
1820 i = mod(k + nWraps, blockSize)
1821 j = mod(k - 1, size(seed))
1822 if(i == 0) then
1823 twister%state(i) = twister%state(blockSize - 1)
1824 twister%state(1) = ieor(twister%state(1), &
1825 ieor(twister%state(1-1), &
1826 ishft(twister%state(1-1), -30_im)) * 1664525_im) + &
1827 seed(j) + j ! Non-linear
1828 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1829 nWraps = nWraps + 1
1830 else
1831 twister%state(i) = ieor(twister%state(i), &
1832 ieor(twister%state(i-1), &
1833 ishft(twister%state(i-1), -30_im)) * 1664525_im) + &
1834 seed(j) + j ! Non-linear
1835 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1836 end if
1837 end do
1839 !
1840 ! Walk through the state array, beginning where we left off in the block above
1841 !
1842 do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
1843 twister%state(i) = ieor(twister%state(i), &
1844 ieor(twister%state(i-1), &
1845 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1846 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1847 end do
1849 twister%state(0) = twister%state(blockSize - 1)
1851 do i = 1, mod(nFirstLoop, blockSize) + nWraps
1852 twister%state(i) = ieor(twister%state(i), &
1853 ieor(twister%state(i-1), &
1854 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1855 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1856 end do
1858 twister%state(0) = UMASK
1859 twister%currentElement = blockSize
1861 end function initialize_vector
1862 ! -------------------------------------------------------------
1863 ! Public functions
1864 ! --------------------
1865 function getRandomInt(twister)
1866 type(randomNumberSequence), intent(inout) :: twister
1867 integer(kind=im) :: getRandomInt
1868 ! Generate a random integer on the interval [0,0xffffffff]
1869 ! Equivalent to genrand_int32 in the C code.
1870 ! Fortran doesn't have a type that's unsigned like C does,
1871 ! so this is integers in the range -2**31 - 2**31
1872 ! All functions for getting random numbers call this one,
1873 ! then manipulate the result
1875 if(twister%currentElement >= blockSize) call nextState(twister)
1877 getRandomInt = temper(twister%state(twister%currentElement))
1878 twister%currentElement = twister%currentElement + 1
1880 end function getRandomInt
1881 ! --------------------
1882 function getRandomPositiveInt(twister)
1883 type(randomNumberSequence), intent(inout) :: twister
1884 integer(kind=im) :: getRandomPositiveInt
1885 ! Generate a random integer on the interval [0,0x7fffffff]
1886 ! or [0,2**31]
1887 ! Equivalent to genrand_int31 in the C code.
1889 ! Local integers
1890 integer(kind=im) :: localInt
1892 localInt = getRandomInt(twister)
1893 getRandomPositiveInt = ishft(localInt, -1)
1895 end function getRandomPositiveInt
1896 ! --------------------
1897 !! mji - modified Jan 2007, double converted to rrtmg real kind type
1898 function getRandomReal(twister)
1899 type(randomNumberSequence), intent(inout) :: twister
1900 ! double precision :: getRandomReal
1901 real(kind=rb) :: getRandomReal
1902 ! Generate a random number on [0,1]
1903 ! Equivalent to genrand_real1 in the C code
1904 ! The result is stored as double precision but has 32 bit resolution
1906 integer(kind=im) :: localInt
1908 localInt = getRandomInt(twister)
1909 if(localInt < 0) then
1910 ! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
1911 getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb)
1912 else
1913 ! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0)
1914 getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb)
1915 end if
1917 end function getRandomReal
1918 ! --------------------
1919 subroutine finalize_RandomNumberSequence(twister)
1920 type(randomNumberSequence), intent(inout) :: twister
1922 twister%currentElement = blockSize
1923 twister%state(:) = 0_im
1924 end subroutine finalize_RandomNumberSequence
1926 ! --------------------
1928 end module MersenneTwister
1931 module mcica_random_numbers
1933 ! Generic module to wrap random number generators.
1934 ! The module defines a type that identifies the particular stream of random
1935 ! numbers, and has procedures for initializing it and getting real numbers
1936 ! in the range 0 to 1.
1937 ! This version uses the Mersenne Twister to generate random numbers on [0, 1].
1938 !
1939 use MersenneTwister, only: randomNumberSequence, & ! The random number engine.
1940 new_RandomNumberSequence, getRandomReal
1941 !! mji
1942 !! use time_manager_mod, only: time_type, get_date
1944 use parkind, only : im => kind_im, rb => kind_rb
1946 implicit none
1947 private
1949 type randomNumberStream
1950 type(randomNumberSequence) :: theNumbers
1951 end type randomNumberStream
1953 interface getRandomNumbers
1954 module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
1955 end interface getRandomNumbers
1957 interface initializeRandomNumberStream
1958 module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
1959 end interface initializeRandomNumberStream
1961 public :: randomNumberStream, &
1962 initializeRandomNumberStream, getRandomNumbers
1963 !! mji
1964 !! initializeRandomNumberStream, getRandomNumbers, &
1965 !! constructSeed
1966 contains
1967 ! ---------------------------------------------------------
1968 ! Initialization
1969 ! ---------------------------------------------------------
1970 function initializeRandomNumberStream_S(seed) result(new)
1971 integer(kind=im), intent( in) :: seed
1972 type(randomNumberStream) :: new
1974 new%theNumbers = new_RandomNumberSequence(seed)
1976 end function initializeRandomNumberStream_S
1977 ! ---------------------------------------------------------
1978 function initializeRandomNumberStream_V(seed) result(new)
1979 integer(kind=im), dimension(:), intent( in) :: seed
1980 type(randomNumberStream) :: new
1982 new%theNumbers = new_RandomNumberSequence(seed)
1984 end function initializeRandomNumberStream_V
1985 ! ---------------------------------------------------------
1986 ! Procedures for drawing random numbers
1987 ! ---------------------------------------------------------
1988 subroutine getRandomNumber_Scalar(stream, number)
1989 type(randomNumberStream), intent(inout) :: stream
1990 real(kind=rb), intent( out) :: number
1992 number = getRandomReal(stream%theNumbers)
1993 end subroutine getRandomNumber_Scalar
1994 ! ---------------------------------------------------------
1995 subroutine getRandomNumber_1D(stream, numbers)
1996 type(randomNumberStream), intent(inout) :: stream
1997 real(kind=rb), dimension(:), intent( out) :: numbers
1999 ! Local variables
2000 integer(kind=im) :: i
2002 do i = 1, size(numbers)
2003 numbers(i) = getRandomReal(stream%theNumbers)
2004 end do
2005 end subroutine getRandomNumber_1D
2006 ! ---------------------------------------------------------
2007 subroutine getRandomNumber_2D(stream, numbers)
2008 type(randomNumberStream), intent(inout) :: stream
2009 real(kind=rb), dimension(:, :), intent( out) :: numbers
2011 ! Local variables
2012 integer(kind=im) :: i
2014 do i = 1, size(numbers, 2)
2015 call getRandomNumber_1D(stream, numbers(:, i))
2016 end do
2017 end subroutine getRandomNumber_2D
2018 ! mji
2019 ! ! ---------------------------------------------------------
2020 ! ! Constructing a unique seed from grid cell index and model date/time
2021 ! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute
2022 ! ! ---------------------------------------------------------
2023 ! function constructSeed(i, j, time) result(seed)
2024 ! integer(kind=im), intent( in) :: i, j
2025 ! type(time_type), intent( in) :: time
2026 ! integer(kind=im), dimension(8) :: seed
2027 !
2028 ! ! Local variables
2029 ! integer(kind=im) :: year, month, day, hour, minute, second
2030 !
2031 !
2032 ! call get_date(time, year, month, day, hour, minute, second)
2033 ! seed = (/ i, j, year, month, day, hour, minute, second /)
2034 ! end function constructSeed
2036 end module mcica_random_numbers
2038 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2039 ! author: $Author: trn $
2040 ! revision: $Revision: 1.3 $
2041 ! created: $Date: 2009/04/16 19:54:22 $
2042 !
2043 module mcica_subcol_gen_lw
2045 ! --------------------------------------------------------------------------
2046 ! | |
2047 ! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). |
2048 ! | This software may be used, copied, or redistributed as long as it is |
2049 ! | not sold and this copyright notice is reproduced on each copy made. |
2050 ! | This model is provided as is without any express or implied warranties. |
2051 ! | (http://www.rtweb.aer.com/) |
2052 ! | |
2053 ! --------------------------------------------------------------------------
2055 ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
2056 ! Two options are possible:
2057 ! 1) Input cloud physical properties: cloud fraction, ice and liquid water
2058 ! paths, ice fraction, and particle sizes. Output will be stochastic
2059 ! arrays of these variables. (inflag = 1)
2060 ! 2) Input cloud optical properties directly: cloud optical depth, single
2061 ! scattering albedo and asymmetry parameter. Output will be stochastic
2062 ! arrays of these variables. (inflag = 0; longwave scattering is not
2063 ! yet available, ssac and asmc are for future expansion)
2065 ! --------- Modules ----------
2067 use parkind, only : im => kind_im, rb => kind_rb
2068 use parrrtm, only : nbndlw, ngptlw
2069 use rrlw_con, only: grav
2070 use rrlw_wvn, only: ngb
2071 use rrlw_vsn
2073 implicit none
2075 ! public interfaces/functions/subroutines
2076 public :: mcica_subcol_lw, generate_stochastic_clouds
2078 contains
2080 !------------------------------------------------------------------
2081 ! Public subroutines
2082 !------------------------------------------------------------------
2084 subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
2085 cldfrac, ciwp, clwp, rei, rel, tauc, cldfmcl, &
2086 ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
2088 ! ----- Input -----
2089 ! Control
2090 integer(kind=im), intent(in) :: iplon ! column/longitude index
2091 integer(kind=im), intent(in) :: ncol ! number of columns
2092 integer(kind=im), intent(in) :: nlay ! number of model layers
2093 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2094 integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times,
2095 ! permute the seed between each call.
2096 ! between calls for LW and SW, recommended
2097 ! permuteseed differes by 'ngpt'
2098 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2099 ! 0 = kissvec
2100 ! 1 = Mersenne Twister
2102 ! Atmosphere
2103 real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb)
2104 ! Dimensions: (ncol,nlay)
2106 ! Atmosphere/clouds - cldprop
2107 real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction
2108 ! Dimensions: (ncol,nlay)
2109 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2110 ! Dimensions: (nbndlw,ncol,nlay)
2111 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2112 ! Dimensions: (nbndlw,ncol,nlay)
2113 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2114 ! Dimensions: (nbndlw,ncol,nlay)
2115 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2116 ! Dimensions: (ncol,nlay)
2117 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2118 ! Dimensions: (ncol,nlay)
2119 real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size
2120 ! Dimensions: (ncol,nlay)
2121 real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size
2122 ! Dimensions: (ncol,nlay)
2124 ! ----- Output -----
2125 ! Atmosphere/clouds - cldprmc [mcica]
2126 real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
2127 ! Dimensions: (ngptlw,ncol,nlay)
2128 real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
2129 ! Dimensions: (ngptlw,ncol,nlay)
2130 real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
2131 ! Dimensions: (ngptlw,ncol,nlay)
2132 real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns)
2133 ! Dimensions: (ncol,nlay)
2134 real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns)
2135 ! Dimensions: (ncol,nlay)
2136 real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
2137 ! Dimensions: (ngptlw,ncol,nlay)
2138 ! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica]
2139 ! Dimensions: (ngptlw,ncol,nlay)
2140 ! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica]
2141 ! Dimensions: (ngptlw,ncol,nlay)
2143 ! ----- Local -----
2145 ! Stochastic cloud generator variables [mcica]
2146 integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals)
2147 integer(kind=im) :: ilev ! loop index
2149 real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa)
2150 ! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa)
2151 ! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity)
2152 ! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity)
2155 ! Return if clear sky; or stop if icld out of range
2156 if (icld.eq.0) return
2157 if (icld.lt.0.or.icld.gt.3) then
2158 stop 'MCICA_SUBCOL: INVALID ICLD'
2159 endif
2161 ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns
2164 ! Pass particle sizes to new arrays, no subcolumns for these properties yet
2165 ! Convert pressures from mb to Pa
2167 reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
2168 relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
2169 pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
2171 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components
2173 ! cwp = (q * pdel * 1000.) / gravit)
2174 ! = (kg/kg * kg m-1 s-2 *1000.) / m s-2
2175 ! = (g m-2)
2176 !
2177 ! q = (cwp * gravit) / (pdel *1000.)
2178 ! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
2179 ! = kg/kg
2181 ! do ilev = 1, nlay
2182 ! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2183 ! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2184 ! enddo
2186 ! Generate the stochastic subcolumns of cloud optical properties for the longwave;
2187 call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, tauc, &
2188 cldfmcl, clwpmcl, ciwpmcl, taucmcl, permuteseed)
2190 end subroutine mcica_subcol_lw
2193 !-------------------------------------------------------------------------------------------------
2194 subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, tauc, &
2195 cld_stoch, clwp_stoch, ciwp_stoch, tauc_stoch, changeSeed)
2196 !-------------------------------------------------------------------------------------------------
2198 !----------------------------------------------------------------------------------------------------------------
2199 ! ---------------------
2200 ! Contact: Cecile Hannay (hannay@ucar.edu)
2201 !
2202 ! Original code: Based on Raisanen et al., QJRMS, 2004.
2203 !
2204 ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
2205 ! random number generator, which can be changed to the optional kissvec random number generator
2206 ! with flag 'irng'. Some extra functionality has been commented or removed.
2207 ! Michael J. Iacono, AER, Inc., February 2007
2208 !
2209 ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
2210 ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
2211 ! and uniform cloud liquid and cloud ice concentration.
2212 ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
2213 ! and obeys an overlap assumption in the vertical.
2214 !
2215 ! Overlap assumption:
2216 ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
2217 ! The default option is maximum-random (option 3)
2218 ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
2219 ! This is set with the variable "overlap"
2220 !mji - Exponential overlap option (overlap=4) has been deactivated in this version
2221 ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
2222 !
2223 ! Seed:
2224 ! If the stochastic cloud generator is called several times during the same timestep,
2225 ! one should change the seed between the call to insure that the subcolumns are different.
2226 ! This is done by changing the argument 'changeSeed'
2227 ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
2228 ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
2229 !
2230 ! PDF assumption:
2231 ! We can use arbitrary complicated PDFS.
2232 ! In the present version, we produce homogeneuous clouds (the simplest case).
2233 ! Future developments include using the PDF scheme of Ben Johnson.
2234 !
2235 ! History file:
2236 ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
2237 ! nsubcol = number of subcolumns
2238 ! overlap = overlap type (1-3)
2239 ! Zo = length scale
2240 ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
2241 ! CLDLIQ_S = mean of the subcolumn cloud water
2242 ! CLDICE_S = mean of the subcolumn cloud ice
2243 !
2244 ! Note:
2245 ! Here: we force that the cloud condensate to be consistent with the cloud fraction
2246 ! i.e we only have cloud condensate when the cell is cloudy.
2247 ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
2248 ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
2249 ! without cloud condensate or the opposite).
2250 !---------------------------------------------------------------------------------------------------------------
2252 use mcica_random_numbers
2253 ! The Mersenne Twister random number engine
2254 use MersenneTwister, only: randomNumberSequence, &
2255 new_RandomNumberSequence, getRandomReal
2257 type(randomNumberSequence) :: randomNumbers
2259 ! -- Arguments
2261 integer(kind=im), intent(in) :: ncol ! number of columns
2262 integer(kind=im), intent(in) :: nlay ! number of layers
2263 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2264 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2265 ! 0 = kissvec
2266 ! 1 = Mersenne Twister
2267 integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
2268 integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed
2270 ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
2271 real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa)
2272 ! Dimensions: (ncol,nlay)
2273 real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction
2274 ! Dimensions: (ncol,nlay)
2275 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2276 ! Dimensions: (ncol,nlay)
2277 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2278 ! Dimensions: (ncol,nlay)
2279 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2280 ! Dimensions: (nbndlw,ncol,nlay)
2281 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2282 ! Dimensions: (nbndlw,ncol,nlay)
2283 ! inactive - for future expansion
2284 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2285 ! Dimensions: (nbndlw,ncol,nlay)
2286 ! inactive - for future expansion
2288 real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
2289 ! Dimensions: (ngptlw,ncol,nlay)
2290 real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
2291 ! Dimensions: (ngptlw,ncol,nlay)
2292 real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
2293 ! Dimensions: (ngptlw,ncol,nlay)
2294 real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
2295 ! Dimensions: (ngptlw,ncol,nlay)
2296 ! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
2297 ! Dimensions: (ngptlw,ncol,nlay)
2298 ! inactive - for future expansion
2299 ! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter
2300 ! Dimensions: (ngptlw,ncol,nlay)
2301 ! inactive - for future expansion
2303 ! -- Local variables
2304 real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction
2306 ! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
2307 ! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction
2308 ! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water
2309 ! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice
2310 ! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth
2311 ! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo
2312 ! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter
2314 ! Set overlap
2315 integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum/random,
2316 ! 3 = maximum overlap,
2317 ! real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m)
2318 ! real(kind=rb) :: zm(ncol,nlay) ! Height of midpoints (above surface)
2319 ! real(kind=rb), dimension(nlay) :: alpha=0.0_rb ! overlap parameter
2321 ! Constants (min value for cloud fraction and cloud water and ice)
2322 real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
2323 ! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used)
2325 ! Variables related to random number and seed
2326 real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers
2327 integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
2328 real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec)
2329 integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister)
2330 real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister)
2332 ! Flag to identify cloud fraction in subcolumns
2333 logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy
2335 ! Indices
2336 integer(kind=im) :: ilev, isubcol, i, n ! indices
2338 !------------------------------------------------------------------------------------------
2340 ! Check that irng is in bounds; if not, set to default
2341 if (irng .ne. 0) irng = 1
2343 ! Pass input cloud overlap setting to local variable
2344 overlap = icld
2346 ! Ensure that cloud fractions are in bounds
2347 do ilev = 1, nlay
2348 do i = 1, ncol
2349 cldf(i,ilev) = cld(i,ilev)
2350 if (cldf(i,ilev) < cldmin) then
2351 cldf(i,ilev) = 0._rb
2352 endif
2353 enddo
2354 enddo
2356 ! ----- Create seed --------
2358 ! Advance randum number generator by changeseed values
2359 if (irng.eq.0) then
2360 ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
2361 ! Must use pmid from bottom four layers.
2362 do i=1,ncol
2363 if (pmid(i,1).lt.pmid(i,2)) then
2364 stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
2365 endif
2366 seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im
2367 seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im
2368 seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im
2369 seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im
2370 enddo
2371 do i=1,changeSeed
2372 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2373 enddo
2374 elseif (irng.eq.1) then
2375 randomNumbers = new_RandomNumberSequence(seed = changeSeed)
2376 endif
2379 ! ------ Apply overlap assumption --------
2381 ! generate the random numbers
2383 select case (overlap)
2385 case(1)
2386 ! Random overlap
2387 ! i) pick a random value at every level
2389 if (irng.eq.0) then
2390 do isubcol = 1,nsubcol
2391 do ilev = 1,nlay
2392 call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level
2393 CDF(isubcol,:,ilev) = rand_num
2394 enddo
2395 enddo
2396 elseif (irng.eq.1) then
2397 do isubcol = 1, nsubcol
2398 do i = 1, ncol
2399 do ilev = 1, nlay
2400 rand_num_mt = getRandomReal(randomNumbers)
2401 CDF(isubcol,i,ilev) = rand_num_mt
2402 enddo
2403 enddo
2404 enddo
2405 endif
2407 case(2)
2408 ! Maximum-Random overlap
2409 ! i) pick a random number for top layer.
2410 ! ii) walk down the column:
2411 ! - if the layer above is cloudy, we use the same random number than in the layer above
2412 ! - if the layer above is clear, we use a new random number
2414 if (irng.eq.0) then
2415 do isubcol = 1,nsubcol
2416 do ilev = 1,nlay
2417 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2418 CDF(isubcol,:,ilev) = rand_num
2419 enddo
2420 enddo
2421 elseif (irng.eq.1) then
2422 do isubcol = 1, nsubcol
2423 do i = 1, ncol
2424 do ilev = 1, nlay
2425 rand_num_mt = getRandomReal(randomNumbers)
2426 CDF(isubcol,i,ilev) = rand_num_mt
2427 enddo
2428 enddo
2429 enddo
2430 endif
2432 do ilev = 2,nlay
2433 do i = 1, ncol
2434 do isubcol = 1, nsubcol
2435 if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
2436 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1)
2437 else
2438 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1))
2439 endif
2440 enddo
2441 enddo
2442 enddo
2444 case(3)
2445 ! Maximum overlap
2446 ! i) pick the same random numebr at every level
2448 if (irng.eq.0) then
2449 do isubcol = 1,nsubcol
2450 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2451 do ilev = 1,nlay
2452 CDF(isubcol,:,ilev) = rand_num
2453 enddo
2454 enddo
2455 elseif (irng.eq.1) then
2456 do isubcol = 1, nsubcol
2457 do i = 1, ncol
2458 rand_num_mt = getRandomReal(randomNumbers)
2459 do ilev = 1, nlay
2460 CDF(isubcol,i,ilev) = rand_num_mt
2461 enddo
2462 enddo
2463 enddo
2464 endif
2466 ! case(4) - inactive
2467 ! ! Exponential overlap: weighting between maximum and random overlap increases with the distance.
2468 ! ! The random numbers for exponential overlap verify:
2469 ! ! j=1 RAN(j)=RND1
2470 ! ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
2471 ! ! RAN(j) = RND2
2472 ! ! alpha is obtained from the equation
2473 ! ! alpha = exp(- (Zi-Zj-1)/Zo) where Zo is a characteristic length scale
2476 ! ! compute alpha
2477 ! zm = state%zm
2478 ! alpha(:, 1) = 0.
2479 ! do ilev = 2,nlay
2480 ! alpha(:, ilev) = exp( -( zm (:, ilev-1) - zm (:, ilev)) / Zo)
2481 ! end do
2483 ! ! generate 2 streams of random numbers
2484 ! do isubcol = 1,nsubcol
2485 ! do ilev = 1,nlay
2486 ! call kissvec(seed1, seed2, seed3, seed4, rand_num)
2487 ! CDF(isubcol, :, ilev) = rand_num
2488 ! call kissvec(seed1, seed2, seed3, seed4, rand_num)
2489 ! CDF2(isubcol, :, ilev) = rand_num
2490 ! end do
2491 ! end do
2493 ! ! generate random numbers
2494 ! do ilev = 2,nlay
2495 ! where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
2496 ! CDF(:,:,ilev) = CDF(:,:,ilev-1)
2497 ! end where
2498 ! end do
2500 end select
2503 ! -- generate subcolumns for homogeneous clouds -----
2504 do ilev = 1,nlay
2505 iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
2506 enddo
2508 ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
2509 ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
2510 ! where there is a cloud, define the subcolumn cloud properties,
2511 ! otherwise set these to zero
2513 do ilev = 1,nlay
2514 do i = 1, ncol
2515 do isubcol = 1, nsubcol
2516 if (iscloudy(isubcol,i,ilev) ) then
2517 cld_stoch(isubcol,i,ilev) = 1._rb
2518 clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
2519 ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
2520 n = ngb(isubcol)
2521 tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
2522 ! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
2523 ! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
2524 else
2525 cld_stoch(isubcol,i,ilev) = 0._rb
2526 clwp_stoch(isubcol,i,ilev) = 0._rb
2527 ciwp_stoch(isubcol,i,ilev) = 0._rb
2528 tauc_stoch(isubcol,i,ilev) = 0._rb
2529 ! ssac_stoch(isubcol,i,ilev) = 1._rb
2530 ! asmc_stoch(isubcol,i,ilev) = 1._rb
2531 endif
2532 enddo
2533 enddo
2534 enddo
2536 ! -- compute the means of the subcolumns ---
2537 ! mean_cld_stoch(:,:) = 0._rb
2538 ! mean_clwp_stoch(:,:) = 0._rb
2539 ! mean_ciwp_stoch(:,:) = 0._rb
2540 ! mean_tauc_stoch(:,:) = 0._rb
2541 ! mean_ssac_stoch(:,:) = 0._rb
2542 ! mean_asmc_stoch(:,:) = 0._rb
2543 ! do i = 1, nsubcol
2544 ! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:)
2545 ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:)
2546 ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:)
2547 ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:)
2548 ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:)
2549 ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:)
2550 ! end do
2551 ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
2552 ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
2553 ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
2554 ! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
2555 ! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
2556 ! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
2558 end subroutine generate_stochastic_clouds
2561 !------------------------------------------------------------------
2562 ! Private subroutines
2563 !------------------------------------------------------------------
2565 !--------------------------------------------------------------------------------------------------
2566 subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
2567 !--------------------------------------------------------------------------------------------------
2569 ! public domain code
2570 ! made available from http://www.fortran.com/
2571 ! downloaded by pjr on 03/16/04 for NCAR CAM
2572 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
2574 ! The KISS (Keep It Simple Stupid) random number generator. Combines:
2575 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
2576 ! (2) A 3-shift shift-register generator, period 2^32-1,
2577 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
2578 ! Overall period>2^123;
2579 !
2580 real(kind=rb), dimension(:), intent(inout) :: ran_arr
2581 integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
2582 integer(kind=im) :: i,sz,kiss
2583 integer(kind=im) :: m, k, n
2585 ! inline function
2586 m(k, n) = ieor (k, ishft (k, n) )
2588 sz = size(ran_arr)
2589 do i = 1, sz
2590 seed1(i) = 69069_im * seed1(i) + 1327217885_im
2591 seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
2592 seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
2593 seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
2594 kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
2595 ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
2596 end do
2598 end subroutine kissvec
2600 end module mcica_subcol_gen_lw
2602 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2603 ! author: $Author: trn $
2604 ! revision: $Revision: 1.3 $
2605 ! created: $Date: 2009/04/16 19:54:22 $
2606 !
2607 module rrtmg_lw_cldprmc
2609 ! --------------------------------------------------------------------------
2610 ! | |
2611 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2612 ! | This software may be used, copied, or redistributed as long as it is |
2613 ! | not sold and this copyright notice is reproduced on each copy made. |
2614 ! | This model is provided as is without any express or implied warranties. |
2615 ! | (http://www.rtweb.aer.com/) |
2616 ! | |
2617 ! --------------------------------------------------------------------------
2619 ! --------- Modules ----------
2621 use parkind, only : im => kind_im, rb => kind_rb
2622 use parrrtm, only : ngptlw
2623 use rrlw_cld, only: abscld1, absliq0, absliq1, &
2624 absice0, absice1, absice2, absice3
2625 use rrlw_wvn, only: ngb
2626 use rrlw_vsn, only: hvrclc, hnamclc
2628 implicit none
2630 contains
2632 ! ------------------------------------------------------------------------------
2633 subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
2634 ciwpmc, clwpmc, reicmc, relqmc, ncbands, taucmc)
2635 ! ------------------------------------------------------------------------------
2637 ! Purpose: Compute the cloud optical depth(s) for each cloudy layer.
2639 ! ------- Input -------
2641 integer(kind=im), intent(in) :: nlayers ! total number of layers
2642 integer(kind=im), intent(in) :: inflag ! see definitions
2643 integer(kind=im), intent(in) :: iceflag ! see definitions
2644 integer(kind=im), intent(in) :: liqflag ! see definitions
2646 real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica]
2647 ! Dimensions: (ngptlw,nlayers)
2648 real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica]
2649 ! Dimensions: (ngptlw,nlayers)
2650 real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica]
2651 ! Dimensions: (ngptlw,nlayers)
2652 real(kind=rb), intent(in) :: relqmc(:) ! liquid particle effective radius (microns)
2653 ! Dimensions: (nlayers)
2654 real(kind=rb), intent(in) :: reicmc(:) ! ice particle effective radius (microns)
2655 ! Dimensions: (nlayers)
2656 ! specific definition of reicmc depends on setting of iceflag:
2657 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
2658 ! r_ec must be >= 10.0 microns
2659 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
2660 ! r_ec range is limited to 13.0 to 130.0 microns
2661 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
2662 ! r_k range is limited to 5.0 to 131.0 microns
2663 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
2664 ! dge range is limited to 5.0 to 140.0 microns
2665 ! [dge = 1.0315 * r_ec]
2667 ! ------- Output -------
2669 integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands
2670 real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica]
2671 ! Dimensions: (ngptlw,nlayers)
2673 ! ------- Local -------
2675 integer(kind=im) :: lay ! Layer index
2676 integer(kind=im) :: ib ! spectral band index
2677 integer(kind=im) :: ig ! g-point interval index
2678 integer(kind=im) :: index
2680 real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients
2681 real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients
2682 real(kind=rb) :: cwp ! cloud water path
2683 real(kind=rb) :: radice ! cloud ice effective size (microns)
2684 real(kind=rb) :: factor !
2685 real(kind=rb) :: fint !
2686 real(kind=rb) :: radliq ! cloud liquid droplet radius (microns)
2687 real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon
2688 real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities
2690 ! ------- Definitions -------
2692 ! Explanation of the method for each value of INFLAG. Values of
2693 ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds.
2694 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
2695 ! requires further user input to specify the method to be used to
2696 ! compute the aborption due to each.
2697 ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray)
2698 ! optical depth are input.
2699 ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud
2700 ! water path (g/m2) are input. The (gray) cloud optical
2701 ! depth is computed as in CCM2.
2702 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
2703 ! water path (g/m2), and cloud ice fraction are input.
2704 ! ICEFLAG = 0: The ice effective radius (microns) is input and the
2705 ! optical depths due to ice clouds are computed as in CCM3.
2706 ! ICEFLAG = 1: The ice effective radius (microns) is input and the
2707 ! optical depths due to ice clouds are computed as in
2708 ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The
2709 ! spectral regions in this work have been matched with
2710 ! the spectral bands in RRTM to as great an extent
2711 ! as possible:
2712 ! E&C 1 IB = 5 RRTM bands 9-16
2713 ! E&C 2 IB = 4 RRTM bands 6-8
2714 ! E&C 3 IB = 3 RRTM bands 3-5
2715 ! E&C 4 IB = 2 RRTM band 2
2716 ! E&C 5 IB = 1 RRTM band 1
2717 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
2718 ! optical properties due to ice clouds are computed from
2719 ! the optical properties stored in the RT code,
2720 ! STREAMER v3.0 (Reference: Key. J., Streamer
2721 ! User's Guide, Cooperative Institute for
2722 ! Meteorological Satellite Studies, 2001, 96 pp.).
2723 ! Valid range of values for re are between 5.0 and
2724 ! 131.0 micron.
2725 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
2726 ! and the optical properties, are calculated as in
2727 ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
2728 ! tables which were appropriately averaged for the
2729 ! bands in RRTM_LW. Linear interpolation is used to
2730 ! get the coefficients from the stored tables.
2731 ! Valid range of values for dge are between 5.0 and
2732 ! 140.0 micron.
2733 ! LIQFLAG = 0: The optical depths due to water clouds are computed as
2734 ! in CCM3.
2735 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
2736 ! and the optical depths due to water clouds are computed
2737 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
2738 ! The values for absorption coefficients appropriate for
2739 ! the spectral bands in RRTM have been obtained for a
2740 ! range of effective radii by an averaging procedure
2741 ! based on the work of J. Pinto (private communication).
2742 ! Linear interpolation is used to get the absorption
2743 ! coefficients for the input effective radius.
2745 hvrclc = '$Revision: 1.3 $'
2747 ncbands = 1
2749 ! This initialization is done in rrtmg_lw_subcol.F90.
2750 ! do lay = 1, nlayers
2751 ! do ig = 1, ngptlw
2752 ! taucmc(ig,lay) = 0.0_rb
2753 ! enddo
2754 ! enddo
2756 ! Main layer loop
2757 do lay = 1, nlayers
2759 do ig = 1, ngptlw
2760 cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2761 if (cldfmc(ig,lay) .ge. cldmin .and. &
2762 (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
2764 ! Ice clouds and water clouds combined.
2765 if (inflag .eq. 0) then
2766 ! Cloud optical depth already defined in taucmc, return to main program
2767 return
2769 elseif(inflag .eq. 1) then
2770 stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
2771 ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2772 ! taucmc(ig,lay) = abscld1 * cwp
2774 ! Separate treatement of ice clouds and water clouds.
2775 elseif(inflag .eq. 2) then
2776 radice = reicmc(lay)
2778 ! Calculation of absorption coefficients due to ice clouds.
2779 if (ciwpmc(ig,lay) .eq. 0.0_rb) then
2780 abscoice(ig) = 0.0_rb
2782 elseif (iceflag .eq. 0) then
2783 if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL'
2784 abscoice(ig) = absice0(1) + absice0(2)/radice
2786 elseif (iceflag .eq. 1) then
2787 if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
2788 'ICE RADIUS OUT OF BOUNDS'
2789 ncbands = 5
2790 ib = ngb(ig)
2791 abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
2793 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
2795 elseif (iceflag .eq. 2) then
2796 if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
2797 ncbands = 16
2798 factor = (radice - 2._rb)/3._rb
2799 index = int(factor)
2800 if (index .eq. 43) index = 42
2801 fint = factor - float(index)
2802 ib = ngb(ig)
2803 abscoice(ig) = &
2804 absice2(index,ib) + fint * &
2805 (absice2(index+1,ib) - (absice2(index,ib)))
2807 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
2809 elseif (iceflag .eq. 3) then
2810 if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
2811 ncbands = 16
2812 factor = (radice - 2._rb)/3._rb
2813 index = int(factor)
2814 if (index .eq. 46) index = 45
2815 fint = factor - float(index)
2816 ib = ngb(ig)
2817 abscoice(ig) = &
2818 absice3(index,ib) + fint * &
2819 (absice3(index+1,ib) - (absice3(index,ib)))
2821 endif
2823 ! Calculation of absorption coefficients due to water clouds.
2824 if (clwpmc(ig,lay) .eq. 0.0_rb) then
2825 abscoliq(ig) = 0.0_rb
2827 elseif (liqflag .eq. 0) then
2828 abscoliq(ig) = absliq0
2830 elseif (liqflag .eq. 1) then
2831 radliq = relqmc(lay)
2832 if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop &
2833 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
2834 index = radliq - 1.5_rb
2835 if (index .eq. 58) index = 57
2836 if (index .eq. 0) index = 1
2837 fint = radliq - 1.5_rb - index
2838 ib = ngb(ig)
2839 abscoliq(ig) = &
2840 absliq1(index,ib) + fint * &
2841 (absliq1(index+1,ib) - (absliq1(index,ib)))
2842 endif
2844 taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + &
2845 clwpmc(ig,lay) * abscoliq(ig)
2847 endif
2848 endif
2849 enddo
2850 enddo
2852 end subroutine cldprmc
2854 end module rrtmg_lw_cldprmc
2856 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2857 ! author: $Author: trn $
2858 ! revision: $Revision: 1.3 $
2859 ! created: $Date: 2009/04/16 19:54:22 $
2860 !
2861 module rrtmg_lw_rtrnmc
2863 ! --------------------------------------------------------------------------
2864 ! | |
2865 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2866 ! | This software may be used, copied, or redistributed as long as it is |
2867 ! | not sold and this copyright notice is reproduced on each copy made. |
2868 ! | This model is provided as is without any express or implied warranties. |
2869 ! | (http://www.rtweb.aer.com/) |
2870 ! | |
2871 ! --------------------------------------------------------------------------
2873 ! --------- Modules ----------
2875 use parkind, only : im => kind_im, rb => kind_rb
2876 use parrrtm, only : mg, nbndlw, ngptlw
2877 use rrlw_con, only: fluxfac, heatfac
2878 use rrlw_wvn, only: delwave, ngb, ngs
2879 use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
2880 use rrlw_vsn, only: hvrrtc, hnamrtc
2882 implicit none
2884 real(kind=rb) :: wtdiff, rec_6
2885 real(kind=rb) :: a0(nbndlw),a1(nbndlw),a2(nbndlw)! diffusivity angle adjustment coefficients
2887 ! This secant and weight corresponds to the standard diffusivity
2888 ! angle. This initial value is redefined below for some bands.
2889 data wtdiff /0.5_rb/
2890 data rec_6 /0.166667_rb/
2892 ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
2893 ! and 1.80) as a function of total column water vapor. The function
2894 ! has been defined to minimize flux and cooling rate errors in these bands
2895 ! over a wide range of precipitable water values.
2896 data a0 / 1.66_rb, 1.55_rb, 1.58_rb, 1.66_rb, &
2897 1.54_rb, 1.454_rb, 1.89_rb, 1.33_rb, &
2898 1.668_rb, 1.66_rb, 1.66_rb, 1.66_rb, &
2899 1.66_rb, 1.66_rb, 1.66_rb, 1.66_rb /
2900 data a1 / 0.00_rb, 0.25_rb, 0.22_rb, 0.00_rb, &
2901 0.13_rb, 0.446_rb, -0.10_rb, 0.40_rb, &
2902 -0.006_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
2903 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
2904 data a2 / 0.00_rb, -12.0_rb, -11.7_rb, 0.00_rb, &
2905 -0.72_rb,-0.243_rb, 0.19_rb,-0.062_rb, &
2906 0.414_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
2907 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
2909 contains
2911 !-----------------------------------------------------------------------------
2912 subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
2913 cldfmc, taucmc, planklay, planklev, plankbnd, &
2914 pwvcm, fracs, taut, &
2915 totuflux, totdflux, fnet, htr, &
2916 totuclfl, totdclfl, fnetc, htrc )
2917 !-----------------------------------------------------------------------------
2918 !
2919 ! Original version: E. J. Mlawer, et al. RRTM_V3.0
2920 ! Revision for GCMs: Michael J. Iacono; October, 2002
2921 ! Revision for F90: Michael J. Iacono; June, 2006
2922 !
2923 ! This program calculates the upward fluxes, downward fluxes, and
2924 ! heating rates for an arbitrary clear or cloudy atmosphere. The input
2925 ! to this program is the atmospheric profile, all Planck function
2926 ! information, and the cloud fraction by layer. A variable diffusivity
2927 ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9
2928 ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
2929 ! the column water vapor, and other bands use a value of 1.66. The Gaussian
2930 ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that
2931 ! use of the emissivity angle for the flux integration can cause errors of
2932 ! 1 to 4 W/m2 within cloudy layers.
2933 ! Clouds are treated with the McICA stochastic approach and maximum-random
2934 ! cloud overlap.
2935 !***************************************************************************
2937 ! ------- Declarations -------
2939 ! ----- Input -----
2940 integer(kind=im), intent(in) :: nlayers ! total number of layers
2941 integer(kind=im), intent(in) :: istart ! beginning band of calculation
2942 integer(kind=im), intent(in) :: iend ! ending band of calculation
2943 integer(kind=im), intent(in) :: iout ! output option flag
2945 ! Atmosphere
2946 real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb)
2947 ! Dimensions: (0:nlayers)
2948 real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm)
2949 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
2950 ! Dimensions: (nbndlw)
2951 real(kind=rb), intent(in) :: planklay(:,:) !
2952 ! Dimensions: (nlayers,nbndlw)
2953 real(kind=rb), intent(in) :: planklev(0:,:) !
2954 ! Dimensions: (0:nlayers,nbndlw)
2955 real(kind=rb), intent(in) :: plankbnd(:) !
2956 ! Dimensions: (nbndlw)
2957 real(kind=rb), intent(in) :: fracs(:,:) !
2958 ! Dimensions: (nlayers,ngptw)
2959 real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths
2960 ! Dimensions: (nlayers,ngptlw)
2962 ! Clouds
2963 integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands
2964 real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica]
2965 ! Dimensions: (ngptlw,nlayers)
2966 real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica]
2967 ! Dimensions: (ngptlw,nlayers)
2969 ! ----- Output -----
2970 real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2)
2971 ! Dimensions: (0:nlayers)
2972 real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2)
2973 ! Dimensions: (0:nlayers)
2974 real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2)
2975 ! Dimensions: (0:nlayers)
2976 real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day)
2977 ! Dimensions: (0:nlayers)
2978 real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2)
2979 ! Dimensions: (0:nlayers)
2980 real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2)
2981 ! Dimensions: (0:nlayers)
2982 real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2)
2983 ! Dimensions: (0:nlayers)
2984 real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day)
2985 ! Dimensions: (0:nlayers)
2987 ! ----- Local -----
2988 ! Declarations for radiative transfer
2989 real(kind=rb) :: abscld(nlayers,ngptlw)
2990 real(kind=rb) :: atot(nlayers)
2991 real(kind=rb) :: atrans(nlayers)
2992 real(kind=rb) :: bbugas(nlayers)
2993 real(kind=rb) :: bbutot(nlayers)
2994 real(kind=rb) :: clrurad(0:nlayers)
2995 real(kind=rb) :: clrdrad(0:nlayers)
2996 real(kind=rb) :: efclfrac(nlayers,ngptlw)
2997 real(kind=rb) :: uflux(0:nlayers)
2998 real(kind=rb) :: dflux(0:nlayers)
2999 real(kind=rb) :: urad(0:nlayers)
3000 real(kind=rb) :: drad(0:nlayers)
3001 real(kind=rb) :: uclfl(0:nlayers)
3002 real(kind=rb) :: dclfl(0:nlayers)
3003 real(kind=rb) :: odcld(nlayers,ngptlw)
3006 real(kind=rb) :: secdiff(nbndlw) ! secant of diffusivity angle
3007 real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
3008 real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
3009 real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
3010 real(kind=rb) :: rad0, reflect, radlu, radclru
3012 integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer
3013 integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices
3014 integer(kind=im) :: igc ! g-point interval counter
3015 integer(kind=im) :: iclddn ! flag for cloud in down path
3016 integer(kind=im) :: ittot, itgas, itr ! lookup table indices
3018 ! ------- Definitions -------
3019 ! input
3020 ! nlayers ! number of model layers
3021 ! ngptlw ! total number of g-point subintervals
3022 ! nbndlw ! number of longwave spectral bands
3023 ! ncbands ! number of spectral bands for clouds
3024 ! secdiff ! diffusivity angle
3025 ! wtdiff ! weight for radiance to flux conversion
3026 ! pavel ! layer pressures (mb)
3027 ! pz ! level (interface) pressures (mb)
3028 ! tavel ! layer temperatures (k)
3029 ! tz ! level (interface) temperatures(mb)
3030 ! tbound ! surface temperature (k)
3031 ! cldfrac ! layer cloud fraction
3032 ! taucloud ! layer cloud optical depth
3033 ! itr ! integer look-up table index
3034 ! icldlyr ! flag for cloudy layers
3035 ! iclddn ! flag for cloud in column at any layer
3036 ! semiss ! surface emissivities for each band
3037 ! reflect ! surface reflectance
3038 ! bpade ! 1/(pade constant)
3039 ! tau_tbl ! clear sky optical depth look-up table
3040 ! exp_tbl ! exponential look-up table for transmittance
3041 ! tfn_tbl ! tau transition function look-up table
3043 ! local
3044 ! atrans ! gaseous absorptivity
3045 ! abscld ! cloud absorptivity
3046 ! atot ! combined gaseous and cloud absorptivity
3047 ! odclr ! clear sky (gaseous) optical depth
3048 ! odcld ! cloud optical depth
3049 ! odtot ! optical depth of gas and cloud
3050 ! tfacgas ! gas-only pade factor, used for planck fn
3051 ! tfactot ! gas and cloud pade factor, used for planck fn
3052 ! bbdgas ! gas-only planck function for downward rt
3053 ! bbugas ! gas-only planck function for upward rt
3054 ! bbdtot ! gas and cloud planck function for downward rt
3055 ! bbutot ! gas and cloud planck function for upward calc.
3056 ! gassrc ! source radiance due to gas only
3057 ! efclfrac ! effective cloud fraction
3058 ! radlu ! spectrally summed upward radiance
3059 ! radclru ! spectrally summed clear sky upward radiance
3060 ! urad ! upward radiance by layer
3061 ! clrurad ! clear sky upward radiance by layer
3062 ! radld ! spectrally summed downward radiance
3063 ! radclrd ! spectrally summed clear sky downward radiance
3064 ! drad ! downward radiance by layer
3065 ! clrdrad ! clear sky downward radiance by layer
3067 ! output
3068 ! totuflux ! upward longwave flux (w/m2)
3069 ! totdflux ! downward longwave flux (w/m2)
3070 ! fnet ! net longwave flux (w/m2)
3071 ! htr ! longwave heating rate (k/day)
3072 ! totuclfl ! clear sky upward longwave flux (w/m2)
3073 ! totdclfl ! clear sky downward longwave flux (w/m2)
3074 ! fnetc ! clear sky net longwave flux (w/m2)
3075 ! htrc ! clear sky longwave heating rate (k/day)
3078 hvrrtc = '$Revision: 1.3 $'
3080 do ibnd = 1,nbndlw
3081 if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
3082 secdiff(ibnd) = 1.66_rb
3083 else
3084 secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm)
3085 if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb
3086 if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb
3087 endif
3088 enddo
3090 urad(0) = 0.0_rb
3091 drad(0) = 0.0_rb
3092 totuflux(0) = 0.0_rb
3093 totdflux(0) = 0.0_rb
3094 clrurad(0) = 0.0_rb
3095 clrdrad(0) = 0.0_rb
3096 totuclfl(0) = 0.0_rb
3097 totdclfl(0) = 0.0_rb
3099 do lay = 1, nlayers
3100 urad(lay) = 0.0_rb
3101 drad(lay) = 0.0_rb
3102 totuflux(lay) = 0.0_rb
3103 totdflux(lay) = 0.0_rb
3104 clrurad(lay) = 0.0_rb
3105 clrdrad(lay) = 0.0_rb
3106 totuclfl(lay) = 0.0_rb
3107 totdclfl(lay) = 0.0_rb
3108 icldlyr(lay) = 0
3110 ! Change to band loop?
3111 do ig = 1, ngptlw
3112 if (cldfmc(ig,lay) .eq. 1._rb) then
3113 ib = ngb(ig)
3114 odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay)
3115 transcld = exp(-odcld(lay,ig))
3116 abscld(lay,ig) = 1._rb - transcld
3117 efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay)
3118 icldlyr(lay) = 1
3119 else
3120 odcld(lay,ig) = 0.0_rb
3121 abscld(lay,ig) = 0.0_rb
3122 efclfrac(lay,ig) = 0.0_rb
3123 endif
3124 enddo
3126 enddo
3128 igc = 1
3129 ! Loop over frequency bands.
3130 do iband = istart, iend
3132 ! Reinitialize g-point counter for each band if output for each band is requested.
3133 if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1
3135 ! Loop over g-channels.
3136 1000 continue
3138 ! Radiative transfer starts here.
3139 radld = 0._rb
3140 radclrd = 0._rb
3141 iclddn = 0
3143 ! Downward radiative transfer loop.
3145 do lev = nlayers, 1, -1
3146 plfrac = fracs(lev,igc)
3147 blay = planklay(lev,iband)
3148 dplankup = planklev(lev,iband) - blay
3149 dplankdn = planklev(lev-1,iband) - blay
3150 odepth = secdiff(iband) * taut(lev,igc)
3151 if (odepth .lt. 0.0_rb) odepth = 0.0_rb
3152 ! Cloudy layer
3153 if (icldlyr(lev).eq.1) then
3154 iclddn = 1
3155 odtot = odepth + odcld(lev,igc)
3156 if (odtot .lt. 0.06_rb) then
3157 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3158 odepth_rec = rec_6*odepth
3159 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3161 atot(lev) = odtot - 0.5_rb*odtot*odtot
3162 odtot_rec = rec_6*odtot
3163 bbdtot = plfrac * (blay+dplankdn*odtot_rec)
3164 bbd = plfrac*(blay+dplankdn*odepth_rec)
3165 radld = radld - radld * (atrans(lev) + &
3166 efclfrac(lev,igc) * (1. - atrans(lev))) + &
3167 gassrc + cldfmc(igc,lev) * &
3168 (bbdtot * atot(lev) - gassrc)
3169 drad(lev-1) = drad(lev-1) + radld
3171 bbugas(lev) = plfrac * (blay+dplankup*odepth_rec)
3172 bbutot(lev) = plfrac * (blay+dplankup*odtot_rec)
3174 elseif (odepth .le. 0.06_rb) then
3175 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3176 odepth_rec = rec_6*odepth
3177 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3179 odtot = odepth + odcld(lev,igc)
3180 tblind = odtot/(bpade+odtot)
3181 ittot = tblint*tblind + 0.5_rb
3182 tfactot = tfn_tbl(ittot)
3183 bbdtot = plfrac * (blay + tfactot*dplankdn)
3184 bbd = plfrac*(blay+dplankdn*odepth_rec)
3185 atot(lev) = 1. - exp_tbl(ittot)
3187 radld = radld - radld * (atrans(lev) + &
3188 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3189 gassrc + cldfmc(igc,lev) * &
3190 (bbdtot * atot(lev) - gassrc)
3191 drad(lev-1) = drad(lev-1) + radld
3193 bbugas(lev) = plfrac * (blay + dplankup*odepth_rec)
3194 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3196 else
3198 tblind = odepth/(bpade+odepth)
3199 itgas = tblint*tblind+0.5_rb
3200 odepth = tau_tbl(itgas)
3201 atrans(lev) = 1._rb - exp_tbl(itgas)
3202 tfacgas = tfn_tbl(itgas)
3203 gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
3205 odtot = odepth + odcld(lev,igc)
3206 tblind = odtot/(bpade+odtot)
3207 ittot = tblint*tblind + 0.5_rb
3208 tfactot = tfn_tbl(ittot)
3209 bbdtot = plfrac * (blay + tfactot*dplankdn)
3210 bbd = plfrac*(blay+tfacgas*dplankdn)
3211 atot(lev) = 1._rb - exp_tbl(ittot)
3213 radld = radld - radld * (atrans(lev) + &
3214 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3215 gassrc + cldfmc(igc,lev) * &
3216 (bbdtot * atot(lev) - gassrc)
3217 drad(lev-1) = drad(lev-1) + radld
3218 bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
3219 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3220 endif
3221 ! Clear layer
3222 else
3223 if (odepth .le. 0.06_rb) then
3224 atrans(lev) = odepth-0.5_rb*odepth*odepth
3225 odepth = rec_6*odepth
3226 bbd = plfrac*(blay+dplankdn*odepth)
3227 bbugas(lev) = plfrac*(blay+dplankup*odepth)
3228 else
3229 tblind = odepth/(bpade+odepth)
3230 itr = tblint*tblind+0.5_rb
3231 transc = exp_tbl(itr)
3232 atrans(lev) = 1._rb-transc
3233 tausfac = tfn_tbl(itr)
3234 bbd = plfrac*(blay+tausfac*dplankdn)
3235 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
3236 endif
3237 radld = radld + (bbd-radld)*atrans(lev)
3238 drad(lev-1) = drad(lev-1) + radld
3239 endif
3240 ! Set clear sky stream to total sky stream as long as layers
3241 ! remain clear. Streams diverge when a cloud is reached (iclddn=1),
3242 ! and clear sky stream must be computed separately from that point.
3243 if (iclddn.eq.1) then
3244 radclrd = radclrd + (bbd-radclrd) * atrans(lev)
3245 clrdrad(lev-1) = clrdrad(lev-1) + radclrd
3246 else
3247 radclrd = radld
3248 clrdrad(lev-1) = drad(lev-1)
3249 endif
3250 enddo
3252 ! Spectral emissivity & reflectance
3253 ! Include the contribution of spectrally varying longwave emissivity
3254 ! and reflection from the surface to the upward radiative transfer.
3255 ! Note: Spectral and Lambertian reflection are identical for the
3256 ! diffusivity angle flux integration used here.
3258 rad0 = fracs(1,igc) * plankbnd(iband)
3259 ! Add in specular reflection of surface downward radiance.
3260 reflect = 1._rb - semiss(iband)
3261 radlu = rad0 + reflect * radld
3262 radclru = rad0 + reflect * radclrd
3265 ! Upward radiative transfer loop.
3266 urad(0) = urad(0) + radlu
3267 clrurad(0) = clrurad(0) + radclru
3269 do lev = 1, nlayers
3270 ! Cloudy layer
3271 if (icldlyr(lev) .eq. 1) then
3272 gassrc = bbugas(lev) * atrans(lev)
3273 radlu = radlu - radlu * (atrans(lev) + &
3274 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3275 gassrc + cldfmc(igc,lev) * &
3276 (bbutot(lev) * atot(lev) - gassrc)
3277 urad(lev) = urad(lev) + radlu
3278 ! Clear layer
3279 else
3280 radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
3281 urad(lev) = urad(lev) + radlu
3282 endif
3283 ! Set clear sky stream to total sky stream as long as all layers
3284 ! are clear (iclddn=0). Streams must be calculated separately at
3285 ! all layers when a cloud is present (ICLDDN=1), because surface
3286 ! reflectance is different for each stream.
3287 if (iclddn.eq.1) then
3288 radclru = radclru + (bbugas(lev)-radclru)*atrans(lev)
3289 clrurad(lev) = clrurad(lev) + radclru
3290 else
3291 radclru = radlu
3292 clrurad(lev) = urad(lev)
3293 endif
3294 enddo
3296 ! Increment g-point counter
3297 igc = igc + 1
3298 ! Return to continue radiative transfer for all g-channels in present band
3299 if (igc .le. ngs(iband)) go to 1000
3301 ! Process longwave output from band for total and clear streams.
3302 ! Calculate upward, downward, and net flux.
3303 do lev = nlayers, 0, -1
3304 uflux(lev) = urad(lev)*wtdiff
3305 dflux(lev) = drad(lev)*wtdiff
3306 urad(lev) = 0.0_rb
3307 drad(lev) = 0.0_rb
3308 totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband)
3309 totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband)
3310 uclfl(lev) = clrurad(lev)*wtdiff
3311 dclfl(lev) = clrdrad(lev)*wtdiff
3312 clrurad(lev) = 0.0_rb
3313 clrdrad(lev) = 0.0_rb
3314 totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband)
3315 totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband)
3316 enddo
3318 ! End spectral band loop
3319 enddo
3321 ! Calculate fluxes at surface
3322 totuflux(0) = totuflux(0) * fluxfac
3323 totdflux(0) = totdflux(0) * fluxfac
3324 fnet(0) = totuflux(0) - totdflux(0)
3325 totuclfl(0) = totuclfl(0) * fluxfac
3326 totdclfl(0) = totdclfl(0) * fluxfac
3327 fnetc(0) = totuclfl(0) - totdclfl(0)
3329 ! Calculate fluxes at model levels
3330 do lev = 1, nlayers
3331 totuflux(lev) = totuflux(lev) * fluxfac
3332 totdflux(lev) = totdflux(lev) * fluxfac
3333 fnet(lev) = totuflux(lev) - totdflux(lev)
3334 totuclfl(lev) = totuclfl(lev) * fluxfac
3335 totdclfl(lev) = totdclfl(lev) * fluxfac
3336 fnetc(lev) = totuclfl(lev) - totdclfl(lev)
3337 l = lev - 1
3339 ! Calculate heating rates at model layers
3340 htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev))
3341 htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev))
3342 enddo
3344 ! Set heating rate to zero in top layer
3345 htr(nlayers) = 0.0_rb
3346 htrc(nlayers) = 0.0_rb
3348 end subroutine rtrnmc
3350 end module rrtmg_lw_rtrnmc
3352 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
3353 ! author: $Author: trn $
3354 ! revision: $Revision: 1.3 $
3355 ! created: $Date: 2009/04/16 19:54:22 $
3356 !
3357 module rrtmg_lw_setcoef
3359 ! --------------------------------------------------------------------------
3360 ! | |
3361 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
3362 ! | This software may be used, copied, or redistributed as long as it is |
3363 ! | not sold and this copyright notice is reproduced on each copy made. |
3364 ! | This model is provided as is without any express or implied warranties. |
3365 ! | (http://www.rtweb.aer.com/) |
3366 ! | |
3367 ! --------------------------------------------------------------------------
3369 ! ------- Modules -------
3371 use parkind, only : im => kind_im, rb => kind_rb
3372 use parrrtm, only : nbndlw, mg, maxxsec, mxmol
3373 use rrlw_wvn, only: totplnk, totplk16
3374 use rrlw_ref
3375 use rrlw_vsn, only: hvrset, hnamset
3377 implicit none
3379 contains
3381 !----------------------------------------------------------------------------
3382 subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
3383 coldry, wkl, wbroad, &
3384 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
3385 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
3386 colbrd, fac00, fac01, fac10, fac11, &
3387 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
3388 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
3389 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
3390 selffac, selffrac, indself, forfac, forfrac, indfor, &
3391 minorfrac, scaleminor, scaleminorn2, indminor)
3392 !----------------------------------------------------------------------------
3393 !
3394 ! Purpose: For a given atmosphere, calculate the indices and
3395 ! fractions related to the pressure and temperature interpolations.
3396 ! Also calculate the values of the integrated Planck functions
3397 ! for each band at the level and layer temperatures.
3399 ! ------- Declarations -------
3401 ! ----- Input -----
3402 integer(kind=im), intent(in) :: nlayers ! total number of layers
3403 integer(kind=im), intent(in) :: istart ! beginning band of calculation
3405 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
3406 ! Dimensions: (nlayers)
3407 real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K)
3408 ! Dimensions: (nlayers)
3409 real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K)
3410 ! Dimensions: (0:nlayers)
3411 real(kind=rb), intent(in) :: tbound ! surface temperature (K)
3412 real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
3413 ! Dimensions: (nlayers)
3414 real(kind=rb), intent(in) :: wbroad(:) ! broadening gas column density (mol/cm2)
3415 ! Dimensions: (nlayers)
3416 real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2)
3417 ! Dimensions: (mxmol,nlayers)
3418 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
3419 ! Dimensions: (nbndlw)
3421 ! ----- Output -----
3422 integer(kind=im), intent(out) :: laytrop ! tropopause layer index
3423 integer(kind=im), intent(out) :: jp(:) !
3424 ! Dimensions: (nlayers)
3425 integer(kind=im), intent(out) :: jt(:) !
3426 ! Dimensions: (nlayers)
3427 integer(kind=im), intent(out) :: jt1(:) !
3428 ! Dimensions: (nlayers)
3429 real(kind=rb), intent(out) :: planklay(:,:) !
3430 ! Dimensions: (nlayers,nbndlw)
3431 real(kind=rb), intent(out) :: planklev(0:,:) !
3432 ! Dimensions: (0:nlayers,nbndlw)
3433 real(kind=rb), intent(out) :: plankbnd(:) !
3434 ! Dimensions: (nbndlw)
3436 real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o)
3437 ! Dimensions: (nlayers)
3438 real(kind=rb), intent(out) :: colco2(:) ! column amount (co2)
3439 ! Dimensions: (nlayers)
3440 real(kind=rb), intent(out) :: colo3(:) ! column amount (o3)
3441 ! Dimensions: (nlayers)
3442 real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o)
3443 ! Dimensions: (nlayers)
3444 real(kind=rb), intent(out) :: colco(:) ! column amount (co)
3445 ! Dimensions: (nlayers)
3446 real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4)
3447 ! Dimensions: (nlayers)
3448 real(kind=rb), intent(out) :: colo2(:) ! column amount (o2)
3449 ! Dimensions: (nlayers)
3450 real(kind=rb), intent(out) :: colbrd(:) ! column amount (broadening gases)
3451 ! Dimensions: (nlayers)
3453 integer(kind=im), intent(out) :: indself(:)
3454 ! Dimensions: (nlayers)
3455 integer(kind=im), intent(out) :: indfor(:)
3456 ! Dimensions: (nlayers)
3457 real(kind=rb), intent(out) :: selffac(:)
3458 ! Dimensions: (nlayers)
3459 real(kind=rb), intent(out) :: selffrac(:)
3460 ! Dimensions: (nlayers)
3461 real(kind=rb), intent(out) :: forfac(:)
3462 ! Dimensions: (nlayers)
3463 real(kind=rb), intent(out) :: forfrac(:)
3464 ! Dimensions: (nlayers)
3466 integer(kind=im), intent(out) :: indminor(:)
3467 ! Dimensions: (nlayers)
3468 real(kind=rb), intent(out) :: minorfrac(:)
3469 ! Dimensions: (nlayers)
3470 real(kind=rb), intent(out) :: scaleminor(:)
3471 ! Dimensions: (nlayers)
3472 real(kind=rb), intent(out) :: scaleminorn2(:)
3473 ! Dimensions: (nlayers)
3475 real(kind=rb), intent(out) :: & !
3476 fac00(:), fac01(:), & ! Dimensions: (nlayers)
3477 fac10(:), fac11(:)
3479 real(kind=rb), intent(out) :: & !
3480 rat_h2oco2(:),rat_h2oco2_1(:), &
3481 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
3482 rat_h2on2o(:),rat_h2on2o_1(:), &
3483 rat_h2och4(:),rat_h2och4_1(:), &
3484 rat_n2oco2(:),rat_n2oco2_1(:), &
3485 rat_o3co2(:),rat_o3co2_1(:)
3488 ! ----- Local -----
3489 integer(kind=im) :: indbound, indlev0
3490 integer(kind=im) :: lay, indlay, indlev, iband
3491 integer(kind=im) :: jp1
3492 real(kind=rb) :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
3493 real(kind=rb) :: dbdtlev, dbdtlay
3494 real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp
3497 hvrset = '$Revision: 1.3 $'
3499 stpfac = 296._rb/1013._rb
3501 indbound = tbound - 159._rb
3502 if (indbound .lt. 1) then
3503 indbound = 1
3504 elseif (indbound .gt. 180) then
3505 indbound = 180
3506 endif
3507 tbndfrac = tbound - 159._rb - float(indbound)
3508 indlev0 = tz(0) - 159._rb
3509 if (indlev0 .lt. 1) then
3510 indlev0 = 1
3511 elseif (indlev0 .gt. 180) then
3512 indlev0 = 180
3513 endif
3514 t0frac = tz(0) - 159._rb - float(indlev0)
3515 laytrop = 0
3517 ! Begin layer loop
3518 ! Calculate the integrated Planck functions for each band at the
3519 ! surface, level, and layer temperatures.
3520 do lay = 1, nlayers
3521 indlay = tavel(lay) - 159._rb
3522 if (indlay .lt. 1) then
3523 indlay = 1
3524 elseif (indlay .gt. 180) then
3525 indlay = 180
3526 endif
3527 tlayfrac = tavel(lay) - 159._rb - float(indlay)
3528 indlev = tz(lay) - 159._rb
3529 if (indlev .lt. 1) then
3530 indlev = 1
3531 elseif (indlev .gt. 180) then
3532 indlev = 180
3533 endif
3534 tlevfrac = tz(lay) - 159._rb - float(indlev)
3536 ! Begin spectral band loop
3537 do iband = 1, 15
3538 if (lay.eq.1) then
3539 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3540 plankbnd(iband) = semiss(iband) * &
3541 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3542 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3543 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3544 endif
3545 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3546 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3547 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3548 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3549 enddo
3551 ! For band 16, if radiative transfer will be performed on just
3552 ! this band, use integrated Planck values up to 3250 cm-1.
3553 ! If radiative transfer will be performed across all 16 bands,
3554 ! then include in the integrated Planck values for this band
3555 ! contributions from 2600 cm-1 to infinity.
3556 iband = 16
3557 if (istart .eq. 16) then
3558 if (lay.eq.1) then
3559 dbdtlev = totplk16(indbound+1) - totplk16(indbound)
3560 plankbnd(iband) = semiss(iband) * &
3561 (totplk16(indbound) + tbndfrac * dbdtlev)
3562 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3563 planklev(0,iband) = totplk16(indlev0) + &
3564 t0frac * dbdtlev
3565 endif
3566 dbdtlev = totplk16(indlev+1) - totplk16(indlev)
3567 dbdtlay = totplk16(indlay+1) - totplk16(indlay)
3568 planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay
3569 planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev
3570 else
3571 if (lay.eq.1) then
3572 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3573 plankbnd(iband) = semiss(iband) * &
3574 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3575 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3576 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3577 endif
3578 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3579 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3580 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3581 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3582 endif
3584 ! Find the two reference pressures on either side of the
3585 ! layer pressure. Store them in JP and JP1. Store in FP the
3586 ! fraction of the difference (in ln(pressure)) between these
3587 ! two values that the layer pressure lies.
3588 plog = log(pavel(lay))
3589 ! plog = dlog(pavel(lay))
3590 jp(lay) = int(36._rb - 5*(plog+0.04_rb))
3591 if (jp(lay) .lt. 1) then
3592 jp(lay) = 1
3593 elseif (jp(lay) .gt. 58) then
3594 jp(lay) = 58
3595 endif
3596 jp1 = jp(lay) + 1
3597 fp = 5._rb *(preflog(jp(lay)) - plog)
3599 ! Determine, for each reference pressure (JP and JP1), which
3600 ! reference temperature (these are different for each
3601 ! reference pressure) is nearest the layer temperature but does
3602 ! not exceed it. Store these indices in JT and JT1, resp.
3603 ! Store in FT (resp. FT1) the fraction of the way between JT
3604 ! (JT1) and the next highest reference temperature that the
3605 ! layer temperature falls.
3606 jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
3607 if (jt(lay) .lt. 1) then
3608 jt(lay) = 1
3609 elseif (jt(lay) .gt. 4) then
3610 jt(lay) = 4
3611 endif
3612 ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3)
3613 jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
3614 if (jt1(lay) .lt. 1) then
3615 jt1(lay) = 1
3616 elseif (jt1(lay) .gt. 4) then
3617 jt1(lay) = 4
3618 endif
3619 ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3)
3620 water = wkl(1,lay)/coldry(lay)
3621 scalefac = pavel(lay) * stpfac / tavel(lay)
3623 ! If the pressure is less than ~100mb, perform a different
3624 ! set of species interpolations.
3625 if (plog .le. 4.56_rb) go to 5300
3626 laytrop = laytrop + 1
3628 forfac(lay) = scalefac / (1.+water)
3629 factor = (332.0_rb-tavel(lay))/36.0_rb
3630 indfor(lay) = min(2, max(1, int(factor)))
3631 forfrac(lay) = factor - float(indfor(lay))
3633 ! Set up factors needed to separately include the water vapor
3634 ! self-continuum in the calculation of absorption coefficient.
3635 selffac(lay) = water * forfac(lay)
3636 factor = (tavel(lay)-188.0_rb)/7.2_rb
3637 indself(lay) = min(9, max(1, int(factor)-7))
3638 selffrac(lay) = factor - float(indself(lay) + 7)
3640 ! Set up factors needed to separately include the minor gases
3641 ! in the calculation of absorption coefficient
3642 scaleminor(lay) = pavel(lay)/tavel(lay)
3643 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3644 *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3645 factor = (tavel(lay)-180.8_rb)/7.2_rb
3646 indminor(lay) = min(18, max(1, int(factor)))
3647 minorfrac(lay) = factor - float(indminor(lay))
3649 ! Setup reference ratio to be used in calculation of binary
3650 ! species parameter in lower atmosphere.
3651 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3652 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3654 rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay))
3655 rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1)
3657 rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay))
3658 rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1)
3660 rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay))
3661 rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1)
3663 rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay))
3664 rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3666 ! Calculate needed column amounts.
3667 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3668 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3669 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3670 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3671 colco(lay) = 1.e-20_rb * wkl(5,lay)
3672 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3673 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3674 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3675 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3676 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3677 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3678 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3679 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3680 go to 5400
3682 ! Above laytrop.
3683 5300 continue
3685 forfac(lay) = scalefac / (1.+water)
3686 factor = (tavel(lay)-188.0_rb)/36.0_rb
3687 indfor(lay) = 3
3688 forfrac(lay) = factor - 1.0_rb
3690 ! Set up factors needed to separately include the water vapor
3691 ! self-continuum in the calculation of absorption coefficient.
3692 selffac(lay) = water * forfac(lay)
3694 ! Set up factors needed to separately include the minor gases
3695 ! in the calculation of absorption coefficient
3696 scaleminor(lay) = pavel(lay)/tavel(lay)
3697 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3698 * (wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3699 factor = (tavel(lay)-180.8_rb)/7.2_rb
3700 indminor(lay) = min(18, max(1, int(factor)))
3701 minorfrac(lay) = factor - float(indminor(lay))
3703 ! Setup reference ratio to be used in calculation of binary
3704 ! species parameter in upper atmosphere.
3705 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3706 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3708 rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay))
3709 rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3711 ! Calculate needed column amounts.
3712 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3713 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3714 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3715 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3716 colco(lay) = 1.e-20_rb * wkl(5,lay)
3717 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3718 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3719 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3720 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3721 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3722 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3723 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3724 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3725 5400 continue
3727 ! We have now isolated the layer ln pressure and temperature,
3728 ! between two reference pressures and two reference temperatures
3729 ! (for each reference pressure). We multiply the pressure
3730 ! fraction FP with the appropriate temperature fractions to get
3731 ! the factors that will be needed for the interpolation that yields
3732 ! the optical depths (performed in routines TAUGBn for band n).`
3734 compfp = 1. - fp
3735 fac10(lay) = compfp * ft
3736 fac00(lay) = compfp * (1._rb - ft)
3737 fac11(lay) = fp * ft1
3738 fac01(lay) = fp * (1._rb - ft1)
3740 ! Rescale selffac and forfac for use in taumol
3741 selffac(lay) = colh2o(lay)*selffac(lay)
3742 forfac(lay) = colh2o(lay)*forfac(lay)
3744 ! End layer loop
3745 enddo
3747 end subroutine setcoef
3749 !***************************************************************************
3750 subroutine lwatmref
3751 !***************************************************************************
3753 save
3755 ! These pressures are chosen such that the ln of the first pressure
3756 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
3757 ! each subsequent ln(pressure) differs from the previous one by 0.2.
3759 pref(:) = (/ &
3760 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
3761 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
3762 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
3763 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
3764 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
3765 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
3766 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
3767 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
3768 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
3769 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
3770 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
3771 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/)
3773 preflog(:) = (/ &
3774 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
3775 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
3776 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
3777 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
3778 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
3779 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
3780 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
3781 -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
3782 -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
3783 -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
3784 -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
3785 -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/)
3787 ! These are the temperatures associated with the respective
3788 ! pressures for the mls standard atmosphere.
3790 tref(:) = (/ &
3791 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
3792 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
3793 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
3794 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
3795 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
3796 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
3797 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
3798 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
3799 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
3800 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
3801 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
3802 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/)
3804 chi_mls(1,1:12) = (/ &
3805 1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, &
3806 7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, &
3807 4.3082e-06_rb, 3.3319e-06_rb/)
3808 chi_mls(1,13:59) = (/ &
3809 3.2039e-06_rb, 3.1619e-06_rb, 3.2524e-06_rb, 3.4226e-06_rb, 3.6288e-06_rb, &
3810 3.9148e-06_rb, 4.1488e-06_rb, 4.3081e-06_rb, 4.4420e-06_rb, 4.5778e-06_rb, &
3811 4.7087e-06_rb, 4.7943e-06_rb, 4.8697e-06_rb, 4.9260e-06_rb, 4.9669e-06_rb, &
3812 4.9963e-06_rb, 5.0527e-06_rb, 5.1266e-06_rb, 5.2503e-06_rb, 5.3571e-06_rb, &
3813 5.4509e-06_rb, 5.4830e-06_rb, 5.5000e-06_rb, 5.5000e-06_rb, 5.4536e-06_rb, &
3814 5.4047e-06_rb, 5.3558e-06_rb, 5.2533e-06_rb, 5.1436e-06_rb, 5.0340e-06_rb, &
3815 4.8766e-06_rb, 4.6979e-06_rb, 4.5191e-06_rb, 4.3360e-06_rb, 4.1442e-06_rb, &
3816 3.9523e-06_rb, 3.7605e-06_rb, 3.5722e-06_rb, 3.3855e-06_rb, 3.1988e-06_rb, &
3817 3.0121e-06_rb, 2.8262e-06_rb, 2.6407e-06_rb, 2.4552e-06_rb, 2.2696e-06_rb, &
3818 4.3360e-06_rb, 4.1442e-06_rb/)
3819 chi_mls(2,1:12) = (/ &
3820 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3821 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3822 3.5500e-04_rb, 3.5500e-04_rb/)
3823 chi_mls(2,13:59) = (/ &
3824 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3825 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3826 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3827 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3828 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3829 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3830 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3831 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3832 3.5500e-04_rb, 3.5471e-04_rb, 3.5427e-04_rb, 3.5384e-04_rb, 3.5340e-04_rb, &
3833 3.5500e-04_rb, 3.5500e-04_rb/)
3834 chi_mls(3,1:12) = (/ &
3835 3.0170e-08_rb, 3.4725e-08_rb, 4.2477e-08_rb, 5.2759e-08_rb, 6.6944e-08_rb, &
3836 8.7130e-08_rb, 1.1391e-07_rb, 1.5677e-07_rb, 2.1788e-07_rb, 3.2443e-07_rb, &
3837 4.6594e-07_rb, 5.6806e-07_rb/)
3838 chi_mls(3,13:59) = (/ &
3839 6.9607e-07_rb, 1.1186e-06_rb, 1.7618e-06_rb, 2.3269e-06_rb, 2.9577e-06_rb, &
3840 3.6593e-06_rb, 4.5950e-06_rb, 5.3189e-06_rb, 5.9618e-06_rb, 6.5113e-06_rb, &
3841 7.0635e-06_rb, 7.6917e-06_rb, 8.2577e-06_rb, 8.7082e-06_rb, 8.8325e-06_rb, &
3842 8.7149e-06_rb, 8.0943e-06_rb, 7.3307e-06_rb, 6.3101e-06_rb, 5.3672e-06_rb, &
3843 4.4829e-06_rb, 3.8391e-06_rb, 3.2827e-06_rb, 2.8235e-06_rb, 2.4906e-06_rb, &
3844 2.1645e-06_rb, 1.8385e-06_rb, 1.6618e-06_rb, 1.5052e-06_rb, 1.3485e-06_rb, &
3845 1.1972e-06_rb, 1.0482e-06_rb, 8.9926e-07_rb, 7.6343e-07_rb, 6.5381e-07_rb, &
3846 5.4419e-07_rb, 4.3456e-07_rb, 3.6421e-07_rb, 3.1194e-07_rb, 2.5967e-07_rb, &
3847 2.0740e-07_rb, 1.9146e-07_rb, 1.9364e-07_rb, 1.9582e-07_rb, 1.9800e-07_rb, &
3848 7.6343e-07_rb, 6.5381e-07_rb/)
3849 chi_mls(4,1:12) = (/ &
3850 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, &
3851 3.1965e-07_rb, 3.1532e-07_rb, 3.0383e-07_rb, 2.9422e-07_rb, 2.8495e-07_rb, &
3852 2.7671e-07_rb, 2.6471e-07_rb/)
3853 chi_mls(4,13:59) = (/ &
3854 2.4285e-07_rb, 2.0955e-07_rb, 1.7195e-07_rb, 1.3749e-07_rb, 1.1332e-07_rb, &
3855 1.0035e-07_rb, 9.1281e-08_rb, 8.5463e-08_rb, 8.0363e-08_rb, 7.3372e-08_rb, &
3856 6.5975e-08_rb, 5.6039e-08_rb, 4.7090e-08_rb, 3.9977e-08_rb, 3.2979e-08_rb, &
3857 2.6064e-08_rb, 2.1066e-08_rb, 1.6592e-08_rb, 1.3017e-08_rb, 1.0090e-08_rb, &
3858 7.6249e-09_rb, 6.1159e-09_rb, 4.6672e-09_rb, 3.2857e-09_rb, 2.8484e-09_rb, &
3859 2.4620e-09_rb, 2.0756e-09_rb, 1.8551e-09_rb, 1.6568e-09_rb, 1.4584e-09_rb, &
3860 1.3195e-09_rb, 1.2072e-09_rb, 1.0948e-09_rb, 9.9780e-10_rb, 9.3126e-10_rb, &
3861 8.6472e-10_rb, 7.9818e-10_rb, 7.5138e-10_rb, 7.1367e-10_rb, 6.7596e-10_rb, &
3862 6.3825e-10_rb, 6.0981e-10_rb, 5.8600e-10_rb, 5.6218e-10_rb, 5.3837e-10_rb, &
3863 9.9780e-10_rb, 9.3126e-10_rb/)
3864 chi_mls(5,1:12) = (/ &
3865 1.5000e-07_rb, 1.4306e-07_rb, 1.3474e-07_rb, 1.3061e-07_rb, 1.2793e-07_rb, &
3866 1.2038e-07_rb, 1.0798e-07_rb, 9.4238e-08_rb, 7.9488e-08_rb, 6.1386e-08_rb, &
3867 4.5563e-08_rb, 3.3475e-08_rb/)
3868 chi_mls(5,13:59) = (/ &
3869 2.5118e-08_rb, 1.8671e-08_rb, 1.4349e-08_rb, 1.2501e-08_rb, 1.2407e-08_rb, &
3870 1.3472e-08_rb, 1.4900e-08_rb, 1.6079e-08_rb, 1.7156e-08_rb, 1.8616e-08_rb, &
3871 2.0106e-08_rb, 2.1654e-08_rb, 2.3096e-08_rb, 2.4340e-08_rb, 2.5643e-08_rb, &
3872 2.6990e-08_rb, 2.8456e-08_rb, 2.9854e-08_rb, 3.0943e-08_rb, 3.2023e-08_rb, &
3873 3.3101e-08_rb, 3.4260e-08_rb, 3.5360e-08_rb, 3.6397e-08_rb, 3.7310e-08_rb, &
3874 3.8217e-08_rb, 3.9123e-08_rb, 4.1303e-08_rb, 4.3652e-08_rb, 4.6002e-08_rb, &
3875 5.0289e-08_rb, 5.5446e-08_rb, 6.0603e-08_rb, 6.8946e-08_rb, 8.3652e-08_rb, &
3876 9.8357e-08_rb, 1.1306e-07_rb, 1.4766e-07_rb, 1.9142e-07_rb, 2.3518e-07_rb, &
3877 2.7894e-07_rb, 3.5001e-07_rb, 4.3469e-07_rb, 5.1938e-07_rb, 6.0407e-07_rb, &
3878 6.8946e-08_rb, 8.3652e-08_rb/)
3879 chi_mls(6,1:12) = (/ &
3880 1.7000e-06_rb, 1.7000e-06_rb, 1.6999e-06_rb, 1.6904e-06_rb, 1.6671e-06_rb, &
3881 1.6351e-06_rb, 1.6098e-06_rb, 1.5590e-06_rb, 1.5120e-06_rb, 1.4741e-06_rb, &
3882 1.4385e-06_rb, 1.4002e-06_rb/)
3883 chi_mls(6,13:59) = (/ &
3884 1.3573e-06_rb, 1.3130e-06_rb, 1.2512e-06_rb, 1.1668e-06_rb, 1.0553e-06_rb, &
3885 9.3281e-07_rb, 8.1217e-07_rb, 7.5239e-07_rb, 7.0728e-07_rb, 6.6722e-07_rb, &
3886 6.2733e-07_rb, 5.8604e-07_rb, 5.4769e-07_rb, 5.1480e-07_rb, 4.8206e-07_rb, &
3887 4.4943e-07_rb, 4.1702e-07_rb, 3.8460e-07_rb, 3.5200e-07_rb, 3.1926e-07_rb, &
3888 2.8646e-07_rb, 2.5498e-07_rb, 2.2474e-07_rb, 1.9588e-07_rb, 1.8295e-07_rb, &
3889 1.7089e-07_rb, 1.5882e-07_rb, 1.5536e-07_rb, 1.5304e-07_rb, 1.5072e-07_rb, &
3890 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3891 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3892 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3893 1.5000e-07_rb, 1.5000e-07_rb/)
3894 chi_mls(7,1:12) = (/ &
3895 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3896 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3897 0.2090_rb, 0.2090_rb/)
3898 chi_mls(7,13:59) = (/ &
3899 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3900 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3901 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3902 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3903 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3904 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3905 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3906 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3907 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3908 0.2090_rb, 0.2090_rb/)
3910 end subroutine lwatmref
3912 !***************************************************************************
3913 subroutine lwavplank
3914 !***************************************************************************
3916 save
3918 totplnk(1:50, 1) = (/ &
3919 0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, &
3920 0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, &
3921 0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, &
3922 0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, &
3923 0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, &
3924 0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, &
3925 0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, &
3926 0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, &
3927 0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, &
3928 0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/)
3929 totplnk(51:100, 1) = (/ &
3930 0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, &
3931 0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, &
3932 0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, &
3933 0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, &
3934 0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, &
3935 0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, &
3936 0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, &
3937 0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, &
3938 0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, &
3939 0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/)
3940 totplnk(101:150, 1) = (/ &
3941 0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, &
3942 0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, &
3943 0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, &
3944 0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, &
3945 0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, &
3946 0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, &
3947 0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, &
3948 0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, &
3949 0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, &
3950 0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/)
3951 totplnk(151:181, 1) = (/ &
3952 0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, &
3953 0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, &
3954 0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, &
3955 0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, &
3956 0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, &
3957 0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, &
3958 0.65247e-05_rb/)
3959 totplnk(1:50, 2) = (/ &
3960 0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, &
3961 0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, &
3962 0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, &
3963 0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, &
3964 0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, &
3965 0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, &
3966 0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, &
3967 0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, &
3968 0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, &
3969 0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/)
3970 totplnk(51:100, 2) = (/ &
3971 0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, &
3972 0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, &
3973 0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, &
3974 0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, &
3975 0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, &
3976 0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, &
3977 0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, &
3978 0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, &
3979 0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, &
3980 0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/)
3981 totplnk(101:150, 2) = (/ &
3982 0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, &
3983 0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, &
3984 0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, &
3985 0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, &
3986 0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, &
3987 0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, &
3988 0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, &
3989 0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, &
3990 0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, &
3991 0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/)
3992 totplnk(151:181, 2) = (/ &
3993 0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, &
3994 0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, &
3995 0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, &
3996 0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, &
3997 0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, &
3998 0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, &
3999 0.17998e-04_rb/)
4000 totplnk(1:50, 3) = (/ &
4001 1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, &
4002 1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, &
4003 1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, &
4004 2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, &
4005 2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, &
4006 2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, &
4007 3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, &
4008 3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, &
4009 3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, &
4010 4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/)
4011 totplnk(51:100, 3) = (/ &
4012 4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, &
4013 4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, &
4014 5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, &
4015 5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, &
4016 6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, &
4017 6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, &
4018 7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, &
4019 8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, &
4020 8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, &
4021 9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/)
4022 totplnk(101:150, 3) = (/ &
4023 9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, &
4024 1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, &
4025 1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, &
4026 1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, &
4027 1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, &
4028 1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, &
4029 1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, &
4030 1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, &
4031 1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, &
4032 1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/)
4033 totplnk(151:181, 3) = (/ &
4034 1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, &
4035 1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, &
4036 1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, &
4037 1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, &
4038 1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, &
4039 2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, &
4040 2.15414e-05_rb/)
4041 totplnk(1:50, 4) = (/ &
4042 8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, &
4043 1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, &
4044 1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, &
4045 1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, &
4046 1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, &
4047 2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, &
4048 2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, &
4049 2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, &
4050 2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, &
4051 3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/)
4052 totplnk(51:100, 4) = (/ &
4053 3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, &
4054 4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, &
4055 4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, &
4056 5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, &
4057 5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, &
4058 6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, &
4059 6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, &
4060 7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, &
4061 7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, &
4062 8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/)
4063 totplnk(101:150, 4) = (/ &
4064 9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, &
4065 9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, &
4066 1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, &
4067 1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, &
4068 1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, &
4069 1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, &
4070 1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, &
4071 1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, &
4072 1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, &
4073 1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/)
4074 totplnk(151:181, 4) = (/ &
4075 1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, &
4076 1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, &
4077 1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, &
4078 1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, &
4079 2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, &
4080 2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, &
4081 2.23158e-05_rb/)
4082 totplnk(1:50, 5) = (/ &
4083 5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, &
4084 7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, &
4085 8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, &
4086 1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, &
4087 1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, &
4088 1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, &
4089 1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, &
4090 1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, &
4091 2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, &
4092 2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/)
4093 totplnk(51:100, 5) = (/ &
4094 2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, &
4095 3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, &
4096 3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, &
4097 4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, &
4098 4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, &
4099 5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, &
4100 5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, &
4101 6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, &
4102 6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, &
4103 7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/)
4104 totplnk(101:150, 5) = (/ &
4105 7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, &
4106 8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, &
4107 9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, &
4108 9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, &
4109 1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, &
4110 1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, &
4111 1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, &
4112 1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, &
4113 1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, &
4114 1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/)
4115 totplnk(151:181, 5) = (/ &
4116 1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, &
4117 1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, &
4118 1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, &
4119 1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, &
4120 1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, &
4121 2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, &
4122 2.17931e-05_rb/)
4123 totplnk(1:50, 6) = (/ &
4124 2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, &
4125 3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, &
4126 4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, &
4127 5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, &
4128 6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, &
4129 8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, &
4130 9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, &
4131 1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, &
4132 1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, &
4133 1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/)
4134 totplnk(51:100, 6) = (/ &
4135 1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, &
4136 2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, &
4137 2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, &
4138 2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, &
4139 3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, &
4140 3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, &
4141 3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, &
4142 4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, &
4143 4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, &
4144 5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/)
4145 totplnk(101:150, 6) = (/ &
4146 6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, &
4147 6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, &
4148 7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, &
4149 7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, &
4150 8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, &
4151 9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, &
4152 1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, &
4153 1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, &
4154 1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, &
4155 1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/)
4156 totplnk(151:181, 6) = (/ &
4157 1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, &
4158 1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, &
4159 1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, &
4160 1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, &
4161 1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, &
4162 1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, &
4163 1.96471e-05_rb/)
4164 totplnk(1:50, 7) = (/ &
4165 1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, &
4166 1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, &
4167 2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, &
4168 2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, &
4169 3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, &
4170 4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, &
4171 5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, &
4172 6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, &
4173 7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, &
4174 9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/)
4175 totplnk(51:100, 7) = (/ &
4176 1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, &
4177 1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, &
4178 1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, &
4179 1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, &
4180 2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, &
4181 2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, &
4182 2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, &
4183 3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, &
4184 3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, &
4185 3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/)
4186 totplnk(101:150, 7) = (/ &
4187 4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, &
4188 4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, &
4189 5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, &
4190 5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, &
4191 6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, &
4192 7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, &
4193 7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, &
4194 8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, &
4195 9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, &
4196 1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/)
4197 totplnk(151:181, 7) = (/ &
4198 1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, &
4199 1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, &
4200 1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, &
4201 1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, &
4202 1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, &
4203 1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, &
4204 1.68640e-05_rb/)
4205 totplnk(1:50, 8) = (/ &
4206 6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, &
4207 9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, &
4208 1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, &
4209 1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, &
4210 2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, &
4211 2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, &
4212 3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, &
4213 4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, &
4214 5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, &
4215 6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/)
4216 totplnk(51:100, 8) = (/ &
4217 7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, &
4218 8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, &
4219 1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, &
4220 1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, &
4221 1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, &
4222 1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, &
4223 1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, &
4224 2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, &
4225 2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, &
4226 2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/)
4227 totplnk(101:150, 8) = (/ &
4228 3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, &
4229 3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, &
4230 4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, &
4231 4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, &
4232 5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, &
4233 5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, &
4234 6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, &
4235 6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, &
4236 7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, &
4237 8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/)
4238 totplnk(151:181, 8) = (/ &
4239 9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, &
4240 9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, &
4241 1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, &
4242 1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, &
4243 1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, &
4244 1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, &
4245 1.45267e-05_rb/)
4246 totplnk(1:50, 9) = (/ &
4247 2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, &
4248 3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, &
4249 5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, &
4250 6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, &
4251 9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, &
4252 1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, &
4253 1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, &
4254 2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, &
4255 2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, &
4256 3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/)
4257 totplnk(51:100, 9) = (/ &
4258 3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, &
4259 4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, &
4260 5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, &
4261 7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, &
4262 8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, &
4263 9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, &
4264 1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, &
4265 1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, &
4266 1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, &
4267 1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/)
4268 totplnk(101:150, 9) = (/ &
4269 2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, &
4270 2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, &
4271 2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, &
4272 3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, &
4273 3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, &
4274 3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, &
4275 4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, &
4276 4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, &
4277 5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, &
4278 5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/)
4279 totplnk(151:181, 9) = (/ &
4280 6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, &
4281 7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, &
4282 7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, &
4283 8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, &
4284 9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, &
4285 1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, &
4286 1.10781e-05_rb/)
4287 totplnk(1:50,10) = (/ &
4288 8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, &
4289 1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, &
4290 1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, &
4291 2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, &
4292 3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, &
4293 5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, &
4294 6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, &
4295 8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, &
4296 1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, &
4297 1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/)
4298 totplnk(51:100,10) = (/ &
4299 1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, &
4300 2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, &
4301 2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, &
4302 3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, &
4303 4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, &
4304 5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, &
4305 6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, &
4306 7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, &
4307 9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, &
4308 1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/)
4309 totplnk(101:150,10) = (/ &
4310 1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, &
4311 1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, &
4312 1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, &
4313 1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, &
4314 2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, &
4315 2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, &
4316 2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, &
4317 3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, &
4318 3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, &
4319 4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/)
4320 totplnk(151:181,10) = (/ &
4321 4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, &
4322 5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, &
4323 5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, &
4324 6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, &
4325 6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, &
4326 7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, &
4327 8.14138e-06_rb/)
4328 totplnk(1:50,11) = (/ &
4329 2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, &
4330 3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, &
4331 5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, &
4332 8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, &
4333 1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, &
4334 1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, &
4335 2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, &
4336 3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, &
4337 4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, &
4338 5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/)
4339 totplnk(51:100,11) = (/ &
4340 7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, &
4341 9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, &
4342 1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, &
4343 1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, &
4344 1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, &
4345 2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, &
4346 3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, &
4347 3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, &
4348 4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, &
4349 5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/)
4350 totplnk(101:150,11) = (/ &
4351 6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, &
4352 7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, &
4353 8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, &
4354 1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, &
4355 1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, &
4356 1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, &
4357 1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, &
4358 1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, &
4359 2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, &
4360 2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/)
4361 totplnk(151:181,11) = (/ &
4362 2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, &
4363 3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, &
4364 3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, &
4365 3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, &
4366 4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, &
4367 4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, &
4368 5.19332e-06_rb/)
4369 totplnk(1:50,12) = (/ &
4370 2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, &
4371 4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, &
4372 7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, &
4373 1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, &
4374 1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, &
4375 2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, &
4376 4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, &
4377 5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, &
4378 8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, &
4379 1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/)
4380 totplnk(51:100,12) = (/ &
4381 1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, &
4382 2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, &
4383 2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, &
4384 3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, &
4385 4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, &
4386 6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, &
4387 8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, &
4388 1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, &
4389 1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, &
4390 1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/)
4391 totplnk(101:150,12) = (/ &
4392 1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, &
4393 2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, &
4394 2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, &
4395 3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, &
4396 4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, &
4397 5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, &
4398 5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, &
4399 6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, &
4400 8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, &
4401 9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/)
4402 totplnk(151:181,12) = (/ &
4403 1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, &
4404 1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, &
4405 1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, &
4406 1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, &
4407 1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, &
4408 2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, &
4409 2.41619e-06_rb/)
4410 totplnk(1:50,13) = (/ &
4411 4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, &
4412 8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, &
4413 1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, &
4414 2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, &
4415 3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, &
4416 6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, &
4417 9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, &
4418 1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, &
4419 2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, &
4420 3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/)
4421 totplnk(51:100,13) = (/ &
4422 4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, &
4423 6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, &
4424 8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, &
4425 1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, &
4426 1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, &
4427 2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, &
4428 2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, &
4429 3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, &
4430 4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, &
4431 6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/)
4432 totplnk(101:150,13) = (/ &
4433 7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, &
4434 9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, &
4435 1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, &
4436 1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, &
4437 1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, &
4438 2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, &
4439 2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, &
4440 3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, &
4441 3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, &
4442 4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/)
4443 totplnk(151:181,13) = (/ &
4444 5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, &
4445 6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, &
4446 7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, &
4447 8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, &
4448 9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, &
4449 1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, &
4450 1.28049e-06_rb/)
4451 totplnk(1:50,14) = (/ &
4452 1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, &
4453 2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, &
4454 4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, &
4455 8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, &
4456 1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, &
4457 2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, &
4458 3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, &
4459 5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, &
4460 8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, &
4461 1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/)
4462 totplnk(51:100,14) = (/ &
4463 1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, &
4464 2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, &
4465 4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, &
4466 5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, &
4467 7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, &
4468 1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, &
4469 1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, &
4470 1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, &
4471 2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, &
4472 3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/)
4473 totplnk(101:150,14) = (/ &
4474 4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, &
4475 5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, &
4476 6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, &
4477 8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, &
4478 1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, &
4479 1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, &
4480 1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, &
4481 1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, &
4482 2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, &
4483 2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/)
4484 totplnk(151:181,14) = (/ &
4485 3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, &
4486 3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, &
4487 4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, &
4488 5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, &
4489 6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, &
4490 7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, &
4491 8.27050e-07_rb/)
4492 totplnk(1:50,15) = (/ &
4493 3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, &
4494 7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, &
4495 1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, &
4496 2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, &
4497 4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, &
4498 7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, &
4499 1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, &
4500 2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, &
4501 3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, &
4502 5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/)
4503 totplnk(51:100,15) = (/ &
4504 7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, &
4505 1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, &
4506 1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, &
4507 2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, &
4508 3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, &
4509 4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, &
4510 6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, &
4511 8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, &
4512 1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, &
4513 1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/)
4514 totplnk(101:150,15) = (/ &
4515 1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, &
4516 2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, &
4517 3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, &
4518 4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, &
4519 5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, &
4520 6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, &
4521 8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, &
4522 1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, &
4523 1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, &
4524 1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/)
4525 totplnk(151:181,15) = (/ &
4526 1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, &
4527 2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, &
4528 2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, &
4529 3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, &
4530 3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, &
4531 4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, &
4532 4.96535e-07_rb/)
4533 totplnk(1:50,16) = (/ &
4534 0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, &
4535 0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, &
4536 0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, &
4537 0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, &
4538 0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, &
4539 0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, &
4540 0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, &
4541 0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, &
4542 0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, &
4543 0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/)
4544 totplnk(51:100,16) = (/ &
4545 0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, &
4546 0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, &
4547 0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, &
4548 0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, &
4549 0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, &
4550 0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, &
4551 0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, &
4552 0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, &
4553 0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, &
4554 0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/)
4555 totplnk(101:150,16) = (/ &
4556 0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, &
4557 0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, &
4558 0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, &
4559 0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, &
4560 0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, &
4561 0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, &
4562 0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, &
4563 0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, &
4564 0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, &
4565 0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/)
4566 totplnk(151:181,16) = (/ &
4567 0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, &
4568 0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, &
4569 0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, &
4570 0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, &
4571 0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, &
4572 0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, &
4573 0.16823e-06_rb/)
4574 totplk16(1:50) = (/ &
4575 0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, &
4576 0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, &
4577 0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, &
4578 0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, &
4579 0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, &
4580 0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, &
4581 0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, &
4582 0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, &
4583 0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, &
4584 0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/)
4585 totplk16(51:100) = (/ &
4586 0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, &
4587 0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, &
4588 0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, &
4589 0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, &
4590 0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, &
4591 0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, &
4592 0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, &
4593 0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, &
4594 0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, &
4595 0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/)
4596 totplk16(101:150) = (/ &
4597 0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, &
4598 0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, &
4599 0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, &
4600 0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, &
4601 0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, &
4602 0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, &
4603 0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, &
4604 0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, &
4605 0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, &
4606 0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/)
4607 totplk16(151:181) = (/ &
4608 0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, &
4609 0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, &
4610 0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, &
4611 0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, &
4612 0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, &
4613 0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, &
4614 0.14841e-06_rb/)
4616 end subroutine lwavplank
4618 end module rrtmg_lw_setcoef
4620 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
4621 ! author: $Author: trn $
4622 ! revision: $Revision: 1.3 $
4623 ! created: $Date: 2009/04/16 19:54:22 $
4624 !
4625 module rrtmg_lw_taumol
4627 ! --------------------------------------------------------------------------
4628 ! | |
4629 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
4630 ! | This software may be used, copied, or redistributed as long as it is |
4631 ! | not sold and this copyright notice is reproduced on each copy made. |
4632 ! | This model is provided as is without any express or implied warranties. |
4633 ! | (http://www.rtweb.aer.com/) |
4634 ! | |
4635 ! --------------------------------------------------------------------------
4637 ! ------- Modules -------
4639 use parkind, only : im => kind_im, rb => kind_rb
4640 use parrrtm, only : mg, nbndlw, maxxsec, ngptlw
4641 use rrlw_con, only: oneminus
4642 use rrlw_wvn, only: nspa, nspb
4643 use rrlw_vsn, only: hvrtau, hnamtau
4645 implicit none
4647 contains
4649 !----------------------------------------------------------------------------
4650 subroutine taumol(nlayers, pavel, wx, coldry, &
4651 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
4652 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
4653 colbrd, fac00, fac01, fac10, fac11, &
4654 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
4655 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
4656 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
4657 selffac, selffrac, indself, forfac, forfrac, indfor, &
4658 minorfrac, scaleminor, scaleminorn2, indminor, &
4659 fracs, taug)
4660 !----------------------------------------------------------------------------
4662 ! *******************************************************************************
4663 ! * *
4664 ! * Optical depths developed for the *
4665 ! * *
4666 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
4667 ! * *
4668 ! * *
4669 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
4670 ! * 131 HARTWELL AVENUE *
4671 ! * LEXINGTON, MA 02421 *
4672 ! * *
4673 ! * *
4674 ! * ELI J. MLAWER *
4675 ! * JENNIFER DELAMERE *
4676 ! * STEVEN J. TAUBMAN *
4677 ! * SHEPARD A. CLOUGH *
4678 ! * *
4679 ! * *
4680 ! * *
4681 ! * *
4682 ! * email: mlawer@aer.com *
4683 ! * email: jdelamer@aer.com *
4684 ! * *
4685 ! * The authors wish to acknowledge the contributions of the *
4686 ! * following people: Karen Cady-Pereira, Patrick D. Brown, *
4687 ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
4688 ! * *
4689 ! *******************************************************************************
4690 ! * *
4691 ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. *
4692 ! * *
4693 ! *******************************************************************************
4694 ! * TAUMOL *
4695 ! * *
4696 ! * This file contains the subroutines TAUGBn (where n goes from *
4697 ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions *
4698 ! * per g-value and layer for band n. *
4699 ! * *
4700 ! * Output: optical depths (unitless) *
4701 ! * fractions needed to compute Planck functions at every layer *
4702 ! * and g-value *
4703 ! * *
4704 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
4705 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
4706 ! * *
4707 ! * Input *
4708 ! * *
4709 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
4710 ! * COMMON /PRECISE/ ONEMINUS *
4711 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
4712 ! * & PZ(0:MXLAY),TZ(0:MXLAY) *
4713 ! * COMMON /PROFDATA/ LAYTROP, *
4714 ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), *
4715 ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), *
4716 ! * & COLO2(MXLAY)
4717 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
4718 ! * & FAC10(MXLAY),FAC11(MXLAY) *
4719 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
4720 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
4721 ! * *
4722 ! * Description: *
4723 ! * NG(IBAND) - number of g-values in band IBAND *
4724 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
4725 ! * atmospheres that are stored for band IBAND per *
4726 ! * pressure level and temperature. Each of these *
4727 ! * atmospheres has different relative amounts of the *
4728 ! * key species for the band (i.e. different binary *
4729 ! * species parameters). *
4730 ! * NSPB(IBAND) - same for upper atmosphere *
4731 ! * ONEMINUS - since problems are caused in some cases by interpolation *
4732 ! * parameters equal to or greater than 1, for these cases *
4733 ! * these parameters are set to this value, slightly < 1. *
4734 ! * PAVEL - layer pressures (mb) *
4735 ! * TAVEL - layer temperatures (degrees K) *
4736 ! * PZ - level pressures (mb) *
4737 ! * TZ - level temperatures (degrees K) *
4738 ! * LAYTROP - layer at which switch is made from one combination of *
4739 ! * key species to another *
4740 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
4741 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
4742 ! * respectively (molecules/cm**2) *
4743 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
4744 ! * compute the interpolation factors that multiply the *
4745 ! * appropriate reference k-values. A value of 0 (1) for *
4746 ! * i,j indicates that the corresponding factor multiplies *
4747 ! * reference k-value for the lower (higher) of the two *
4748 ! * appropriate temperatures, and altitudes, respectively. *
4749 ! * JP - the index of the lower (in altitude) of the two appropriate *
4750 ! * reference pressure levels needed for interpolation *
4751 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
4752 ! * temperatures needed for interpolation (for pressure *
4753 ! * levels JP and JP+1, respectively) *
4754 ! * SELFFAC - scale factor needed for water vapor self-continuum, equals *
4755 ! * (water vapor density)/(atmospheric density at 296K and *
4756 ! * 1013 mb) *
4757 ! * SELFFRAC - factor needed for temperature interpolation of reference *
4758 ! * water vapor self-continuum data *
4759 ! * INDSELF - index of the lower of the two appropriate reference *
4760 ! * temperatures needed for the self-continuum interpolation *
4761 ! * FORFAC - scale factor needed for water vapor foreign-continuum. *
4762 ! * FORFRAC - factor needed for temperature interpolation of reference *
4763 ! * water vapor foreign-continuum data *
4764 ! * INDFOR - index of the lower of the two appropriate reference *
4765 ! * temperatures needed for the foreign-continuum interpolation *
4766 ! * *
4767 ! * Data input *
4768 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
4769 ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' *
4770 ! * (note: n is the band number,'MGAS' is the species name of the minor *
4771 ! * gas) *
4772 ! * *
4773 ! * Description: *
4774 ! * KA - k-values for low reference atmospheres (key-species only) *
4775 ! * (units: cm**2/molecule) *
4776 ! * KB - k-values for high reference atmospheres (key-species only) *
4777 ! * (units: cm**2/molecule) *
4778 ! * KA_M'MGAS' - k-values for low reference atmosphere minor species *
4779 ! * (units: cm**2/molecule) *
4780 ! * KB_M'MGAS' - k-values for high reference atmosphere minor species *
4781 ! * (units: cm**2/molecule) *
4782 ! * SELFREF - k-values for water vapor self-continuum for reference *
4783 ! * atmospheres (used below LAYTROP) *
4784 ! * (units: cm**2/molecule) *
4785 ! * FORREF - k-values for water vapor foreign-continuum for reference *
4786 ! * atmospheres (used below/above LAYTROP) *
4787 ! * (units: cm**2/molecule) *
4788 ! * *
4789 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
4790 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
4791 ! * *
4792 !*******************************************************************************
4794 ! ------- Declarations -------
4796 ! ----- Input -----
4797 integer(kind=im), intent(in) :: nlayers ! total number of layers
4798 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
4799 ! Dimensions: (nlayers)
4800 real(kind=rb), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2)
4801 ! Dimensions: (maxxsec,nlayers)
4802 real(kind=rb), intent(in) :: coldry(:) ! column amount (dry air)
4803 ! Dimensions: (nlayers)
4805 integer(kind=im), intent(in) :: laytrop ! tropopause layer index
4806 integer(kind=im), intent(in) :: jp(:) !
4807 ! Dimensions: (nlayers)
4808 integer(kind=im), intent(in) :: jt(:) !
4809 ! Dimensions: (nlayers)
4810 integer(kind=im), intent(in) :: jt1(:) !
4811 ! Dimensions: (nlayers)
4812 real(kind=rb), intent(in) :: planklay(:,:) !
4813 ! Dimensions: (nlayers,nbndlw)
4814 real(kind=rb), intent(in) :: planklev(0:,:) !
4815 ! Dimensions: (nlayers,nbndlw)
4816 real(kind=rb), intent(in) :: plankbnd(:) !
4817 ! Dimensions: (nbndlw)
4819 real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o)
4820 ! Dimensions: (nlayers)
4821 real(kind=rb), intent(in) :: colco2(:) ! column amount (co2)
4822 ! Dimensions: (nlayers)
4823 real(kind=rb), intent(in) :: colo3(:) ! column amount (o3)
4824 ! Dimensions: (nlayers)
4825 real(kind=rb), intent(in) :: coln2o(:) ! column amount (n2o)
4826 ! Dimensions: (nlayers)
4827 real(kind=rb), intent(in) :: colco(:) ! column amount (co)
4828 ! Dimensions: (nlayers)
4829 real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4)
4830 ! Dimensions: (nlayers)
4831 real(kind=rb), intent(in) :: colo2(:) ! column amount (o2)
4832 ! Dimensions: (nlayers)
4833 real(kind=rb), intent(in) :: colbrd(:) ! column amount (broadening gases)
4834 ! Dimensions: (nlayers)
4836 integer(kind=im), intent(in) :: indself(:)
4837 ! Dimensions: (nlayers)
4838 integer(kind=im), intent(in) :: indfor(:)
4839 ! Dimensions: (nlayers)
4840 real(kind=rb), intent(in) :: selffac(:)
4841 ! Dimensions: (nlayers)
4842 real(kind=rb), intent(in) :: selffrac(:)
4843 ! Dimensions: (nlayers)
4844 real(kind=rb), intent(in) :: forfac(:)
4845 ! Dimensions: (nlayers)
4846 real(kind=rb), intent(in) :: forfrac(:)
4847 ! Dimensions: (nlayers)
4849 integer(kind=im), intent(in) :: indminor(:)
4850 ! Dimensions: (nlayers)
4851 real(kind=rb), intent(in) :: minorfrac(:)
4852 ! Dimensions: (nlayers)
4853 real(kind=rb), intent(in) :: scaleminor(:)
4854 ! Dimensions: (nlayers)
4855 real(kind=rb), intent(in) :: scaleminorn2(:)
4856 ! Dimensions: (nlayers)
4858 real(kind=rb), intent(in) :: & !
4859 fac00(:), fac01(:), & ! Dimensions: (nlayers)
4860 fac10(:), fac11(:)
4861 real(kind=rb), intent(in) :: & !
4862 rat_h2oco2(:),rat_h2oco2_1(:), &
4863 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
4864 rat_h2on2o(:),rat_h2on2o_1(:), &
4865 rat_h2och4(:),rat_h2och4_1(:), &
4866 rat_n2oco2(:),rat_n2oco2_1(:), &
4867 rat_o3co2(:),rat_o3co2_1(:)
4869 ! ----- Output -----
4870 real(kind=rb), intent(out) :: fracs(:,:) ! planck fractions
4871 ! Dimensions: (nlayers,ngptlw)
4872 real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth
4873 ! Dimensions: (nlayers,ngptlw)
4875 hvrtau = '$Revision: 1.3 $'
4877 ! Calculate gaseous optical depth and planck fractions for each spectral band.
4879 call taugb1
4880 call taugb2
4881 call taugb3
4882 call taugb4
4883 call taugb5
4884 call taugb6
4885 call taugb7
4886 call taugb8
4887 call taugb9
4888 call taugb10
4889 call taugb11
4890 call taugb12
4891 call taugb13
4892 call taugb14
4893 call taugb15
4894 call taugb16
4896 contains
4898 !----------------------------------------------------------------------------
4899 subroutine taugb1
4900 !----------------------------------------------------------------------------
4902 ! ------- Modifications -------
4903 ! Written by Eli J. Mlawer, Atmospheric & Environmental Research.
4904 ! Revised by Michael J. Iacono, Atmospheric & Environmental Research.
4905 !
4906 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
4907 ! (high key - h2o; high minor - n2)
4908 !
4909 ! note: previous versions of rrtm band 1:
4910 ! 10-250 cm-1 (low - h2o; high - h2o)
4911 !----------------------------------------------------------------------------
4913 ! ------- Modules -------
4915 use parrrtm, only : ng1
4916 use rrlw_kg01, only : fracrefa, fracrefb, absa, ka, absb, kb, &
4917 ka_mn2, kb_mn2, selfref, forref
4919 ! ------- Declarations -------
4921 ! Local
4922 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
4923 real(kind=rb) :: pp, corradj, scalen2, tauself, taufor, taun2
4926 ! Minor gas mapping levels:
4927 ! lower - n2, p = 142.5490 mbar, t = 215.70 k
4928 ! upper - n2, p = 142.5490 mbar, t = 215.70 k
4930 ! Compute the optical depth by interpolating in ln(pressure) and
4931 ! temperature. Below laytrop, the water vapor self-continuum and
4932 ! foreign continuum is interpolated (in temperature) separately.
4934 ! Lower atmosphere loop
4935 do lay = 1, laytrop
4937 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1
4938 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1
4939 inds = indself(lay)
4940 indf = indfor(lay)
4941 indm = indminor(lay)
4942 pp = pavel(lay)
4943 corradj = 1.
4944 if (pp .lt. 250._rb) then
4945 corradj = 1._rb - 0.15_rb * (250._rb-pp) / 154.4_rb
4946 endif
4948 scalen2 = colbrd(lay) * scaleminorn2(lay)
4949 do ig = 1, ng1
4950 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
4951 (selfref(inds+1,ig) - selfref(inds,ig)))
4952 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
4953 (forref(indf+1,ig) - forref(indf,ig)))
4954 taun2 = scalen2*(ka_mn2(indm,ig) + &
4955 minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig)))
4956 taug(lay,ig) = corradj * (colh2o(lay) * &
4957 (fac00(lay) * absa(ind0,ig) + &
4958 fac10(lay) * absa(ind0+1,ig) + &
4959 fac01(lay) * absa(ind1,ig) + &
4960 fac11(lay) * absa(ind1+1,ig)) &
4961 + tauself + taufor + taun2)
4962 fracs(lay,ig) = fracrefa(ig)
4963 enddo
4964 enddo
4966 ! Upper atmosphere loop
4967 do lay = laytrop+1, nlayers
4969 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1
4970 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1
4971 indf = indfor(lay)
4972 indm = indminor(lay)
4973 pp = pavel(lay)
4974 corradj = 1._rb - 0.15_rb * (pp / 95.6_rb)
4976 scalen2 = colbrd(lay) * scaleminorn2(lay)
4977 do ig = 1, ng1
4978 taufor = forfac(lay) * (forref(indf,ig) + &
4979 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
4980 taun2 = scalen2*(kb_mn2(indm,ig) + &
4981 minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig)))
4982 taug(lay,ig) = corradj * (colh2o(lay) * &
4983 (fac00(lay) * absb(ind0,ig) + &
4984 fac10(lay) * absb(ind0+1,ig) + &
4985 fac01(lay) * absb(ind1,ig) + &
4986 fac11(lay) * absb(ind1+1,ig)) &
4987 + taufor + taun2)
4988 fracs(lay,ig) = fracrefb(ig)
4989 enddo
4990 enddo
4992 end subroutine taugb1
4994 !----------------------------------------------------------------------------
4995 subroutine taugb2
4996 !----------------------------------------------------------------------------
4997 !
4998 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
4999 !
5000 ! note: previous version of rrtm band 2:
5001 ! 250 - 500 cm-1 (low - h2o; high - h2o)
5002 !----------------------------------------------------------------------------
5004 ! ------- Modules -------
5006 use parrrtm, only : ng2, ngs1
5007 use rrlw_kg02, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5008 selfref, forref
5010 ! ------- Declarations -------
5012 ! Local
5013 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5014 real(kind=rb) :: pp, corradj, tauself, taufor
5017 ! Compute the optical depth by interpolating in ln(pressure) and
5018 ! temperature. Below laytrop, the water vapor self-continuum and
5019 ! foreign continuum is interpolated (in temperature) separately.
5021 ! Lower atmosphere loop
5022 do lay = 1, laytrop
5024 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
5025 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
5026 inds = indself(lay)
5027 indf = indfor(lay)
5028 pp = pavel(lay)
5029 corradj = 1._rb - .05_rb * (pp - 100._rb) / 900._rb
5030 do ig = 1, ng2
5031 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5032 (selfref(inds+1,ig) - selfref(inds,ig)))
5033 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5034 (forref(indf+1,ig) - forref(indf,ig)))
5035 taug(lay,ngs1+ig) = corradj * (colh2o(lay) * &
5036 (fac00(lay) * absa(ind0,ig) + &
5037 fac10(lay) * absa(ind0+1,ig) + &
5038 fac01(lay) * absa(ind1,ig) + &
5039 fac11(lay) * absa(ind1+1,ig)) &
5040 + tauself + taufor)
5041 fracs(lay,ngs1+ig) = fracrefa(ig)
5042 enddo
5043 enddo
5045 ! Upper atmosphere loop
5046 do lay = laytrop+1, nlayers
5048 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
5049 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
5050 indf = indfor(lay)
5051 do ig = 1, ng2
5052 taufor = forfac(lay) * (forref(indf,ig) + &
5053 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5054 taug(lay,ngs1+ig) = colh2o(lay) * &
5055 (fac00(lay) * absb(ind0,ig) + &
5056 fac10(lay) * absb(ind0+1,ig) + &
5057 fac01(lay) * absb(ind1,ig) + &
5058 fac11(lay) * absb(ind1+1,ig)) &
5059 + taufor
5060 fracs(lay,ngs1+ig) = fracrefb(ig)
5061 enddo
5062 enddo
5064 end subroutine taugb2
5066 !----------------------------------------------------------------------------
5067 subroutine taugb3
5068 !----------------------------------------------------------------------------
5069 !
5070 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
5071 ! (high key - h2o,co2; high minor - n2o)
5072 !----------------------------------------------------------------------------
5074 ! ------- Modules -------
5076 use parrrtm, only : ng3, ngs2
5077 use rrlw_ref, only : chi_mls
5078 use rrlw_kg03, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5079 ka_mn2o, kb_mn2o, selfref, forref
5081 ! ------- Declarations -------
5083 ! Local
5084 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5085 integer(kind=im) :: js, js1, jmn2o, jpl
5086 real(kind=rb) :: speccomb, specparm, specmult, fs
5087 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5088 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, &
5089 fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
5090 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5091 real(kind=rb) :: p, p4, fk0, fk1, fk2
5092 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5093 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5094 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
5095 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
5099 ! Minor gas mapping levels:
5100 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
5101 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
5103 ! P = 212.725 mb
5104 refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
5106 ! P = 95.58 mb
5107 refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
5109 ! P = 706.270mb
5110 refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
5112 ! P = 95.58 mb
5113 refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
5115 ! Compute the optical depth by interpolating in ln(pressure) and
5116 ! temperature, and appropriate species. Below laytrop, the water vapor
5117 ! self-continuum and foreign continuum is interpolated (in temperature)
5118 ! separately.
5120 ! Lower atmosphere loop
5121 do lay = 1, laytrop
5123 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5124 specparm = colh2o(lay)/speccomb
5125 if (specparm .ge. oneminus) specparm = oneminus
5126 specmult = 8._rb*(specparm)
5127 js = 1 + int(specmult)
5128 fs = mod(specmult,1.0_rb)
5130 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5131 specparm1 = colh2o(lay)/speccomb1
5132 if (specparm1 .ge. oneminus) specparm1 = oneminus
5133 specmult1 = 8._rb*(specparm1)
5134 js1 = 1 + int(specmult1)
5135 fs1 = mod(specmult1,1.0_rb)
5137 speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay)
5138 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5139 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5140 specmult_mn2o = 8._rb*specparm_mn2o
5141 jmn2o = 1 + int(specmult_mn2o)
5142 fmn2o = mod(specmult_mn2o,1.0_rb)
5143 fmn2omf = minorfrac(lay)*fmn2o
5144 ! In atmospheres where the amount of N2O is too great to be considered
5145 ! a minor species, adjust the column amount of N2O by an empirical factor
5146 ! to obtain the proper contribution.
5147 chi_n2o = coln2o(lay)/coldry(lay)
5148 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
5149 if (ratn2o .gt. 1.5_rb) then
5150 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5151 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5152 else
5153 adjcoln2o = coln2o(lay)
5154 endif
5156 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5157 specparm_planck = colh2o(lay)/speccomb_planck
5158 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5159 specmult_planck = 8._rb*specparm_planck
5160 jpl= 1 + int(specmult_planck)
5161 fpl = mod(specmult_planck,1.0_rb)
5163 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js
5164 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1
5165 inds = indself(lay)
5166 indf = indfor(lay)
5167 indm = indminor(lay)
5169 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
5170 p = fs - 1
5171 p4 = p**4
5172 fk0 = p4
5173 fk1 = 1 - p - 2.0_rb*p4
5174 fk2 = p + p4
5175 fac000 = fk0*fac00(lay)
5176 fac100 = fk1*fac00(lay)
5177 fac200 = fk2*fac00(lay)
5178 fac010 = fk0*fac10(lay)
5179 fac110 = fk1*fac10(lay)
5180 fac210 = fk2*fac10(lay)
5182 p = fs1 - 1
5183 p4 = p**4
5184 fk0 = p4
5185 fk1 = 1 - p - 2.0_rb*p4
5186 fk2 = p + p4
5187 fac001 = fk0*fac01(lay)
5188 fac101 = fk1*fac01(lay)
5189 fac201 = fk2*fac01(lay)
5190 fac011 = fk0*fac11(lay)
5191 fac111 = fk1*fac11(lay)
5192 fac211 = fk2*fac11(lay)
5194 do ig = 1, ng3
5195 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5196 (selfref(inds+1,ig) - selfref(inds,ig)))
5197 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5198 (forref(indf+1,ig) - forref(indf,ig)))
5199 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
5200 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
5201 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5202 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
5203 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5204 taug(lay,ngs2+ig) = speccomb * &
5205 (fac000 * absa(ind0,ig) + &
5206 fac100 * absa(ind0+1,ig) + &
5207 fac200 * absa(ind0+2,ig) + &
5208 fac010 * absa(ind0+9,ig) + &
5209 fac110 * absa(ind0+10,ig) + &
5210 fac210 * absa(ind0+11,ig)) &
5211 + speccomb1 * &
5212 (fac001 * absa(ind1,ig) + &
5213 fac101 * absa(ind1+1,ig) + &
5214 fac201 * absa(ind1+2,ig) + &
5215 fac011 * absa(ind1+9,ig) + &
5216 fac111 * absa(ind1+10,ig) + &
5217 fac211 * absa(ind1+11,ig)) &
5218 + tauself + taufor &
5219 + adjcoln2o*absn2o
5220 fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
5221 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5222 enddo
5223 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
5224 p = -fs
5225 p4 = p**4
5226 fk0 = p4
5227 fk1 = 1 - p - 2.0_rb*p4
5228 fk2 = p + p4
5229 fac000 = fk0*fac00(lay)
5230 fac100 = fk1*fac00(lay)
5231 fac200 = fk2*fac00(lay)
5232 fac010 = fk0*fac10(lay)
5233 fac110 = fk1*fac10(lay)
5234 fac210 = fk2*fac10(lay)
5236 p = -fs1
5237 p4 = p**4
5238 fk0 = p4
5239 fk1 = 1 - p - 2.0_rb*p4
5240 fk2 = p + p4
5241 fac001 = fk0*fac01(lay)
5242 fac101 = fk1*fac01(lay)
5243 fac201 = fk2*fac01(lay)
5244 fac011 = fk0*fac11(lay)
5245 fac111 = fk1*fac11(lay)
5246 fac211 = fk2*fac11(lay)
5248 do ig = 1, ng3
5249 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5250 (selfref(inds+1,ig) - selfref(inds,ig)))
5251 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5252 (forref(indf+1,ig) - forref(indf,ig)))
5253 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
5254 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
5255 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5256 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
5257 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5258 taug(lay,ngs2+ig) = speccomb * &
5259 (fac200 * absa(ind0-1,ig) + &
5260 fac100 * absa(ind0,ig) + &
5261 fac000 * absa(ind0+1,ig) + &
5262 fac210 * absa(ind0+8,ig) + &
5263 fac110 * absa(ind0+9,ig) + &
5264 fac010 * absa(ind0+10,ig)) &
5265 + speccomb1 * &
5266 (fac201 * absa(ind1-1,ig) + &
5267 fac101 * absa(ind1,ig) + &
5268 fac001 * absa(ind1+1,ig) + &
5269 fac211 * absa(ind1+8,ig) + &
5270 fac111 * absa(ind1+9,ig) + &
5271 fac011 * absa(ind1+10,ig)) &
5272 + tauself + taufor &
5273 + adjcoln2o*absn2o
5274 fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
5275 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5276 enddo
5277 else
5278 fac000 = (1. - fs) * fac00(lay)
5279 fac010 = (1. - fs) * fac10(lay)
5280 fac100 = fs * fac00(lay)
5281 fac110 = fs * fac10(lay)
5283 fac001 = (1. - fs1) * fac01(lay)
5284 fac011 = (1. - fs1) * fac11(lay)
5285 fac101 = fs1 * fac01(lay)
5286 fac111 = fs1 * fac11(lay)
5288 do ig = 1, ng3
5289 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5290 (selfref(inds+1,ig) - selfref(inds,ig)))
5291 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5292 (forref(indf+1,ig) - forref(indf,ig)))
5293 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
5294 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
5295 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5296 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
5297 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5298 taug(lay,ngs2+ig) = speccomb * &
5299 (fac000 * absa(ind0,ig) + &
5300 fac100 * absa(ind0+1,ig) + &
5301 fac010 * absa(ind0+9,ig) + &
5302 fac110 * absa(ind0+10,ig)) &
5303 + speccomb1 * &
5304 (fac001 * absa(ind1,ig) + &
5305 fac101 * absa(ind1+1,ig) + &
5306 fac011 * absa(ind1+9,ig) + &
5307 fac111 * absa(ind1+10,ig)) &
5308 + tauself + taufor &
5309 + adjcoln2o*absn2o
5310 fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
5311 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5312 enddo
5313 endif
5314 enddo
5316 ! Upper atmosphere loop
5317 do lay = laytrop+1, nlayers
5319 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5320 specparm = colh2o(lay)/speccomb
5321 if (specparm .ge. oneminus) specparm = oneminus
5322 specmult = 4._rb*(specparm)
5323 js = 1 + int(specmult)
5324 fs = mod(specmult,1.0_rb)
5326 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5327 specparm1 = colh2o(lay)/speccomb1
5328 if (specparm1 .ge. oneminus) specparm1 = oneminus
5329 specmult1 = 4._rb*(specparm1)
5330 js1 = 1 + int(specmult1)
5331 fs1 = mod(specmult1,1.0_rb)
5333 fac000 = (1._rb - fs) * fac00(lay)
5334 fac010 = (1._rb - fs) * fac10(lay)
5335 fac100 = fs * fac00(lay)
5336 fac110 = fs * fac10(lay)
5337 fac001 = (1._rb - fs1) * fac01(lay)
5338 fac011 = (1._rb - fs1) * fac11(lay)
5339 fac101 = fs1 * fac01(lay)
5340 fac111 = fs1 * fac11(lay)
5342 speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay)
5343 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5344 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5345 specmult_mn2o = 4._rb*specparm_mn2o
5346 jmn2o = 1 + int(specmult_mn2o)
5347 fmn2o = mod(specmult_mn2o,1.0_rb)
5348 fmn2omf = minorfrac(lay)*fmn2o
5349 ! In atmospheres where the amount of N2O is too great to be considered
5350 ! a minor species, adjust the column amount of N2O by an empirical factor
5351 ! to obtain the proper contribution.
5352 chi_n2o = coln2o(lay)/coldry(lay)
5353 ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1)
5354 if (ratn2o .gt. 1.5_rb) then
5355 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5356 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5357 else
5358 adjcoln2o = coln2o(lay)
5359 endif
5361 speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay)
5362 specparm_planck = colh2o(lay)/speccomb_planck
5363 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5364 specmult_planck = 4._rb*specparm_planck
5365 jpl= 1 + int(specmult_planck)
5366 fpl = mod(specmult_planck,1.0_rb)
5368 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
5369 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1
5370 indf = indfor(lay)
5371 indm = indminor(lay)
5373 do ig = 1, ng3
5374 taufor = forfac(lay) * (forref(indf,ig) + &
5375 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5376 n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * &
5377 (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig))
5378 n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5379 (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig))
5380 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5381 taug(lay,ngs2+ig) = speccomb * &
5382 (fac000 * absb(ind0,ig) + &
5383 fac100 * absb(ind0+1,ig) + &
5384 fac010 * absb(ind0+5,ig) + &
5385 fac110 * absb(ind0+6,ig)) &
5386 + speccomb1 * &
5387 (fac001 * absb(ind1,ig) + &
5388 fac101 * absb(ind1+1,ig) + &
5389 fac011 * absb(ind1+5,ig) + &
5390 fac111 * absb(ind1+6,ig)) &
5391 + taufor &
5392 + adjcoln2o*absn2o
5393 fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * &
5394 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5395 enddo
5396 enddo
5398 end subroutine taugb3
5400 !----------------------------------------------------------------------------
5401 subroutine taugb4
5402 !----------------------------------------------------------------------------
5403 !
5404 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
5405 !----------------------------------------------------------------------------
5407 ! ------- Modules -------
5409 use parrrtm, only : ng4, ngs3
5410 use rrlw_ref, only : chi_mls
5411 use rrlw_kg04, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5412 selfref, forref
5414 ! ------- Declarations -------
5416 ! Local
5417 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5418 integer(kind=im) :: js, js1, jpl
5419 real(kind=rb) :: speccomb, specparm, specmult, fs
5420 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5421 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5422 real(kind=rb) :: p, p4, fk0, fk1, fk2
5423 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5424 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5425 real(kind=rb) :: tauself, taufor
5426 real(kind=rb) :: refrat_planck_a, refrat_planck_b
5429 ! P = 142.5940 mb
5430 refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
5432 ! P = 95.58350 mb
5433 refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
5435 ! Compute the optical depth by interpolating in ln(pressure) and
5436 ! temperature, and appropriate species. Below laytrop, the water
5437 ! vapor self-continuum and foreign continuum is interpolated (in temperature)
5438 ! separately.
5440 ! Lower atmosphere loop
5441 do lay = 1, laytrop
5443 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5444 specparm = colh2o(lay)/speccomb
5445 if (specparm .ge. oneminus) specparm = oneminus
5446 specmult = 8._rb*(specparm)
5447 js = 1 + int(specmult)
5448 fs = mod(specmult,1.0_rb)
5450 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5451 specparm1 = colh2o(lay)/speccomb1
5452 if (specparm1 .ge. oneminus) specparm1 = oneminus
5453 specmult1 = 8._rb*(specparm1)
5454 js1 = 1 + int(specmult1)
5455 fs1 = mod(specmult1,1.0_rb)
5457 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5458 specparm_planck = colh2o(lay)/speccomb_planck
5459 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5460 specmult_planck = 8._rb*specparm_planck
5461 jpl= 1 + int(specmult_planck)
5462 fpl = mod(specmult_planck,1.0_rb)
5464 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js
5465 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1
5466 inds = indself(lay)
5467 indf = indfor(lay)
5469 if (specparm .lt. 0.125 .and. specparm1 .lt. 0.125) then
5470 p = fs - 1
5471 p4 = p**4
5472 fk0 = p4
5473 fk1 = 1 - p - 2.0_rb*p4
5474 fk2 = p + p4
5475 fac000 = fk0*fac00(lay)
5476 fac100 = fk1*fac00(lay)
5477 fac200 = fk2*fac00(lay)
5478 fac010 = fk0*fac10(lay)
5479 fac110 = fk1*fac10(lay)
5480 fac210 = fk2*fac10(lay)
5482 p = fs1 - 1
5483 p4 = p**4
5484 fk0 = p4
5485 fk1 = 1 - p - 2.0_rb*p4
5486 fk2 = p + p4
5487 fac001 = fk0*fac01(lay)
5488 fac101 = fk1*fac01(lay)
5489 fac201 = fk2*fac01(lay)
5490 fac011 = fk0*fac11(lay)
5491 fac111 = fk1*fac11(lay)
5492 fac211 = fk2*fac11(lay)
5494 do ig = 1, ng4
5495 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5496 (selfref(inds+1,ig) - selfref(inds,ig)))
5497 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5498 (forref(indf+1,ig) - forref(indf,ig)))
5499 taug(lay,ngs3+ig) = speccomb * &
5500 (fac000 * absa(ind0,ig) + &
5501 fac100 * absa(ind0+1,ig) + &
5502 fac200 * absa(ind0+2,ig) + &
5503 fac010 * absa(ind0+9,ig) + &
5504 fac110 * absa(ind0+10,ig) + &
5505 fac210 * absa(ind0+11,ig)) &
5506 + speccomb1 * &
5507 (fac001 * absa(ind1,ig) + &
5508 fac101 * absa(ind1+1,ig) + &
5509 fac201 * absa(ind1+2,ig) + &
5510 fac011 * absa(ind1+9,ig) + &
5511 fac111 * absa(ind1+10,ig) + &
5512 fac211 * absa(ind1+11,ig)) &
5513 + tauself + taufor
5514 fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
5515 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5516 enddo
5517 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
5518 p = -fs
5519 p4 = p**4
5520 fk0 = p4
5521 fk1 = 1 - p - 2.0_rb*p4
5522 fk2 = p + p4
5523 fac000 = fk0*fac00(lay)
5524 fac100 = fk1*fac00(lay)
5525 fac200 = fk2*fac00(lay)
5526 fac010 = fk0*fac10(lay)
5527 fac110 = fk1*fac10(lay)
5528 fac210 = fk2*fac10(lay)
5530 p = -fs1
5531 p4 = p**4
5532 fk0 = p4
5533 fk1 = 1 - p - 2.0_rb*p4
5534 fk2 = p + p4
5535 fac001 = fk0*fac01(lay)
5536 fac101 = fk1*fac01(lay)
5537 fac201 = fk2*fac01(lay)
5538 fac011 = fk0*fac11(lay)
5539 fac111 = fk1*fac11(lay)
5540 fac211 = fk2*fac11(lay)
5541 do ig = 1, ng4
5542 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5543 (selfref(inds+1,ig) - selfref(inds,ig)))
5544 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5545 (forref(indf+1,ig) - forref(indf,ig)))
5546 taug(lay,ngs3+ig) = speccomb * &
5547 (fac200 * absa(ind0-1,ig) + &
5548 fac100 * absa(ind0,ig) + &
5549 fac000 * absa(ind0+1,ig) + &
5550 fac210 * absa(ind0+8,ig) + &
5551 fac110 * absa(ind0+9,ig) + &
5552 fac010 * absa(ind0+10,ig)) &
5553 + speccomb1 * &
5554 (fac201 * absa(ind1-1,ig) + &
5555 fac101 * absa(ind1,ig) + &
5556 fac001 * absa(ind1+1,ig) + &
5557 fac211 * absa(ind1+8,ig) + &
5558 fac111 * absa(ind1+9,ig) + &
5559 fac011 * absa(ind1+10,ig)) &
5560 + tauself + taufor
5561 fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
5562 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5563 enddo
5564 else
5565 fac000 = (1._rb - fs) * fac00(lay)
5566 fac010 = (1._rb - fs) * fac10(lay)
5567 fac100 = fs * fac00(lay)
5568 fac110 = fs * fac10(lay)
5570 fac001 = (1._rb - fs1) * fac01(lay)
5571 fac011 = (1._rb - fs1) * fac11(lay)
5572 fac101 = fs1 * fac01(lay)
5573 fac111 = fs1 * fac11(lay)
5575 do ig = 1, ng4
5576 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5577 (selfref(inds+1,ig) - selfref(inds,ig)))
5578 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5579 (forref(indf+1,ig) - forref(indf,ig)))
5580 taug(lay,ngs3+ig) = speccomb * &
5581 (fac000 * absa(ind0,ig) + &
5582 fac100 * absa(ind0+1,ig) + &
5583 fac010 * absa(ind0+9,ig) + &
5584 fac110 * absa(ind0+10,ig)) &
5585 + speccomb1 * &
5586 (fac001 * absa(ind1,ig) + &
5587 fac101 * absa(ind1+1,ig) + &
5588 fac011 * absa(ind1+9,ig) + &
5589 fac111 * absa(ind1+10,ig)) &
5590 + tauself + taufor
5591 fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
5592 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5593 enddo
5594 endif
5595 enddo
5597 ! Upper atmosphere loop
5598 do lay = laytrop+1, nlayers
5600 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
5601 specparm = colo3(lay)/speccomb
5602 if (specparm .ge. oneminus) specparm = oneminus
5603 specmult = 4._rb*(specparm)
5604 js = 1 + int(specmult)
5605 fs = mod(specmult,1.0_rb)
5607 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
5608 specparm1 = colo3(lay)/speccomb1
5609 if (specparm1 .ge. oneminus) specparm1 = oneminus
5610 specmult1 = 4._rb*(specparm1)
5611 js1 = 1 + int(specmult1)
5612 fs1 = mod(specmult1,1.0_rb)
5614 fac000 = (1._rb - fs) * fac00(lay)
5615 fac010 = (1._rb - fs) * fac10(lay)
5616 fac100 = fs * fac00(lay)
5617 fac110 = fs * fac10(lay)
5618 fac001 = (1._rb - fs1) * fac01(lay)
5619 fac011 = (1._rb - fs1) * fac11(lay)
5620 fac101 = fs1 * fac01(lay)
5621 fac111 = fs1 * fac11(lay)
5623 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5624 specparm_planck = colo3(lay)/speccomb_planck
5625 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5626 specmult_planck = 4._rb*specparm_planck
5627 jpl= 1 + int(specmult_planck)
5628 fpl = mod(specmult_planck,1.0_rb)
5630 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js
5631 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1
5633 do ig = 1, ng4
5634 taug(lay,ngs3+ig) = speccomb * &
5635 (fac000 * absb(ind0,ig) + &
5636 fac100 * absb(ind0+1,ig) + &
5637 fac010 * absb(ind0+5,ig) + &
5638 fac110 * absb(ind0+6,ig)) &
5639 + speccomb1 * &
5640 (fac001 * absb(ind1,ig) + &
5641 fac101 * absb(ind1+1,ig) + &
5642 fac011 * absb(ind1+5,ig) + &
5643 fac111 * absb(ind1+6,ig))
5644 fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * &
5645 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5646 enddo
5648 ! Empirical modification to code to improve stratospheric cooling rates
5649 ! for co2. Revised to apply weighting for g-point reduction in this band.
5651 taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92
5652 taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88
5653 taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07
5654 taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1
5655 taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99
5656 taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88
5657 taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943
5659 enddo
5661 end subroutine taugb4
5663 !----------------------------------------------------------------------------
5664 subroutine taugb5
5665 !----------------------------------------------------------------------------
5666 !
5667 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
5668 ! (high key - o3,co2)
5669 !----------------------------------------------------------------------------
5671 ! ------- Modules -------
5673 use parrrtm, only : ng5, ngs4
5674 use rrlw_ref, only : chi_mls
5675 use rrlw_kg05, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5676 ka_mo3, selfref, forref, ccl4
5678 ! ------- Declarations -------
5680 ! Local
5681 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5682 integer(kind=im) :: js, js1, jmo3, jpl
5683 real(kind=rb) :: speccomb, specparm, specmult, fs
5684 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5685 real(kind=rb) :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
5686 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5687 real(kind=rb) :: p, p4, fk0, fk1, fk2
5688 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5689 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5690 real(kind=rb) :: tauself, taufor, o3m1, o3m2, abso3
5691 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a
5694 ! Minor gas mapping level :
5695 ! lower - o3, p = 317.34 mbar, t = 240.77 k
5696 ! lower - ccl4
5698 ! Calculate reference ratio to be used in calculation of Planck
5699 ! fraction in lower/upper atmosphere.
5701 ! P = 473.420 mb
5702 refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
5704 ! P = 0.2369 mb
5705 refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
5707 ! P = 317.3480
5708 refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
5710 ! Compute the optical depth by interpolating in ln(pressure) and
5711 ! temperature, and appropriate species. Below laytrop, the
5712 ! water vapor self-continuum and foreign continuum is
5713 ! interpolated (in temperature) separately.
5715 ! Lower atmosphere loop
5716 do lay = 1, laytrop
5718 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5719 specparm = colh2o(lay)/speccomb
5720 if (specparm .ge. oneminus) specparm = oneminus
5721 specmult = 8._rb*(specparm)
5722 js = 1 + int(specmult)
5723 fs = mod(specmult,1.0_rb)
5725 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5726 specparm1 = colh2o(lay)/speccomb1
5727 if (specparm1 .ge. oneminus) specparm1 = oneminus
5728 specmult1 = 8._rb*(specparm1)
5729 js1 = 1 + int(specmult1)
5730 fs1 = mod(specmult1,1.0_rb)
5732 speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay)
5733 specparm_mo3 = colh2o(lay)/speccomb_mo3
5734 if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus
5735 specmult_mo3 = 8._rb*specparm_mo3
5736 jmo3 = 1 + int(specmult_mo3)
5737 fmo3 = mod(specmult_mo3,1.0_rb)
5739 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5740 specparm_planck = colh2o(lay)/speccomb_planck
5741 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5742 specmult_planck = 8._rb*specparm_planck
5743 jpl= 1 + int(specmult_planck)
5744 fpl = mod(specmult_planck,1.0_rb)
5746 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js
5747 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1
5748 inds = indself(lay)
5749 indf = indfor(lay)
5750 indm = indminor(lay)
5752 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
5753 p = fs - 1
5754 p4 = p**4
5755 fk0 = p4
5756 fk1 = 1 - p - 2.0_rb*p4
5757 fk2 = p + p4
5758 fac000 = fk0*fac00(lay)
5759 fac100 = fk1*fac00(lay)
5760 fac200 = fk2*fac00(lay)
5761 fac010 = fk0*fac10(lay)
5762 fac110 = fk1*fac10(lay)
5763 fac210 = fk2*fac10(lay)
5765 p = fs1 - 1
5766 p4 = p**4
5767 fk0 = p4
5768 fk1 = 1 - p - 2.0_rb*p4
5769 fk2 = p + p4
5770 fac001 = fk0*fac01(lay)
5771 fac101 = fk1*fac01(lay)
5772 fac201 = fk2*fac01(lay)
5773 fac011 = fk0*fac11(lay)
5774 fac111 = fk1*fac11(lay)
5775 fac211 = fk2*fac11(lay)
5777 do ig = 1, ng5
5778 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5779 (selfref(inds+1,ig) - selfref(inds,ig)))
5780 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5781 (forref(indf+1,ig) - forref(indf,ig)))
5782 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
5783 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
5784 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
5785 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
5786 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
5787 taug(lay,ngs4+ig) = speccomb * &
5788 (fac000 * absa(ind0,ig) + &
5789 fac100 * absa(ind0+1,ig) + &
5790 fac200 * absa(ind0+2,ig) + &
5791 fac010 * absa(ind0+9,ig) + &
5792 fac110 * absa(ind0+10,ig) + &
5793 fac210 * absa(ind0+11,ig)) &
5794 + speccomb1 * &
5795 (fac001 * absa(ind1,ig) + &
5796 fac101 * absa(ind1+1,ig) + &
5797 fac201 * absa(ind1+2,ig) + &
5798 fac011 * absa(ind1+9,ig) + &
5799 fac111 * absa(ind1+10,ig) + &
5800 fac211 * absa(ind1+11,ig)) &
5801 + tauself + taufor &
5802 + abso3*colo3(lay) &
5803 + wx(1,lay) * ccl4(ig)
5804 fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
5805 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5806 enddo
5807 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
5808 p = -fs
5809 p4 = p**4
5810 fk0 = p4
5811 fk1 = 1 - p - 2.0_rb*p4
5812 fk2 = p + p4
5813 fac000 = fk0*fac00(lay)
5814 fac100 = fk1*fac00(lay)
5815 fac200 = fk2*fac00(lay)
5816 fac010 = fk0*fac10(lay)
5817 fac110 = fk1*fac10(lay)
5818 fac210 = fk2*fac10(lay)
5820 p = -fs1
5821 p4 = p**4
5822 fk0 = p4
5823 fk1 = 1 - p - 2.0_rb*p4
5824 fk2 = p + p4
5825 fac001 = fk0*fac01(lay)
5826 fac101 = fk1*fac01(lay)
5827 fac201 = fk2*fac01(lay)
5828 fac011 = fk0*fac11(lay)
5829 fac111 = fk1*fac11(lay)
5830 fac211 = fk2*fac11(lay)
5832 do ig = 1, ng5
5833 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5834 (selfref(inds+1,ig) - selfref(inds,ig)))
5835 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5836 (forref(indf+1,ig) - forref(indf,ig)))
5837 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
5838 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
5839 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
5840 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
5841 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
5842 taug(lay,ngs4+ig) = speccomb * &
5843 (fac200 * absa(ind0-1,ig) + &
5844 fac100 * absa(ind0,ig) + &
5845 fac000 * absa(ind0+1,ig) + &
5846 fac210 * absa(ind0+8,ig) + &
5847 fac110 * absa(ind0+9,ig) + &
5848 fac010 * absa(ind0+10,ig)) &
5849 + speccomb1 * &
5850 (fac201 * absa(ind1-1,ig) + &
5851 fac101 * absa(ind1,ig) + &
5852 fac001 * absa(ind1+1,ig) + &
5853 fac211 * absa(ind1+8,ig) + &
5854 fac111 * absa(ind1+9,ig) + &
5855 fac011 * absa(ind1+10,ig)) &
5856 + tauself+ taufor &
5857 + abso3*colo3(lay) &
5858 + wx(1,lay) * ccl4(ig)
5859 fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
5860 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5861 enddo
5862 else
5863 fac000 = (1._rb - fs) * fac00(lay)
5864 fac010 = (1._rb - fs) * fac10(lay)
5865 fac100 = fs * fac00(lay)
5866 fac110 = fs * fac10(lay)
5868 fac001 = (1._rb - fs1) * fac01(lay)
5869 fac011 = (1._rb - fs1) * fac11(lay)
5870 fac101 = fs1 * fac01(lay)
5871 fac111 = fs1 * fac11(lay)
5873 do ig = 1, ng5
5874 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5875 (selfref(inds+1,ig) - selfref(inds,ig)))
5876 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5877 (forref(indf+1,ig) - forref(indf,ig)))
5878 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
5879 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
5880 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
5881 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
5882 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
5883 taug(lay,ngs4+ig) = speccomb * &
5884 (fac000 * absa(ind0,ig) + &
5885 fac100 * absa(ind0+1,ig) + &
5886 fac010 * absa(ind0+9,ig) + &
5887 fac110 * absa(ind0+10,ig)) &
5888 + speccomb1 * &
5889 (fac001 * absa(ind1,ig) + &
5890 fac101 * absa(ind1+1,ig) + &
5891 fac011 * absa(ind1+9,ig) + &
5892 fac111 * absa(ind1+10,ig)) &
5893 + tauself + taufor &
5894 + abso3*colo3(lay) &
5895 + wx(1,lay) * ccl4(ig)
5896 fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
5897 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5898 enddo
5899 endif
5900 enddo
5902 ! Upper atmosphere loop
5903 do lay = laytrop+1, nlayers
5905 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
5906 specparm = colo3(lay)/speccomb
5907 if (specparm .ge. oneminus) specparm = oneminus
5908 specmult = 4._rb*(specparm)
5909 js = 1 + int(specmult)
5910 fs = mod(specmult,1.0_rb)
5912 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
5913 specparm1 = colo3(lay)/speccomb1
5914 if (specparm1 .ge. oneminus) specparm1 = oneminus
5915 specmult1 = 4._rb*(specparm1)
5916 js1 = 1 + int(specmult1)
5917 fs1 = mod(specmult1,1.0_rb)
5919 fac000 = (1._rb - fs) * fac00(lay)
5920 fac010 = (1._rb - fs) * fac10(lay)
5921 fac100 = fs * fac00(lay)
5922 fac110 = fs * fac10(lay)
5923 fac001 = (1._rb - fs1) * fac01(lay)
5924 fac011 = (1._rb - fs1) * fac11(lay)
5925 fac101 = fs1 * fac01(lay)
5926 fac111 = fs1 * fac11(lay)
5928 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5929 specparm_planck = colo3(lay)/speccomb_planck
5930 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5931 specmult_planck = 4._rb*specparm_planck
5932 jpl= 1 + int(specmult_planck)
5933 fpl = mod(specmult_planck,1.0_rb)
5935 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js
5936 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1
5938 do ig = 1, ng5
5939 taug(lay,ngs4+ig) = speccomb * &
5940 (fac000 * absb(ind0,ig) + &
5941 fac100 * absb(ind0+1,ig) + &
5942 fac010 * absb(ind0+5,ig) + &
5943 fac110 * absb(ind0+6,ig)) &
5944 + speccomb1 * &
5945 (fac001 * absb(ind1,ig) + &
5946 fac101 * absb(ind1+1,ig) + &
5947 fac011 * absb(ind1+5,ig) + &
5948 fac111 * absb(ind1+6,ig)) &
5949 + wx(1,lay) * ccl4(ig)
5950 fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * &
5951 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5952 enddo
5953 enddo
5955 end subroutine taugb5
5957 !----------------------------------------------------------------------------
5958 subroutine taugb6
5959 !----------------------------------------------------------------------------
5960 !
5961 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
5962 ! (high key - nothing; high minor - cfc11, cfc12)
5963 !----------------------------------------------------------------------------
5965 ! ------- Modules -------
5967 use parrrtm, only : ng6, ngs5
5968 use rrlw_ref, only : chi_mls
5969 use rrlw_kg06, only : fracrefa, absa, ka, ka_mco2, &
5970 selfref, forref, cfc11adj, cfc12
5972 ! ------- Declarations -------
5974 ! Local
5975 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5976 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
5977 real(kind=rb) :: tauself, taufor, absco2
5980 ! Minor gas mapping level:
5981 ! lower - co2, p = 706.2720 mb, t = 294.2 k
5982 ! upper - cfc11, cfc12
5984 ! Compute the optical depth by interpolating in ln(pressure) and
5985 ! temperature. The water vapor self-continuum and foreign continuum
5986 ! is interpolated (in temperature) separately.
5988 ! Lower atmosphere loop
5989 do lay = 1, laytrop
5991 ! In atmospheres where the amount of CO2 is too great to be considered
5992 ! a minor species, adjust the column amount of CO2 by an empirical factor
5993 ! to obtain the proper contribution.
5994 chi_co2 = colco2(lay)/(coldry(lay))
5995 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
5996 if (ratco2 .gt. 3.0_rb) then
5997 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb
5998 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
5999 else
6000 adjcolco2 = colco2(lay)
6001 endif
6003 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1
6004 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1
6005 inds = indself(lay)
6006 indf = indfor(lay)
6007 indm = indminor(lay)
6009 do ig = 1, ng6
6010 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6011 (selfref(inds+1,ig) - selfref(inds,ig)))
6012 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6013 (forref(indf+1,ig) - forref(indf,ig)))
6014 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
6015 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6016 taug(lay,ngs5+ig) = colh2o(lay) * &
6017 (fac00(lay) * absa(ind0,ig) + &
6018 fac10(lay) * absa(ind0+1,ig) + &
6019 fac01(lay) * absa(ind1,ig) + &
6020 fac11(lay) * absa(ind1+1,ig)) &
6021 + tauself + taufor &
6022 + adjcolco2 * absco2 &
6023 + wx(2,lay) * cfc11adj(ig) &
6024 + wx(3,lay) * cfc12(ig)
6025 fracs(lay,ngs5+ig) = fracrefa(ig)
6026 enddo
6027 enddo
6029 ! Upper atmosphere loop
6030 ! Nothing important goes on above laytrop in this band.
6031 do lay = laytrop+1, nlayers
6033 do ig = 1, ng6
6034 taug(lay,ngs5+ig) = 0.0_rb &
6035 + wx(2,lay) * cfc11adj(ig) &
6036 + wx(3,lay) * cfc12(ig)
6037 fracs(lay,ngs5+ig) = fracrefa(ig)
6038 enddo
6039 enddo
6041 end subroutine taugb6
6043 !----------------------------------------------------------------------------
6044 subroutine taugb7
6045 !----------------------------------------------------------------------------
6046 !
6047 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
6048 ! (high key - o3; high minor - co2)
6049 !----------------------------------------------------------------------------
6051 ! ------- Modules -------
6053 use parrrtm, only : ng7, ngs6
6054 use rrlw_ref, only : chi_mls
6055 use rrlw_kg07, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6056 ka_mco2, kb_mco2, selfref, forref
6058 ! ------- Declarations -------
6060 ! Local
6061 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6062 integer(kind=im) :: js, js1, jmco2, jpl
6063 real(kind=rb) :: speccomb, specparm, specmult, fs
6064 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6065 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
6066 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6067 real(kind=rb) :: p, p4, fk0, fk1, fk2
6068 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6069 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6070 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
6071 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6072 real(kind=rb) :: refrat_planck_a, refrat_m_a
6075 ! Minor gas mapping level :
6076 ! lower - co2, p = 706.2620 mbar, t= 278.94 k
6077 ! upper - co2, p = 12.9350 mbar, t = 234.01 k
6079 ! Calculate reference ratio to be used in calculation of Planck
6080 ! fraction in lower atmosphere.
6082 ! P = 706.2620 mb
6083 refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
6085 ! P = 706.2720 mb
6086 refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
6088 ! Compute the optical depth by interpolating in ln(pressure),
6089 ! temperature, and appropriate species. Below laytrop, the water
6090 ! vapor self-continuum and foreign continuum is interpolated
6091 ! (in temperature) separately.
6093 ! Lower atmosphere loop
6094 do lay = 1, laytrop
6096 speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay)
6097 specparm = colh2o(lay)/speccomb
6098 if (specparm .ge. oneminus) specparm = oneminus
6099 specmult = 8._rb*(specparm)
6100 js = 1 + int(specmult)
6101 fs = mod(specmult,1.0_rb)
6103 speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay)
6104 specparm1 = colh2o(lay)/speccomb1
6105 if (specparm1 .ge. oneminus) specparm1 = oneminus
6106 specmult1 = 8._rb*(specparm1)
6107 js1 = 1 + int(specmult1)
6108 fs1 = mod(specmult1,1.0_rb)
6110 speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay)
6111 specparm_mco2 = colh2o(lay)/speccomb_mco2
6112 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
6113 specmult_mco2 = 8._rb*specparm_mco2
6115 jmco2 = 1 + int(specmult_mco2)
6116 fmco2 = mod(specmult_mco2,1.0_rb)
6118 ! In atmospheres where the amount of CO2 is too great to be considered
6119 ! a minor species, adjust the column amount of CO2 by an empirical factor
6120 ! to obtain the proper contribution.
6121 chi_co2 = colco2(lay)/(coldry(lay))
6122 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6123 if (ratco2 .gt. 3.0_rb) then
6124 adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb
6125 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6126 else
6127 adjcolco2 = colco2(lay)
6128 endif
6130 speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay)
6131 specparm_planck = colh2o(lay)/speccomb_planck
6132 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6133 specmult_planck = 8._rb*specparm_planck
6134 jpl= 1 + int(specmult_planck)
6135 fpl = mod(specmult_planck,1.0_rb)
6137 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js
6138 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1
6139 inds = indself(lay)
6140 indf = indfor(lay)
6141 indm = indminor(lay)
6143 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
6144 p = fs - 1
6145 p4 = p**4
6146 fk0 = p4
6147 fk1 = 1 - p - 2.0_rb*p4
6148 fk2 = p + p4
6149 fac000 = fk0*fac00(lay)
6150 fac100 = fk1*fac00(lay)
6151 fac200 = fk2*fac00(lay)
6152 fac010 = fk0*fac10(lay)
6153 fac110 = fk1*fac10(lay)
6154 fac210 = fk2*fac10(lay)
6156 p = fs1 - 1
6157 p4 = p**4
6158 fk0 = p4
6159 fk1 = 1 - p - 2.0_rb*p4
6160 fk2 = p + p4
6161 fac001 = fk0*fac01(lay)
6162 fac101 = fk1*fac01(lay)
6163 fac201 = fk2*fac01(lay)
6164 fac011 = fk0*fac11(lay)
6165 fac111 = fk1*fac11(lay)
6166 fac211 = fk2*fac11(lay)
6168 do ig = 1, ng7
6169 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6170 (selfref(inds+1,ig) - selfref(inds,ig)))
6171 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6172 (forref(indf+1,ig) - forref(indf,ig)))
6173 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
6174 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6175 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
6176 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6177 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6178 taug(lay,ngs6+ig) = speccomb * &
6179 (fac000 * absa(ind0,ig) + &
6180 fac100 * absa(ind0+1,ig) + &
6181 fac200 * absa(ind0+2,ig) + &
6182 fac010 * absa(ind0+9,ig) + &
6183 fac110 * absa(ind0+10,ig) + &
6184 fac210 * absa(ind0+11,ig)) &
6185 + speccomb1 * &
6186 (fac001 * absa(ind1,ig) + &
6187 fac101 * absa(ind1+1,ig) + &
6188 fac201 * absa(ind1+2,ig) + &
6189 fac011 * absa(ind1+9,ig) + &
6190 fac111 * absa(ind1+10,ig) + &
6191 fac211 * absa(ind1+11,ig)) &
6192 + tauself + taufor &
6193 + adjcolco2*absco2
6194 fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
6195 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6196 enddo
6197 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
6198 p = -fs
6199 p4 = p**4
6200 fk0 = p4
6201 fk1 = 1 - p - 2.0_rb*p4
6202 fk2 = p + p4
6203 fac000 = fk0*fac00(lay)
6204 fac100 = fk1*fac00(lay)
6205 fac200 = fk2*fac00(lay)
6206 fac010 = fk0*fac10(lay)
6207 fac110 = fk1*fac10(lay)
6208 fac210 = fk2*fac10(lay)
6210 p = -fs1
6211 p4 = p**4
6212 fk0 = p4
6213 fk1 = 1 - p - 2.0_rb*p4
6214 fk2 = p + p4
6215 fac001 = fk0*fac01(lay)
6216 fac101 = fk1*fac01(lay)
6217 fac201 = fk2*fac01(lay)
6218 fac011 = fk0*fac11(lay)
6219 fac111 = fk1*fac11(lay)
6220 fac211 = fk2*fac11(lay)
6222 do ig = 1, ng7
6223 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6224 (selfref(inds+1,ig) - selfref(inds,ig)))
6225 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6226 (forref(indf+1,ig) - forref(indf,ig)))
6227 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
6228 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6229 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
6230 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6231 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6232 taug(lay,ngs6+ig) = speccomb * &
6233 (fac200 * absa(ind0-1,ig) + &
6234 fac100 * absa(ind0,ig) + &
6235 fac000 * absa(ind0+1,ig) + &
6236 fac210 * absa(ind0+8,ig) + &
6237 fac110 * absa(ind0+9,ig) + &
6238 fac010 * absa(ind0+10,ig)) &
6239 + speccomb1 * &
6240 (fac201 * absa(ind1-1,ig) + &
6241 fac101 * absa(ind1,ig) + &
6242 fac001 * absa(ind1+1,ig) + &
6243 fac211 * absa(ind1+8,ig) + &
6244 fac111 * absa(ind1+9,ig) + &
6245 fac011 * absa(ind1+10,ig)) &
6246 + tauself + taufor &
6247 + adjcolco2*absco2
6248 fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
6249 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6250 enddo
6251 else
6252 fac000 = (1._rb - fs) * fac00(lay)
6253 fac010 = (1._rb - fs) * fac10(lay)
6254 fac100 = fs * fac00(lay)
6255 fac110 = fs * fac10(lay)
6257 fac001 = (1._rb - fs1) * fac01(lay)
6258 fac011 = (1._rb - fs1) * fac11(lay)
6259 fac101 = fs1 * fac01(lay)
6260 fac111 = fs1 * fac11(lay)
6262 do ig = 1, ng7
6263 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6264 (selfref(inds+1,ig) - selfref(inds,ig)))
6265 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6266 (forref(indf+1,ig) - forref(indf,ig)))
6267 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
6268 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6269 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
6270 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6271 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6272 taug(lay,ngs6+ig) = speccomb * &
6273 (fac000 * absa(ind0,ig) + &
6274 fac100 * absa(ind0+1,ig) + &
6275 fac010 * absa(ind0+9,ig) + &
6276 fac110 * absa(ind0+10,ig)) &
6277 + speccomb1 * &
6278 (fac001 * absa(ind1,ig) + &
6279 fac101 * absa(ind1+1,ig) + &
6280 fac011 * absa(ind1+9,ig) + &
6281 fac111 * absa(ind1+10,ig)) &
6282 + tauself + taufor &
6283 + adjcolco2*absco2
6284 fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
6285 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6286 enddo
6287 endif
6288 enddo
6290 ! Upper atmosphere loop
6291 do lay = laytrop+1, nlayers
6293 ! In atmospheres where the amount of CO2 is too great to be considered
6294 ! a minor species, adjust the column amount of CO2 by an empirical factor
6295 ! to obtain the proper contribution.
6296 chi_co2 = colco2(lay)/(coldry(lay))
6297 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6298 if (ratco2 .gt. 3.0_rb) then
6299 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb
6300 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6301 else
6302 adjcolco2 = colco2(lay)
6303 endif
6305 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1
6306 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1
6307 indm = indminor(lay)
6309 do ig = 1, ng7
6310 absco2 = kb_mco2(indm,ig) + minorfrac(lay) * &
6311 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))
6312 taug(lay,ngs6+ig) = colo3(lay) * &
6313 (fac00(lay) * absb(ind0,ig) + &
6314 fac10(lay) * absb(ind0+1,ig) + &
6315 fac01(lay) * absb(ind1,ig) + &
6316 fac11(lay) * absb(ind1+1,ig)) &
6317 + adjcolco2 * absco2
6318 fracs(lay,ngs6+ig) = fracrefb(ig)
6319 enddo
6321 ! Empirical modification to code to improve stratospheric cooling rates
6322 ! for o3. revised to apply weighting for g-point reduction in this band.
6324 taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_rb
6325 taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_rb
6326 taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_rb
6327 taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_rb
6328 taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_rb
6329 taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_rb
6331 enddo
6333 end subroutine taugb7
6335 !----------------------------------------------------------------------------
6336 subroutine taugb8
6337 !----------------------------------------------------------------------------
6338 !
6339 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
6340 ! (high key - o3; high minor - co2, n2o)
6341 !----------------------------------------------------------------------------
6343 ! ------- Modules -------
6345 use parrrtm, only : ng8, ngs7
6346 use rrlw_ref, only : chi_mls
6347 use rrlw_kg08, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6348 ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o, &
6349 selfref, forref, cfc12, cfc22adj
6351 ! ------- Declarations -------
6353 ! Local
6354 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6355 real(kind=rb) :: tauself, taufor, absco2, abso3, absn2o
6356 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6359 ! Minor gas mapping level:
6360 ! lower - co2, p = 1053.63 mb, t = 294.2 k
6361 ! lower - o3, p = 317.348 mb, t = 240.77 k
6362 ! lower - n2o, p = 706.2720 mb, t= 278.94 k
6363 ! lower - cfc12,cfc11
6364 ! upper - co2, p = 35.1632 mb, t = 223.28 k
6365 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k
6367 ! Compute the optical depth by interpolating in ln(pressure) and
6368 ! temperature, and appropriate species. Below laytrop, the water vapor
6369 ! self-continuum and foreign continuum is interpolated (in temperature)
6370 ! separately.
6372 ! Lower atmosphere loop
6373 do lay = 1, laytrop
6375 ! In atmospheres where the amount of CO2 is too great to be considered
6376 ! a minor species, adjust the column amount of CO2 by an empirical factor
6377 ! to obtain the proper contribution.
6378 chi_co2 = colco2(lay)/(coldry(lay))
6379 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6380 if (ratco2 .gt. 3.0_rb) then
6381 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6382 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6383 else
6384 adjcolco2 = colco2(lay)
6385 endif
6387 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
6388 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
6389 inds = indself(lay)
6390 indf = indfor(lay)
6391 indm = indminor(lay)
6393 do ig = 1, ng8
6394 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6395 (selfref(inds+1,ig) - selfref(inds,ig)))
6396 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6397 (forref(indf+1,ig) - forref(indf,ig)))
6398 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
6399 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6400 abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * &
6401 (ka_mo3(indm+1,ig) - ka_mo3(indm,ig)))
6402 absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * &
6403 (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig)))
6404 taug(lay,ngs7+ig) = colh2o(lay) * &
6405 (fac00(lay) * absa(ind0,ig) + &
6406 fac10(lay) * absa(ind0+1,ig) + &
6407 fac01(lay) * absa(ind1,ig) + &
6408 fac11(lay) * absa(ind1+1,ig)) &
6409 + tauself + taufor &
6410 + adjcolco2*absco2 &
6411 + colo3(lay) * abso3 &
6412 + coln2o(lay) * absn2o &
6413 + wx(3,lay) * cfc12(ig) &
6414 + wx(4,lay) * cfc22adj(ig)
6415 fracs(lay,ngs7+ig) = fracrefa(ig)
6416 enddo
6417 enddo
6419 ! Upper atmosphere loop
6420 do lay = laytrop+1, nlayers
6422 ! In atmospheres where the amount of CO2 is too great to be considered
6423 ! a minor species, adjust the column amount of CO2 by an empirical factor
6424 ! to obtain the proper contribution.
6425 chi_co2 = colco2(lay)/coldry(lay)
6426 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6427 if (ratco2 .gt. 3.0_rb) then
6428 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6429 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb
6430 else
6431 adjcolco2 = colco2(lay)
6432 endif
6434 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1
6435 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1
6436 indm = indminor(lay)
6438 do ig = 1, ng8
6439 absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * &
6440 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)))
6441 absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * &
6442 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)))
6443 taug(lay,ngs7+ig) = colo3(lay) * &
6444 (fac00(lay) * absb(ind0,ig) + &
6445 fac10(lay) * absb(ind0+1,ig) + &
6446 fac01(lay) * absb(ind1,ig) + &
6447 fac11(lay) * absb(ind1+1,ig)) &
6448 + adjcolco2*absco2 &
6449 + coln2o(lay)*absn2o &
6450 + wx(3,lay) * cfc12(ig) &
6451 + wx(4,lay) * cfc22adj(ig)
6452 fracs(lay,ngs7+ig) = fracrefb(ig)
6453 enddo
6454 enddo
6456 end subroutine taugb8
6458 !----------------------------------------------------------------------------
6459 subroutine taugb9
6460 !----------------------------------------------------------------------------
6461 !
6462 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
6463 ! (high key - ch4; high minor - n2o)
6464 !----------------------------------------------------------------------------
6466 ! ------- Modules -------
6468 use parrrtm, only : ng9, ngs8
6469 use rrlw_ref, only : chi_mls
6470 use rrlw_kg09, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6471 ka_mn2o, kb_mn2o, selfref, forref
6473 ! ------- Declarations -------
6475 ! Local
6476 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6477 integer(kind=im) :: js, js1, jmn2o, jpl
6478 real(kind=rb) :: speccomb, specparm, specmult, fs
6479 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6480 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
6481 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6482 real(kind=rb) :: p, p4, fk0, fk1, fk2
6483 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6484 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6485 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
6486 real(kind=rb) :: chi_n2o, ratn2o, adjfac, adjcoln2o
6487 real(kind=rb) :: refrat_planck_a, refrat_m_a
6490 ! Minor gas mapping level :
6491 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
6492 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
6494 ! Calculate reference ratio to be used in calculation of Planck
6495 ! fraction in lower/upper atmosphere.
6497 ! P = 212 mb
6498 refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
6500 ! P = 706.272 mb
6501 refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
6503 ! Compute the optical depth by interpolating in ln(pressure),
6504 ! temperature, and appropriate species. Below laytrop, the water
6505 ! vapor self-continuum and foreign continuum is interpolated
6506 ! (in temperature) separately.
6508 ! Lower atmosphere loop
6509 do lay = 1, laytrop
6511 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
6512 specparm = colh2o(lay)/speccomb
6513 if (specparm .ge. oneminus) specparm = oneminus
6514 specmult = 8._rb*(specparm)
6515 js = 1 + int(specmult)
6516 fs = mod(specmult,1.0_rb)
6518 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
6519 specparm1 = colh2o(lay)/speccomb1
6520 if (specparm1 .ge. oneminus) specparm1 = oneminus
6521 specmult1 = 8._rb*(specparm1)
6522 js1 = 1 + int(specmult1)
6523 fs1 = mod(specmult1,1.0_rb)
6525 speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay)
6526 specparm_mn2o = colh2o(lay)/speccomb_mn2o
6527 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
6528 specmult_mn2o = 8._rb*specparm_mn2o
6529 jmn2o = 1 + int(specmult_mn2o)
6530 fmn2o = mod(specmult_mn2o,1.0_rb)
6532 ! In atmospheres where the amount of N2O is too great to be considered
6533 ! a minor species, adjust the column amount of N2O by an empirical factor
6534 ! to obtain the proper contribution.
6535 chi_n2o = coln2o(lay)/(coldry(lay))
6536 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6537 if (ratn2o .gt. 1.5_rb) then
6538 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6539 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6540 else
6541 adjcoln2o = coln2o(lay)
6542 endif
6544 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
6545 specparm_planck = colh2o(lay)/speccomb_planck
6546 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6547 specmult_planck = 8._rb*specparm_planck
6548 jpl= 1 + int(specmult_planck)
6549 fpl = mod(specmult_planck,1.0_rb)
6551 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js
6552 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1
6553 inds = indself(lay)
6554 indf = indfor(lay)
6555 indm = indminor(lay)
6557 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
6558 p = fs - 1
6559 p4 = p**4
6560 fk0 = p4
6561 fk1 = 1 - p - 2.0_rb*p4
6562 fk2 = p + p4
6563 fac000 = fk0*fac00(lay)
6564 fac100 = fk1*fac00(lay)
6565 fac200 = fk2*fac00(lay)
6566 fac010 = fk0*fac10(lay)
6567 fac110 = fk1*fac10(lay)
6568 fac210 = fk2*fac10(lay)
6570 p = fs1 - 1
6571 p4 = p**4
6572 fk0 = p4
6573 fk1 = 1 - p - 2.0_rb*p4
6574 fk2 = p + p4
6575 fac001 = fk0*fac01(lay)
6576 fac101 = fk1*fac01(lay)
6577 fac201 = fk2*fac01(lay)
6578 fac011 = fk0*fac11(lay)
6579 fac111 = fk1*fac11(lay)
6580 fac211 = fk2*fac11(lay)
6582 do ig = 1, ng9
6583 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6584 (selfref(inds+1,ig) - selfref(inds,ig)))
6585 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6586 (forref(indf+1,ig) - forref(indf,ig)))
6587 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
6588 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6589 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
6590 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6591 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6592 taug(lay,ngs8+ig) = speccomb * &
6593 (fac000 * absa(ind0,ig) + &
6594 fac100 * absa(ind0+1,ig) + &
6595 fac200 * absa(ind0+2,ig) + &
6596 fac010 * absa(ind0+9,ig) + &
6597 fac110 * absa(ind0+10,ig) + &
6598 fac210 * absa(ind0+11,ig)) &
6599 + speccomb1 * &
6600 (fac001 * absa(ind1,ig) + &
6601 fac101 * absa(ind1+1,ig) + &
6602 fac201 * absa(ind1+2,ig) + &
6603 fac011 * absa(ind1+9,ig) + &
6604 fac111 * absa(ind1+10,ig) + &
6605 fac211 * absa(ind1+11,ig)) &
6606 + tauself + taufor &
6607 + adjcoln2o*absn2o
6608 fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
6609 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6610 enddo
6611 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
6612 p = -fs
6613 p4 = p**4
6614 fk0 = p4
6615 fk1 = 1 - p - 2.0_rb*p4
6616 fk2 = p + p4
6617 fac000 = fk0*fac00(lay)
6618 fac100 = fk1*fac00(lay)
6619 fac200 = fk2*fac00(lay)
6620 fac010 = fk0*fac10(lay)
6621 fac110 = fk1*fac10(lay)
6622 fac210 = fk2*fac10(lay)
6624 p = -fs1
6625 p4 = p**4
6626 fk0 = p4
6627 fk1 = 1 - p - 2.0_rb*p4
6628 fk2 = p + p4
6629 fac001 = fk0*fac01(lay)
6630 fac101 = fk1*fac01(lay)
6631 fac201 = fk2*fac01(lay)
6632 fac011 = fk0*fac11(lay)
6633 fac111 = fk1*fac11(lay)
6634 fac211 = fk2*fac11(lay)
6636 do ig = 1, ng9
6637 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6638 (selfref(inds+1,ig) - selfref(inds,ig)))
6639 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6640 (forref(indf+1,ig) - forref(indf,ig)))
6641 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
6642 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6643 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
6644 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6645 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6646 taug(lay,ngs8+ig) = speccomb * &
6647 (fac200 * absa(ind0-1,ig) + &
6648 fac100 * absa(ind0,ig) + &
6649 fac000 * absa(ind0+1,ig) + &
6650 fac210 * absa(ind0+8,ig) + &
6651 fac110 * absa(ind0+9,ig) + &
6652 fac010 * absa(ind0+10,ig)) &
6653 + speccomb1 * &
6654 (fac201 * absa(ind1-1,ig) + &
6655 fac101 * absa(ind1,ig) + &
6656 fac001 * absa(ind1+1,ig) + &
6657 fac211 * absa(ind1+8,ig) + &
6658 fac111 * absa(ind1+9,ig) + &
6659 fac011 * absa(ind1+10,ig)) &
6660 + tauself + taufor &
6661 + adjcoln2o*absn2o
6662 fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
6663 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6664 enddo
6665 else
6666 fac000 = (1._rb - fs) * fac00(lay)
6667 fac010 = (1._rb - fs) * fac10(lay)
6668 fac100 = fs * fac00(lay)
6669 fac110 = fs * fac10(lay)
6671 fac001 = (1._rb - fs1) * fac01(lay)
6672 fac011 = (1._rb - fs1) * fac11(lay)
6673 fac101 = fs1 * fac01(lay)
6674 fac111 = fs1 * fac11(lay)
6676 do ig = 1, ng9
6677 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6678 (selfref(inds+1,ig) - selfref(inds,ig)))
6679 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6680 (forref(indf+1,ig) - forref(indf,ig)))
6681 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
6682 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6683 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
6684 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6685 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6686 taug(lay,ngs8+ig) = speccomb * &
6687 (fac000 * absa(ind0,ig) + &
6688 fac100 * absa(ind0+1,ig) + &
6689 fac010 * absa(ind0+9,ig) + &
6690 fac110 * absa(ind0+10,ig)) &
6691 + speccomb1 * &
6692 (fac001 * absa(ind1,ig) + &
6693 fac101 * absa(ind1+1,ig) + &
6694 fac011 * absa(ind1+9,ig) + &
6695 fac111 * absa(ind1+10,ig)) &
6696 + tauself + taufor &
6697 + adjcoln2o*absn2o
6698 fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
6699 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6700 enddo
6701 endif
6702 enddo
6704 ! Upper atmosphere loop
6705 do lay = laytrop+1, nlayers
6707 ! In atmospheres where the amount of N2O is too great to be considered
6708 ! a minor species, adjust the column amount of N2O by an empirical factor
6709 ! to obtain the proper contribution.
6710 chi_n2o = coln2o(lay)/(coldry(lay))
6711 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6712 if (ratn2o .gt. 1.5_rb) then
6713 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6714 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6715 else
6716 adjcoln2o = coln2o(lay)
6717 endif
6719 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1
6720 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1
6721 indm = indminor(lay)
6723 do ig = 1, ng9
6724 absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * &
6725 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))
6726 taug(lay,ngs8+ig) = colch4(lay) * &
6727 (fac00(lay) * absb(ind0,ig) + &
6728 fac10(lay) * absb(ind0+1,ig) + &
6729 fac01(lay) * absb(ind1,ig) + &
6730 fac11(lay) * absb(ind1+1,ig)) &
6731 + adjcoln2o*absn2o
6732 fracs(lay,ngs8+ig) = fracrefb(ig)
6733 enddo
6734 enddo
6736 end subroutine taugb9
6738 !----------------------------------------------------------------------------
6739 subroutine taugb10
6740 !----------------------------------------------------------------------------
6741 !
6742 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
6743 !----------------------------------------------------------------------------
6745 ! ------- Modules -------
6747 use parrrtm, only : ng10, ngs9
6748 use rrlw_kg10, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6749 selfref, forref
6751 ! ------- Declarations -------
6753 ! Local
6754 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6755 real(kind=rb) :: tauself, taufor
6758 ! Compute the optical depth by interpolating in ln(pressure) and
6759 ! temperature. Below laytrop, the water vapor self-continuum and
6760 ! foreign continuum is interpolated (in temperature) separately.
6762 ! Lower atmosphere loop
6763 do lay = 1, laytrop
6764 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1
6765 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1
6766 inds = indself(lay)
6767 indf = indfor(lay)
6769 do ig = 1, ng10
6770 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6771 (selfref(inds+1,ig) - selfref(inds,ig)))
6772 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6773 (forref(indf+1,ig) - forref(indf,ig)))
6774 taug(lay,ngs9+ig) = colh2o(lay) * &
6775 (fac00(lay) * absa(ind0,ig) + &
6776 fac10(lay) * absa(ind0+1,ig) + &
6777 fac01(lay) * absa(ind1,ig) + &
6778 fac11(lay) * absa(ind1+1,ig)) &
6779 + tauself + taufor
6780 fracs(lay,ngs9+ig) = fracrefa(ig)
6781 enddo
6782 enddo
6784 ! Upper atmosphere loop
6785 do lay = laytrop+1, nlayers
6786 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1
6787 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1
6788 indf = indfor(lay)
6790 do ig = 1, ng10
6791 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6792 (forref(indf+1,ig) - forref(indf,ig)))
6793 taug(lay,ngs9+ig) = colh2o(lay) * &
6794 (fac00(lay) * absb(ind0,ig) + &
6795 fac10(lay) * absb(ind0+1,ig) + &
6796 fac01(lay) * absb(ind1,ig) + &
6797 fac11(lay) * absb(ind1+1,ig)) &
6798 + taufor
6799 fracs(lay,ngs9+ig) = fracrefb(ig)
6800 enddo
6801 enddo
6803 end subroutine taugb10
6805 !----------------------------------------------------------------------------
6806 subroutine taugb11
6807 !----------------------------------------------------------------------------
6808 !
6809 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
6810 ! (high key - h2o; high minor - o2)
6811 !----------------------------------------------------------------------------
6813 ! ------- Modules -------
6815 use parrrtm, only : ng11, ngs10
6816 use rrlw_kg11, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6817 ka_mo2, kb_mo2, selfref, forref
6819 ! ------- Declarations -------
6821 ! Local
6822 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6823 real(kind=rb) :: scaleo2, tauself, taufor, tauo2
6826 ! Minor gas mapping level :
6827 ! lower - o2, p = 706.2720 mbar, t = 278.94 k
6828 ! upper - o2, p = 4.758820 mbarm t = 250.85 k
6830 ! Compute the optical depth by interpolating in ln(pressure) and
6831 ! temperature. Below laytrop, the water vapor self-continuum and
6832 ! foreign continuum is interpolated (in temperature) separately.
6834 ! Lower atmosphere loop
6835 do lay = 1, laytrop
6836 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1
6837 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1
6838 inds = indself(lay)
6839 indf = indfor(lay)
6840 indm = indminor(lay)
6841 scaleo2 = colo2(lay)*scaleminor(lay)
6842 do ig = 1, ng11
6843 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6844 (selfref(inds+1,ig) - selfref(inds,ig)))
6845 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6846 (forref(indf+1,ig) - forref(indf,ig)))
6847 tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * &
6848 (ka_mo2(indm+1,ig) - ka_mo2(indm,ig)))
6849 taug(lay,ngs10+ig) = colh2o(lay) * &
6850 (fac00(lay) * absa(ind0,ig) + &
6851 fac10(lay) * absa(ind0+1,ig) + &
6852 fac01(lay) * absa(ind1,ig) + &
6853 fac11(lay) * absa(ind1+1,ig)) &
6854 + tauself + taufor &
6855 + tauo2
6856 fracs(lay,ngs10+ig) = fracrefa(ig)
6857 enddo
6858 enddo
6860 ! Upper atmosphere loop
6861 do lay = laytrop+1, nlayers
6862 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1
6863 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1
6864 indf = indfor(lay)
6865 indm = indminor(lay)
6866 scaleo2 = colo2(lay)*scaleminor(lay)
6867 do ig = 1, ng11
6868 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6869 (forref(indf+1,ig) - forref(indf,ig)))
6870 tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * &
6871 (kb_mo2(indm+1,ig) - kb_mo2(indm,ig)))
6872 taug(lay,ngs10+ig) = colh2o(lay) * &
6873 (fac00(lay) * absb(ind0,ig) + &
6874 fac10(lay) * absb(ind0+1,ig) + &
6875 fac01(lay) * absb(ind1,ig) + &
6876 fac11(lay) * absb(ind1+1,ig)) &
6877 + taufor &
6878 + tauo2
6879 fracs(lay,ngs10+ig) = fracrefb(ig)
6880 enddo
6881 enddo
6883 end subroutine taugb11
6885 !----------------------------------------------------------------------------
6886 subroutine taugb12
6887 !----------------------------------------------------------------------------
6888 !
6889 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
6890 !----------------------------------------------------------------------------
6892 ! ------- Modules -------
6894 use parrrtm, only : ng12, ngs11
6895 use rrlw_ref, only : chi_mls
6896 use rrlw_kg12, only : fracrefa, absa, ka, &
6897 selfref, forref
6899 ! ------- Declarations -------
6901 ! Local
6902 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6903 integer(kind=im) :: js, js1, jpl
6904 real(kind=rb) :: speccomb, specparm, specmult, fs
6905 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6906 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6907 real(kind=rb) :: p, p4, fk0, fk1, fk2
6908 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6909 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6910 real(kind=rb) :: tauself, taufor
6911 real(kind=rb) :: refrat_planck_a
6914 ! Calculate reference ratio to be used in calculation of Planck
6915 ! fraction in lower/upper atmosphere.
6917 ! P = 174.164 mb
6918 refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
6920 ! Compute the optical depth by interpolating in ln(pressure),
6921 ! temperature, and appropriate species. Below laytrop, the water
6922 ! vapor self-continuum adn foreign continuum is interpolated
6923 ! (in temperature) separately.
6925 ! Lower atmosphere loop
6926 do lay = 1, laytrop
6928 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
6929 specparm = colh2o(lay)/speccomb
6930 if (specparm .ge. oneminus) specparm = oneminus
6931 specmult = 8._rb*(specparm)
6932 js = 1 + int(specmult)
6933 fs = mod(specmult,1.0_rb)
6935 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
6936 specparm1 = colh2o(lay)/speccomb1
6937 if (specparm1 .ge. oneminus) specparm1 = oneminus
6938 specmult1 = 8._rb*(specparm1)
6939 js1 = 1 + int(specmult1)
6940 fs1 = mod(specmult1,1.0_rb)
6942 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
6943 specparm_planck = colh2o(lay)/speccomb_planck
6944 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6945 specmult_planck = 8._rb*specparm_planck
6946 jpl= 1 + int(specmult_planck)
6947 fpl = mod(specmult_planck,1.0_rb)
6949 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js
6950 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1
6951 inds = indself(lay)
6952 indf = indfor(lay)
6954 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
6955 p = fs - 1
6956 p4 = p**4
6957 fk0 = p4
6958 fk1 = 1 - p - 2.0_rb*p4
6959 fk2 = p + p4
6960 fac000 = fk0*fac00(lay)
6961 fac100 = fk1*fac00(lay)
6962 fac200 = fk2*fac00(lay)
6963 fac010 = fk0*fac10(lay)
6964 fac110 = fk1*fac10(lay)
6965 fac210 = fk2*fac10(lay)
6967 p = fs1 - 1
6968 p4 = p**4
6969 fk0 = p4
6970 fk1 = 1 - p - 2.0_rb*p4
6971 fk2 = p + p4
6972 fac001 = fk0*fac01(lay)
6973 fac101 = fk1*fac01(lay)
6974 fac201 = fk2*fac01(lay)
6975 fac011 = fk0*fac11(lay)
6976 fac111 = fk1*fac11(lay)
6977 fac211 = fk2*fac11(lay)
6979 do ig = 1, ng12
6980 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6981 (selfref(inds+1,ig) - selfref(inds,ig)))
6982 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6983 (forref(indf+1,ig) - forref(indf,ig)))
6984 taug(lay,ngs11+ig) = speccomb * &
6985 (fac000 * absa(ind0,ig) + &
6986 fac100 * absa(ind0+1,ig) + &
6987 fac200 * absa(ind0+2,ig) + &
6988 fac010 * absa(ind0+9,ig) + &
6989 fac110 * absa(ind0+10,ig) + &
6990 fac210 * absa(ind0+11,ig)) &
6991 + speccomb1 * &
6992 (fac001 * absa(ind1,ig) + &
6993 fac101 * absa(ind1+1,ig) + &
6994 fac201 * absa(ind1+2,ig) + &
6995 fac011 * absa(ind1+9,ig) + &
6996 fac111 * absa(ind1+10,ig) + &
6997 fac211 * absa(ind1+11,ig)) &
6998 + tauself + taufor
6999 fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
7000 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7001 enddo
7002 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
7003 p = -fs
7004 p4 = p**4
7005 fk0 = p4
7006 fk1 = 1 - p - 2.0_rb*p4
7007 fk2 = p + p4
7008 fac000 = fk0*fac00(lay)
7009 fac100 = fk1*fac00(lay)
7010 fac200 = fk2*fac00(lay)
7011 fac010 = fk0*fac10(lay)
7012 fac110 = fk1*fac10(lay)
7013 fac210 = fk2*fac10(lay)
7015 p = -fs1
7016 p4 = p**4
7017 fk0 = p4
7018 fk1 = 1 - p - 2.0_rb*p4
7019 fk2 = p + p4
7020 fac001 = fk0*fac01(lay)
7021 fac101 = fk1*fac01(lay)
7022 fac201 = fk2*fac01(lay)
7023 fac011 = fk0*fac11(lay)
7024 fac111 = fk1*fac11(lay)
7025 fac211 = fk2*fac11(lay)
7027 do ig = 1, ng12
7028 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7029 (selfref(inds+1,ig) - selfref(inds,ig)))
7030 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7031 (forref(indf+1,ig) - forref(indf,ig)))
7032 taug(lay,ngs11+ig) = speccomb * &
7033 (fac200 * absa(ind0-1,ig) + &
7034 fac100 * absa(ind0,ig) + &
7035 fac000 * absa(ind0+1,ig) + &
7036 fac210 * absa(ind0+8,ig) + &
7037 fac110 * absa(ind0+9,ig) + &
7038 fac010 * absa(ind0+10,ig)) &
7039 + speccomb1 * &
7040 (fac201 * absa(ind1-1,ig) + &
7041 fac101 * absa(ind1,ig) + &
7042 fac001 * absa(ind1+1,ig) + &
7043 fac211 * absa(ind1+8,ig) + &
7044 fac111 * absa(ind1+9,ig) + &
7045 fac011 * absa(ind1+10,ig)) &
7046 + tauself + taufor
7047 fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
7048 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7049 enddo
7050 else
7051 fac000 = (1._rb - fs) * fac00(lay)
7052 fac010 = (1._rb - fs) * fac10(lay)
7053 fac100 = fs * fac00(lay)
7054 fac110 = fs * fac10(lay)
7056 fac001 = (1._rb - fs1) * fac01(lay)
7057 fac011 = (1._rb - fs1) * fac11(lay)
7058 fac101 = fs1 * fac01(lay)
7059 fac111 = fs1 * fac11(lay)
7061 do ig = 1, ng12
7062 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7063 (selfref(inds+1,ig) - selfref(inds,ig)))
7064 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7065 (forref(indf+1,ig) - forref(indf,ig)))
7066 taug(lay,ngs11+ig) = speccomb * &
7067 (fac000 * absa(ind0,ig) + &
7068 fac100 * absa(ind0+1,ig) + &
7069 fac010 * absa(ind0+9,ig) + &
7070 fac110 * absa(ind0+10,ig)) &
7071 + speccomb1 * &
7072 (fac001 * absa(ind1,ig) + &
7073 fac101 * absa(ind1+1,ig) + &
7074 fac011 * absa(ind1+9,ig) + &
7075 fac111 * absa(ind1+10,ig)) &
7076 + tauself + taufor
7077 fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
7078 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7079 enddo
7080 endif
7081 enddo
7083 ! Upper atmosphere loop
7084 do lay = laytrop+1, nlayers
7085 do ig = 1, ng12
7086 taug(lay,ngs11+ig) = 0.0_rb
7087 fracs(lay,ngs11+ig) = 0.0_rb
7088 enddo
7089 enddo
7091 end subroutine taugb12
7093 !----------------------------------------------------------------------------
7094 subroutine taugb13
7095 !----------------------------------------------------------------------------
7096 !
7097 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
7098 !----------------------------------------------------------------------------
7100 ! ------- Modules -------
7102 use parrrtm, only : ng13, ngs12
7103 use rrlw_ref, only : chi_mls
7104 use rrlw_kg13, only : fracrefa, fracrefb, absa, ka, &
7105 ka_mco2, ka_mco, kb_mo3, selfref, forref
7107 ! ------- Declarations -------
7109 ! Local
7110 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7111 integer(kind=im) :: js, js1, jmco2, jmco, jpl
7112 real(kind=rb) :: speccomb, specparm, specmult, fs
7113 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7114 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
7115 real(kind=rb) :: speccomb_mco, specparm_mco, specmult_mco, fmco
7116 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7117 real(kind=rb) :: p, p4, fk0, fk1, fk2
7118 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7119 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7120 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
7121 real(kind=rb) :: com1, com2, absco, abso3
7122 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
7123 real(kind=rb) :: refrat_planck_a, refrat_m_a, refrat_m_a3
7126 ! Minor gas mapping levels :
7127 ! lower - co2, p = 1053.63 mb, t = 294.2 k
7128 ! lower - co, p = 706 mb, t = 278.94 k
7129 ! upper - o3, p = 95.5835 mb, t = 215.7 k
7131 ! Calculate reference ratio to be used in calculation of Planck
7132 ! fraction in lower/upper atmosphere.
7134 ! P = 473.420 mb (Level 5)
7135 refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
7137 ! P = 1053. (Level 1)
7138 refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
7140 ! P = 706. (Level 3)
7141 refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
7143 ! Compute the optical depth by interpolating in ln(pressure),
7144 ! temperature, and appropriate species. Below laytrop, the water
7145 ! vapor self-continuum and foreign continuum is interpolated
7146 ! (in temperature) separately.
7148 ! Lower atmosphere loop
7149 do lay = 1, laytrop
7151 speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay)
7152 specparm = colh2o(lay)/speccomb
7153 if (specparm .ge. oneminus) specparm = oneminus
7154 specmult = 8._rb*(specparm)
7155 js = 1 + int(specmult)
7156 fs = mod(specmult,1.0_rb)
7158 speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay)
7159 specparm1 = colh2o(lay)/speccomb1
7160 if (specparm1 .ge. oneminus) specparm1 = oneminus
7161 specmult1 = 8._rb*(specparm1)
7162 js1 = 1 + int(specmult1)
7163 fs1 = mod(specmult1,1.0_rb)
7165 speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay)
7166 specparm_mco2 = colh2o(lay)/speccomb_mco2
7167 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
7168 specmult_mco2 = 8._rb*specparm_mco2
7169 jmco2 = 1 + int(specmult_mco2)
7170 fmco2 = mod(specmult_mco2,1.0_rb)
7172 ! In atmospheres where the amount of CO2 is too great to be considered
7173 ! a minor species, adjust the column amount of CO2 by an empirical factor
7174 ! to obtain the proper contribution.
7175 chi_co2 = colco2(lay)/(coldry(lay))
7176 ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb
7177 if (ratco2 .gt. 3.0_rb) then
7178 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb
7179 adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb
7180 else
7181 adjcolco2 = colco2(lay)
7182 endif
7184 speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay)
7185 specparm_mco = colh2o(lay)/speccomb_mco
7186 if (specparm_mco .ge. oneminus) specparm_mco = oneminus
7187 specmult_mco = 8._rb*specparm_mco
7188 jmco = 1 + int(specmult_mco)
7189 fmco = mod(specmult_mco,1.0_rb)
7191 speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay)
7192 specparm_planck = colh2o(lay)/speccomb_planck
7193 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7194 specmult_planck = 8._rb*specparm_planck
7195 jpl= 1 + int(specmult_planck)
7196 fpl = mod(specmult_planck,1.0_rb)
7198 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js
7199 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1
7200 inds = indself(lay)
7201 indf = indfor(lay)
7202 indm = indminor(lay)
7204 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
7205 p = fs - 1
7206 p4 = p**4
7207 fk0 = p4
7208 fk1 = 1 - p - 2.0_rb*p4
7209 fk2 = p + p4
7210 fac000 = fk0*fac00(lay)
7211 fac100 = fk1*fac00(lay)
7212 fac200 = fk2*fac00(lay)
7213 fac010 = fk0*fac10(lay)
7214 fac110 = fk1*fac10(lay)
7215 fac210 = fk2*fac10(lay)
7217 p = fs1 - 1
7218 p4 = p**4
7219 fk0 = p4
7220 fk1 = 1 - p - 2.0_rb*p4
7221 fk2 = p + p4
7222 fac001 = fk0*fac01(lay)
7223 fac101 = fk1*fac01(lay)
7224 fac201 = fk2*fac01(lay)
7225 fac011 = fk0*fac11(lay)
7226 fac111 = fk1*fac11(lay)
7227 fac211 = fk2*fac11(lay)
7229 do ig = 1, ng13
7230 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7231 (selfref(inds+1,ig) - selfref(inds,ig)))
7232 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7233 (forref(indf+1,ig) - forref(indf,ig)))
7234 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
7235 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7236 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
7237 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7238 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7239 com1 = ka_mco(jmco,indm,ig) + fmco * &
7240 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7241 com2 = ka_mco(jmco,indm+1,ig) + fmco * &
7242 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7243 absco = com1 + minorfrac(lay) * (com2 - com1)
7244 taug(lay,ngs12+ig) = speccomb * &
7245 (fac000 * absa(ind0,ig) + &
7246 fac100 * absa(ind0+1,ig) + &
7247 fac200 * absa(ind0+2,ig) + &
7248 fac010 * absa(ind0+9,ig) + &
7249 fac110 * absa(ind0+10,ig) + &
7250 fac210 * absa(ind0+11,ig)) + &
7251 speccomb1 * &
7252 (fac001 * absa(ind1,ig) + &
7253 fac101 * absa(ind1+1,ig) + &
7254 fac201 * absa(ind1+2,ig) + &
7255 fac011 * absa(ind1+9,ig) + &
7256 fac111 * absa(ind1+10,ig) + &
7257 fac211 * absa(ind1+11,ig)) &
7258 + tauself + taufor &
7259 + adjcolco2*absco2 &
7260 + colco(lay)*absco
7261 fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
7262 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7263 enddo
7264 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
7265 p = -fs
7266 p4 = p**4
7267 fk0 = p4
7268 fk1 = 1 - p - 2.0_rb*p4
7269 fk2 = p + p4
7270 fac000 = fk0*fac00(lay)
7271 fac100 = fk1*fac00(lay)
7272 fac200 = fk2*fac00(lay)
7273 fac010 = fk0*fac10(lay)
7274 fac110 = fk1*fac10(lay)
7275 fac210 = fk2*fac10(lay)
7277 p = -fs1
7278 p4 = p**4
7279 fk0 = p4
7280 fk1 = 1 - p - 2.0_rb*p4
7281 fk2 = p + p4
7282 fac001 = fk0*fac01(lay)
7283 fac101 = fk1*fac01(lay)
7284 fac201 = fk2*fac01(lay)
7285 fac011 = fk0*fac11(lay)
7286 fac111 = fk1*fac11(lay)
7287 fac211 = fk2*fac11(lay)
7289 do ig = 1, ng13
7290 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7291 (selfref(inds+1,ig) - selfref(inds,ig)))
7292 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7293 (forref(indf+1,ig) - forref(indf,ig)))
7294 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
7295 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7296 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
7297 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7298 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7299 com1 = ka_mco(jmco,indm,ig) + fmco * &
7300 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7301 com2 = ka_mco(jmco,indm+1,ig) + fmco * &
7302 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7303 absco = com1 + minorfrac(lay) * (com2 - com1)
7304 taug(lay,ngs12+ig) = speccomb * &
7305 (fac200 * absa(ind0-1,ig) + &
7306 fac100 * absa(ind0,ig) + &
7307 fac000 * absa(ind0+1,ig) + &
7308 fac210 * absa(ind0+8,ig) + &
7309 fac110 * absa(ind0+9,ig) + &
7310 fac010 * absa(ind0+10,ig)) &
7311 + speccomb1 * &
7312 (fac201 * absa(ind1-1,ig) + &
7313 fac101 * absa(ind1,ig) + &
7314 fac001 * absa(ind1+1,ig) + &
7315 fac211 * absa(ind1+8,ig) + &
7316 fac111 * absa(ind1+9,ig) + &
7317 fac011 * absa(ind1+10,ig)) &
7318 + tauself + taufor &
7319 + adjcolco2*absco2 &
7320 + colco(lay)*absco
7321 fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
7322 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7323 enddo
7324 else
7325 fac000 = (1._rb - fs) * fac00(lay)
7326 fac010 = (1._rb - fs) * fac10(lay)
7327 fac100 = fs * fac00(lay)
7328 fac110 = fs * fac10(lay)
7330 fac001 = (1._rb - fs1) * fac01(lay)
7331 fac011 = (1._rb - fs1) * fac11(lay)
7332 fac101 = fs1 * fac01(lay)
7333 fac111 = fs1 * fac11(lay)
7335 do ig = 1, ng13
7336 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7337 (selfref(inds+1,ig) - selfref(inds,ig)))
7338 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7339 (forref(indf+1,ig) - forref(indf,ig)))
7340 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
7341 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7342 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
7343 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7344 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7345 com1 = ka_mco(jmco,indm,ig) + fmco * &
7346 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7347 com2 = ka_mco(jmco,indm+1,ig) + fmco * &
7348 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7349 absco = com1 + minorfrac(lay) * (com2 - com1)
7350 taug(lay,ngs12+ig) = speccomb * &
7351 (fac000 * absa(ind0,ig) + &
7352 fac100 * absa(ind0+1,ig) + &
7353 fac010 * absa(ind0+9,ig) + &
7354 fac110 * absa(ind0+10,ig)) &
7355 + speccomb1 * &
7356 (fac001 * absa(ind1,ig) + &
7357 fac101 * absa(ind1+1,ig) + &
7358 fac011 * absa(ind1+9,ig) + &
7359 fac111 * absa(ind1+10,ig)) &
7360 + tauself + taufor &
7361 + adjcolco2*absco2 &
7362 + colco(lay)*absco
7363 fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
7364 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7365 enddo
7366 endif
7367 enddo
7369 ! Upper atmosphere loop
7370 do lay = laytrop+1, nlayers
7371 indm = indminor(lay)
7372 do ig = 1, ng13
7373 abso3 = kb_mo3(indm,ig) + minorfrac(lay) * &
7374 (kb_mo3(indm+1,ig) - kb_mo3(indm,ig))
7375 taug(lay,ngs12+ig) = colo3(lay)*abso3
7376 fracs(lay,ngs12+ig) = fracrefb(ig)
7377 enddo
7378 enddo
7380 end subroutine taugb13
7382 !----------------------------------------------------------------------------
7383 subroutine taugb14
7384 !----------------------------------------------------------------------------
7385 !
7386 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
7387 !----------------------------------------------------------------------------
7389 ! ------- Modules -------
7391 use parrrtm, only : ng14, ngs13
7392 use rrlw_kg14, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7393 selfref, forref
7395 ! ------- Declarations -------
7397 ! Local
7398 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7399 real(kind=rb) :: tauself, taufor
7402 ! Compute the optical depth by interpolating in ln(pressure) and
7403 ! temperature. Below laytrop, the water vapor self-continuum
7404 ! and foreign continuum is interpolated (in temperature) separately.
7406 ! Lower atmosphere loop
7407 do lay = 1, laytrop
7408 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1
7409 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1
7410 inds = indself(lay)
7411 indf = indfor(lay)
7412 do ig = 1, ng14
7413 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
7414 (selfref(inds+1,ig) - selfref(inds,ig)))
7415 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7416 (forref(indf+1,ig) - forref(indf,ig)))
7417 taug(lay,ngs13+ig) = colco2(lay) * &
7418 (fac00(lay) * absa(ind0,ig) + &
7419 fac10(lay) * absa(ind0+1,ig) + &
7420 fac01(lay) * absa(ind1,ig) + &
7421 fac11(lay) * absa(ind1+1,ig)) &
7422 + tauself + taufor
7423 fracs(lay,ngs13+ig) = fracrefa(ig)
7424 enddo
7425 enddo
7427 ! Upper atmosphere loop
7428 do lay = laytrop+1, nlayers
7429 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1
7430 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1
7431 do ig = 1, ng14
7432 taug(lay,ngs13+ig) = colco2(lay) * &
7433 (fac00(lay) * absb(ind0,ig) + &
7434 fac10(lay) * absb(ind0+1,ig) + &
7435 fac01(lay) * absb(ind1,ig) + &
7436 fac11(lay) * absb(ind1+1,ig))
7437 fracs(lay,ngs13+ig) = fracrefb(ig)
7438 enddo
7439 enddo
7441 end subroutine taugb14
7443 !----------------------------------------------------------------------------
7444 subroutine taugb15
7445 !----------------------------------------------------------------------------
7446 !
7447 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
7448 ! (high - nothing)
7449 !----------------------------------------------------------------------------
7451 ! ------- Modules -------
7453 use parrrtm, only : ng15, ngs14
7454 use rrlw_ref, only : chi_mls
7455 use rrlw_kg15, only : fracrefa, absa, ka, &
7456 ka_mn2, selfref, forref
7458 ! ------- Declarations -------
7460 ! Local
7461 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7462 integer(kind=im) :: js, js1, jmn2, jpl
7463 real(kind=rb) :: speccomb, specparm, specmult, fs
7464 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7465 real(kind=rb) :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
7466 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7467 real(kind=rb) :: p, p4, fk0, fk1, fk2
7468 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7469 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7470 real(kind=rb) :: scalen2, tauself, taufor, n2m1, n2m2, taun2
7471 real(kind=rb) :: refrat_planck_a, refrat_m_a
7474 ! Minor gas mapping level :
7475 ! Lower - Nitrogen Continuum, P = 1053., T = 294.
7477 ! Calculate reference ratio to be used in calculation of Planck
7478 ! fraction in lower atmosphere.
7479 ! P = 1053. mb (Level 1)
7480 refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
7482 ! P = 1053.
7483 refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
7485 ! Compute the optical depth by interpolating in ln(pressure),
7486 ! temperature, and appropriate species. Below laytrop, the water
7487 ! vapor self-continuum and foreign continuum is interpolated
7488 ! (in temperature) separately.
7490 ! Lower atmosphere loop
7491 do lay = 1, laytrop
7493 speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay)
7494 specparm = coln2o(lay)/speccomb
7495 if (specparm .ge. oneminus) specparm = oneminus
7496 specmult = 8._rb*(specparm)
7497 js = 1 + int(specmult)
7498 fs = mod(specmult,1.0_rb)
7500 speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay)
7501 specparm1 = coln2o(lay)/speccomb1
7502 if (specparm1 .ge. oneminus) specparm1 = oneminus
7503 specmult1 = 8._rb*(specparm1)
7504 js1 = 1 + int(specmult1)
7505 fs1 = mod(specmult1,1.0_rb)
7507 speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay)
7508 specparm_mn2 = coln2o(lay)/speccomb_mn2
7509 if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus
7510 specmult_mn2 = 8._rb*specparm_mn2
7511 jmn2 = 1 + int(specmult_mn2)
7512 fmn2 = mod(specmult_mn2,1.0_rb)
7514 speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay)
7515 specparm_planck = coln2o(lay)/speccomb_planck
7516 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7517 specmult_planck = 8._rb*specparm_planck
7518 jpl= 1 + int(specmult_planck)
7519 fpl = mod(specmult_planck,1.0_rb)
7521 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js
7522 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1
7523 inds = indself(lay)
7524 indf = indfor(lay)
7525 indm = indminor(lay)
7527 scalen2 = colbrd(lay)*scaleminor(lay)
7528 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
7529 p = fs - 1
7530 p4 = p**4
7531 fk0 = p4
7532 fk1 = 1 - p - 2.0_rb*p4
7533 fk2 = p + p4
7534 fac000 = fk0*fac00(lay)
7535 fac100 = fk1*fac00(lay)
7536 fac200 = fk2*fac00(lay)
7537 fac010 = fk0*fac10(lay)
7538 fac110 = fk1*fac10(lay)
7539 fac210 = fk2*fac10(lay)
7541 p = fs1 - 1
7542 p4 = p**4
7543 fk0 = p4
7544 fk1 = 1 - p - 2.0_rb*p4
7545 fk2 = p + p4
7546 fac001 = fk0*fac01(lay)
7547 fac101 = fk1*fac01(lay)
7548 fac201 = fk2*fac01(lay)
7549 fac011 = fk0*fac11(lay)
7550 fac111 = fk1*fac11(lay)
7551 fac211 = fk2*fac11(lay)
7553 do ig = 1, ng15
7554 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7555 (selfref(inds+1,ig) - selfref(inds,ig)))
7556 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7557 (forref(indf+1,ig) - forref(indf,ig)))
7558 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
7559 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7560 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
7561 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7562 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7563 taug(lay,ngs14+ig) = speccomb * &
7564 (fac000 * absa(ind0,ig) + &
7565 fac100 * absa(ind0+1,ig) + &
7566 fac200 * absa(ind0+2,ig) + &
7567 fac010 * absa(ind0+9,ig) + &
7568 fac110 * absa(ind0+10,ig) + &
7569 fac210 * absa(ind0+11,ig)) &
7570 + speccomb1 * &
7571 (fac001 * absa(ind1,ig) + &
7572 fac101 * absa(ind1+1,ig) + &
7573 fac201 * absa(ind1+2,ig) + &
7574 fac011 * absa(ind1+9,ig) + &
7575 fac111 * absa(ind1+10,ig) + &
7576 fac211 * absa(ind1+11,ig)) &
7577 + tauself + taufor &
7578 + taun2
7579 fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
7580 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7581 enddo
7583 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
7584 p = -fs
7585 p4 = p**4
7586 fk0 = p4
7587 fk1 = 1 - p - 2.0_rb*p4
7588 fk2 = p + p4
7589 fac000 = fk0*fac00(lay)
7590 fac100 = fk1*fac00(lay)
7591 fac200 = fk2*fac00(lay)
7592 fac010 = fk0*fac10(lay)
7593 fac110 = fk1*fac10(lay)
7594 fac210 = fk2*fac10(lay)
7596 p = -fs1
7597 p4 = p**4
7598 fk0 = p4
7599 fk1 = 1 - p - 2.0_rb*p4
7600 fk2 = p + p4
7601 fac001 = fk0*fac01(lay)
7602 fac101 = fk1*fac01(lay)
7603 fac201 = fk2*fac01(lay)
7604 fac011 = fk0*fac11(lay)
7605 fac111 = fk1*fac11(lay)
7606 fac211 = fk2*fac11(lay)
7608 do ig = 1, ng15
7609 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7610 (selfref(inds+1,ig) - selfref(inds,ig)))
7611 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7612 (forref(indf+1,ig) - forref(indf,ig)))
7613 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
7614 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7615 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
7616 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7617 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7618 taug(lay,ngs14+ig) = speccomb * &
7619 (fac200 * absa(ind0-1,ig) + &
7620 fac100 * absa(ind0,ig) + &
7621 fac000 * absa(ind0+1,ig) + &
7622 fac210 * absa(ind0+8,ig) + &
7623 fac110 * absa(ind0+9,ig) + &
7624 fac010 * absa(ind0+10,ig)) &
7625 + speccomb1 * &
7626 (fac201 * absa(ind1-1,ig) + &
7627 fac101 * absa(ind1,ig) + &
7628 fac001 * absa(ind1+1,ig) + &
7629 fac211 * absa(ind1+8,ig) + &
7630 fac111 * absa(ind1+9,ig) + &
7631 fac011 * absa(ind1+10,ig)) &
7632 + tauself + taufor &
7633 + taun2
7634 fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
7635 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7636 enddo
7638 else
7639 fac000 = (1._rb - fs) * fac00(lay)
7640 fac010 = (1._rb - fs) * fac10(lay)
7641 fac100 = fs * fac00(lay)
7642 fac110 = fs * fac10(lay)
7644 fac001 = (1._rb - fs1) * fac01(lay)
7645 fac011 = (1._rb - fs1) * fac11(lay)
7646 fac101 = fs1 * fac01(lay)
7647 fac111 = fs1 * fac11(lay)
7649 do ig = 1, ng15
7650 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7651 (selfref(inds+1,ig) - selfref(inds,ig)))
7652 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7653 (forref(indf+1,ig) - forref(indf,ig)))
7654 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
7655 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7656 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
7657 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7658 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7659 taug(lay,ngs14+ig) = speccomb * &
7660 (fac000 * absa(ind0,ig) + &
7661 fac100 * absa(ind0+1,ig) + &
7662 fac010 * absa(ind0+9,ig) + &
7663 fac110 * absa(ind0+10,ig)) &
7664 + speccomb1 * &
7665 (fac001 * absa(ind1,ig) + &
7666 fac101 * absa(ind1+1,ig) + &
7667 fac011 * absa(ind1+9,ig) + &
7668 fac111 * absa(ind1+10,ig)) &
7669 + tauself + taufor &
7670 + taun2
7671 fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
7672 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7673 enddo
7674 endif
7675 enddo
7677 ! Upper atmosphere loop
7678 do lay = laytrop+1, nlayers
7679 do ig = 1, ng15
7680 taug(lay,ngs14+ig) = 0.0_rb
7681 fracs(lay,ngs14+ig) = 0.0_rb
7682 enddo
7683 enddo
7685 end subroutine taugb15
7687 !----------------------------------------------------------------------------
7688 subroutine taugb16
7689 !----------------------------------------------------------------------------
7690 !
7691 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
7692 !----------------------------------------------------------------------------
7694 ! ------- Modules -------
7696 use parrrtm, only : ng16, ngs15
7697 use rrlw_ref, only : chi_mls
7698 use rrlw_kg16, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7699 selfref, forref
7701 ! ------- Declarations -------
7703 ! Local
7704 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7705 integer(kind=im) :: js, js1, jpl
7706 real(kind=rb) :: speccomb, specparm, specmult, fs
7707 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7708 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7709 real(kind=rb) :: p, p4, fk0, fk1, fk2
7710 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7711 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7712 real(kind=rb) :: tauself, taufor
7713 real(kind=rb) :: refrat_planck_a
7716 ! Calculate reference ratio to be used in calculation of Planck
7717 ! fraction in lower atmosphere.
7719 ! P = 387. mb (Level 6)
7720 refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
7722 ! Compute the optical depth by interpolating in ln(pressure),
7723 ! temperature,and appropriate species. Below laytrop, the water
7724 ! vapor self-continuum and foreign continuum is interpolated
7725 ! (in temperature) separately.
7727 ! Lower atmosphere loop
7728 do lay = 1, laytrop
7730 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
7731 specparm = colh2o(lay)/speccomb
7732 if (specparm .ge. oneminus) specparm = oneminus
7733 specmult = 8._rb*(specparm)
7734 js = 1 + int(specmult)
7735 fs = mod(specmult,1.0_rb)
7737 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
7738 specparm1 = colh2o(lay)/speccomb1
7739 if (specparm1 .ge. oneminus) specparm1 = oneminus
7740 specmult1 = 8._rb*(specparm1)
7741 js1 = 1 + int(specmult1)
7742 fs1 = mod(specmult1,1.0_rb)
7744 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
7745 specparm_planck = colh2o(lay)/speccomb_planck
7746 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7747 specmult_planck = 8._rb*specparm_planck
7748 jpl= 1 + int(specmult_planck)
7749 fpl = mod(specmult_planck,1.0_rb)
7751 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
7752 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1
7753 inds = indself(lay)
7754 indf = indfor(lay)
7756 if (specparm .lt. 0.125_rb .and. specparm1 .lt. 0.125_rb) then
7757 p = fs - 1
7758 p4 = p**4
7759 fk0 = p4
7760 fk1 = 1 - p - 2.0_rb*p4
7761 fk2 = p + p4
7762 fac000 = fk0*fac00(lay)
7763 fac100 = fk1*fac00(lay)
7764 fac200 = fk2*fac00(lay)
7765 fac010 = fk0*fac10(lay)
7766 fac110 = fk1*fac10(lay)
7767 fac210 = fk2*fac10(lay)
7769 p = fs1 - 1
7770 p4 = p**4
7771 fk0 = p4
7772 fk1 = 1 - p - 2.0_rb*p4
7773 fk2 = p + p4
7774 fac001 = fk0*fac01(lay)
7775 fac101 = fk1*fac01(lay)
7776 fac201 = fk2*fac01(lay)
7777 fac011 = fk0*fac11(lay)
7778 fac111 = fk1*fac11(lay)
7779 fac211 = fk2*fac11(lay)
7781 do ig = 1, ng16
7782 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7783 (selfref(inds+1,ig) - selfref(inds,ig)))
7784 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7785 (forref(indf+1,ig) - forref(indf,ig)))
7786 taug(lay,ngs15+ig) = speccomb * &
7787 (fac000 * absa(ind0,ig) + &
7788 fac100 * absa(ind0+1,ig) + &
7789 fac200 * absa(ind0+2,ig) + &
7790 fac010 * absa(ind0+9,ig) + &
7791 fac110 * absa(ind0+10,ig) + &
7792 fac210 * absa(ind0+11,ig)) &
7793 + speccomb1 * &
7794 (fac001 * absa(ind1,ig) + &
7795 fac101 * absa(ind1+1,ig) + &
7796 fac201 * absa(ind1+2,ig) + &
7797 fac011 * absa(ind1+9,ig) + &
7798 fac111 * absa(ind1+10,ig) + &
7799 fac211 * absa(ind1+11,ig)) &
7800 + tauself + taufor
7801 fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
7802 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7803 enddo
7804 else if (specparm .gt. 0.875_rb .and. specparm1 .gt. 0.875_rb) then
7805 p = -fs
7806 p4 = p**4
7807 fk0 = p4
7808 fk1 = 1 - p - 2.0_rb*p4
7809 fk2 = p + p4
7810 fac000 = fk0*fac00(lay)
7811 fac100 = fk1*fac00(lay)
7812 fac200 = fk2*fac00(lay)
7813 fac010 = fk0*fac10(lay)
7814 fac110 = fk1*fac10(lay)
7815 fac210 = fk2*fac10(lay)
7817 p = -fs1
7818 p4 = p**4
7819 fk0 = p4
7820 fk1 = 1 - p - 2.0_rb*p4
7821 fk2 = p + p4
7822 fac001 = fk0*fac01(lay)
7823 fac101 = fk1*fac01(lay)
7824 fac201 = fk2*fac01(lay)
7825 fac011 = fk0*fac11(lay)
7826 fac111 = fk1*fac11(lay)
7827 fac211 = fk2*fac11(lay)
7829 do ig = 1, ng16
7830 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7831 (selfref(inds+1,ig) - selfref(inds,ig)))
7832 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7833 (forref(indf+1,ig) - forref(indf,ig)))
7834 taug(lay,ngs15+ig) = speccomb * &
7835 (fac200 * absa(ind0-1,ig) + &
7836 fac100 * absa(ind0,ig) + &
7837 fac000 * absa(ind0+1,ig) + &
7838 fac210 * absa(ind0+8,ig) + &
7839 fac110 * absa(ind0+9,ig) + &
7840 fac010 * absa(ind0+10,ig)) &
7841 + speccomb1 * &
7842 (fac201 * absa(ind1-1,ig) + &
7843 fac101 * absa(ind1,ig) + &
7844 fac001 * absa(ind1+1,ig) + &
7845 fac211 * absa(ind1+8,ig) + &
7846 fac111 * absa(ind1+9,ig) + &
7847 fac011 * absa(ind1+10,ig)) &
7848 + tauself + taufor
7849 fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
7850 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7851 enddo
7852 else
7853 fac000 = (1._rb - fs) * fac00(lay)
7854 fac010 = (1._rb - fs) * fac10(lay)
7855 fac100 = fs * fac00(lay)
7856 fac110 = fs * fac10(lay)
7858 fac001 = (1._rb - fs1) * fac01(lay)
7859 fac011 = (1._rb - fs1) * fac11(lay)
7860 fac101 = fs1 * fac01(lay)
7861 fac111 = fs1 * fac11(lay)
7863 do ig = 1, ng16
7864 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7865 (selfref(inds+1,ig) - selfref(inds,ig)))
7866 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7867 (forref(indf+1,ig) - forref(indf,ig)))
7868 taug(lay,ngs15+ig) = speccomb * &
7869 (fac000 * absa(ind0,ig) + &
7870 fac100 * absa(ind0+1,ig) + &
7871 fac010 * absa(ind0+9,ig) + &
7872 fac110 * absa(ind0+10,ig)) &
7873 + speccomb1 * &
7874 (fac001 * absa(ind1,ig) + &
7875 fac101 * absa(ind1+1,ig) + &
7876 fac011 * absa(ind1+9,ig) + &
7877 fac111 * absa(ind1+10,ig)) &
7878 + tauself + taufor
7879 fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
7880 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7881 enddo
7882 endif
7884 enddo
7886 ! Upper atmosphere loop
7887 do lay = laytrop+1, nlayers
7888 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
7889 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
7890 do ig = 1, ng16
7891 taug(lay,ngs15+ig) = colch4(lay) * &
7892 (fac00(lay) * absb(ind0,ig) + &
7893 fac10(lay) * absb(ind0+1,ig) + &
7894 fac01(lay) * absb(ind1,ig) + &
7895 fac11(lay) * absb(ind1+1,ig))
7896 fracs(lay,ngs15+ig) = fracrefb(ig)
7897 enddo
7898 enddo
7900 end subroutine taugb16
7902 end subroutine taumol
7904 end module rrtmg_lw_taumol
7906 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
7907 ! author: $Author: trn $
7908 ! revision: $Revision: 1.3 $
7909 ! created: $Date: 2009/04/16 19:54:22 $
7910 !
7911 module rrtmg_lw_init
7913 ! --------------------------------------------------------------------------
7914 ! | |
7915 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
7916 ! | This software may be used, copied, or redistributed as long as it is |
7917 ! | not sold and this copyright notice is reproduced on each copy made. |
7918 ! | This model is provided as is without any express or implied warranties. |
7919 ! | (http://www.rtweb.aer.com/) |
7920 ! | |
7921 ! --------------------------------------------------------------------------
7923 ! ------- Modules -------
7924 use parkind, only : im => kind_im, rb => kind_rb
7925 use rrlw_wvn
7926 use rrtmg_lw_setcoef, only: lwatmref, lwavplank
7928 implicit none
7930 contains
7932 ! **************************************************************************
7933 subroutine rrtmg_lw_ini(cpdair)
7934 ! **************************************************************************
7935 !
7936 ! Original version: Michael J. Iacono; July, 1998
7937 ! First revision for GCMs: September, 1998
7938 ! Second revision for RRTM_V3.0: September, 2002
7939 !
7940 ! This subroutine performs calculations necessary for the initialization
7941 ! of the longwave model. Lookup tables are computed for use in the LW
7942 ! radiative transfer, and input absorption coefficient data for each
7943 ! spectral band are reduced from 256 g-point intervals to 140.
7944 ! **************************************************************************
7946 use parrrtm, only : mg, nbndlw, ngptlw
7947 use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
7948 use rrlw_vsn, only: hvrini, hnamini
7950 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
7951 ! at constant pressure at 273 K
7952 ! (J kg-1 K-1)
7954 ! ------- Local -------
7956 integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr
7957 integer(kind=im) :: igcsm, iprsm
7959 real(kind=rb) :: wtsum, wtsm(mg) !
7960 real(kind=rb) :: tfn !
7962 real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table
7964 ! ------- Definitions -------
7965 ! Arrays for 10000-point look-up tables:
7966 ! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
7967 ! EXP_TBL Exponential lookup table for ransmittance
7968 ! TFN_TBL Tau transition function; i.e. the transition of the Planck
7969 ! function from that for the mean layer temperature to that for
7970 ! the layer boundary temperature as a function of optical depth.
7971 ! The "linear in tau" method is used to make the table.
7972 ! PADE Pade approximation constant (= 0.278)
7973 ! BPADE Inverse of the Pade approximation constant
7974 !
7976 hvrini = '$Revision: 1.3 $'
7978 ! Initialize model data
7979 call lwdatinit(cpdair)
7980 call lwcmbdat ! g-point interval reduction data
7981 call lwcldpr ! cloud optical properties
7982 call lwatmref ! reference MLS profile
7983 call lwavplank ! Planck function
7984 ! Moved to module_ra_rrtmg_lw for WRF
7985 ! call lw_kgb01 ! molecular absorption coefficients
7986 ! call lw_kgb02
7987 ! call lw_kgb03
7988 ! call lw_kgb04
7989 ! call lw_kgb05
7990 ! call lw_kgb06
7991 ! call lw_kgb07
7992 ! call lw_kgb08
7993 ! call lw_kgb09
7994 ! call lw_kgb10
7995 ! call lw_kgb11
7996 ! call lw_kgb12
7997 ! call lw_kgb13
7998 ! call lw_kgb14
7999 ! call lw_kgb15
8000 ! call lw_kgb16
8002 ! Compute lookup tables for transmittance, tau transition function,
8003 ! and clear sky tau (for the cloudy sky radiative transfer). Tau is
8004 ! computed as a function of the tau transition function, transmittance
8005 ! is calculated as a function of tau, and the tau transition function
8006 ! is calculated using the linear in tau formulation at values of tau
8007 ! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables
8008 ! are computed at intervals of 0.001. The inverse of the constant used
8009 ! in the Pade approximation to the tau transition function is set to b.
8011 tau_tbl(0) = 0.0_rb
8012 tau_tbl(ntbl) = 1.e10_rb
8013 exp_tbl(0) = 1.0_rb
8014 exp_tbl(ntbl) = expeps
8015 tfn_tbl(0) = 0.0_rb
8016 tfn_tbl(ntbl) = 1.0_rb
8017 bpade = 1.0_rb / pade
8018 do itr = 1, ntbl-1
8019 tfn = float(itr) / float(ntbl)
8020 tau_tbl(itr) = bpade * tfn / (1._rb - tfn)
8021 exp_tbl(itr) = exp(-tau_tbl(itr))
8022 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
8023 if (tau_tbl(itr) .lt. 0.06_rb) then
8024 tfn_tbl(itr) = tau_tbl(itr)/6._rb
8025 else
8026 tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
8027 endif
8028 enddo
8030 ! Perform g-point reduction from 16 per band (256 total points) to
8031 ! a band dependant number (140 total points) for all absorption
8032 ! coefficient input data and Planck fraction input data.
8033 ! Compute relative weighting for new g-point combinations.
8035 igcsm = 0
8036 do ibnd = 1,nbndlw
8037 iprsm = 0
8038 if (ngc(ibnd).lt.mg) then
8039 do igc = 1,ngc(ibnd)
8040 igcsm = igcsm + 1
8041 wtsum = 0._rb
8042 do ipr = 1, ngn(igcsm)
8043 iprsm = iprsm + 1
8044 wtsum = wtsum + wt(iprsm)
8045 enddo
8046 wtsm(igc) = wtsum
8047 enddo
8048 do ig = 1, ng(ibnd)
8049 ind = (ibnd-1)*mg + ig
8050 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
8051 enddo
8052 else
8053 do ig = 1, ng(ibnd)
8054 igcsm = igcsm + 1
8055 ind = (ibnd-1)*mg + ig
8056 rwgt(ind) = 1.0_rb
8057 enddo
8058 endif
8059 enddo
8061 ! Reduce g-points for absorption coefficient data in each LW spectral band.
8063 call cmbgb1
8064 call cmbgb2
8065 call cmbgb3
8066 call cmbgb4
8067 call cmbgb5
8068 call cmbgb6
8069 call cmbgb7
8070 call cmbgb8
8071 call cmbgb9
8072 call cmbgb10
8073 call cmbgb11
8074 call cmbgb12
8075 call cmbgb13
8076 call cmbgb14
8077 call cmbgb15
8078 call cmbgb16
8080 end subroutine rrtmg_lw_ini
8082 !***************************************************************************
8083 subroutine lwdatinit(cpdair)
8084 !***************************************************************************
8086 ! --------- Modules ----------
8088 use parrrtm, only : maxxsec, maxinpx
8089 use rrlw_con, only: heatfac, grav, planck, boltz, &
8090 clight, avogad, alosmt, gascon, radcn1, radcn2, &
8091 sbcnst, secdy
8092 use rrlw_vsn
8094 save
8096 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
8097 ! at constant pressure at 273 K
8098 ! (J kg-1 K-1)
8100 ! Longwave spectral band limits (wavenumbers)
8101 wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb, &
8102 980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb, &
8103 2080._rb,2250._rb,2380._rb,2600._rb/)
8104 wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb, &
8105 1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb, &
8106 2250._rb,2380._rb,2600._rb,3250._rb/)
8107 delwave(:) = (/340._rb, 150._rb, 130._rb, 70._rb, 120._rb, 160._rb, &
8108 100._rb, 100._rb, 210._rb, 90._rb, 320._rb, 280._rb, &
8109 170._rb, 130._rb, 220._rb, 650._rb/)
8111 ! Spectral band information
8112 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
8113 nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
8114 nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
8116 ! nxmol - number of cross-sections input by user
8117 ! ixindx(i) - index of cross-section molecule corresponding to Ith
8118 ! cross-section specified by user
8119 ! = 0 -- not allowed in rrtm
8120 ! = 1 -- ccl4
8121 ! = 2 -- cfc11
8122 ! = 3 -- cfc12
8123 ! = 4 -- cfc22
8124 nxmol = 4
8125 ixindx(1) = 1
8126 ixindx(2) = 2
8127 ixindx(3) = 3
8128 ixindx(4) = 4
8129 ixindx(5:maxinpx) = 0
8131 ! Fundamental physical constants from NIST 2002
8133 grav = 9.8066_rb ! Acceleration of gravity
8134 ! (m s-2)
8135 planck = 6.62606876e-27_rb ! Planck constant
8136 ! (ergs s; g cm2 s-1)
8137 boltz = 1.3806503e-16_rb ! Boltzmann constant
8138 ! (ergs K-1; g cm2 s-2 K-1)
8139 clight = 2.99792458e+10_rb ! Speed of light in a vacuum
8140 ! (cm s-1)
8141 avogad = 6.02214199e+23_rb ! Avogadro constant
8142 ! (mol-1)
8143 alosmt = 2.6867775e+19_rb ! Loschmidt constant
8144 ! (cm-3)
8145 gascon = 8.31447200e+07_rb ! Molar gas constant
8146 ! (ergs mol-1 K-1)
8147 radcn1 = 1.191042722e-12_rb ! First radiation constant
8148 ! (W cm2 sr-1)
8149 radcn2 = 1.4387752_rb ! Second radiation constant
8150 ! (cm K)
8151 sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
8152 ! (W cm-2 K-4)
8153 secdy = 8.6400e4_rb ! Number of seconds per day
8154 ! (s d-1)
8155 !
8156 ! units are generally cgs
8157 !
8158 ! The first and second radiation constants are taken from NIST.
8159 ! They were previously obtained from the relations:
8160 ! radcn1 = 2.*planck*clight*clight*1.e-07
8161 ! radcn2 = planck*clight/boltz
8163 ! Heatfac is the factor by which delta-flux / delta-pressure is
8164 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
8165 ! the heating rate in units of degrees/day. It is equal to:
8166 ! Original value:
8167 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8168 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
8169 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8170 ! = (9.8066)(86400)(1e-5)/(1.004)
8171 ! heatfac = 8.4391_rb
8172 !
8173 ! Modified value for consistency with CAM3:
8174 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8175 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
8176 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8177 ! = (9.80616)(86400)(1e-5)/(1.00464)
8178 ! heatfac = 8.43339130434_rb
8179 !
8180 ! Calculated value:
8181 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
8182 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
8183 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
8184 heatfac = grav * secdy / (cpdair * 1.e2_rb)
8186 end subroutine lwdatinit
8188 !***************************************************************************
8189 subroutine lwcmbdat
8190 !***************************************************************************
8192 save
8194 ! ------- Definitions -------
8195 ! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
8196 ! This mapping from 256 to 140 points has been carefully selected to
8197 ! minimize the effect on the resulting fluxes and cooling rates, and
8198 ! caution should be used if the mapping is modified. The full 256
8199 ! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
8200 ! ngptlw The total number of new g-points
8201 ! ngc The number of new g-points in each band
8202 ! ngs The cumulative sum of new g-points for each band
8203 ! ngm The index of each new g-point relative to the original
8204 ! 16 g-points for each band.
8205 ! ngn The number of original g-points that are combined to make
8206 ! each new g-point in each band.
8207 ! ngb The band index for each new g-point.
8208 ! wt RRTM weights for 16 g-points.
8210 ! ------- Data statements -------
8211 ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
8212 ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
8213 ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1
8214 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2
8215 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3
8216 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4
8217 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5
8218 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6
8219 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7
8220 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8
8221 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9
8222 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10
8223 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11
8224 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12
8225 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13
8226 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14
8227 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15
8228 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16
8229 ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1
8230 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2
8231 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3
8232 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4
8233 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5
8234 2,2,2,2,2,2,2,2, & ! band 6
8235 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7
8236 2,2,2,2,2,2,2,2, & ! band 8
8237 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9
8238 2,2,2,2,4,4, & ! band 10
8239 1,1,2,2,2,2,3,3, & ! band 11
8240 1,1,1,1,2,2,4,4, & ! band 12
8241 3,3,4,6, & ! band 13
8242 8,8, & ! band 14
8243 8,8, & ! band 15
8244 4,12/) ! band 16
8245 ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1
8246 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2
8247 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3
8248 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4
8249 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5
8250 6,6,6,6,6,6,6,6, & ! band 6
8251 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7
8252 8,8,8,8,8,8,8,8, & ! band 8
8253 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9
8254 10,10,10,10,10,10, & ! band 10
8255 11,11,11,11,11,11,11,11, & ! band 11
8256 12,12,12,12,12,12,12,12, & ! band 12
8257 13,13,13,13, & ! band 13
8258 14,14, & ! band 14
8259 15,15, & ! band 15
8260 16,16/) ! band 16
8261 wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
8262 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
8263 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
8264 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
8265 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
8266 0.0000750000_rb/)
8268 end subroutine lwcmbdat
8270 !***************************************************************************
8271 subroutine cmbgb1
8272 !***************************************************************************
8273 !
8274 ! Original version: MJIacono; July 1998
8275 ! Revision for GCMs: MJIacono; September 1998
8276 ! Revision for RRTMG: MJIacono, September 2002
8277 ! Revision for F90 reformatting: MJIacono, June 2006
8278 !
8279 ! The subroutines CMBGB1->CMBGB16 input the absorption coefficient
8280 ! data for each band, which are defined for 16 g-points and 16 spectral
8281 ! bands. The data are combined with appropriate weighting following the
8282 ! g-point mapping arrays specified in RRTMINIT. Plank fraction data
8283 ! in arrays FRACREFA and FRACREFB are combined without weighting. All
8284 ! g-point reduced data are put into new arrays for use in RRTM.
8285 !
8286 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
8287 ! (high key - h2o; high minor - n2)
8288 ! note: previous versions of rrtm band 1:
8289 ! 10-250 cm-1 (low - h2o; high - h2o)
8290 !***************************************************************************
8292 use parrrtm, only : mg, nbndlw, ngptlw, ng1
8293 use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
8294 selfrefo, forrefo, &
8295 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, &
8296 selfref, forref
8298 ! ------- Local -------
8299 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8300 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
8303 do jt = 1,5
8304 do jp = 1,13
8305 iprsm = 0
8306 do igc = 1,ngc(1)
8307 sumk = 0.
8308 do ipr = 1, ngn(igc)
8309 iprsm = iprsm + 1
8310 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
8311 enddo
8312 ka(jt,jp,igc) = sumk
8313 enddo
8314 enddo
8315 do jp = 13,59
8316 iprsm = 0
8317 do igc = 1,ngc(1)
8318 sumk = 0.
8319 do ipr = 1, ngn(igc)
8320 iprsm = iprsm + 1
8321 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
8322 enddo
8323 kb(jt,jp,igc) = sumk
8324 enddo
8325 enddo
8326 enddo
8328 do jt = 1,10
8329 iprsm = 0
8330 do igc = 1,ngc(1)
8331 sumk = 0.
8332 do ipr = 1, ngn(igc)
8333 iprsm = iprsm + 1
8334 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
8335 enddo
8336 selfref(jt,igc) = sumk
8337 enddo
8338 enddo
8340 do jt = 1,4
8341 iprsm = 0
8342 do igc = 1,ngc(1)
8343 sumk = 0.
8344 do ipr = 1, ngn(igc)
8345 iprsm = iprsm + 1
8346 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
8347 enddo
8348 forref(jt,igc) = sumk
8349 enddo
8350 enddo
8352 do jt = 1,19
8353 iprsm = 0
8354 do igc = 1,ngc(1)
8355 sumk1 = 0.
8356 sumk2 = 0.
8357 do ipr = 1, ngn(igc)
8358 iprsm = iprsm + 1
8359 sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
8360 sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
8361 enddo
8362 ka_mn2(jt,igc) = sumk1
8363 kb_mn2(jt,igc) = sumk2
8364 enddo
8365 enddo
8367 iprsm = 0
8368 do igc = 1,ngc(1)
8369 sumf1 = 0.
8370 sumf2 = 0.
8371 do ipr = 1, ngn(igc)
8372 iprsm = iprsm + 1
8373 sumf1= sumf1+ fracrefao(iprsm)
8374 sumf2= sumf2+ fracrefbo(iprsm)
8375 enddo
8376 fracrefa(igc) = sumf1
8377 fracrefb(igc) = sumf2
8378 enddo
8380 end subroutine cmbgb1
8382 !***************************************************************************
8383 subroutine cmbgb2
8384 !***************************************************************************
8385 !
8386 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
8387 !
8388 ! note: previous version of rrtm band 2:
8389 ! 250 - 500 cm-1 (low - h2o; high - h2o)
8390 !***************************************************************************
8392 use parrrtm, only : mg, nbndlw, ngptlw, ng2
8393 use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8394 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8396 ! ------- Local -------
8397 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8398 real(kind=rb) :: sumk, sumf1, sumf2
8401 do jt = 1,5
8402 do jp = 1,13
8403 iprsm = 0
8404 do igc = 1,ngc(2)
8405 sumk = 0.
8406 do ipr = 1, ngn(ngs(1)+igc)
8407 iprsm = iprsm + 1
8408 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
8409 enddo
8410 ka(jt,jp,igc) = sumk
8411 enddo
8412 enddo
8413 do jp = 13,59
8414 iprsm = 0
8415 do igc = 1,ngc(2)
8416 sumk = 0.
8417 do ipr = 1, ngn(ngs(1)+igc)
8418 iprsm = iprsm + 1
8419 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
8420 enddo
8421 kb(jt,jp,igc) = sumk
8422 enddo
8423 enddo
8424 enddo
8426 do jt = 1,10
8427 iprsm = 0
8428 do igc = 1,ngc(2)
8429 sumk = 0.
8430 do ipr = 1, ngn(ngs(1)+igc)
8431 iprsm = iprsm + 1
8432 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
8433 enddo
8434 selfref(jt,igc) = sumk
8435 enddo
8436 enddo
8438 do jt = 1,4
8439 iprsm = 0
8440 do igc = 1,ngc(2)
8441 sumk = 0.
8442 do ipr = 1, ngn(ngs(1)+igc)
8443 iprsm = iprsm + 1
8444 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
8445 enddo
8446 forref(jt,igc) = sumk
8447 enddo
8448 enddo
8450 iprsm = 0
8451 do igc = 1,ngc(2)
8452 sumf1 = 0.
8453 sumf2 = 0.
8454 do ipr = 1, ngn(ngs(1)+igc)
8455 iprsm = iprsm + 1
8456 sumf1= sumf1+ fracrefao(iprsm)
8457 sumf2= sumf2+ fracrefbo(iprsm)
8458 enddo
8459 fracrefa(igc) = sumf1
8460 fracrefb(igc) = sumf2
8461 enddo
8463 end subroutine cmbgb2
8465 !***************************************************************************
8466 subroutine cmbgb3
8467 !***************************************************************************
8468 !
8469 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
8470 ! (high key - h2o,co2; high minor - n2o)
8471 !
8472 ! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
8473 !***************************************************************************
8475 use parrrtm, only : mg, nbndlw, ngptlw, ng3
8476 use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
8477 selfrefo, forrefo, &
8478 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, &
8479 selfref, forref
8481 ! ------- Local -------
8482 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8483 real(kind=rb) :: sumk, sumf
8486 do jn = 1,9
8487 do jt = 1,5
8488 do jp = 1,13
8489 iprsm = 0
8490 do igc = 1,ngc(3)
8491 sumk = 0.
8492 do ipr = 1, ngn(ngs(2)+igc)
8493 iprsm = iprsm + 1
8494 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8495 enddo
8496 ka(jn,jt,jp,igc) = sumk
8497 enddo
8498 enddo
8499 enddo
8500 enddo
8501 do jn = 1,5
8502 do jt = 1,5
8503 do jp = 13,59
8504 iprsm = 0
8505 do igc = 1,ngc(3)
8506 sumk = 0.
8507 do ipr = 1, ngn(ngs(2)+igc)
8508 iprsm = iprsm + 1
8509 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8510 enddo
8511 kb(jn,jt,jp,igc) = sumk
8512 enddo
8513 enddo
8514 enddo
8515 enddo
8517 do jn = 1,9
8518 do jt = 1,19
8519 iprsm = 0
8520 do igc = 1,ngc(3)
8521 sumk = 0.
8522 do ipr = 1, ngn(ngs(2)+igc)
8523 iprsm = iprsm + 1
8524 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8525 enddo
8526 ka_mn2o(jn,jt,igc) = sumk
8527 enddo
8528 enddo
8529 enddo
8531 do jn = 1,5
8532 do jt = 1,19
8533 iprsm = 0
8534 do igc = 1,ngc(3)
8535 sumk = 0.
8536 do ipr = 1, ngn(ngs(2)+igc)
8537 iprsm = iprsm + 1
8538 sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8539 enddo
8540 kb_mn2o(jn,jt,igc) = sumk
8541 enddo
8542 enddo
8543 enddo
8545 do jt = 1,10
8546 iprsm = 0
8547 do igc = 1,ngc(3)
8548 sumk = 0.
8549 do ipr = 1, ngn(ngs(2)+igc)
8550 iprsm = iprsm + 1
8551 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
8552 enddo
8553 selfref(jt,igc) = sumk
8554 enddo
8555 enddo
8557 do jt = 1,4
8558 iprsm = 0
8559 do igc = 1,ngc(3)
8560 sumk = 0.
8561 do ipr = 1, ngn(ngs(2)+igc)
8562 iprsm = iprsm + 1
8563 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
8564 enddo
8565 forref(jt,igc) = sumk
8566 enddo
8567 enddo
8569 do jp = 1,9
8570 iprsm = 0
8571 do igc = 1,ngc(3)
8572 sumf = 0.
8573 do ipr = 1, ngn(ngs(2)+igc)
8574 iprsm = iprsm + 1
8575 sumf = sumf + fracrefao(iprsm,jp)
8576 enddo
8577 fracrefa(igc,jp) = sumf
8578 enddo
8579 enddo
8581 do jp = 1,5
8582 iprsm = 0
8583 do igc = 1,ngc(3)
8584 sumf = 0.
8585 do ipr = 1, ngn(ngs(2)+igc)
8586 iprsm = iprsm + 1
8587 sumf = sumf + fracrefbo(iprsm,jp)
8588 enddo
8589 fracrefb(igc,jp) = sumf
8590 enddo
8591 enddo
8593 end subroutine cmbgb3
8595 !***************************************************************************
8596 subroutine cmbgb4
8597 !***************************************************************************
8598 !
8599 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
8600 !
8601 ! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
8602 !***************************************************************************
8604 use parrrtm, only : mg, nbndlw, ngptlw, ng4
8605 use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8606 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8608 ! ------- Local -------
8609 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8610 real(kind=rb) :: sumk, sumf
8613 do jn = 1,9
8614 do jt = 1,5
8615 do jp = 1,13
8616 iprsm = 0
8617 do igc = 1,ngc(4)
8618 sumk = 0.
8619 do ipr = 1, ngn(ngs(3)+igc)
8620 iprsm = iprsm + 1
8621 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8622 enddo
8623 ka(jn,jt,jp,igc) = sumk
8624 enddo
8625 enddo
8626 enddo
8627 enddo
8628 do jn = 1,5
8629 do jt = 1,5
8630 do jp = 13,59
8631 iprsm = 0
8632 do igc = 1,ngc(4)
8633 sumk = 0.
8634 do ipr = 1, ngn(ngs(3)+igc)
8635 iprsm = iprsm + 1
8636 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8637 enddo
8638 kb(jn,jt,jp,igc) = sumk
8639 enddo
8640 enddo
8641 enddo
8642 enddo
8644 do jt = 1,10
8645 iprsm = 0
8646 do igc = 1,ngc(4)
8647 sumk = 0.
8648 do ipr = 1, ngn(ngs(3)+igc)
8649 iprsm = iprsm + 1
8650 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
8651 enddo
8652 selfref(jt,igc) = sumk
8653 enddo
8654 enddo
8656 do jt = 1,4
8657 iprsm = 0
8658 do igc = 1,ngc(4)
8659 sumk = 0.
8660 do ipr = 1, ngn(ngs(3)+igc)
8661 iprsm = iprsm + 1
8662 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
8663 enddo
8664 forref(jt,igc) = sumk
8665 enddo
8666 enddo
8668 do jp = 1,9
8669 iprsm = 0
8670 do igc = 1,ngc(4)
8671 sumf = 0.
8672 do ipr = 1, ngn(ngs(3)+igc)
8673 iprsm = iprsm + 1
8674 sumf = sumf + fracrefao(iprsm,jp)
8675 enddo
8676 fracrefa(igc,jp) = sumf
8677 enddo
8678 enddo
8680 do jp = 1,5
8681 iprsm = 0
8682 do igc = 1,ngc(4)
8683 sumf = 0.
8684 do ipr = 1, ngn(ngs(3)+igc)
8685 iprsm = iprsm + 1
8686 sumf = sumf + fracrefbo(iprsm,jp)
8687 enddo
8688 fracrefb(igc,jp) = sumf
8689 enddo
8690 enddo
8692 end subroutine cmbgb4
8694 !***************************************************************************
8695 subroutine cmbgb5
8696 !***************************************************************************
8697 !
8698 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
8699 ! (high key - o3,co2)
8700 !
8701 ! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
8702 !***************************************************************************
8704 use parrrtm, only : mg, nbndlw, ngptlw, ng5
8705 use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
8706 selfrefo, forrefo, &
8707 fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
8708 selfref, forref
8710 ! ------- Local -------
8711 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8712 real(kind=rb) :: sumk, sumf
8715 do jn = 1,9
8716 do jt = 1,5
8717 do jp = 1,13
8718 iprsm = 0
8719 do igc = 1,ngc(5)
8720 sumk = 0.
8721 do ipr = 1, ngn(ngs(4)+igc)
8722 iprsm = iprsm + 1
8723 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8724 enddo
8725 ka(jn,jt,jp,igc) = sumk
8726 enddo
8727 enddo
8728 enddo
8729 enddo
8730 do jn = 1,5
8731 do jt = 1,5
8732 do jp = 13,59
8733 iprsm = 0
8734 do igc = 1,ngc(5)
8735 sumk = 0.
8736 do ipr = 1, ngn(ngs(4)+igc)
8737 iprsm = iprsm + 1
8738 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8739 enddo
8740 kb(jn,jt,jp,igc) = sumk
8741 enddo
8742 enddo
8743 enddo
8744 enddo
8746 do jn = 1,9
8747 do jt = 1,19
8748 iprsm = 0
8749 do igc = 1,ngc(5)
8750 sumk = 0.
8751 do ipr = 1, ngn(ngs(4)+igc)
8752 iprsm = iprsm + 1
8753 sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
8754 enddo
8755 ka_mo3(jn,jt,igc) = sumk
8756 enddo
8757 enddo
8758 enddo
8760 do jt = 1,10
8761 iprsm = 0
8762 do igc = 1,ngc(5)
8763 sumk = 0.
8764 do ipr = 1, ngn(ngs(4)+igc)
8765 iprsm = iprsm + 1
8766 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
8767 enddo
8768 selfref(jt,igc) = sumk
8769 enddo
8770 enddo
8772 do jt = 1,4
8773 iprsm = 0
8774 do igc = 1,ngc(5)
8775 sumk = 0.
8776 do ipr = 1, ngn(ngs(4)+igc)
8777 iprsm = iprsm + 1
8778 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
8779 enddo
8780 forref(jt,igc) = sumk
8781 enddo
8782 enddo
8784 do jp = 1,9
8785 iprsm = 0
8786 do igc = 1,ngc(5)
8787 sumf = 0.
8788 do ipr = 1, ngn(ngs(4)+igc)
8789 iprsm = iprsm + 1
8790 sumf = sumf + fracrefao(iprsm,jp)
8791 enddo
8792 fracrefa(igc,jp) = sumf
8793 enddo
8794 enddo
8796 do jp = 1,5
8797 iprsm = 0
8798 do igc = 1,ngc(5)
8799 sumf = 0.
8800 do ipr = 1, ngn(ngs(4)+igc)
8801 iprsm = iprsm + 1
8802 sumf = sumf + fracrefbo(iprsm,jp)
8803 enddo
8804 fracrefb(igc,jp) = sumf
8805 enddo
8806 enddo
8808 iprsm = 0
8809 do igc = 1,ngc(5)
8810 sumk = 0.
8811 do ipr = 1, ngn(ngs(4)+igc)
8812 iprsm = iprsm + 1
8813 sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
8814 enddo
8815 ccl4(igc) = sumk
8816 enddo
8818 end subroutine cmbgb5
8820 !***************************************************************************
8821 subroutine cmbgb6
8822 !***************************************************************************
8823 !
8824 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
8825 ! (high key - nothing; high minor - cfc11, cfc12)
8826 !
8827 ! old band 6: 820-980 cm-1 (low - h2o; high - nothing)
8828 !***************************************************************************
8830 use parrrtm, only : mg, nbndlw, ngptlw, ng6
8831 use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
8832 selfrefo, forrefo, &
8833 fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, &
8834 selfref, forref
8836 ! ------- Local -------
8837 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8838 real(kind=rb) :: sumk, sumf, sumk1, sumk2
8841 do jt = 1,5
8842 do jp = 1,13
8843 iprsm = 0
8844 do igc = 1,ngc(6)
8845 sumk = 0.
8846 do ipr = 1, ngn(ngs(5)+igc)
8847 iprsm = iprsm + 1
8848 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
8849 enddo
8850 ka(jt,jp,igc) = sumk
8851 enddo
8852 enddo
8853 enddo
8855 do jt = 1,19
8856 iprsm = 0
8857 do igc = 1,ngc(6)
8858 sumk = 0.
8859 do ipr = 1, ngn(ngs(5)+igc)
8860 iprsm = iprsm + 1
8861 sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
8862 enddo
8863 ka_mco2(jt,igc) = sumk
8864 enddo
8865 enddo
8867 do jt = 1,10
8868 iprsm = 0
8869 do igc = 1,ngc(6)
8870 sumk = 0.
8871 do ipr = 1, ngn(ngs(5)+igc)
8872 iprsm = iprsm + 1
8873 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
8874 enddo
8875 selfref(jt,igc) = sumk
8876 enddo
8877 enddo
8879 do jt = 1,4
8880 iprsm = 0
8881 do igc = 1,ngc(6)
8882 sumk = 0.
8883 do ipr = 1, ngn(ngs(5)+igc)
8884 iprsm = iprsm + 1
8885 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
8886 enddo
8887 forref(jt,igc) = sumk
8888 enddo
8889 enddo
8891 iprsm = 0
8892 do igc = 1,ngc(6)
8893 sumf = 0.
8894 sumk1= 0.
8895 sumk2= 0.
8896 do ipr = 1, ngn(ngs(5)+igc)
8897 iprsm = iprsm + 1
8898 sumf = sumf + fracrefao(iprsm)
8899 sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
8900 sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
8901 enddo
8902 fracrefa(igc) = sumf
8903 cfc11adj(igc) = sumk1
8904 cfc12(igc) = sumk2
8905 enddo
8907 end subroutine cmbgb6
8909 !***************************************************************************
8910 subroutine cmbgb7
8911 !***************************************************************************
8912 !
8913 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
8914 ! (high key - o3; high minor - co2)
8915 !
8916 ! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
8917 !***************************************************************************
8919 use parrrtm, only : mg, nbndlw, ngptlw, ng7
8920 use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
8921 selfrefo, forrefo, &
8922 fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, &
8923 selfref, forref
8925 ! ------- Local -------
8926 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8927 real(kind=rb) :: sumk, sumf
8930 do jn = 1,9
8931 do jt = 1,5
8932 do jp = 1,13
8933 iprsm = 0
8934 do igc = 1,ngc(7)
8935 sumk = 0.
8936 do ipr = 1, ngn(ngs(6)+igc)
8937 iprsm = iprsm + 1
8938 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
8939 enddo
8940 ka(jn,jt,jp,igc) = sumk
8941 enddo
8942 enddo
8943 enddo
8944 enddo
8945 do jt = 1,5
8946 do jp = 13,59
8947 iprsm = 0
8948 do igc = 1,ngc(7)
8949 sumk = 0.
8950 do ipr = 1, ngn(ngs(6)+igc)
8951 iprsm = iprsm + 1
8952 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
8953 enddo
8954 kb(jt,jp,igc) = sumk
8955 enddo
8956 enddo
8957 enddo
8959 do jn = 1,9
8960 do jt = 1,19
8961 iprsm = 0
8962 do igc = 1,ngc(7)
8963 sumk = 0.
8964 do ipr = 1, ngn(ngs(6)+igc)
8965 iprsm = iprsm + 1
8966 sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
8967 enddo
8968 ka_mco2(jn,jt,igc) = sumk
8969 enddo
8970 enddo
8971 enddo
8973 do jt = 1,19
8974 iprsm = 0
8975 do igc = 1,ngc(7)
8976 sumk = 0.
8977 do ipr = 1, ngn(ngs(6)+igc)
8978 iprsm = iprsm + 1
8979 sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
8980 enddo
8981 kb_mco2(jt,igc) = sumk
8982 enddo
8983 enddo
8985 do jt = 1,10
8986 iprsm = 0
8987 do igc = 1,ngc(7)
8988 sumk = 0.
8989 do ipr = 1, ngn(ngs(6)+igc)
8990 iprsm = iprsm + 1
8991 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
8992 enddo
8993 selfref(jt,igc) = sumk
8994 enddo
8995 enddo
8997 do jt = 1,4
8998 iprsm = 0
8999 do igc = 1,ngc(7)
9000 sumk = 0.
9001 do ipr = 1, ngn(ngs(6)+igc)
9002 iprsm = iprsm + 1
9003 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
9004 enddo
9005 forref(jt,igc) = sumk
9006 enddo
9007 enddo
9009 do jp = 1,9
9010 iprsm = 0
9011 do igc = 1,ngc(7)
9012 sumf = 0.
9013 do ipr = 1, ngn(ngs(6)+igc)
9014 iprsm = iprsm + 1
9015 sumf = sumf + fracrefao(iprsm,jp)
9016 enddo
9017 fracrefa(igc,jp) = sumf
9018 enddo
9019 enddo
9021 iprsm = 0
9022 do igc = 1,ngc(7)
9023 sumf = 0.
9024 do ipr = 1, ngn(ngs(6)+igc)
9025 iprsm = iprsm + 1
9026 sumf = sumf + fracrefbo(iprsm)
9027 enddo
9028 fracrefb(igc) = sumf
9029 enddo
9031 end subroutine cmbgb7
9033 !***************************************************************************
9034 subroutine cmbgb8
9035 !***************************************************************************
9036 !
9037 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
9038 ! (high key - o3; high minor - co2, n2o)
9039 !
9040 ! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
9041 !***************************************************************************
9043 use parrrtm, only : mg, nbndlw, ngptlw, ng8
9044 use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
9045 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
9046 cfc12o, cfc22adjo, &
9047 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, &
9048 ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, &
9049 cfc12, cfc22adj
9051 ! ------- Local -------
9052 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9053 real(kind=rb) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
9056 do jt = 1,5
9057 do jp = 1,13
9058 iprsm = 0
9059 do igc = 1,ngc(8)
9060 sumk = 0.
9061 do ipr = 1, ngn(ngs(7)+igc)
9062 iprsm = iprsm + 1
9063 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
9064 enddo
9065 ka(jt,jp,igc) = sumk
9066 enddo
9067 enddo
9068 enddo
9069 do jt = 1,5
9070 do jp = 13,59
9071 iprsm = 0
9072 do igc = 1,ngc(8)
9073 sumk = 0.
9074 do ipr = 1, ngn(ngs(7)+igc)
9075 iprsm = iprsm + 1
9076 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
9077 enddo
9078 kb(jt,jp,igc) = sumk
9079 enddo
9080 enddo
9081 enddo
9083 do jt = 1,10
9084 iprsm = 0
9085 do igc = 1,ngc(8)
9086 sumk = 0.
9087 do ipr = 1, ngn(ngs(7)+igc)
9088 iprsm = iprsm + 1
9089 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
9090 enddo
9091 selfref(jt,igc) = sumk
9092 enddo
9093 enddo
9095 do jt = 1,4
9096 iprsm = 0
9097 do igc = 1,ngc(8)
9098 sumk = 0.
9099 do ipr = 1, ngn(ngs(7)+igc)
9100 iprsm = iprsm + 1
9101 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
9102 enddo
9103 forref(jt,igc) = sumk
9104 enddo
9105 enddo
9107 do jt = 1,19
9108 iprsm = 0
9109 do igc = 1,ngc(8)
9110 sumk1 = 0.
9111 sumk2 = 0.
9112 sumk3 = 0.
9113 sumk4 = 0.
9114 sumk5 = 0.
9115 do ipr = 1, ngn(ngs(7)+igc)
9116 iprsm = iprsm + 1
9117 sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
9118 sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
9119 sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
9120 sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
9121 sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
9122 enddo
9123 ka_mco2(jt,igc) = sumk1
9124 kb_mco2(jt,igc) = sumk2
9125 ka_mo3(jt,igc) = sumk3
9126 ka_mn2o(jt,igc) = sumk4
9127 kb_mn2o(jt,igc) = sumk5
9128 enddo
9129 enddo
9131 iprsm = 0
9132 do igc = 1,ngc(8)
9133 sumf1= 0.
9134 sumf2= 0.
9135 sumk1= 0.
9136 sumk2= 0.
9137 do ipr = 1, ngn(ngs(7)+igc)
9138 iprsm = iprsm + 1
9139 sumf1= sumf1+ fracrefao(iprsm)
9140 sumf2= sumf2+ fracrefbo(iprsm)
9141 sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
9142 sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
9143 enddo
9144 fracrefa(igc) = sumf1
9145 fracrefb(igc) = sumf2
9146 cfc12(igc) = sumk1
9147 cfc22adj(igc) = sumk2
9148 enddo
9150 end subroutine cmbgb8
9152 !***************************************************************************
9153 subroutine cmbgb9
9154 !***************************************************************************
9155 !
9156 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
9157 ! (high key - ch4; high minor - n2o)!
9159 ! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
9160 !***************************************************************************
9162 use parrrtm, only : mg, nbndlw, ngptlw, ng9
9163 use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, &
9164 kbo, kbo_mn2o, selfrefo, forrefo, &
9165 fracrefa, fracrefb, absa, ka, ka_mn2o, &
9166 absb, kb, kb_mn2o, selfref, forref
9168 ! ------- Local -------
9169 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9170 real(kind=rb) :: sumk, sumf
9173 do jn = 1,9
9174 do jt = 1,5
9175 do jp = 1,13
9176 iprsm = 0
9177 do igc = 1,ngc(9)
9178 sumk = 0.
9179 do ipr = 1, ngn(ngs(8)+igc)
9180 iprsm = iprsm + 1
9181 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
9182 enddo
9183 ka(jn,jt,jp,igc) = sumk
9184 enddo
9185 enddo
9186 enddo
9187 enddo
9189 do jt = 1,5
9190 do jp = 13,59
9191 iprsm = 0
9192 do igc = 1,ngc(9)
9193 sumk = 0.
9194 do ipr = 1, ngn(ngs(8)+igc)
9195 iprsm = iprsm + 1
9196 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
9197 enddo
9198 kb(jt,jp,igc) = sumk
9199 enddo
9200 enddo
9201 enddo
9203 do jn = 1,9
9204 do jt = 1,19
9205 iprsm = 0
9206 do igc = 1,ngc(9)
9207 sumk = 0.
9208 do ipr = 1, ngn(ngs(8)+igc)
9209 iprsm = iprsm + 1
9210 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
9211 enddo
9212 ka_mn2o(jn,jt,igc) = sumk
9213 enddo
9214 enddo
9215 enddo
9217 do jt = 1,19
9218 iprsm = 0
9219 do igc = 1,ngc(9)
9220 sumk = 0.
9221 do ipr = 1, ngn(ngs(8)+igc)
9222 iprsm = iprsm + 1
9223 sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
9224 enddo
9225 kb_mn2o(jt,igc) = sumk
9226 enddo
9227 enddo
9229 do jt = 1,10
9230 iprsm = 0
9231 do igc = 1,ngc(9)
9232 sumk = 0.
9233 do ipr = 1, ngn(ngs(8)+igc)
9234 iprsm = iprsm + 1
9235 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
9236 enddo
9237 selfref(jt,igc) = sumk
9238 enddo
9239 enddo
9241 do jt = 1,4
9242 iprsm = 0
9243 do igc = 1,ngc(9)
9244 sumk = 0.
9245 do ipr = 1, ngn(ngs(8)+igc)
9246 iprsm = iprsm + 1
9247 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
9248 enddo
9249 forref(jt,igc) = sumk
9250 enddo
9251 enddo
9253 do jp = 1,9
9254 iprsm = 0
9255 do igc = 1,ngc(9)
9256 sumf = 0.
9257 do ipr = 1, ngn(ngs(8)+igc)
9258 iprsm = iprsm + 1
9259 sumf = sumf + fracrefao(iprsm,jp)
9260 enddo
9261 fracrefa(igc,jp) = sumf
9262 enddo
9263 enddo
9265 iprsm = 0
9266 do igc = 1,ngc(9)
9267 sumf = 0.
9268 do ipr = 1, ngn(ngs(8)+igc)
9269 iprsm = iprsm + 1
9270 sumf = sumf + fracrefbo(iprsm)
9271 enddo
9272 fracrefb(igc) = sumf
9273 enddo
9275 end subroutine cmbgb9
9277 !***************************************************************************
9278 subroutine cmbgb10
9279 !***************************************************************************
9280 !
9281 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
9282 !
9283 ! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
9284 !***************************************************************************
9286 use parrrtm, only : mg, nbndlw, ngptlw, ng10
9287 use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, &
9288 selfrefo, forrefo, &
9289 fracrefa, fracrefb, absa, ka, absb, kb, &
9290 selfref, forref
9292 ! ------- Local -------
9293 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9294 real(kind=rb) :: sumk, sumf1, sumf2
9297 do jt = 1,5
9298 do jp = 1,13
9299 iprsm = 0
9300 do igc = 1,ngc(10)
9301 sumk = 0.
9302 do ipr = 1, ngn(ngs(9)+igc)
9303 iprsm = iprsm + 1
9304 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
9305 enddo
9306 ka(jt,jp,igc) = sumk
9307 enddo
9308 enddo
9309 enddo
9311 do jt = 1,5
9312 do jp = 13,59
9313 iprsm = 0
9314 do igc = 1,ngc(10)
9315 sumk = 0.
9316 do ipr = 1, ngn(ngs(9)+igc)
9317 iprsm = iprsm + 1
9318 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
9319 enddo
9320 kb(jt,jp,igc) = sumk
9321 enddo
9322 enddo
9323 enddo
9325 do jt = 1,10
9326 iprsm = 0
9327 do igc = 1,ngc(10)
9328 sumk = 0.
9329 do ipr = 1, ngn(ngs(9)+igc)
9330 iprsm = iprsm + 1
9331 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
9332 enddo
9333 selfref(jt,igc) = sumk
9334 enddo
9335 enddo
9337 do jt = 1,4
9338 iprsm = 0
9339 do igc = 1,ngc(10)
9340 sumk = 0.
9341 do ipr = 1, ngn(ngs(9)+igc)
9342 iprsm = iprsm + 1
9343 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
9344 enddo
9345 forref(jt,igc) = sumk
9346 enddo
9347 enddo
9349 iprsm = 0
9350 do igc = 1,ngc(10)
9351 sumf1= 0.
9352 sumf2= 0.
9353 do ipr = 1, ngn(ngs(9)+igc)
9354 iprsm = iprsm + 1
9355 sumf1= sumf1+ fracrefao(iprsm)
9356 sumf2= sumf2+ fracrefbo(iprsm)
9357 enddo
9358 fracrefa(igc) = sumf1
9359 fracrefb(igc) = sumf2
9360 enddo
9362 end subroutine cmbgb10
9364 !***************************************************************************
9365 subroutine cmbgb11
9366 !***************************************************************************
9367 !
9368 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9369 ! (high key - h2o; high minor - o2)
9370 !
9371 ! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9372 ! (high key - h2o; high minor - o2)
9373 !***************************************************************************
9375 use parrrtm, only : mg, nbndlw, ngptlw, ng11
9376 use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, &
9377 kbo, kbo_mo2, selfrefo, forrefo, &
9378 fracrefa, fracrefb, absa, ka, ka_mo2, &
9379 absb, kb, kb_mo2, selfref, forref
9381 ! ------- Local -------
9382 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9383 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
9386 do jt = 1,5
9387 do jp = 1,13
9388 iprsm = 0
9389 do igc = 1,ngc(11)
9390 sumk = 0.
9391 do ipr = 1, ngn(ngs(10)+igc)
9392 iprsm = iprsm + 1
9393 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
9394 enddo
9395 ka(jt,jp,igc) = sumk
9396 enddo
9397 enddo
9398 enddo
9399 do jt = 1,5
9400 do jp = 13,59
9401 iprsm = 0
9402 do igc = 1,ngc(11)
9403 sumk = 0.
9404 do ipr = 1, ngn(ngs(10)+igc)
9405 iprsm = iprsm + 1
9406 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
9407 enddo
9408 kb(jt,jp,igc) = sumk
9409 enddo
9410 enddo
9411 enddo
9413 do jt = 1,19
9414 iprsm = 0
9415 do igc = 1,ngc(11)
9416 sumk1 = 0.
9417 sumk2 = 0.
9418 do ipr = 1, ngn(ngs(10)+igc)
9419 iprsm = iprsm + 1
9420 sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
9421 sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
9422 enddo
9423 ka_mo2(jt,igc) = sumk1
9424 kb_mo2(jt,igc) = sumk2
9425 enddo
9426 enddo
9428 do jt = 1,10
9429 iprsm = 0
9430 do igc = 1,ngc(11)
9431 sumk = 0.
9432 do ipr = 1, ngn(ngs(10)+igc)
9433 iprsm = iprsm + 1
9434 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
9435 enddo
9436 selfref(jt,igc) = sumk
9437 enddo
9438 enddo
9440 do jt = 1,4
9441 iprsm = 0
9442 do igc = 1,ngc(11)
9443 sumk = 0.
9444 do ipr = 1, ngn(ngs(10)+igc)
9445 iprsm = iprsm + 1
9446 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
9447 enddo
9448 forref(jt,igc) = sumk
9449 enddo
9450 enddo
9452 iprsm = 0
9453 do igc = 1,ngc(11)
9454 sumf1= 0.
9455 sumf2= 0.
9456 do ipr = 1, ngn(ngs(10)+igc)
9457 iprsm = iprsm + 1
9458 sumf1= sumf1+ fracrefao(iprsm)
9459 sumf2= sumf2+ fracrefbo(iprsm)
9460 enddo
9461 fracrefa(igc) = sumf1
9462 fracrefb(igc) = sumf2
9463 enddo
9465 end subroutine cmbgb11
9467 !***************************************************************************
9468 subroutine cmbgb12
9469 !***************************************************************************
9470 !
9471 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9472 !
9473 ! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9474 !***************************************************************************
9476 use parrrtm, only : mg, nbndlw, ngptlw, ng12
9477 use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, &
9478 fracrefa, absa, ka, selfref, forref
9480 ! ------- Local -------
9481 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9482 real(kind=rb) :: sumk, sumf
9485 do jn = 1,9
9486 do jt = 1,5
9487 do jp = 1,13
9488 iprsm = 0
9489 do igc = 1,ngc(12)
9490 sumk = 0.
9491 do ipr = 1, ngn(ngs(11)+igc)
9492 iprsm = iprsm + 1
9493 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
9494 enddo
9495 ka(jn,jt,jp,igc) = sumk
9496 enddo
9497 enddo
9498 enddo
9499 enddo
9501 do jt = 1,10
9502 iprsm = 0
9503 do igc = 1,ngc(12)
9504 sumk = 0.
9505 do ipr = 1, ngn(ngs(11)+igc)
9506 iprsm = iprsm + 1
9507 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
9508 enddo
9509 selfref(jt,igc) = sumk
9510 enddo
9511 enddo
9513 do jt = 1,4
9514 iprsm = 0
9515 do igc = 1,ngc(12)
9516 sumk = 0.
9517 do ipr = 1, ngn(ngs(11)+igc)
9518 iprsm = iprsm + 1
9519 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
9520 enddo
9521 forref(jt,igc) = sumk
9522 enddo
9523 enddo
9525 do jp = 1,9
9526 iprsm = 0
9527 do igc = 1,ngc(12)
9528 sumf = 0.
9529 do ipr = 1, ngn(ngs(11)+igc)
9530 iprsm = iprsm + 1
9531 sumf = sumf + fracrefao(iprsm,jp)
9532 enddo
9533 fracrefa(igc,jp) = sumf
9534 enddo
9535 enddo
9537 end subroutine cmbgb12
9539 !***************************************************************************
9540 subroutine cmbgb13
9541 !***************************************************************************
9542 !
9543 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
9544 !
9545 ! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
9546 !***************************************************************************
9548 use parrrtm, only : mg, nbndlw, ngptlw, ng13
9549 use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
9550 kbo_mo3, selfrefo, forrefo, &
9551 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, &
9552 kb_mo3, selfref, forref
9554 ! ------- Local -------
9555 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9556 real(kind=rb) :: sumk, sumk1, sumk2, sumf
9559 do jn = 1,9
9560 do jt = 1,5
9561 do jp = 1,13
9562 iprsm = 0
9563 do igc = 1,ngc(13)
9564 sumk = 0.
9565 do ipr = 1, ngn(ngs(12)+igc)
9566 iprsm = iprsm + 1
9567 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
9568 enddo
9569 ka(jn,jt,jp,igc) = sumk
9570 enddo
9571 enddo
9572 enddo
9573 enddo
9575 do jn = 1,9
9576 do jt = 1,19
9577 iprsm = 0
9578 do igc = 1,ngc(13)
9579 sumk1 = 0.
9580 sumk2 = 0.
9581 do ipr = 1, ngn(ngs(12)+igc)
9582 iprsm = iprsm + 1
9583 sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
9584 sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
9585 enddo
9586 ka_mco2(jn,jt,igc) = sumk1
9587 ka_mco(jn,jt,igc) = sumk2
9588 enddo
9589 enddo
9590 enddo
9592 do jt = 1,19
9593 iprsm = 0
9594 do igc = 1,ngc(13)
9595 sumk = 0.
9596 do ipr = 1, ngn(ngs(12)+igc)
9597 iprsm = iprsm + 1
9598 sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
9599 enddo
9600 kb_mo3(jt,igc) = sumk
9601 enddo
9602 enddo
9604 do jt = 1,10
9605 iprsm = 0
9606 do igc = 1,ngc(13)
9607 sumk = 0.
9608 do ipr = 1, ngn(ngs(12)+igc)
9609 iprsm = iprsm + 1
9610 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
9611 enddo
9612 selfref(jt,igc) = sumk
9613 enddo
9614 enddo
9616 do jt = 1,4
9617 iprsm = 0
9618 do igc = 1,ngc(13)
9619 sumk = 0.
9620 do ipr = 1, ngn(ngs(12)+igc)
9621 iprsm = iprsm + 1
9622 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
9623 enddo
9624 forref(jt,igc) = sumk
9625 enddo
9626 enddo
9628 iprsm = 0
9629 do igc = 1,ngc(13)
9630 sumf = 0.
9631 do ipr = 1, ngn(ngs(12)+igc)
9632 iprsm = iprsm + 1
9633 sumf = sumf + fracrefbo(iprsm)
9634 enddo
9635 fracrefb(igc) = sumf
9636 enddo
9638 do jp = 1,9
9639 iprsm = 0
9640 do igc = 1,ngc(13)
9641 sumf = 0.
9642 do ipr = 1, ngn(ngs(12)+igc)
9643 iprsm = iprsm + 1
9644 sumf = sumf + fracrefao(iprsm,jp)
9645 enddo
9646 fracrefa(igc,jp) = sumf
9647 enddo
9648 enddo
9650 end subroutine cmbgb13
9652 !***************************************************************************
9653 subroutine cmbgb14
9654 !***************************************************************************
9655 !
9656 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
9657 !
9658 ! old band 14: 2250-2380 cm-1 (low - co2; high - co2)
9659 !***************************************************************************
9661 use parrrtm, only : mg, nbndlw, ngptlw, ng14
9662 use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, &
9663 selfrefo, forrefo, &
9664 fracrefa, fracrefb, absa, ka, absb, kb, &
9665 selfref, forref
9667 ! ------- Local -------
9668 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9669 real(kind=rb) :: sumk, sumf1, sumf2
9672 do jt = 1,5
9673 do jp = 1,13
9674 iprsm = 0
9675 do igc = 1,ngc(14)
9676 sumk = 0.
9677 do ipr = 1, ngn(ngs(13)+igc)
9678 iprsm = iprsm + 1
9679 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
9680 enddo
9681 ka(jt,jp,igc) = sumk
9682 enddo
9683 enddo
9684 enddo
9686 do jt = 1,5
9687 do jp = 13,59
9688 iprsm = 0
9689 do igc = 1,ngc(14)
9690 sumk = 0.
9691 do ipr = 1, ngn(ngs(13)+igc)
9692 iprsm = iprsm + 1
9693 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
9694 enddo
9695 kb(jt,jp,igc) = sumk
9696 enddo
9697 enddo
9698 enddo
9700 do jt = 1,10
9701 iprsm = 0
9702 do igc = 1,ngc(14)
9703 sumk = 0.
9704 do ipr = 1, ngn(ngs(13)+igc)
9705 iprsm = iprsm + 1
9706 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
9707 enddo
9708 selfref(jt,igc) = sumk
9709 enddo
9710 enddo
9712 do jt = 1,4
9713 iprsm = 0
9714 do igc = 1,ngc(14)
9715 sumk = 0.
9716 do ipr = 1, ngn(ngs(13)+igc)
9717 iprsm = iprsm + 1
9718 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
9719 enddo
9720 forref(jt,igc) = sumk
9721 enddo
9722 enddo
9724 iprsm = 0
9725 do igc = 1,ngc(14)
9726 sumf1= 0.
9727 sumf2= 0.
9728 do ipr = 1, ngn(ngs(13)+igc)
9729 iprsm = iprsm + 1
9730 sumf1= sumf1+ fracrefao(iprsm)
9731 sumf2= sumf2+ fracrefbo(iprsm)
9732 enddo
9733 fracrefa(igc) = sumf1
9734 fracrefb(igc) = sumf2
9735 enddo
9737 end subroutine cmbgb14
9739 !***************************************************************************
9740 subroutine cmbgb15
9741 !***************************************************************************
9742 !
9743 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
9744 ! (high - nothing)
9745 !
9746 ! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
9747 !***************************************************************************
9749 use parrrtm, only : mg, nbndlw, ngptlw, ng15
9750 use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
9751 fracrefa, absa, ka, ka_mn2, selfref, forref
9753 ! ------- Local -------
9754 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9755 real(kind=rb) :: sumk, sumf
9758 do jn = 1,9
9759 do jt = 1,5
9760 do jp = 1,13
9761 iprsm = 0
9762 do igc = 1,ngc(15)
9763 sumk = 0.
9764 do ipr = 1, ngn(ngs(14)+igc)
9765 iprsm = iprsm + 1
9766 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
9767 enddo
9768 ka(jn,jt,jp,igc) = sumk
9769 enddo
9770 enddo
9771 enddo
9772 enddo
9774 do jn = 1,9
9775 do jt = 1,19
9776 iprsm = 0
9777 do igc = 1,ngc(15)
9778 sumk = 0.
9779 do ipr = 1, ngn(ngs(14)+igc)
9780 iprsm = iprsm + 1
9781 sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
9782 enddo
9783 ka_mn2(jn,jt,igc) = sumk
9784 enddo
9785 enddo
9786 enddo
9788 do jt = 1,10
9789 iprsm = 0
9790 do igc = 1,ngc(15)
9791 sumk = 0.
9792 do ipr = 1, ngn(ngs(14)+igc)
9793 iprsm = iprsm + 1
9794 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
9795 enddo
9796 selfref(jt,igc) = sumk
9797 enddo
9798 enddo
9800 do jt = 1,4
9801 iprsm = 0
9802 do igc = 1,ngc(15)
9803 sumk = 0.
9804 do ipr = 1, ngn(ngs(14)+igc)
9805 iprsm = iprsm + 1
9806 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
9807 enddo
9808 forref(jt,igc) = sumk
9809 enddo
9810 enddo
9812 do jp = 1,9
9813 iprsm = 0
9814 do igc = 1,ngc(15)
9815 sumf = 0.
9816 do ipr = 1, ngn(ngs(14)+igc)
9817 iprsm = iprsm + 1
9818 sumf = sumf + fracrefao(iprsm,jp)
9819 enddo
9820 fracrefa(igc,jp) = sumf
9821 enddo
9822 enddo
9824 end subroutine cmbgb15
9826 !***************************************************************************
9827 subroutine cmbgb16
9828 !***************************************************************************
9829 !
9830 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
9831 !
9832 ! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
9833 !***************************************************************************
9835 use parrrtm, only : mg, nbndlw, ngptlw, ng16
9836 use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
9837 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
9839 ! ------- Local -------
9840 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9841 real(kind=rb) :: sumk, sumf
9844 do jn = 1,9
9845 do jt = 1,5
9846 do jp = 1,13
9847 iprsm = 0
9848 do igc = 1,ngc(16)
9849 sumk = 0.
9850 do ipr = 1, ngn(ngs(15)+igc)
9851 iprsm = iprsm + 1
9852 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
9853 enddo
9854 ka(jn,jt,jp,igc) = sumk
9855 enddo
9856 enddo
9857 enddo
9858 enddo
9860 do jt = 1,5
9861 do jp = 13,59
9862 iprsm = 0
9863 do igc = 1,ngc(16)
9864 sumk = 0.
9865 do ipr = 1, ngn(ngs(15)+igc)
9866 iprsm = iprsm + 1
9867 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
9868 enddo
9869 kb(jt,jp,igc) = sumk
9870 enddo
9871 enddo
9872 enddo
9874 do jt = 1,10
9875 iprsm = 0
9876 do igc = 1,ngc(16)
9877 sumk = 0.
9878 do ipr = 1, ngn(ngs(15)+igc)
9879 iprsm = iprsm + 1
9880 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
9881 enddo
9882 selfref(jt,igc) = sumk
9883 enddo
9884 enddo
9886 do jt = 1,4
9887 iprsm = 0
9888 do igc = 1,ngc(16)
9889 sumk = 0.
9890 do ipr = 1, ngn(ngs(15)+igc)
9891 iprsm = iprsm + 1
9892 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
9893 enddo
9894 forref(jt,igc) = sumk
9895 enddo
9896 enddo
9898 iprsm = 0
9899 do igc = 1,ngc(16)
9900 sumf = 0.
9901 do ipr = 1, ngn(ngs(15)+igc)
9902 iprsm = iprsm + 1
9903 sumf = sumf + fracrefbo(iprsm)
9904 enddo
9905 fracrefb(igc) = sumf
9906 enddo
9908 do jp = 1,9
9909 iprsm = 0
9910 do igc = 1,ngc(16)
9911 sumf = 0.
9912 do ipr = 1, ngn(ngs(15)+igc)
9913 iprsm = iprsm + 1
9914 sumf = sumf + fracrefao(iprsm,jp)
9915 enddo
9916 fracrefa(igc,jp) = sumf
9917 enddo
9918 enddo
9920 end subroutine cmbgb16
9922 !***************************************************************************
9923 subroutine lwcldpr
9924 !***************************************************************************
9926 ! --------- Modules ----------
9928 use rrlw_cld, only: abscld1, absliq0, absliq1, &
9929 absice0, absice1, absice2, absice3
9931 save
9933 ! ABSCLDn is the liquid water absorption coefficient (m2/g).
9934 ! For INFLAG = 1.
9935 abscld1 = 0.0602410_rb
9936 !
9937 ! Everything below is for INFLAG = 2.
9939 ! ABSICEn(J,IB) are the parameters needed to compute the liquid water
9940 ! absorption coefficient in spectral region IB for ICEFLAG=n. The units
9941 ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)).
9942 ! For ICEFLAG = 0.
9944 absice0(:)= (/0.005_rb, 1.0_rb/)
9946 ! For ICEFLAG = 1.
9947 absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/)
9948 absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /)
9950 ! For ICEFLAG = 2. In each band, the absorption
9951 ! coefficients are listed for a range of effective radii from 5.0
9952 ! to 131.0 microns in increments of 3.0 microns.
9953 ! Spherical Ice Particle Parameterization
9954 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
9955 absice2(:,1) = (/ &
9956 ! band 1
9957 7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, &
9958 3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, &
9959 2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, &
9960 2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, &
9961 1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, &
9962 1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, &
9963 1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, &
9964 8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, &
9965 7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/)
9966 absice2(:,2) = (/ &
9967 ! band 2
9968 2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, &
9969 2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, &
9970 2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, &
9971 1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, &
9972 1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, &
9973 1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, &
9974 9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, &
9975 7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, &
9976 5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/)
9977 absice2(:,3) = (/ &
9978 ! band 3
9979 1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, &
9980 4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, &
9981 2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, &
9982 2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, &
9983 1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, &
9984 1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, &
9985 9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, &
9986 7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, &
9987 5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/)
9988 absice2(:,4) = (/ &
9989 ! band 4
9990 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, &
9991 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, &
9992 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, &
9993 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, &
9994 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, &
9995 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, &
9996 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, &
9997 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, &
9998 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/)
9999 absice2(:,5) = (/ &
10000 ! band 5
10001 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, &
10002 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, &
10003 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, &
10004 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, &
10005 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, &
10006 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, &
10007 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, &
10008 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, &
10009 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/)
10010 absice2(:,6) = (/ &
10011 ! band 6
10012 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, &
10013 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, &
10014 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, &
10015 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, &
10016 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, &
10017 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, &
10018 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, &
10019 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, &
10020 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/)
10021 absice2(:,7) = (/ &
10022 ! band 7
10023 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, &
10024 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, &
10025 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, &
10026 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, &
10027 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, &
10028 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, &
10029 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, &
10030 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, &
10031 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/)
10032 absice2(:,8) = (/ &
10033 ! band 8
10034 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, &
10035 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, &
10036 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, &
10037 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, &
10038 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, &
10039 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, &
10040 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, &
10041 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, &
10042 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/)
10043 absice2(:,9) = (/ &
10044 ! band 9
10045 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, &
10046 4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, &
10047 2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, &
10048 1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, &
10049 1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, &
10050 1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, &
10051 8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, &
10052 7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, &
10053 6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/)
10054 absice2(:,10) = (/ &
10055 ! band 10
10056 1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, &
10057 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, &
10058 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, &
10059 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, &
10060 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, &
10061 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, &
10062 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, &
10063 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, &
10064 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/)
10065 absice2(:,11) = (/ &
10066 ! band 11
10067 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, &
10068 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, &
10069 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, &
10070 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, &
10071 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, &
10072 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, &
10073 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, &
10074 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, &
10075 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/)
10076 absice2(:,12) = (/ &
10077 ! band 12
10078 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, &
10079 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, &
10080 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, &
10081 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, &
10082 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, &
10083 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, &
10084 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, &
10085 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, &
10086 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/)
10087 absice2(:,13) = (/ &
10088 ! band 13
10089 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, &
10090 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, &
10091 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, &
10092 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, &
10093 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, &
10094 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, &
10095 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, &
10096 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, &
10097 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/)
10098 absice2(:,14) = (/ &
10099 ! band 14
10100 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, &
10101 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, &
10102 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, &
10103 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, &
10104 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, &
10105 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, &
10106 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, &
10107 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, &
10108 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/)
10109 absice2(:,15) = (/ &
10110 ! band 15
10111 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, &
10112 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, &
10113 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, &
10114 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, &
10115 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, &
10116 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, &
10117 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, &
10118 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, &
10119 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/)
10120 absice2(:,16) = (/ &
10121 ! band 16
10122 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, &
10123 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, &
10124 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, &
10125 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, &
10126 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, &
10127 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, &
10128 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, &
10129 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, &
10130 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/)
10132 ! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in
10133 ! increments of 3 microns.
10134 ! units = m2/g
10135 ! Hexagonal Ice Particle Parameterization
10136 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10137 absice3(:,1) = (/ &
10138 ! band 1
10139 3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, &
10140 5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, &
10141 3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, &
10142 2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, &
10143 1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, &
10144 1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, &
10145 1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, &
10146 1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, &
10147 1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, &
10148 9.602126e-03_rb/)
10149 absice3(:,2) = (/ &
10150 ! band 2
10151 3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, &
10152 2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, &
10153 2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, &
10154 1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, &
10155 1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, &
10156 1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, &
10157 1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, &
10158 8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, &
10159 7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, &
10160 6.326424e-03_rb/)
10161 absice3(:,3) = (/ &
10162 ! band 3
10163 6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, &
10164 5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, &
10165 3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, &
10166 2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, &
10167 1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, &
10168 1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, &
10169 1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, &
10170 9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, &
10171 8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, &
10172 6.769036e-03_rb/)
10173 absice3(:,4) = (/ &
10174 ! band 4
10175 1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, &
10176 6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, &
10177 3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, &
10178 2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, &
10179 1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, &
10180 1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, &
10181 1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, &
10182 1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, &
10183 8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, &
10184 7.621418e-03_rb/)
10185 absice3(:,5) = (/ &
10186 ! band 5
10187 2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, &
10188 7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, &
10189 4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, &
10190 2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, &
10191 2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, &
10192 1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, &
10193 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, &
10194 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, &
10195 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, &
10196 7.890412e-03_rb/)
10197 absice3(:,6) = (/ &
10198 ! band 6
10199 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, &
10200 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, &
10201 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, &
10202 2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, &
10203 1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, &
10204 1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, &
10205 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, &
10206 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, &
10207 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, &
10208 8.114723e-03_rb/)
10209 absice3(:,7) = (/ &
10210 ! band 7
10211 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, &
10212 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, &
10213 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, &
10214 2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, &
10215 1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, &
10216 1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, &
10217 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, &
10218 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, &
10219 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, &
10220 7.026186e-03_rb/)
10221 absice3(:,8) = (/ &
10222 ! band 8
10223 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, &
10224 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, &
10225 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, &
10226 2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, &
10227 1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, &
10228 1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, &
10229 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, &
10230 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, &
10231 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, &
10232 7.060305e-03_rb/)
10233 absice3(:,9) = (/ &
10234 ! band 9
10235 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, &
10236 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, &
10237 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, &
10238 2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, &
10239 1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, &
10240 1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, &
10241 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, &
10242 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, &
10243 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, &
10244 7.964013e-03_rb/)
10245 absice3(:,10) = (/ &
10246 ! band 10
10247 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, &
10248 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, &
10249 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, &
10250 2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, &
10251 1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, &
10252 1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, &
10253 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, &
10254 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, &
10255 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, &
10256 8.442725e-03_rb/)
10257 absice3(:,11) = (/ &
10258 ! band 11
10259 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, &
10260 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, &
10261 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, &
10262 2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, &
10263 1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, &
10264 1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, &
10265 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, &
10266 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, &
10267 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, &
10268 8.422115e-03_rb/)
10269 absice3(:,12) = (/ &
10270 ! band 12
10271 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, &
10272 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, &
10273 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, &
10274 1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, &
10275 1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, &
10276 1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, &
10277 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, &
10278 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, &
10279 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, &
10280 7.947730e-03_rb/)
10281 absice3(:,13) = (/ &
10282 ! band 13
10283 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, &
10284 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, &
10285 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, &
10286 2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, &
10287 1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, &
10288 1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, &
10289 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, &
10290 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, &
10291 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, &
10292 8.652951e-03_rb/)
10293 absice3(:,14) = (/ &
10294 ! band 14
10295 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, &
10296 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, &
10297 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, &
10298 2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, &
10299 1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, &
10300 1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, &
10301 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, &
10302 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, &
10303 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, &
10304 8.785184e-03_rb/)
10305 absice3(:,15) = (/ &
10306 ! band 15
10307 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, &
10308 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, &
10309 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, &
10310 1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, &
10311 1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, &
10312 1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, &
10313 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, &
10314 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, &
10315 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, &
10316 8.560232e-03_rb/)
10317 absice3(:,16) = (/ &
10318 ! band 16
10319 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, &
10320 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, &
10321 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, &
10322 2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, &
10323 1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, &
10324 1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, &
10325 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, &
10326 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, &
10327 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, &
10328 8.123136e-03_rb/)
10330 ! For LIQFLAG = 0.
10331 absliq0 = 0.0903614_rb
10333 ! For LIQFLAG = 1. In each band, the absorption
10334 ! coefficients are listed for a range of effective radii from 2.5
10335 ! to 59.5 microns in increments of 1.0 micron.
10336 absliq1(:, 1) = (/ &
10337 ! band 1
10338 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, &
10339 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, &
10340 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, &
10341 5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, &
10342 4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, &
10343 3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, &
10344 3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, &
10345 2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, &
10346 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, &
10347 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, &
10348 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, &
10349 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/)
10350 absliq1(:, 2) = (/ &
10351 ! band 2
10352 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, &
10353 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, &
10354 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, &
10355 5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, &
10356 4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, &
10357 3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, &
10358 2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, &
10359 2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, &
10360 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, &
10361 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, &
10362 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, &
10363 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/)
10364 absliq1(:, 3) = (/ &
10365 ! band 3
10366 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, &
10367 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, &
10368 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, &
10369 5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, &
10370 4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, &
10371 3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, &
10372 2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, &
10373 2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, &
10374 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, &
10375 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, &
10376 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, &
10377 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/)
10378 absliq1(:, 4) = (/ &
10379 ! band 4
10380 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, &
10381 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, &
10382 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, &
10383 5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, &
10384 3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, &
10385 3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, &
10386 2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, &
10387 2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, &
10388 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, &
10389 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, &
10390 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, &
10391 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/)
10392 absliq1(:, 5) = (/ &
10393 ! band 5
10394 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, &
10395 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, &
10396 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, &
10397 5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, &
10398 3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, &
10399 3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, &
10400 2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, &
10401 2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, &
10402 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, &
10403 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, &
10404 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, &
10405 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/)
10406 absliq1(:, 6) = (/ &
10407 ! band 6
10408 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, &
10409 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, &
10410 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, &
10411 4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, &
10412 3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, &
10413 3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, &
10414 2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, &
10415 2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, &
10416 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, &
10417 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, &
10418 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, &
10419 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/)
10420 absliq1(:, 7) = (/ &
10421 ! band 7
10422 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, &
10423 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, &
10424 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, &
10425 4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, &
10426 3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, &
10427 2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, &
10428 2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, &
10429 2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, &
10430 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, &
10431 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, &
10432 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, &
10433 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/)
10434 absliq1(:, 8) = (/ &
10435 ! band 8
10436 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, &
10437 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, &
10438 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, &
10439 4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, &
10440 3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, &
10441 2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, &
10442 2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, &
10443 2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, &
10444 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, &
10445 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, &
10446 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, &
10447 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/)
10448 absliq1(:, 9) = (/ &
10449 ! band 9
10450 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, &
10451 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, &
10452 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, &
10453 4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, &
10454 3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, &
10455 2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, &
10456 2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, &
10457 2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, &
10458 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, &
10459 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, &
10460 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, &
10461 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/)
10462 absliq1(:,10) = (/ &
10463 ! band 10
10464 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, &
10465 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, &
10466 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, &
10467 4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, &
10468 3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, &
10469 2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, &
10470 2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, &
10471 2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, &
10472 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, &
10473 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, &
10474 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, &
10475 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/)
10476 absliq1(:,11) = (/ &
10477 ! band 11
10478 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, &
10479 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, &
10480 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, &
10481 4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, &
10482 3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, &
10483 2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, &
10484 2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, &
10485 2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, &
10486 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, &
10487 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, &
10488 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, &
10489 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/)
10490 absliq1(:,12) = (/ &
10491 ! band 12
10492 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, &
10493 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, &
10494 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, &
10495 2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, &
10496 2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, &
10497 2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, &
10498 1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, &
10499 1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, &
10500 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, &
10501 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, &
10502 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, &
10503 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/)
10504 absliq1(:,13) = (/ &
10505 ! band 13
10506 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, &
10507 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, &
10508 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, &
10509 3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, &
10510 2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, &
10511 2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, &
10512 2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, &
10513 1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, &
10514 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, &
10515 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, &
10516 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, &
10517 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/)
10518 absliq1(:,14) = (/ &
10519 ! band 14
10520 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, &
10521 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, &
10522 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, &
10523 2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, &
10524 2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, &
10525 2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, &
10526 1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, &
10527 1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, &
10528 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, &
10529 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, &
10530 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, &
10531 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/)
10532 absliq1(:,15) = (/ &
10533 ! band 15
10534 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, &
10535 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, &
10536 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, &
10537 1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, &
10538 1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, &
10539 1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, &
10540 1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, &
10541 1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, &
10542 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, &
10543 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, &
10544 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, &
10545 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/)
10546 absliq1(:,16) = (/ &
10547 ! band 16
10548 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, &
10549 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, &
10550 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, &
10551 2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, &
10552 2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, &
10553 2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, &
10554 1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, &
10555 1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, &
10556 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, &
10557 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, &
10558 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, &
10559 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/)
10561 end subroutine lwcldpr
10563 end module rrtmg_lw_init
10565 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
10566 ! author: $Author: trn $
10567 ! revision: $Revision: 1.3 $
10568 ! created: $Date: 2009/04/16 19:54:22 $
10569 !
10570 module rrtmg_lw_rad
10572 ! --------------------------------------------------------------------------
10573 ! | |
10574 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
10575 ! | This software may be used, copied, or redistributed as long as it is |
10576 ! | not sold and this copyright notice is reproduced on each copy made. |
10577 ! | This model is provided as is without any express or implied warranties. |
10578 ! | (http://www.rtweb.aer.com/) |
10579 ! | |
10580 ! --------------------------------------------------------------------------
10581 !
10582 ! ****************************************************************************
10583 ! * *
10584 ! * RRTMG_LW *
10585 ! * *
10586 ! * *
10587 ! * *
10588 ! * a rapid radiative transfer model *
10589 ! * for the longwave region *
10590 ! * for application to general circulation models *
10591 ! * *
10592 ! * *
10593 ! * Atmospheric and Environmental Research, Inc. *
10594 ! * 131 Hartwell Avenue *
10595 ! * Lexington, MA 02421 *
10596 ! * *
10597 ! * *
10598 ! * Eli J. Mlawer *
10599 ! * Jennifer S. Delamere *
10600 ! * Michael J. Iacono *
10601 ! * Shepard A. Clough *
10602 ! * *
10603 ! * *
10604 ! * *
10605 ! * *
10606 ! * *
10607 ! * *
10608 ! * email: miacono@aer.com *
10609 ! * email: emlawer@aer.com *
10610 ! * email: jdelamer@aer.com *
10611 ! * *
10612 ! * The authors wish to acknowledge the contributions of the *
10613 ! * following people: Steven J. Taubman, Karen Cady-Pereira, *
10614 ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
10615 ! * *
10616 ! ****************************************************************************
10618 ! -------- Modules --------
10619 use parkind, only : im => kind_im, rb => kind_rb
10620 use rrlw_vsn
10621 use mcica_subcol_gen_lw, only: mcica_subcol_lw
10622 use rrtmg_lw_cldprmc, only: cldprmc
10623 ! *** Move the required call to rrtmg_lw_ini below and the following
10624 ! use association to the GCM initialization area ***
10625 ! use rrtmg_lw_init, only: rrtmg_lw_ini
10626 use rrtmg_lw_rtrnmc, only: rtrnmc
10627 use rrtmg_lw_setcoef, only: setcoef
10628 use rrtmg_lw_taumol, only: taumol
10630 implicit none
10632 ! public interfaces/functions/subroutines
10633 public :: rrtmg_lw, inatm
10635 !------------------------------------------------------------------
10636 contains
10637 !------------------------------------------------------------------
10639 !------------------------------------------------------------------
10640 ! Public subroutines
10641 !------------------------------------------------------------------
10643 subroutine rrtmg_lw &
10644 (ncol ,nlay ,icld , &
10645 play ,plev ,tlay ,tlev ,tsfc , &
10646 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
10647 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
10648 inflglw ,iceflglw,liqflglw,cldfmcl , &
10649 taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
10650 tauaer , &
10651 uflx ,dflx ,hr ,uflxc ,dflxc, hrc)
10653 ! -------- Description --------
10655 ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation
10656 ! model for application to GCMs, that has been adapted from RRTM_LW for
10657 ! improved efficiency.
10658 !
10659 ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization
10660 ! area, since this has to be called only once.
10661 !
10662 ! This routine:
10663 ! a) calls INATM to read in the atmospheric profile from GCM;
10664 ! all layering in RRTMG is ordered from surface to toa.
10665 ! b) calls CLDPRMC to set cloud optical depth for McICA based
10666 ! on input cloud properties
10667 ! c) calls SETCOEF to calculate various quantities needed for
10668 ! the radiative transfer algorithm
10669 ! d) calls TAUMOL to calculate gaseous optical depths for each
10670 ! of the 16 spectral bands
10671 ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the
10672 ! radiative transfer calculation using McICA, the Monte-Carlo
10673 ! Independent Column Approximation, to represent sub-grid scale
10674 ! cloud variability
10675 ! f) passes the necessary fluxes and cooling rates back to GCM
10676 !
10677 ! Two modes of operation are possible:
10678 ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
10679 ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM.
10680 !
10681 ! 1) Standard, single forward model calculation (imca = 0)
10682 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
10683 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
10684 !
10685 ! This call to RRTMG_LW must be preceeded by a call to the module
10686 ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
10687 ! which will provide the cloud physical or cloud optical properties
10688 ! on the RRTMG quadrature point (ngpt) dimension.
10689 ! Two random number generators are available for use when imca = 1.
10690 ! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
10691 ! 1) KISSVEC (irnd = 0)
10692 ! 2) Mersenne-Twister (irnd = 1)
10693 !
10694 ! Two methods of cloud property input are possible:
10695 ! Cloud properties can be input in one of two ways (controlled by input
10696 ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
10697 ! and subroutine rrtmg_lw_cldprop.f90 for further details):
10698 !
10699 ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
10700 ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);
10701 ! cloud optical properties are calculated by cldprop or cldprmc based
10702 ! on input settings of iceflglw and liqflglw. Ice particle size provided
10703 ! must be appropriately defined for the ice parameterization selected.
10704 !
10705 ! One method of aerosol property input is possible:
10706 ! Aerosol properties can be input in only one way (controlled by input
10707 ! flag iaer; see text file rrtmg_lw_instructions for further details):
10708 !
10709 ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10);
10710 ! band average optical depth at the mid-point of each spectral band.
10711 ! RRTMG_LW currently treats only aerosol absorption;
10712 ! scattering capability is not presently available.
10713 !
10714 !
10715 ! ------- Modifications -------
10716 !
10717 ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced
10718 ! set of g-points for application to GCMs.
10719 !
10720 !-- Original version (derived from RRTM_LW), reduction of g-points, other
10721 ! revisions for use with GCMs.
10722 ! 1999: M. J. Iacono, AER, Inc.
10723 !-- Adapted for use with NCAR/CAM.
10724 ! May 2004: M. J. Iacono, AER, Inc.
10725 !-- Revised to add McICA capability.
10726 ! Nov 2005: M. J. Iacono, AER, Inc.
10727 !-- Conversion to F90 formatting for consistency with rrtmg_sw.
10728 ! Feb 2007: M. J. Iacono, AER, Inc.
10729 !-- Modifications to formatting to use assumed-shape arrays.
10730 ! Aug 2007: M. J. Iacono, AER, Inc.
10731 !-- Modified to add longwave aerosol absorption.
10732 ! Apr 2008: M. J. Iacono, AER, Inc.
10734 ! --------- Modules ----------
10736 use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol
10737 use rrlw_con, only: fluxfac, heatfac, oneminus, pi
10738 use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
10740 ! ------- Declarations -------
10742 ! ----- Input -----
10743 integer(kind=im), intent(in) :: ncol ! Number of horizontal columns
10744 integer(kind=im), intent(in) :: nlay ! Number of model layers
10745 integer(kind=im), intent(inout) :: icld ! Cloud overlap method
10746 ! 0: Clear only
10747 ! 1: Random
10748 ! 2: Maximum/random
10749 ! 3: Maximum
10750 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
10751 ! Dimensions: (ncol,nlay)
10752 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
10753 ! Dimensions: (ncol,nlay+1)
10754 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
10755 ! Dimensions: (ncol,nlay)
10756 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
10757 ! Dimensions: (ncol,nlay+1)
10758 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
10759 ! Dimensions: (ncol)
10760 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
10761 ! Dimensions: (ncol,nlay)
10762 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
10763 ! Dimensions: (ncol,nlay)
10764 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
10765 ! Dimensions: (ncol,nlay)
10766 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
10767 ! Dimensions: (ncol,nlay)
10768 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
10769 ! Dimensions: (ncol,nlay)
10770 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
10771 ! Dimensions: (ncol,nlay)
10772 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
10773 ! Dimensions: (ncol,nlay)
10774 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
10775 ! Dimensions: (ncol,nlay)
10776 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
10777 ! Dimensions: (ncol,nlay)
10778 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
10779 ! Dimensions: (ncol,nlay)
10780 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
10781 ! Dimensions: (ncol,nbndlw)
10783 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
10784 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
10785 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
10787 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
10788 ! Dimensions: (ngptlw,ncol,nlay)
10789 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
10790 ! Dimensions: (ngptlw,ncol,nlay)
10791 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
10792 ! Dimensions: (ngptlw,ncol,nlay)
10793 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice particle effective size (microns)
10794 ! Dimensions: (ncol,nlay)
10795 ! specific definition of reicmcl depends on setting of iceflglw:
10796 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
10797 ! r_ec must be >= 10.0 microns
10798 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
10799 ! r_ec range is limited to 13.0 to 130.0 microns
10800 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
10801 ! r_k range is limited to 5.0 to 131.0 microns
10802 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
10803 ! dge range is limited to 5.0 to 140.0 microns
10804 ! [dge = 1.0315 * r_ec]
10805 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
10806 ! Dimensions: (ncol,nlay)
10807 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
10808 ! Dimensions: (ngptlw,ncol,nlay)
10809 ! real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
10810 ! Dimensions: (ngptlw,ncol,nlay)
10811 ! for future expansion
10812 ! lw scattering not yet available
10813 ! real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
10814 ! Dimensions: (ngptlw,ncol,nlay)
10815 ! for future expansion
10816 ! lw scattering not yet available
10817 real(kind=rb), intent(in) :: tauaer(:,:,:) ! aerosol optical depth
10818 ! at mid-point of LW spectral bands
10819 ! Dimensions: (ncol,nlay,nbndlw)
10820 ! real(kind=rb), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo
10821 ! Dimensions: (ncol,nlay,nbndlw)
10822 ! for future expansion
10823 ! (lw aerosols/scattering not yet available)
10824 ! real(kind=rb), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter
10825 ! Dimensions: (ncol,nlay,nbndlw)
10826 ! for future expansion
10827 ! (lw aerosols/scattering not yet available)
10829 ! ----- Output -----
10831 real(kind=rb), intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2)
10832 ! Dimensions: (ncol,nlay+1)
10833 real(kind=rb), intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2)
10834 ! Dimensions: (ncol,nlay+1)
10835 real(kind=rb), intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d)
10836 ! Dimensions: (ncol,nlay)
10837 real(kind=rb), intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2)
10838 ! Dimensions: (ncol,nlay+1)
10839 real(kind=rb), intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2)
10840 ! Dimensions: (ncol,nlay+1)
10841 real(kind=rb), intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d)
10842 ! Dimensions: (ncol,nlay)
10844 ! ----- Local -----
10846 ! Control
10847 integer(kind=im) :: nlayers ! total number of layers
10848 integer(kind=im) :: istart ! beginning band of calculation
10849 integer(kind=im) :: iend ! ending band of calculation
10850 integer(kind=im) :: iout ! output option flag (inactive)
10851 integer(kind=im) :: iaer ! aerosol option flag
10852 integer(kind=im) :: iplon ! column loop index
10853 integer(kind=im) :: imca ! flag for mcica [0=off, 1=on]
10854 integer(kind=im) :: ims ! value for changing mcica permute seed
10855 integer(kind=im) :: k ! layer loop index
10856 integer(kind=im) :: ig ! g-point loop index
10858 ! Atmosphere
10859 real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb)
10860 real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K)
10861 real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb)
10862 real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K)
10863 real(kind=rb) :: tbound ! surface temperature (K)
10864 real(kind=rb) :: coldry(nlay+1) ! dry air column density (mol/cm2)
10865 real(kind=rb) :: wbrodl(nlay+1) ! broadening gas column density (mol/cm2)
10866 real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2)
10867 real(kind=rb) :: wx(maxxsec,nlay+1) ! cross-section amounts (mol/cm-2)
10868 real(kind=rb) :: pwvcm ! precipitable water vapor (cm)
10869 real(kind=rb) :: semiss(nbndlw) ! lw surface emissivity
10870 real(kind=rb) :: fracs(nlay+1,ngptlw) !
10871 real(kind=rb) :: taug(nlay+1,ngptlw) ! gaseous optical depths
10872 real(kind=rb) :: taut(nlay+1,ngptlw) ! gaseous + aerosol optical depths
10874 real(kind=rb) :: taua(nlay+1,nbndlw) ! aerosol optical depth
10875 ! real(kind=rb) :: ssaa(nlay+1,nbndlw) ! aerosol single scattering albedo
10876 ! for future expansion
10877 ! (lw aerosols/scattering not yet available)
10878 ! real(kind=rb) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter
10879 ! for future expansion
10880 ! (lw aerosols/scattering not yet available)
10882 ! Atmosphere - setcoef
10883 integer(kind=im) :: laytrop ! tropopause layer index
10884 integer(kind=im) :: jp(nlay+1) ! lookup table index
10885 integer(kind=im) :: jt(nlay+1) ! lookup table index
10886 integer(kind=im) :: jt1(nlay+1) ! lookup table index
10887 real(kind=rb) :: planklay(nlay+1,nbndlw)!
10888 real(kind=rb) :: planklev(0:nlay+1,nbndlw)!
10889 real(kind=rb) :: plankbnd(nbndlw) !
10891 real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o)
10892 real(kind=rb) :: colco2(nlay+1) ! column amount (co2)
10893 real(kind=rb) :: colo3(nlay+1) ! column amount (o3)
10894 real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o)
10895 real(kind=rb) :: colco(nlay+1) ! column amount (co)
10896 real(kind=rb) :: colch4(nlay+1) ! column amount (ch4)
10897 real(kind=rb) :: colo2(nlay+1) ! column amount (o2)
10898 real(kind=rb) :: colbrd(nlay+1) ! column amount (broadening gases)
10900 integer(kind=im) :: indself(nlay+1)
10901 integer(kind=im) :: indfor(nlay+1)
10902 real(kind=rb) :: selffac(nlay+1)
10903 real(kind=rb) :: selffrac(nlay+1)
10904 real(kind=rb) :: forfac(nlay+1)
10905 real(kind=rb) :: forfrac(nlay+1)
10907 integer(kind=im) :: indminor(nlay+1)
10908 real(kind=rb) :: minorfrac(nlay+1)
10909 real(kind=rb) :: scaleminor(nlay+1)
10910 real(kind=rb) :: scaleminorn2(nlay+1)
10912 real(kind=rb) :: & !
10913 fac00(nlay+1), fac01(nlay+1), &
10914 fac10(nlay+1), fac11(nlay+1)
10915 real(kind=rb) :: & !
10916 rat_h2oco2(nlay+1),rat_h2oco2_1(nlay+1), &
10917 rat_h2oo3(nlay+1),rat_h2oo3_1(nlay+1), &
10918 rat_h2on2o(nlay+1),rat_h2on2o_1(nlay+1), &
10919 rat_h2och4(nlay+1),rat_h2och4_1(nlay+1), &
10920 rat_n2oco2(nlay+1),rat_n2oco2_1(nlay+1), &
10921 rat_o3co2(nlay+1),rat_o3co2_1(nlay+1)
10923 ! Atmosphere/clouds - cldprop
10924 integer(kind=im) :: ncbands ! number of cloud spectral bands
10925 integer(kind=im) :: inflag ! flag for cloud property method
10926 integer(kind=im) :: iceflag ! flag for ice cloud properties
10927 integer(kind=im) :: liqflag ! flag for liquid cloud properties
10929 ! Atmosphere/clouds - cldprmc [mcica]
10930 real(kind=rb) :: cldfmc(ngptlw,nlay+1) ! cloud fraction [mcica]
10931 real(kind=rb) :: ciwpmc(ngptlw,nlay+1) ! in-cloud ice water path [mcica]
10932 real(kind=rb) :: clwpmc(ngptlw,nlay+1) ! in-cloud liquid water path [mcica]
10933 real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns)
10934 real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns)
10935 real(kind=rb) :: taucmc(ngptlw,nlay+1) ! in-cloud optical depth [mcica]
10936 ! real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica]
10937 ! for future expansion
10938 ! (lw scattering not yet available)
10939 ! real(kind=rb) :: asmcmc(ngptlw,nlay+1) ! in-cloud asymmetry parameter [mcica]
10940 ! for future expansion
10941 ! (lw scattering not yet available)
10943 ! Output
10944 real(kind=rb) :: totuflux(0:nlay+1) ! upward longwave flux (w/m2)
10945 real(kind=rb) :: totdflux(0:nlay+1) ! downward longwave flux (w/m2)
10946 real(kind=rb) :: fnet(0:nlay+1) ! net longwave flux (w/m2)
10947 real(kind=rb) :: htr(0:nlay+1) ! longwave heating rate (k/day)
10948 real(kind=rb) :: totuclfl(0:nlay+1) ! clear sky upward longwave flux (w/m2)
10949 real(kind=rb) :: totdclfl(0:nlay+1) ! clear sky downward longwave flux (w/m2)
10950 real(kind=rb) :: fnetc(0:nlay+1) ! clear sky net longwave flux (w/m2)
10951 real(kind=rb) :: htrc(0:nlay+1) ! clear sky longwave heating rate (k/day)
10953 !
10954 ! Initializations
10956 oneminus = 1._rb - 1.e-6_rb
10957 pi = 2._rb * asin(1._rb)
10958 fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4
10959 istart = 1
10960 iend = 16
10961 iout = 0
10962 ims = 1
10964 ! Set imca to select calculation type:
10965 ! imca = 0, use standard forward model calculation
10966 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
10968 ! *** This version uses McICA (imca = 1) ***
10970 ! Set icld to select of clear or cloud calculation and cloud overlap method
10971 ! icld = 0, clear only
10972 ! icld = 1, with clouds using random cloud overlap
10973 ! icld = 2, with clouds using maximum/random cloud overlap
10974 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
10975 if (icld.lt.0.or.icld.gt.3) icld = 2
10977 ! Set iaer to select aerosol option
10978 ! iaer = 0, no aerosols
10979 ! icld = 10, input total aerosol optical depth (tauaer) directly
10980 iaer = 10
10982 ! Call model and data initialization, compute lookup tables, perform
10983 ! reduction of g-points from 256 to 140 for input absorption coefficient
10984 ! data and other arrays.
10985 !
10986 ! In a GCM this call should be placed in the model initialization
10987 ! area, since this has to be called only once.
10988 ! call rrtmg_lw_ini(cpdair)
10990 ! This is the main longitude/column loop within RRTMG.
10991 do iplon = 1, ncol
10993 ! Prepare atmospheric profile from GCM for use in RRTMG, and define
10994 ! other input parameters.
10996 call inatm (iplon, nlay, icld, iaer, &
10997 play, plev, tlay, tlev, tsfc, h2ovmr, &
10998 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
10999 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
11000 cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
11001 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
11002 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
11003 cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
11005 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
11006 ! input cloud physical properties. Select method based on choices described
11007 ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
11008 ! effective radius must be passed into cldprop. Cloud fraction and cloud
11009 ! optical depth are transferred to rrtmg_lw arrays in cldprop.
11011 call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, &
11012 clwpmc, reicmc, relqmc, ncbands, taucmc)
11014 ! Calculate information needed by the radiative transfer routine
11015 ! that is specific to this atmosphere, especially some of the
11016 ! coefficients and indices needed to compute the optical depths
11017 ! by interpolating data from stored reference atmospheres.
11019 call setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
11020 coldry, wkl, wbrodl, &
11021 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
11022 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
11023 colbrd, fac00, fac01, fac10, fac11, &
11024 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
11025 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
11026 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
11027 selffac, selffrac, indself, forfac, forfrac, indfor, &
11028 minorfrac, scaleminor, scaleminorn2, indminor)
11030 ! Calculate the gaseous optical depths and Planck fractions for
11031 ! each longwave spectral band.
11033 call taumol(nlayers, pavel, wx, coldry, &
11034 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
11035 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
11036 colbrd, fac00, fac01, fac10, fac11, &
11037 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
11038 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
11039 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
11040 selffac, selffrac, indself, forfac, forfrac, indfor, &
11041 minorfrac, scaleminor, scaleminorn2, indminor, &
11042 fracs, taug)
11045 ! Combine gaseous and aerosol optical depths, if aerosol active
11046 if (iaer .eq. 0) then
11047 do k = 1, nlayers
11048 do ig = 1, ngptlw
11049 taut(k,ig) = taug(k,ig)
11050 enddo
11051 enddo
11052 elseif (iaer .eq. 10) then
11053 do k = 1, nlayers
11054 do ig = 1, ngptlw
11055 taut(k,ig) = taug(k,ig) + taua(k,ngb(ig))
11056 enddo
11057 enddo
11058 endif
11060 ! Call the radiative transfer routine.
11061 ! Either routine can be called to do clear sky calculation. If clouds
11062 ! are present, then select routine based on cloud overlap assumption
11063 ! to be used. Clear sky calculation is done simultaneously.
11064 ! For McICA, RTRNMC is called for clear and cloudy calculations.
11066 call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
11067 cldfmc, taucmc, planklay, planklev, plankbnd, &
11068 pwvcm, fracs, taut, &
11069 totuflux, totdflux, fnet, htr, &
11070 totuclfl, totdclfl, fnetc, htrc )
11072 ! Transfer up and down fluxes and heating rate to output arrays.
11073 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
11075 do k = 0, nlayers
11076 uflx(iplon,k+1) = totuflux(k)
11077 dflx(iplon,k+1) = totdflux(k)
11078 uflxc(iplon,k+1) = totuclfl(k)
11079 dflxc(iplon,k+1) = totdclfl(k)
11080 enddo
11081 do k = 0, nlayers-1
11082 hr(iplon,k+1) = htr(k)
11083 hrc(iplon,k+1) = htrc(k)
11084 enddo
11086 enddo
11088 end subroutine rrtmg_lw
11090 !***************************************************************************
11091 subroutine inatm (iplon, nlay, icld, iaer, &
11092 play, plev, tlay, tlev, tsfc, h2ovmr, &
11093 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
11094 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
11095 cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
11096 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
11097 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
11098 cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
11099 !***************************************************************************
11100 !
11101 ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
11102 ! Set other RRTMG_LW input parameters.
11103 !
11104 !***************************************************************************
11106 ! --------- Modules ----------
11108 use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol
11109 use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad
11110 use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
11112 ! ------- Declarations -------
11114 ! ----- Input -----
11115 integer(kind=im), intent(in) :: iplon ! column loop index
11116 integer(kind=im), intent(in) :: nlay ! Number of model layers
11117 integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag
11118 integer(kind=im), intent(in) :: iaer ! aerosol option flag
11120 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
11121 ! Dimensions: (ncol,nlay)
11122 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
11123 ! Dimensions: (ncol,nlay+1)
11124 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
11125 ! Dimensions: (ncol,nlay)
11126 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
11127 ! Dimensions: (ncol,nlay+1)
11128 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
11129 ! Dimensions: (ncol)
11130 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
11131 ! Dimensions: (ncol,nlay)
11132 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
11133 ! Dimensions: (ncol,nlay)
11134 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
11135 ! Dimensions: (ncol,nlay)
11136 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
11137 ! Dimensions: (ncol,nlay)
11138 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
11139 ! Dimensions: (ncol,nlay)
11140 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
11141 ! Dimensions: (ncol,nlay)
11142 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
11143 ! Dimensions: (ncol,nlay)
11144 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
11145 ! Dimensions: (ncol,nlay)
11146 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
11147 ! Dimensions: (ncol,nlay)
11148 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
11149 ! Dimensions: (ncol,nlay)
11150 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
11151 ! Dimensions: (ncol,nbndlw)
11153 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
11154 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
11155 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
11157 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
11158 ! Dimensions: (ngptlw,ncol,nlay)
11159 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
11160 ! Dimensions: (ngptlw,ncol,nlay)
11161 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
11162 ! Dimensions: (ngptlw,ncol,nlay)
11163 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
11164 ! Dimensions: (ncol,nlay)
11165 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns)
11166 ! Dimensions: (ncol,nlay)
11167 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
11168 ! Dimensions: (ngptlw,ncol,nlay)
11169 real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth
11170 ! Dimensions: (ncol,nlay,nbndlw)
11172 ! ----- Output -----
11173 ! Atmosphere
11174 integer(kind=im), intent(out) :: nlayers ! number of layers
11176 real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb)
11177 ! Dimensions: (nlay)
11178 real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K)
11179 ! Dimensions: (nlay)
11180 real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb)
11181 ! Dimensions: (0:nlay)
11182 real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K)
11183 ! Dimensions: (0:nlay)
11184 real(kind=rb), intent(out) :: tbound ! surface temperature (K)
11185 real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2)
11186 ! Dimensions: (nlay)
11187 real(kind=rb), intent(out) :: wbrodl(:) ! broadening gas column density (mol/cm2)
11188 ! Dimensions: (nlay)
11189 real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2)
11190 ! Dimensions: (mxmol,nlay)
11191 real(kind=rb), intent(out) :: wx(:,:) ! cross-section amounts (mol/cm-2)
11192 ! Dimensions: (maxxsec,nlay)
11193 real(kind=rb), intent(out) :: pwvcm ! precipitable water vapor (cm)
11194 real(kind=rb), intent(out) :: semiss(:) ! lw surface emissivity
11195 ! Dimensions: (nbndlw)
11197 ! Atmosphere/clouds - cldprop
11198 integer(kind=im), intent(out) :: inflag ! flag for cloud property method
11199 integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties
11200 integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties
11202 real(kind=rb), intent(out) :: cldfmc(:,:) ! cloud fraction [mcica]
11203 ! Dimensions: (ngptlw,nlay)
11204 real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path [mcica]
11205 ! Dimensions: (ngptlw,nlay)
11206 real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path [mcica]
11207 ! Dimensions: (ngptlw,nlay)
11208 real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns)
11209 ! Dimensions: (nlay)
11210 real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns)
11211 ! Dimensions: (nlay)
11212 real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth [mcica]
11213 ! Dimensions: (ngptlw,nlay)
11214 real(kind=rb), intent(out) :: taua(:,:) ! aerosol optical depth
11215 ! Dimensions: (nlay,nbndlw)
11218 ! ----- Local -----
11219 real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol)
11220 real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol)
11221 ! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol)
11222 ! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol)
11223 ! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol)
11224 ! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
11225 ! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
11226 ! real(kind=rb), parameter :: amc11 = 137.3684_rb ! Molecular weight of CFC11 (g/mol) - CCL3F
11227 ! real(kind=rb), parameter :: amc12 = 120.9138_rb ! Molecular weight of CFC12 (g/mol) - CCL2F2
11228 ! real(kind=rb), parameter :: amc22 = 86.4688_rb ! Molecular weight of CFC22 (g/mol) - CHCLF2
11229 ! real(kind=rb), parameter :: amcl4 = 153.823_rb ! Molecular weight of CCL4 (g/mol) - CCL4
11231 ! Set molecular weight ratios (for converting mmr to vmr)
11232 ! e.g. h2ovmr = h2ommr * amdw)
11233 real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor
11234 real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide
11235 real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone
11236 real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane
11237 real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide
11238 real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
11239 real(kind=rb), parameter :: amdc1 = 0.210852_rb ! Molecular weight of dry air / CFC11
11240 real(kind=rb), parameter :: amdc2 = 0.239546_rb ! Molecular weight of dry air / CFC12
11242 integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices
11243 real(kind=rb) :: amm, amttl, wvttl, wvsh, summol
11245 ! Add one to nlayers here to include extra model layer at top of atmosphere
11246 nlayers = nlay
11248 ! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts
11249 ! into RRTM arrays below.
11251 wkl(:,:) = 0.0_rb
11252 wx(:,:) = 0.0_rb
11253 cldfmc(:,:) = 0.0_rb
11254 taucmc(:,:) = 0.0_rb
11255 ciwpmc(:,:) = 0.0_rb
11256 clwpmc(:,:) = 0.0_rb
11257 reicmc(:) = 0.0_rb
11258 relqmc(:) = 0.0_rb
11259 taua(:,:) = 0.0_rb
11260 amttl = 0.0_rb
11261 wvttl = 0.0_rb
11263 ! Set surface temperature.
11264 tbound = tsfc(iplon)
11266 ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature,
11267 ! and molecular amounts.
11268 ! Pressures are input in mb, or are converted to mb here.
11269 ! Molecular amounts are input in volume mixing ratio, or are converted from
11270 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
11271 ! here. These are then converted to molecular amount (molec/cm2) below.
11272 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
11273 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
11274 ! correction to account for h2o in the layer. The molecular weight of moist
11275 ! air (amm) is calculated for each layer.
11276 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
11277 ! assumes GCM input fields are also bottom to top. Input layer indexing
11278 ! from GCM fields should be reversed here if necessary.
11280 pz(0) = plev(iplon,1)
11281 tz(0) = tlev(iplon,1)
11282 do l = 1, nlayers
11283 pavel(l) = play(iplon,l)
11284 tavel(l) = tlay(iplon,l)
11285 pz(l) = plev(iplon,l+1)
11286 tz(l) = tlev(iplon,l+1)
11287 ! For h2o input in vmr:
11288 wkl(1,l) = h2ovmr(iplon,l)
11289 ! For h2o input in mmr:
11290 ! wkl(1,l) = h2o(iplon,l)*amdw
11291 ! For h2o input in specific humidity;
11292 ! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
11293 wkl(2,l) = co2vmr(iplon,l)
11294 wkl(3,l) = o3vmr(iplon,l)
11295 wkl(4,l) = n2ovmr(iplon,l)
11296 wkl(6,l) = ch4vmr(iplon,l)
11297 wkl(7,l) = o2vmr(iplon,l)
11298 amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
11299 coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
11300 (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
11301 enddo
11303 ! Set cross section molecule amounts from input; convert to vmr if necessary
11304 do l=1, nlayers
11305 wx(1,l) = ccl4vmr(iplon,l)
11306 wx(2,l) = cfc11vmr(iplon,l)
11307 wx(3,l) = cfc12vmr(iplon,l)
11308 wx(4,l) = cfc22vmr(iplon,l)
11309 enddo
11311 ! The following section can be used to set values for an additional layer (from
11312 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
11313 ! Temperature and molecular amounts in the extra model layer are set to
11314 ! their values in the top GCM model layer, though these can be modified
11315 ! here if necessary.
11316 ! If this feature is utilized, increase nlayers by one above, limit the two
11317 ! loops above to (nlayers-1), and set the top most (extra) layer values here.
11319 ! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
11320 ! tavel(nlayers) = tavel(nlayers-1)
11321 ! pz(nlayers) = 1.e-4_rb
11322 ! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
11323 ! tz(nlayers) = tz(nlayers-1)
11324 ! wkl(1,nlayers) = wkl(1,nlayers-1)
11325 ! wkl(2,nlayers) = wkl(2,nlayers-1)
11326 ! wkl(3,nlayers) = wkl(3,nlayers-1)
11327 ! wkl(4,nlayers) = wkl(4,nlayers-1)
11328 ! wkl(6,nlayers) = wkl(6,nlayers-1)
11329 ! wkl(7,nlayers) = wkl(7,nlayers-1)
11330 ! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
11331 ! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
11332 ! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
11333 ! wx(1,nlayers) = wx(1,nlayers-1)
11334 ! wx(2,nlayers) = wx(2,nlayers-1)
11335 ! wx(3,nlayers) = wx(3,nlayers-1)
11336 ! wx(4,nlayers) = wx(4,nlayers-1)
11338 ! At this point all molecular amounts in wkl and wx are in volume mixing ratio;
11339 ! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable
11340 ! water vapor for diffusivity angle adjustments in rtrn and rtrnmr.
11342 do l = 1, nlayers
11343 summol = 0.0_rb
11344 do imol = 2, nmol
11345 summol = summol + wkl(imol,l)
11346 enddo
11347 wbrodl(l) = coldry(l) * (1._rb - summol)
11348 do imol = 1, nmol
11349 wkl(imol,l) = coldry(l) * wkl(imol,l)
11350 enddo
11351 amttl = amttl + coldry(l)+wkl(1,l)
11352 wvttl = wvttl + wkl(1,l)
11353 do ix = 1,maxxsec
11354 if (ixindx(ix) .ne. 0) then
11355 wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb
11356 endif
11357 enddo
11358 enddo
11360 wvsh = (amw * wvttl) / (amd * amttl)
11361 pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav)
11363 ! Set spectral surface emissivity for each longwave band.
11365 do n=1,nbndlw
11366 semiss(n) = emis(iplon,n)
11367 ! semiss(n) = 1.0_rb
11368 enddo
11370 ! Transfer aerosol optical properties to RRTM variable;
11371 ! modify to reverse layer indexing here if necessary.
11373 if (iaer .ge. 1) then
11374 do l = 1, nlayers
11375 do ib = 1, nbndlw
11376 taua(l,ib) = tauaer(iplon,l,ib)
11377 enddo
11378 enddo
11379 endif
11381 ! Transfer cloud fraction and cloud optical properties to RRTM variables,
11382 ! modify to reverse layer indexing here if necessary.
11384 if (icld .ge. 1) then
11385 inflag = inflglw
11386 iceflag = iceflglw
11387 liqflag = liqflglw
11389 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
11390 ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw)
11392 do l = 1, nlayers
11393 do ig = 1, ngptlw
11394 cldfmc(ig,l) = cldfmcl(ig,iplon,l)
11395 taucmc(ig,l) = taucmcl(ig,iplon,l)
11396 ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
11397 clwpmc(ig,l) = clwpmcl(ig,iplon,l)
11398 enddo
11399 reicmc(l) = reicmcl(iplon,l)
11400 relqmc(l) = relqmcl(iplon,l)
11401 enddo
11403 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
11405 ! cldfmc(:,nlayers) = 0.0_rb
11406 ! taucmc(:,nlayers) = 0.0_rb
11407 ! ciwpmc(:,nlayers) = 0.0_rb
11408 ! clwpmc(:,nlayers) = 0.0_rb
11409 ! reicmc(nlayers) = 0.0_rb
11410 ! relqmc(nlayers) = 0.0_rb
11411 ! taua(nlayers,:) = 0.0_rb
11413 endif
11415 end subroutine inatm
11417 end module rrtmg_lw_rad
11419 !------------------------------------------------------------------
11420 MODULE module_ra_rrtmg_lw
11422 use module_model_constants, only : cp
11423 use module_wrf_error
11424 !use module_dm
11426 use parrrtm, only : nbndlw, ngptlw
11427 use rrtmg_lw_init, only: rrtmg_lw_ini
11428 use rrtmg_lw_rad, only: rrtmg_lw
11429 use mcica_subcol_gen_lw, only: mcica_subcol_lw
11431 real retab(95)
11432 data retab / &
11433 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
11434 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
11435 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
11436 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
11437 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
11438 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
11439 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
11440 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
11441 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
11442 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
11443 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
11444 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
11445 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
11446 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
11447 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
11448 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
11449 !
11450 save retab
11452 CONTAINS
11454 !------------------------------------------------------------------
11455 SUBROUTINE RRTMG_LWRAD( &
11456 rthratenlw, &
11457 lwupt, lwuptc, lwdnt, lwdntc, &
11458 lwupb, lwupbc, lwdnb, lwdnbc, &
11459 ! lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
11460 glw, olr, lwcf, emiss, &
11461 p8w, p3d, pi3d, &
11462 dz8w, tsk, t3d, t8w, rho3d, r, g, &
11463 icloud, warm_rain, cldfra3d, &
11464 f_ice_phy, f_rain_phy, &
11465 xland, xice, snow, &
11466 qv3d, qc3d, qr3d, &
11467 qi3d, qs3d, qg3d, &
11468 f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
11469 ids,ide, jds,jde, kds,kde, &
11470 ims,ime, jms,jme, kms,kme, &
11471 its,ite, jts,jte, kts,kte, &
11472 lwupflx, lwupflxc, lwdnflx, lwdnflxc &
11473 )
11474 !------------------------------------------------------------------
11475 IMPLICIT NONE
11476 !------------------------------------------------------------------
11477 LOGICAL, INTENT(IN ) :: warm_rain
11478 !
11479 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
11480 ims,ime, jms,jme, kms,kme, &
11481 its,ite, jts,jte, kts,kte
11483 INTEGER, INTENT(IN ) :: ICLOUD
11484 !
11485 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11486 INTENT(IN ) :: dz8w, &
11487 t3d, &
11488 t8w, &
11489 p8w, &
11490 p3d, &
11491 pi3d, &
11492 rho3d
11494 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11495 INTENT(INOUT) :: RTHRATENLW
11497 REAL, DIMENSION( ims:ime, jms:jme ) , &
11498 INTENT(INOUT) :: GLW, &
11499 OLR, &
11500 LWCF
11502 REAL, DIMENSION( ims:ime, jms:jme ) , &
11503 INTENT(IN ) :: EMISS, &
11504 TSK
11506 REAL, INTENT(IN ) :: R,G
11508 REAL, DIMENSION( ims:ime, jms:jme ) , &
11509 INTENT(IN ) :: XLAND, &
11510 XICE, &
11511 SNOW
11512 !
11513 ! Optional
11514 !
11515 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11516 OPTIONAL , &
11517 INTENT(IN ) :: &
11518 CLDFRA3D, &
11519 QV3D, &
11520 QC3D, &
11521 QR3D, &
11522 QI3D, &
11523 QS3D, &
11524 QG3D
11526 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11527 OPTIONAL , &
11528 INTENT(IN ) :: &
11529 F_ICE_PHY, &
11530 F_RAIN_PHY
11532 LOGICAL, OPTIONAL, INTENT(IN) :: &
11533 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
11535 ! Top of atmosphere and surface longwave fluxes (W m-2)
11536 REAL, DIMENSION( ims:ime, jms:jme ), &
11537 OPTIONAL, INTENT(INOUT) :: &
11538 LWUPT,LWUPTC,LWDNT,LWDNTC, &
11539 LWUPB,LWUPBC,LWDNB,LWDNBC
11541 ! Layer longwave fluxes (including extra layer above model top)
11542 ! Vertical ordering is from bottom to top (W m-2)
11543 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
11544 OPTIONAL, INTENT(OUT) :: &
11545 LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
11547 ! LOCAL VARS
11549 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
11550 Tw1D
11552 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
11553 CLDFRA1D, &
11554 DZ1D, &
11555 P1D, &
11556 T1D, &
11557 QV1D, &
11558 QC1D, &
11559 QR1D, &
11560 QI1D, &
11561 QS1D, &
11562 QG1D
11564 ! Added local arrays for RRTMG
11565 integer :: ncol, &
11566 nlay, &
11567 icld, &
11568 inflglw, &
11569 iceflglw, &
11570 liqflglw
11571 ! Dimension with extra layer from model top to TOA
11572 real, dimension( 1, kts:kte+2 ) :: plev, &
11573 tlev
11574 real, dimension( 1, kts:kte+1 ) :: play, &
11575 tlay, &
11576 h2ovmr, &
11577 o3vmr, &
11578 co2vmr, &
11579 o2vmr, &
11580 ch4vmr, &
11581 n2ovmr, &
11582 cfc11vmr, &
11583 cfc12vmr, &
11584 cfc22vmr, &
11585 ccl4vmr
11586 real, dimension( kts:kte+1 ) :: o3mmr
11587 ! For old cloud property specification for rrtm_lw
11588 real, dimension( kts:kte ) :: clwp, &
11589 ciwp, &
11590 plwp, &
11591 piwp
11592 ! Surface emissivity (for 16 LW spectral bands)
11593 real, dimension( 1, nbndlw ) :: emis
11594 ! Dimension with extra layer from model top to TOA,
11595 ! though no clouds are allowed in extra layer
11596 real, dimension( 1, kts:kte+1 ) :: clwpth, &
11597 ciwpth, &
11598 rel, &
11599 rei, &
11600 cldfrac, &
11601 relqmcl, &
11602 reicmcl
11603 real, dimension( nbndlw, 1, kts:kte+1 ) :: taucld
11604 real, dimension( ngptlw, 1, kts:kte+1 ) :: cldfmcl, &
11605 clwpmcl, &
11606 ciwpmcl, &
11607 taucmcl
11608 real, dimension( 1, kts:kte+1, nbndlw ) :: tauaer
11610 ! Output arrays contain extra layer from model top to TOA
11611 real, dimension( 1, kts:kte+2 ) :: uflx, &
11612 dflx, &
11613 uflxc, &
11614 dflxc
11615 real, dimension( 1, kts:kte+1 ) :: hr, &
11616 hrc
11618 real, dimension ( 1 ) :: tsfc, &
11619 ps
11620 real :: ro, &
11621 dz
11623 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11624 ! carbon dioxide (379 ppmv)
11625 real :: co2
11626 data co2 / 379.e-6 /
11627 ! methane (1774 ppbv)
11628 real :: ch4
11629 data ch4 / 1774.e-9 /
11630 ! nitrous oxide (319 ppbv)
11631 real :: n2o
11632 data n2o / 319.e-9 /
11633 ! cfc-11 (251 ppt)
11634 real :: cfc11
11635 data cfc11 / 0.251e-9 /
11636 ! cfc-12 (538 ppt)
11637 real :: cfc12
11638 data cfc12 / 0.538e-9 /
11639 ! cfc-22 (169 ppt)
11640 real :: cfc22
11641 data cfc22 / 0.169e-9 /
11642 ! ccl4 (93 ppt)
11643 real :: ccl4
11644 data ccl4 / 0.093e-9 /
11645 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
11646 real :: o2
11647 data o2 / 0.209488 /
11649 integer :: iplon, irng, permuteseed
11650 integer :: nb
11652 ! For old cloud property specification for rrtm_lw
11653 ! Cloud and precipitation absorption coefficients
11654 real :: abcw,abice,abrn,absn
11655 data abcw /0.144/
11656 data abice /0.0735/
11657 data abrn /0.330e-3/
11658 data absn /2.34e-3/
11660 ! Molecular weights and ratios for converting mmr to vmr units
11661 ! real :: amd ! Effective molecular weight of dry air (g/mol)
11662 ! real :: amw ! Molecular weight of water vapor (g/mol)
11663 ! real :: amo ! Molecular weight of ozone (g/mol)
11664 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
11665 ! Atomic weights for conversion from mass to volume mixing ratios
11666 ! data amd / 28.9660 /
11667 ! data amw / 18.0160 /
11668 ! data amo / 47.9998 /
11669 ! data amo2 / 31.9999 /
11671 real :: amdw ! Molecular weight of dry air / water vapor
11672 real :: amdo ! Molecular weight of dry air / ozone
11673 real :: amdo2 ! Molecular weight of dry air / oxygen
11674 data amdw / 1.607793 /
11675 data amdo / 0.603461 /
11676 data amdo2 / 0.905190 /
11678 !!
11679 real, dimension( 1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
11681 real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
11682 cliqwp, & ! in-cloud cloud liquid water path
11683 reliq, & ! effective drop radius (microns)
11684 reice ! ice effective drop size (microns)
11685 real :: gliqwp, gicewp, gravmks
11687 !
11688 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
11690 real, dimension (1) :: landfrac, landm, snowh, icefrac
11692 integer :: pcols, pver
11694 !
11695 INTEGER :: i,j,K
11696 LOGICAL :: predicate
11698 !------------------------------------------------------------------
11700 !-----CALCULATE LONG WAVE RADIATION
11701 !
11702 ! All fields are ordered vertically from bottom to top
11703 ! Pressures are in mb
11705 ! latitude loop
11706 j_loop: do j = jts,jte
11708 ! longitude loop
11709 i_loop: do i = its,ite
11711 do k=kts,kte+1
11712 Pw1D(K) = p8w(I,K,J)/100.
11713 Tw1D(K) = t8w(I,K,J)
11714 enddo
11716 DO K=kts,kte
11717 QV1D(K)=0.
11718 QC1D(K)=0.
11719 QR1D(K)=0.
11720 QI1D(K)=0.
11721 QS1D(K)=0.
11722 CLDFRA1D(k)=0.
11723 ENDDO
11725 DO K=kts,kte
11726 QV1D(K)=QV3D(I,K,J)
11727 QV1D(K)=max(0.,QV1D(K))
11728 ENDDO
11730 DO K=kts,kte
11731 TTEN1D(K)=0.
11732 T1D(K)=T3D(I,K,J)
11733 P1D(K)=P3D(I,K,J)/100.
11734 DZ1D(K)=dz8w(I,K,J)
11735 ENDDO
11737 ! moist variables
11739 IF (ICLOUD .ne. 0) THEN
11740 IF ( PRESENT( CLDFRA3D ) ) THEN
11741 DO K=kts,kte
11742 CLDFRA1D(k)=CLDFRA3D(I,K,J)
11743 ENDDO
11744 ENDIF
11746 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
11747 IF ( F_QC) THEN
11748 DO K=kts,kte
11749 QC1D(K)=QC3D(I,K,J)
11750 QC1D(K)=max(0.,QC1D(K))
11751 ENDDO
11752 ENDIF
11753 ENDIF
11755 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
11756 IF ( F_QR) THEN
11757 DO K=kts,kte
11758 QR1D(K)=QR3D(I,K,J)
11759 QR1D(K)=max(0.,QR1D(K))
11760 ENDDO
11761 ENDIF
11762 ENDIF
11764 ! This logic is tortured because cannot test F_QI unless
11765 ! it is present, and order of evaluation of expressions
11766 ! is not specified in Fortran
11768 IF ( PRESENT ( F_QI ) ) THEN
11769 predicate = F_QI
11770 ELSE
11771 predicate = .FALSE.
11772 ENDIF
11774 ! For MP option 3
11775 IF (.NOT. predicate .and. .not. warm_rain) THEN
11776 DO K=kts,kte
11777 IF (T1D(K) .lt. 273.15) THEN
11778 QI1D(K)=QC1D(K)
11779 QS1D(K)=QR1D(K)
11780 QC1D(K)=0.
11781 QR1D(K)=0.
11782 ENDIF
11783 ENDDO
11784 ENDIF
11786 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
11787 IF (F_QI) THEN
11788 DO K=kts,kte
11789 QI1D(K)=QI3D(I,K,J)
11790 QI1D(K)=max(0.,QI1D(K))
11791 ENDDO
11792 ENDIF
11793 ENDIF
11795 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
11796 IF (F_QS) THEN
11797 DO K=kts,kte
11798 QS1D(K)=QS3D(I,K,J)
11799 QS1D(K)=max(0.,QS1D(K))
11800 ENDDO
11801 ENDIF
11802 ENDIF
11804 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
11805 IF (F_QG) THEN
11806 DO K=kts,kte
11807 QG1D(K)=QG3D(I,K,J)
11808 QG1D(K)=max(0.,QG1D(K))
11809 ENDDO
11810 ENDIF
11811 ENDIF
11813 ! mji - For MP option 5
11814 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
11815 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
11816 DO K=kts,kte
11817 qi1d(k) = qs3d(i,k,j)
11818 qc1d(k) = qc3d(i,k,j)
11819 qi1d(k) = max(0.,qi1d(k))
11820 qc1d(k) = max(0.,qc1d(k))
11821 ENDDO
11822 ENDIF
11823 ENDIF
11825 ENDIF
11827 ! EMISS0=EMISS(I,J)
11828 ! GLW0=0.
11829 ! OLR0=0.
11830 ! TSFC=TSK(I,J)
11831 DO K=kts,kte
11832 QV1D(K)=AMAX1(QV1D(K),1.E-12)
11833 ENDDO
11835 ! Set up input for longwave
11836 ncol = 1
11837 ! Add extra layer from top of model to top of atmosphere
11838 nlay = (kte - kts + 1) + 1
11840 ! Select cloud liquid and ice optics parameterization options
11841 ! For passing in cloud optical properties directly:
11842 ! icld = 2
11843 ! inflglw = 0
11844 ! iceflglw = 0
11845 ! liqflglw = 0
11846 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
11847 icld = 2
11848 inflglw = 2
11849 iceflglw = 3
11850 liqflglw = 1
11852 ! Layer indexing goes bottom to top here for all fields.
11853 ! Water vapor and ozone are converted from mmr to vmr.
11854 ! Pressures are in units of mb here.
11855 plev(ncol,1) = pw1d(1)
11856 tlev(ncol,1) = tw1d(1)
11857 tsfc(ncol) = tsk(i,j)
11858 do k = kts, kte
11859 play(ncol,k) = p1d(k)
11860 plev(ncol,k+1) = pw1d(k+1)
11861 pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
11862 tlay(ncol,k) = t1d(k)
11863 tlev(ncol,k+1) = tw1d(k+1)
11864 h2ovmr(ncol,k) = qv1d(k) * amdw
11865 co2vmr(ncol,k) = co2
11866 o2vmr(ncol,k) = o2
11867 ch4vmr(ncol,k) = ch4
11868 n2ovmr(ncol,k) = n2o
11869 cfc11vmr(ncol,k) = cfc11
11870 cfc12vmr(ncol,k) = cfc12
11871 cfc22vmr(ncol,k) = cfc22
11872 ccl4vmr(ncol,k) = ccl4
11873 enddo
11875 ! Define profile values for extra layer from model top to top of atmosphere.
11876 ! The top layer temperature for all gridpoints is set to the top layer-1
11877 ! temperature plus a constant (0 K) that represents an isothermal layer
11878 ! above ptop. Top layer interface temperatures are linearly interpolated
11879 ! from the layer temperatures.
11881 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
11882 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
11883 plev(ncol,kte+2) = 1.0e-5
11884 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
11885 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
11886 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
11887 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
11888 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
11889 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
11890 cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte)
11891 cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte)
11892 cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte)
11893 ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte)
11895 ! Get ozone profile including amount in extra layer above model top
11896 call inirad (o3mmr,plev,kts,kte)
11898 do k = kts, kte+1
11899 o3vmr(ncol,k) = o3mmr(k) * amdo
11900 enddo
11902 ! Set surface emissivity in each RRTMG longwave band
11903 do nb = 1, nbndlw
11904 emis(ncol, nb) = emiss(i,j)
11905 enddo
11907 ! Define cloud optical properties for radiation (inflglw = 0)
11908 ! This is approach used with older RRTM_LW;
11909 ! Cloud and precipitation paths in g/m2
11910 ! qi=0 if no ice phase
11911 ! qs=0 if no ice phase
11912 if (inflglw .eq. 0) then
11913 do k = kts,kte
11914 ro = p1d(k) / (r * t1d(k))*100.
11915 dz = dz1d(k)
11916 clwp(k) = ro*qc1d(k)*dz*1000.
11917 ciwp(k) = ro*qi1d(k)*dz*1000.
11918 plwp(k) = (ro*qr1d(k))**0.75*dz*1000.
11919 piwp(k) = (ro*qs1d(k))**0.75*dz*1000.
11920 enddo
11922 ! Cloud fraction and cloud optical depth; old approach used with RRTM_LW
11923 do k = kts, kte
11924 cldfrac(ncol,k) = cldfra1d(k)
11925 do nb = 1, nbndlw
11926 taucld(nb,ncol,k) = abcw*clwp(k) + abice*ciwp(k) &
11927 +abrn*plwp(k) + absn*piwp(k)
11928 if (taucld(nb,ncol,k) .gt. 0.01) cldfrac(ncol,k) = 1.
11929 enddo
11930 enddo
11932 ! Zero out cloud physical property arrays; not used when passing optical properties
11933 ! into radiation
11934 do k = kts, kte
11935 clwpth(ncol,k) = 0.0
11936 ciwpth(ncol,k) = 0.0
11937 rel(ncol,k) = 10.0
11938 rei(ncol,k) = 10.0
11939 enddo
11940 endif
11942 ! Define cloud physical properties for radiation (inflglw = 1 or 2)
11943 ! Cloud fraction
11944 ! Set cloud arrays if passing cloud physical properties into radiation
11945 if (inflglw .gt. 0) then
11946 do k = kts, kte
11947 cldfrac(ncol,k) = cldfra1d(k)
11948 enddo
11950 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
11951 pcols = ncol
11952 pver = kte - kts + 1
11953 gravmks = g
11954 landfrac(ncol) = 2.-XLAND(I,J)
11955 landm(ncol) = landfrac(ncol)
11956 snowh(ncol) = 0.001*SNOW(I,J)
11957 icefrac(ncol) = XICE(I,J)
11959 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
11960 ! pdel is in mb here; convert back to Pa (*100.)
11961 ! Water paths are in units of g/m2
11962 ! snow added as ice cloud (JD 091022)
11963 do k = kts, kte
11964 gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
11965 gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
11966 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
11967 cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
11968 end do
11970 ! following Kiehl
11971 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
11973 ! following Kristjansson and Mitchell
11974 call reicalc(ncol, pcols, pver, tlay, reice)
11976 ! Limit upper bound of reice for Fu ice parameterization and convert
11977 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
11978 if (iceflglw .eq. 3) then
11979 do k = kts, kte
11980 reice(ncol,k) = reice(ncol,k) * 1.0315
11981 reice(ncol,k) = min(140.0,reice(ncol,k))
11982 end do
11983 endif
11985 ! Set cloud physical property arrays
11986 do k = kts, kte
11987 clwpth(ncol,k) = cliqwp(ncol,k)
11988 ciwpth(ncol,k) = cicewp(ncol,k)
11989 rel(ncol,k) = reliq(ncol,k)
11990 rei(ncol,k) = reice(ncol,k)
11991 enddo
11993 ! Zero out cloud optical properties here; not used when passing physical properties
11994 ! to radiation and taucld is calculated in radiation
11995 do k = kts, kte
11996 do nb = 1, nbndlw
11997 taucld(nb,ncol,k) = 0.0
11998 enddo
11999 enddo
12000 endif
12002 ! No clouds are allowed in the extra layer from model top to TOA
12003 clwpth(ncol,kte+1) = 0.
12004 ciwpth(ncol,kte+1) = 0.
12005 rel(ncol,kte+1) = 10.
12006 rei(ncol,kte+1) = 10.
12007 cldfrac(ncol,kte+1) = 0.
12008 do nb = 1, nbndlw
12009 taucld(nb,ncol,kte+1) = 0.
12010 enddo
12012 iplon = 1
12013 irng = 0
12014 permuteseed = 150
12016 ! Sub-column generator for McICA
12017 call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
12018 cldfrac, ciwpth, clwpth, rei, rel, taucld, cldfmcl, &
12019 ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
12021 ! Aerosol optical depth by layer for each RRTMG longwave band
12022 ! No aerosols in layer above model top (kte+1)
12023 do nb = 1, nbndlw
12024 do k = kts, kte+1
12025 tauaer(ncol,k,nb) = 0.
12026 enddo
12027 enddo
12029 ! Call RRTMG longwave radiation model
12030 call rrtmg_lw &
12031 (ncol ,nlay ,icld , &
12032 play ,plev ,tlay ,tlev ,tsfc , &
12033 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
12034 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
12035 inflglw ,iceflglw,liqflglw,cldfmcl , &
12036 taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
12037 tauaer , &
12038 uflx ,dflx ,hr ,uflxc ,dflxc, hrc)
12040 ! Output downard surface flux, and outgoing longwave flux and cloud forcing
12041 ! at the top of atmosphere (W/m2)
12042 glw(i,j) = dflx(1,1)
12043 olr(i,j) = uflx(1,kte+2)
12044 lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
12046 if (present(lwupt)) then
12047 ! Output up and down toa fluxes for total and clear sky
12048 lwupt(i,j) = uflx(1,kte+2)
12049 lwuptc(i,j) = uflxc(1,kte+2)
12050 lwdnt(i,j) = dflx(1,kte+2)
12051 lwdntc(i,j) = dflxc(1,kte+2)
12052 ! Output up and down surface fluxes for total and clear sky
12053 lwupb(i,j) = uflx(1,1)
12054 lwupbc(i,j) = uflxc(1,1)
12055 lwdnb(i,j) = dflx(1,1)
12056 lwdnbc(i,j) = dflxc(1,1)
12057 endif
12059 ! Output up and down layer fluxes for total and clear sky.
12060 ! Vertical ordering is from bottom to top in units of W m-2.
12061 if ( present (lwupflx) ) then
12062 do k=kts,kte+2
12063 lwupflx(i,k,j) = uflx(1,k)
12064 lwupflxc(i,k,j) = uflxc(1,k)
12065 lwdnflx(i,k,j) = dflx(1,k)
12066 lwdnflxc(i,k,j) = dflxc(1,k)
12067 enddo
12068 endif
12070 ! Output heating rate tendency; convert heating rate from K/d to K/s
12071 ! Heating rate arrays are ordered vertically from bottom to top here.
12072 do k=kts,kte
12073 tten1d(k) = hr(ncol,k)/86400.
12074 rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j)
12075 enddo
12077 !
12078 end do i_loop
12079 end do j_loop
12081 !-------------------------------------------------------------------
12083 END SUBROUTINE RRTMG_LWRAD
12086 !-------------------------------------------------------------------------
12087 SUBROUTINE INIRAD (O3PROF,Plev, kts, kte)
12088 !-------------------------------------------------------------------------
12089 IMPLICIT NONE
12090 !-------------------------------------------------------------------------
12091 INTEGER, INTENT(IN ) :: kts,kte
12093 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12095 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12097 ! LOCAL VAR
12099 INTEGER :: k
12101 !
12102 ! COMPUTE OZONE MIXING RATIO DISTRIBUTION
12103 !
12104 DO K=kts,kte+1
12105 O3PROF(K)=0.
12106 ENDDO
12108 CALL O3DATA(O3PROF, Plev, kts, kte)
12110 END SUBROUTINE INIRAD
12112 !-------------------------------------------------------------------------
12113 SUBROUTINE O3DATA (O3PROF, Plev, kts, kte)
12114 !-------------------------------------------------------------------------
12115 IMPLICIT NONE
12116 !-------------------------------------------------------------------------
12117 !
12118 INTEGER, INTENT(IN ) :: kts, kte
12119 !
12120 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12122 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12124 ! LOCAL VAR
12125 INTEGER :: K, JJ
12127 REAL :: PRLEVH(kts:kte+2),PPWRKH(32), &
12128 O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), &
12129 O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31)
12131 REAL :: PB1, PB2, PT1, PT2
12133 DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, &
12134 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, &
12135 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, &
12136 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, &
12137 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, &
12138 9.856E-6,5.960E-6,5.960E-6/
12140 DATA PPSUM /955.890,850.532,754.599,667.742,589.841, &
12141 519.421,455.480,398.085,347.171,301.735,261.310,225.360, &
12142 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, &
12143 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, &
12144 9.277, 4.660, 2.421, 1.294, 0.647/
12145 !
12146 DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, &
12147 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, &
12148 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, &
12149 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, &
12150 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, &
12151 9.389E-6,6.135E-6,6.135E-6/
12153 DATA PPWIN /955.747,841.783,740.199,649.538,568.404, &
12154 495.815,431.069,373.464,322.354,277.190,237.635,203.433, &
12155 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, &
12156 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, &
12157 7.583, 3.620, 1.807, 0.938, 0.469/
12158 !
12160 DO K=1,31
12161 PPANN(K)=PPSUM(K)
12162 ENDDO
12163 !
12164 O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1))
12165 !
12166 DO K=2,31
12167 O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* &
12168 (PPSUM(K)-PPWIN(K-1))
12169 ENDDO
12170 !
12171 DO K=2,31
12172 O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K))
12173 ENDDO
12174 !
12175 DO K=1,31
12176 O3WRK(K)=O3ANN(K)
12177 PPWRK(K)=PPANN(K)
12178 ENDDO
12179 !
12180 ! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS
12181 !
12183 ! Plev is total P at model levels, from bottom to top
12184 ! Plev is in mb
12186 DO K=kts,kte+2
12187 PRLEVH(K)=Plev(K)
12188 ENDDO
12189 !
12190 PPWRKH(1)=1100.
12191 DO K=2,31
12192 PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2.
12193 ENDDO
12194 PPWRKH(32)=0.
12195 DO K=kts,kte+1
12196 DO 25 JJ=1,31
12197 IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN
12198 PB1=0.
12199 ELSE
12200 PB1=PRLEVH(K)-PPWRKH(JJ)
12201 ENDIF
12202 IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN
12203 PB2=0.
12204 ELSE
12205 PB2=PRLEVH(K)-PPWRKH(JJ+1)
12206 ENDIF
12207 IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN
12208 PT1=0.
12209 ELSE
12210 PT1=PRLEVH(K+1)-PPWRKH(JJ)
12211 ENDIF
12212 IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN
12213 PT2=0.
12214 ELSE
12215 PT2=PRLEVH(K+1)-PPWRKH(JJ+1)
12216 ENDIF
12217 O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ)
12218 25 CONTINUE
12219 O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1))
12221 ENDDO
12222 !
12223 END SUBROUTINE O3DATA
12225 !------------------------------------------------------------------
12227 !====================================================================
12228 SUBROUTINE rrtmg_lwinit( &
12229 allowed_to_read , &
12230 ids, ide, jds, jde, kds, kde, &
12231 ims, ime, jms, jme, kms, kme, &
12232 its, ite, jts, jte, kts, kte )
12233 !--------------------------------------------------------------------
12234 IMPLICIT NONE
12235 !--------------------------------------------------------------------
12237 LOGICAL , INTENT(IN) :: allowed_to_read
12238 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
12239 ims, ime, jms, jme, kms, kme, &
12240 its, ite, jts, jte, kts, kte
12242 ! Read in absorption coefficients and other data
12243 IF ( allowed_to_read ) THEN
12244 CALL rrtmg_lwlookuptable
12245 ENDIF
12247 ! Perform g-point reduction and other initializations
12248 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
12249 call rrtmg_lw_ini(cp)
12251 END SUBROUTINE rrtmg_lwinit
12254 ! **************************************************************************
12255 SUBROUTINE rrtmg_lwlookuptable
12256 ! **************************************************************************
12258 IMPLICIT NONE
12260 ! Local
12261 INTEGER :: i
12262 LOGICAL :: opened
12263 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
12265 CHARACTER*80 errmess
12266 INTEGER rrtmg_unit
12268 IF ( wrf_dm_on_monitor() ) THEN
12269 DO i = 10,99
12270 INQUIRE ( i , OPENED = opened )
12271 IF ( .NOT. opened ) THEN
12272 rrtmg_unit = i
12273 GOTO 2010
12274 ENDIF
12275 ENDDO
12276 rrtmg_unit = -1
12277 2010 CONTINUE
12278 ENDIF
12279 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
12280 IF ( rrtmg_unit < 0 ) THEN
12281 CALL wrf_error_fatal ( 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// &
12282 'find unused fortran unit to read in lookup table.' )
12283 ENDIF
12285 IF ( wrf_dm_on_monitor() ) THEN
12286 OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA', &
12287 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
12288 ENDIF
12290 call lw_kgb01(rrtmg_unit)
12291 call lw_kgb02(rrtmg_unit)
12292 call lw_kgb03(rrtmg_unit)
12293 call lw_kgb04(rrtmg_unit)
12294 call lw_kgb05(rrtmg_unit)
12295 call lw_kgb06(rrtmg_unit)
12296 call lw_kgb07(rrtmg_unit)
12297 call lw_kgb08(rrtmg_unit)
12298 call lw_kgb09(rrtmg_unit)
12299 call lw_kgb10(rrtmg_unit)
12300 call lw_kgb11(rrtmg_unit)
12301 call lw_kgb12(rrtmg_unit)
12302 call lw_kgb13(rrtmg_unit)
12303 call lw_kgb14(rrtmg_unit)
12304 call lw_kgb15(rrtmg_unit)
12305 call lw_kgb16(rrtmg_unit)
12307 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
12309 RETURN
12310 9009 CONTINUE
12311 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_DATA on unit ',rrtmg_unit
12312 CALL wrf_error_fatal(errmess)
12314 END SUBROUTINE rrtmg_lwlookuptable
12316 ! **************************************************************************
12317 ! RRTMG Longwave Radiative Transfer Model
12318 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
12319 !
12320 ! Original version: E. J. Mlawer, et al.
12321 ! Revision for GCMs: Michael J. Iacono; October, 2002
12322 ! Revision for F90 formatting: Michael J. Iacono; June 2006
12323 !
12324 ! This file contains 16 READ statements that include the
12325 ! absorption coefficients and other data for each of the 16 longwave
12326 ! spectral bands used in RRTMG_LW. Here, the data are defined for 16
12327 ! g-points, or sub-intervals, per band. These data are combined and
12328 ! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce
12329 ! the total number of g-points from 256 to 140 for use in the GCM.
12330 ! **************************************************************************
12332 ! **************************************************************************
12333 subroutine lw_kgb01(rrtmg_unit)
12334 ! **************************************************************************
12336 use rrlw_kg01, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
12337 absa, absb, &
12338 selfrefo, forrefo
12340 implicit none
12341 save
12343 ! Input
12344 integer, intent(in) :: rrtmg_unit
12346 ! Local
12347 character*80 errmess
12348 logical, external :: wrf_dm_on_monitor
12350 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12351 ! and upper atmosphere.
12352 ! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
12354 ! The array KAO contains absorption coefs at the 16 chosen g-values
12355 ! for a range of pressure levels > ~100mb and temperatures. The first
12356 ! index in the array, JT, which runs from 1 to 5, corresponds to
12357 ! different temperatures. More specifically, JT = 3 means that the
12358 ! data are for the corresponding TREF for this pressure level,
12359 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12360 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
12361 ! index, JP, runs from 1 to 13 and refers to the corresponding
12362 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12363 ! The third index, IG, goes from 1 to 16, and tells us which
12364 ! g-interval the absorption coefficients are for.
12366 ! The array KBO contains absorption coefs at the 16 chosen g-values
12367 ! for a range of pressure levels < ~100mb and temperatures. The first
12368 ! index in the array, JT, which runs from 1 to 5, corresponds to
12369 ! different temperatures. More specifically, JT = 3 means that the
12370 ! data are for the reference temperature TREF for this pressure
12371 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12372 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12373 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12374 ! reference pressure level (see taumol.f for the value of these
12375 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12376 ! and tells us which g-interval the absorption coefficients are for.
12378 ! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the
12379 ! nitrogen continuum for the upper and lower atmosphere.
12380 ! Minor gas mapping levels:
12381 ! Lower - n2: P = 142.5490 mbar, T = 215.70 K
12382 ! Upper - n2: P = 142.5490 mbar, T = 215.70 K
12384 ! The array FORREFO contains the coefficient of the water vapor
12385 ! foreign-continuum (including the energy term). The first
12386 ! index refers to reference temperature (296,260,224,260) and
12387 ! pressure (970,475,219,3 mbar) levels. The second index
12388 ! runs over the g-channel (1 to 16).
12390 ! The array SELFREFO contains the coefficient of the water vapor
12391 ! self-continuum (including the energy term). The first index
12392 ! refers to temperature in 7.2 degree increments. For instance,
12393 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12394 ! etc. The second index runs over the g-channel (1 to 16).
12396 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12398 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12399 fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
12400 DM_BCAST_MACRO(fracrefao)
12401 DM_BCAST_MACRO(fracrefbo)
12402 DM_BCAST_MACRO(kao)
12403 DM_BCAST_MACRO(kbo)
12404 DM_BCAST_MACRO(kao_mn2)
12405 DM_BCAST_MACRO(kbo_mn2)
12406 DM_BCAST_MACRO(selfrefo)
12407 DM_BCAST_MACRO(forrefo)
12409 RETURN
12410 9010 CONTINUE
12411 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12412 CALL wrf_error_fatal(errmess)
12414 end subroutine lw_kgb01
12416 ! **************************************************************************
12417 subroutine lw_kgb02(rrtmg_unit)
12418 ! **************************************************************************
12420 use rrlw_kg02, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12422 implicit none
12423 save
12425 ! Input
12426 integer, intent(in) :: rrtmg_unit
12428 ! Local
12429 character*80 errmess
12430 logical, external :: wrf_dm_on_monitor
12432 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12433 ! and upper atmosphere.
12434 ! Planck fraction mapping levels:
12435 ! Lower: P = 1053.630 mbar, T = 294.2 K
12436 ! Upper: P = 3.206e-2 mb, T = 197.92 K
12438 ! The array KAO contains absorption coefs at the 16 chosen g-values
12439 ! for a range of pressure levels > ~100mb and temperatures. The first
12440 ! index in the array, JT, which runs from 1 to 5, corresponds to
12441 ! different temperatures. More specifically, JT = 3 means that the
12442 ! data are for the corresponding TREF for this pressure level,
12443 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12444 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
12445 ! index, JP, runs from 1 to 13 and refers to the corresponding
12446 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12447 ! The third index, IG, goes from 1 to 16, and tells us which
12448 ! g-interval the absorption coefficients are for.
12450 ! The array KBO contains absorption coefs at the 16 chosen g-values
12451 ! for a range of pressure levels < ~100mb and temperatures. The first
12452 ! index in the array, JT, which runs from 1 to 5, corresponds to
12453 ! different temperatures. More specifically, JT = 3 means that the
12454 ! data are for the reference temperature TREF for this pressure
12455 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12456 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12457 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12458 ! reference pressure level (see taumol.f for the value of these
12459 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12460 ! and tells us which g-interval the absorption coefficients are for.
12462 ! The array FORREFO contains the coefficient of the water vapor
12463 ! foreign-continuum (including the energy term). The first
12464 ! index refers to reference temperature (296,260,224,260) and
12465 ! pressure (970,475,219,3 mbar) levels. The second index
12466 ! runs over the g-channel (1 to 16).
12468 ! The array SELFREFO contains the coefficient of the water vapor
12469 ! self-continuum (including the energy term). The first index
12470 ! refers to temperature in 7.2 degree increments. For instance,
12471 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12472 ! etc. The second index runs over the g-channel (1 to 16).
12474 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12476 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12477 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12478 DM_BCAST_MACRO(fracrefao)
12479 DM_BCAST_MACRO(fracrefbo)
12480 DM_BCAST_MACRO(kao)
12481 DM_BCAST_MACRO(kbo)
12482 DM_BCAST_MACRO(selfrefo)
12483 DM_BCAST_MACRO(forrefo)
12485 RETURN
12486 9010 CONTINUE
12487 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12488 CALL wrf_error_fatal(errmess)
12490 end subroutine lw_kgb02
12492 ! **************************************************************************
12493 subroutine lw_kgb03(rrtmg_unit)
12494 ! **************************************************************************
12496 use rrlw_kg03, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
12497 kbo_mn2o, selfrefo, forrefo
12499 implicit none
12500 save
12502 ! Input
12503 integer, intent(in) :: rrtmg_unit
12505 ! Local
12506 character*80 errmess
12507 logical, external :: wrf_dm_on_monitor
12509 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12510 ! and upper atmosphere.
12511 ! Planck fraction mapping levels:
12512 ! Lower: P = 212.7250 mbar, T = 223.06 K
12513 ! Upper: P = 95.8 mbar, T = 215.7 k
12515 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12516 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12517 ! of water vapor to CO2. The first index in the array, JS, runs
12518 ! from 1 to 10, and corresponds to different gas column amount ratios,
12519 ! as expressed through the binary species parameter eta, defined as
12520 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12521 ! ratio of the reference MLS column amount value of gas 1
12522 ! to that of gas2.
12523 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12524 ! to different temperatures. More specifically, JT = 3 means that the
12525 ! data are for the reference temperature TREF for this pressure
12526 ! level, JT = 2 refers to the temperature
12527 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12528 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12529 ! to the reference pressure level (e.g. JP = 1 is for a
12530 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12531 ! and tells us which g-interval the absorption coefficients are for.
12533 ! The array KBO contains absorption coefs at the 16 chosen g-values
12534 ! for a range of pressure levels < ~100mb and temperatures. The first
12535 ! index in the array, JT, which runs from 1 to 5, corresponds to
12536 ! different temperatures. More specifically, JT = 3 means that the
12537 ! data are for the reference temperature TREF for this pressure
12538 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12539 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12540 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12541 ! reference pressure level (see taumol.f for the value of these
12542 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12543 ! and tells us which g-interval the absorption coefficients are for.
12544 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12545 ! to different temperatures. More specifically, JT = 3 means that the
12546 ! data are for the reference temperature TREF for this pressure
12547 ! level, JT = 2 refers to the temperature
12548 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12549 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12550 ! to the reference pressure level (e.g. JP = 1 is for a
12551 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12552 ! and tells us which g-interval the absorption coefficients are for.
12554 ! The array KAO_Mxx contains the absorption coefficient for
12555 ! a minor species at the 16 chosen g-values for a reference pressure
12556 ! level below 100~ mb. The first index in the array, JS, runs
12557 ! from 1 to 10, and corresponds to different gas column amount ratios,
12558 ! as expressed through the binary species parameter eta, defined as
12559 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12560 ! ratio of the reference MLS column amount value of gas 1
12561 ! to that of gas2. The second index refers to temperature
12562 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12563 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12564 ! runs over the g-channel (1 to 16).
12566 ! The array KBO_Mxx contains the absorption coefficient for
12567 ! a minor species at the 16 chosen g-values for a reference pressure
12568 ! level above 100~ mb. The first index in the array, JS, runs
12569 ! from 1 to 10, and corresponds to different gas column amounts ratios,
12570 ! as expressed through the binary species parameter eta, defined as
12571 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12572 ! ratio of the reference MLS column amount value of gas 1 to
12573 ! that of gas2. The second index refers to temperature
12574 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12575 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12576 ! runs over the g-channel (1 to 16).
12578 ! The array FORREFO contains the coefficient of the water vapor
12579 ! foreign-continuum (including the energy term). The first
12580 ! index refers to reference temperature (296,260,224,260) and
12581 ! pressure (970,475,219,3 mbar) levels. The second index
12582 ! runs over the g-channel (1 to 16).
12584 ! The array SELFREFO contains the coefficient of the water vapor
12585 ! self-continuum (including the energy term). The first index
12586 ! refers to temperature in 7.2 degree increments. For instance,
12587 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12588 ! etc. The second index runs over the g-channel (1 to 16).
12590 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12592 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12593 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
12594 DM_BCAST_MACRO(fracrefao)
12595 DM_BCAST_MACRO(fracrefbo)
12596 DM_BCAST_MACRO(kao)
12597 DM_BCAST_MACRO(kbo)
12598 DM_BCAST_MACRO(kao_mn2o)
12599 DM_BCAST_MACRO(kbo_mn2o)
12600 DM_BCAST_MACRO(selfrefo)
12601 DM_BCAST_MACRO(forrefo)
12603 RETURN
12604 9010 CONTINUE
12605 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12606 CALL wrf_error_fatal(errmess)
12608 end subroutine lw_kgb03
12610 ! **************************************************************************
12611 subroutine lw_kgb04(rrtmg_unit)
12612 ! **************************************************************************
12614 use rrlw_kg04, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12616 implicit none
12617 save
12619 ! Input
12620 integer, intent(in) :: rrtmg_unit
12622 ! Local
12623 character*80 errmess
12624 logical, external :: wrf_dm_on_monitor
12626 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12627 ! and upper atmosphere.
12628 ! Planck fraction mapping levels:
12629 ! Lower : P = 142.5940 mbar, T = 215.70 K
12630 ! Upper : P = 95.58350 mb, T = 215.70 K
12632 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12633 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12634 ! of water vapor to CO2. The first index in the array, JS, runs
12635 ! from 1 to 10, and corresponds to different gas column amount ratios,
12636 ! as expressed through the binary species parameter eta, defined as
12637 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12638 ! ratio of the reference MLS column amount value of gas 1
12639 ! to that of gas2.
12640 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12641 ! to different temperatures. More specifically, JT = 3 means that the
12642 ! data are for the reference temperature TREF for this pressure
12643 ! level, JT = 2 refers to the temperature
12644 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12645 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12646 ! to the reference pressure level (e.g. JP = 1 is for a
12647 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12648 ! and tells us which g-interval the absorption coefficients are for.
12650 ! The array KBO contains absorption coefs for each of the 16 g-intervals
12651 ! for a range of pressure levels < ~100mb, temperatures, and ratios
12652 ! of H2O to CO2. The first index in the array, JS, runs
12653 ! from 1 to 10, and corresponds to different gas column amount ratios,
12654 ! as expressed through the binary species parameter eta, defined as
12655 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12656 ! ratio of the reference MLS column amount value of gas 1
12657 ! to that of gas2. The second index, JT, which
12658 ! runs from 1 to 5, corresponds to different temperatures. More
12659 ! specifically, JT = 3 means that the data are for the corresponding
12660 ! reference temperature TREF for this pressure level, JT = 2 refers
12661 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12662 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
12663 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12664 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
12665 ! 16, and tells us which g-interval the absorption coefficients are for.
12667 ! The array FORREFO contains the coefficient of the water vapor
12668 ! foreign-continuum (including the energy term). The first
12669 ! index refers to reference temperature (296,260,224,260) and
12670 ! pressure (970,475,219,3 mbar) levels. The second index
12671 ! runs over the g-channel (1 to 16).
12673 ! The array SELFREFO contains the coefficient of the water vapor
12674 ! self-continuum (including the energy term). The first index
12675 ! refers to temperature in 7.2 degree increments. For instance,
12676 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12677 ! etc. The second index runs over the g-channel (1 to 16).
12679 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12681 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12682 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12683 DM_BCAST_MACRO(fracrefao)
12684 DM_BCAST_MACRO(fracrefbo)
12685 DM_BCAST_MACRO(kao)
12686 DM_BCAST_MACRO(kbo)
12687 DM_BCAST_MACRO(selfrefo)
12688 DM_BCAST_MACRO(forrefo)
12690 RETURN
12691 9010 CONTINUE
12692 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12693 CALL wrf_error_fatal(errmess)
12695 end subroutine lw_kgb04
12697 ! **************************************************************************
12698 subroutine lw_kgb05(rrtmg_unit)
12699 ! **************************************************************************
12701 use rrlw_kg05, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, &
12702 selfrefo, forrefo, ccl4o
12704 implicit none
12705 save
12707 ! Input
12708 integer, intent(in) :: rrtmg_unit
12710 ! Local
12711 character*80 errmess
12712 logical, external :: wrf_dm_on_monitor
12714 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12715 ! and upper atmosphere.
12716 ! Planck fraction mapping levels:
12717 ! Lower: P = 473.42 mb, T = 259.83
12718 ! Upper: P = 0.2369280 mbar, T = 253.60 K
12720 ! The arrays kao_mo3 and ccl4o contain the coefficients for
12721 ! ozone and ccl4 in the lower atmosphere.
12722 ! Minor gas mapping level:
12723 ! Lower - o3: P = 317.34 mbar, T = 240.77 k
12724 ! Lower - ccl4:
12726 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12727 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12728 ! of water vapor to CO2. The first index in the array, JS, runs
12729 ! from 1 to 10, and corresponds to different gas column amount ratios,
12730 ! as expressed through the binary species parameter eta, defined as
12731 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12732 ! ratio of the reference MLS column amount value of gas 1
12733 ! to that of gas2.
12734 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12735 ! to different temperatures. More specifically, JT = 3 means that the
12736 ! data are for the reference temperature TREF for this pressure
12737 ! level, JT = 2 refers to the temperature
12738 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12739 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12740 ! to the reference pressure level (e.g. JP = 1 is for a
12741 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12742 ! and tells us which g-interval the absorption coefficients are for.
12744 ! The array KBO contains absorption coefs for each of the 16 g-intervals
12745 ! for a range of pressure levels < ~100mb, temperatures, and ratios
12746 ! of H2O to CO2. The first index in the array, JS, runs
12747 ! from 1 to 10, and corresponds to different gas column amount ratios,
12748 ! as expressed through the binary species parameter eta, defined as
12749 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12750 ! ratio of the reference MLS column amount value of gas 1
12751 ! to that of gas2. The second index, JT, which
12752 ! runs from 1 to 5, corresponds to different temperatures. More
12753 ! specifically, JT = 3 means that the data are for the corresponding
12754 ! reference temperature TREF for this pressure level, JT = 2 refers
12755 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12756 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
12757 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12758 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
12759 ! 16, and tells us which g-interval the absorption coefficients are for.
12761 ! The array KAO_Mxx contains the absorption coefficient for
12762 ! a minor species at the 16 chosen g-values for a reference pressure
12763 ! level below 100~ mb. The first index in the array, JS, runs
12764 ! from 1 to 10, and corresponds to different gas column amount ratios,
12765 ! as expressed through the binary species parameter eta, defined as
12766 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12767 ! ratio of the reference MLS column amount value of gas 1
12768 ! to that of gas2. The second index refers to temperature
12769 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12770 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12771 ! runs over the g-channel (1 to 16).
12773 ! The array FORREFO contains the coefficient of the water vapor
12774 ! foreign-continuum (including the energy term). The first
12775 ! index refers to reference temperature (296,260,224,260) and
12776 ! pressure (970,475,219,3 mbar) levels. The second index
12777 ! runs over the g-channel (1 to 16).
12779 ! The array SELFREFO contains the coefficient of the water vapor
12780 ! self-continuum (including the energy term). The first index
12781 ! refers to temperature in 7.2 degree increments. For instance,
12782 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12783 ! etc. The second index runs over the g-channel (1 to 16).
12785 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12787 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12788 fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
12789 DM_BCAST_MACRO(fracrefao)
12790 DM_BCAST_MACRO(fracrefbo)
12791 DM_BCAST_MACRO(kao)
12792 DM_BCAST_MACRO(kbo)
12793 DM_BCAST_MACRO(kao_mo3)
12794 DM_BCAST_MACRO(ccl4o)
12795 DM_BCAST_MACRO(selfrefo)
12796 DM_BCAST_MACRO(forrefo)
12798 RETURN
12799 9010 CONTINUE
12800 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12801 CALL wrf_error_fatal(errmess)
12803 end subroutine lw_kgb05
12805 ! **************************************************************************
12806 subroutine lw_kgb06(rrtmg_unit)
12807 ! **************************************************************************
12809 use rrlw_kg06, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, &
12810 cfc11adjo, cfc12o
12812 implicit none
12813 save
12815 ! Input
12816 integer, intent(in) :: rrtmg_unit
12818 ! Local
12819 character*80 errmess
12820 logical, external :: wrf_dm_on_monitor
12822 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12823 ! and upper atmosphere.
12824 ! Planck fraction mapping levels:
12825 ! Lower: : P = 473.4280 mb, T = 259.83 K
12827 ! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
12828 ! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
12829 ! atmosphere.
12830 ! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
12831 ! Minor gas mapping level:
12832 ! Lower - co2: P = 706.2720 mb, T = 294.2 k
12833 ! Upper - cfc11, cfc12
12835 ! The array KAO contains absorption coefs at the 16 chosen g-values
12836 ! for a range of pressure levels > ~100mb and temperatures. The first
12837 ! index in the array, JT, which runs from 1 to 5, corresponds to
12838 ! different temperatures. More specifically, JT = 3 means that the
12839 ! data are for the corresponding TREF for this pressure level,
12840 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12841 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
12842 ! index, JP, runs from 1 to 13 and refers to the corresponding
12843 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12844 ! The third index, IG, goes from 1 to 16, and tells us which
12845 ! g-interval the absorption coefficients are for.
12847 ! The array KAO_Mxx contains the absorption coefficient for
12848 ! a minor species at the 16 chosen g-values for a reference pressure
12849 ! level below 100~ mb. The first index refers to temperature
12850 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12851 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
12852 ! runs over the g-channel (1 to 16).
12854 ! The array FORREFO contains the coefficient of the water vapor
12855 ! foreign-continuum (including the energy term). The first
12856 ! index refers to reference temperature (296,260,224,260) and
12857 ! pressure (970,475,219,3 mbar) levels. The second index
12858 ! runs over the g-channel (1 to 16).
12860 ! The array SELFREFO contains the coefficient of the water vapor
12861 ! self-continuum (including the energy term). The first index
12862 ! refers to temperature in 7.2 degree increments. For instance,
12863 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12864 ! etc. The second index runs over the g-channel (1 to 16).
12866 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12868 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12869 fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
12870 DM_BCAST_MACRO(fracrefao)
12871 DM_BCAST_MACRO(kao)
12872 DM_BCAST_MACRO(kao_mco2)
12873 DM_BCAST_MACRO(cfc11adjo)
12874 DM_BCAST_MACRO(cfc12o)
12875 DM_BCAST_MACRO(selfrefo)
12876 DM_BCAST_MACRO(forrefo)
12878 RETURN
12879 9010 CONTINUE
12880 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12881 CALL wrf_error_fatal(errmess)
12883 end subroutine lw_kgb06
12885 ! **************************************************************************
12886 subroutine lw_kgb07(rrtmg_unit)
12887 ! **************************************************************************
12889 use rrlw_kg07, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, &
12890 kbo_mco2, selfrefo, forrefo
12892 implicit none
12893 save
12895 ! Input
12896 integer, intent(in) :: rrtmg_unit
12898 ! Local
12899 character*80 errmess
12900 logical, external :: wrf_dm_on_monitor
12902 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12903 ! and upper atmosphere.
12904 ! Planck fraction mapping levels:
12905 ! Lower : P = 706.27 mb, T = 278.94 K
12906 ! Upper : P = 95.58 mbar, T= 215.70 K
12908 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12909 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12910 ! of water vapor to CO2. The first index in the array, JS, runs
12911 ! from 1 to 10, and corresponds to different gas column amount ratios,
12912 ! as expressed through the binary species parameter eta, defined as
12913 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12914 ! ratio of the reference MLS column amount value of gas 1
12915 ! to that of gas2.
12916 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12917 ! to different temperatures. More specifically, JT = 3 means that the
12918 ! data are for the reference temperature TREF for this pressure
12919 ! level, JT = 2 refers to the temperature
12920 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12921 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12922 ! to the reference pressure level (e.g. JP = 1 is for a
12923 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12924 ! and tells us which g-interval the absorption coefficients are for.
12926 ! The array KBO contains absorption coefs at the 16 chosen g-values
12927 ! for a range of pressure levels < ~100mb and temperatures. The first
12928 ! index in the array, JT, which runs from 1 to 5, corresponds to
12929 ! different temperatures. More specifically, JT = 3 means that the
12930 ! data are for the reference temperature TREF for this pressure
12931 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12932 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12933 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12934 ! reference pressure level (see taumol.f for the value of these
12935 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12936 ! and tells us which g-interval the absorption coefficients are for.
12938 ! The array KAO_Mxx contains the absorption coefficient for
12939 ! a minor species at the 16 chosen g-values for a reference pressure
12940 ! level below 100~ mb. The first index in the array, JS, runs
12941 ! from 1 to 10, and corresponds to different gas column amount ratios,
12942 ! as expressed through the binary species parameter eta, defined as
12943 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12944 ! ratio of the reference MLS column amount value of gas 1
12945 ! to that of gas2. The second index refers to temperature
12946 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12947 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12948 ! runs over the g-channel (1 to 16).
12950 ! The array KBO_Mxx contains the absorption coefficient for
12951 ! a minor species at the 16 chosen g-values for a reference pressure
12952 ! level above 100~ mb. The first index refers to temperature
12953 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12954 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
12955 ! runs over the g-channel (1 to 16).
12957 ! The array FORREFO contains the coefficient of the water vapor
12958 ! foreign-continuum (including the energy term). The first
12959 ! index refers to reference temperature (296_rb,260_rb,224,260) and
12960 ! pressure (970,475,219,3 mbar) levels. The second index
12961 ! runs over the g-channel (1 to 16).
12963 ! The array SELFREFO contains the coefficient of the water vapor
12964 ! self-continuum (including the energy term). The first index
12965 ! refers to temperature in 7.2 degree increments. For instance,
12966 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12967 ! etc. The second index runs over the g-channel (1 to 16).
12969 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12971 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12972 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
12973 DM_BCAST_MACRO(fracrefao)
12974 DM_BCAST_MACRO(fracrefbo)
12975 DM_BCAST_MACRO(kao)
12976 DM_BCAST_MACRO(kbo)
12977 DM_BCAST_MACRO(kao_mco2)
12978 DM_BCAST_MACRO(kbo_mco2)
12979 DM_BCAST_MACRO(selfrefo)
12980 DM_BCAST_MACRO(forrefo)
12982 RETURN
12983 9010 CONTINUE
12984 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12985 CALL wrf_error_fatal(errmess)
12987 end subroutine lw_kgb07
12989 ! **************************************************************************
12990 subroutine lw_kgb08(rrtmg_unit)
12991 ! **************************************************************************
12993 use rrlw_kg08, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
12994 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
12995 cfc12o, cfc22adjo
12997 implicit none
12998 save
13000 ! Input
13001 integer, intent(in) :: rrtmg_unit
13003 ! Local
13004 character*80 errmess
13005 logical, external :: wrf_dm_on_monitor
13007 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13008 ! and upper atmosphere.
13009 ! Planck fraction mapping levels:
13010 ! Lower: P=473.4280 mb, T = 259.83 K
13011 ! Upper: P=95.5835 mb, T= 215.7 K
13013 ! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for
13014 ! carbon dioxide and n2o in the lower and upper atmosphere.
13015 ! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere,
13016 ! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22.
13017 ! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1
13018 ! and 1290-1335 cm-1 bands.
13019 ! Minor gas mapping level:
13020 ! Lower - co2: P = 1053.63 mb, T = 294.2 k
13021 ! Lower - o3: P = 317.348 mb, T = 240.77 k
13022 ! Lower - n2o: P = 706.2720 mb, T= 278.94 k
13023 ! Lower - cfc12, cfc22
13024 ! Upper - co2: P = 35.1632 mb, T = 223.28 k
13025 ! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
13027 ! The array KAO contains absorption coefs at the 16 chosen g-values
13028 ! for a range of pressure levels > ~100mb and temperatures. The first
13029 ! index in the array, JT, which runs from 1 to 5, corresponds to
13030 ! different temperatures. More specifically, JT = 3 means that the
13031 ! data are for the corresponding TREF for this pressure level,
13032 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13033 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13034 ! index, JP, runs from 1 to 13 and refers to the corresponding
13035 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13036 ! The third index, IG, goes from 1 to 16, and tells us which
13037 ! g-interval the absorption coefficients are for.
13039 ! The array KBO contains absorption coefs at the 16 chosen g-values
13040 ! for a range of pressure levels < ~100mb and temperatures. The first
13041 ! index in the array, JT, which runs from 1 to 5, corresponds to
13042 ! different temperatures. More specifically, JT = 3 means that the
13043 ! data are for the reference temperature TREF for this pressure
13044 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13045 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13046 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13047 ! reference pressure level (see taumol.f for the value of these
13048 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13049 ! and tells us which g-interval the absorption coefficients are for.
13051 ! The array KAO_Mxx contains the absorption coefficient for
13052 ! a minor species at the 16 chosen g-values for a reference pressure
13053 ! level below 100~ mb. The first index refers to temperature
13054 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13055 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13056 ! runs over the g-channel (1 to 16).
13058 ! The array KBO_Mxx contains the absorption coefficient for
13059 ! a minor species at the 16 chosen g-values for a reference pressure
13060 ! level above 100~ mb. The first index refers to temperature
13061 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13062 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13063 ! runs over the g-channel (1 to 16).
13065 ! The array FORREFO contains the coefficient of the water vapor
13066 ! foreign-continuum (including the energy term). The first
13067 ! index refers to reference temperature (296,260,224,260) and
13068 ! pressure (970,475,219,3 mbar) levels. The second index
13069 ! runs over the g-channel (1 to 16).
13071 ! The array SELFREFO contains the coefficient of the water vapor
13072 ! self-continuum (including the energy term). The first index
13073 ! refers to temperature in 7.2 degree increments. For instance,
13074 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13075 ! etc. The second index runs over the g-channel (1 to 16).
13077 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13079 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13080 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, &
13081 kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
13082 DM_BCAST_MACRO(fracrefao)
13083 DM_BCAST_MACRO(fracrefbo)
13084 DM_BCAST_MACRO(kao)
13085 DM_BCAST_MACRO(kbo)
13086 DM_BCAST_MACRO(kao_mco2)
13087 DM_BCAST_MACRO(kbo_mco2)
13088 DM_BCAST_MACRO(kao_mn2o)
13089 DM_BCAST_MACRO(kbo_mn2o)
13090 DM_BCAST_MACRO(kao_mo3)
13091 DM_BCAST_MACRO(cfc12o)
13092 DM_BCAST_MACRO(cfc22adjo)
13093 DM_BCAST_MACRO(selfrefo)
13094 DM_BCAST_MACRO(forrefo)
13096 RETURN
13097 9010 CONTINUE
13098 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13099 CALL wrf_error_fatal(errmess)
13101 end subroutine lw_kgb08
13103 ! **************************************************************************
13104 subroutine lw_kgb09(rrtmg_unit)
13105 ! **************************************************************************
13107 use rrlw_kg09, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
13108 kbo_mn2o, selfrefo, forrefo
13110 implicit none
13111 save
13113 ! Input
13114 integer, intent(in) :: rrtmg_unit
13116 ! Local
13117 character*80 errmess
13118 logical, external :: wrf_dm_on_monitor
13120 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13121 ! and upper atmosphere.
13122 ! Planck fraction mapping levels:
13123 ! Lower: P=212.7250 mb, T = 223.06 K
13124 ! Upper: P=3.20e-2 mb, T = 197.92 k
13126 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13127 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13128 ! of water vapor to CO2. The first index in the array, JS, runs
13129 ! from 1 to 10, and corresponds to different gas column amount ratios,
13130 ! as expressed through the binary species parameter eta, defined as
13131 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13132 ! ratio of the reference MLS column amount value of gas 1
13133 ! to that of gas2.
13134 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13135 ! to different temperatures. More specifically, JT = 3 means that the
13136 ! data are for the reference temperature TREF for this pressure
13137 ! level, JT = 2 refers to the temperature
13138 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13139 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13140 ! to the reference pressure level (e.g. JP = 1 is for a
13141 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13142 ! and tells us which g-interval the absorption coefficients are for.
13144 ! The array KBO contains absorption coefs at the 16 chosen g-values
13145 ! for a range of pressure levels < ~100mb and temperatures. The first
13146 ! index in the array, JT, which runs from 1 to 5, corresponds to
13147 ! different temperatures. More specifically, JT = 3 means that the
13148 ! data are for the reference temperature TREF for this pressure
13149 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13150 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13151 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13152 ! reference pressure level (see taumol.f for the value of these
13153 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13154 ! and tells us which g-interval the absorption coefficients are for.
13156 ! The array KAO_Mxx contains the absorption coefficient for
13157 ! a minor species at the 16 chosen g-values for a reference pressure
13158 ! level below 100~ mb. The first index in the array, JS, runs
13159 ! from 1 to 10, and corresponds to different gas column amount ratios,
13160 ! as expressed through the binary species parameter eta, defined as
13161 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13162 ! ratio of the reference MLS column amount value of gas 1
13163 ! to that of gas2. The second index refers to temperature
13164 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13165 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13166 ! runs over the g-channel (1 to 16).
13168 ! The array KBO_Mxx contains the absorption coefficient for
13169 ! a minor species at the 16 chosen g-values for a reference pressure
13170 ! level above 100~ mb. The first index refers to temperature
13171 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13172 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13173 ! runs over the g-channel (1 to 16).
13175 ! The array FORREFO contains the coefficient of the water vapor
13176 ! foreign-continuum (including the energy term). The first
13177 ! index refers to reference temperature (296,260,224,260) and
13178 ! pressure (970,475,219,3 mbar) levels. The second index
13179 ! runs over the g-channel (1 to 16).
13181 ! The array SELFREFO contains the coefficient of the water vapor
13182 ! self-continuum (including the energy term). The first index
13183 ! refers to temperature in 7.2 degree increments. For instance,
13184 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13185 ! etc. The second index runs over the g-channel (1 to 16).
13187 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13189 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13190 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
13191 DM_BCAST_MACRO(fracrefao)
13192 DM_BCAST_MACRO(fracrefbo)
13193 DM_BCAST_MACRO(kao)
13194 DM_BCAST_MACRO(kbo)
13195 DM_BCAST_MACRO(kao_mn2o)
13196 DM_BCAST_MACRO(kbo_mn2o)
13197 DM_BCAST_MACRO(selfrefo)
13198 DM_BCAST_MACRO(forrefo)
13200 RETURN
13201 9010 CONTINUE
13202 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13203 CALL wrf_error_fatal(errmess)
13205 end subroutine lw_kgb09
13207 ! **************************************************************************
13208 subroutine lw_kgb10(rrtmg_unit)
13209 ! **************************************************************************
13211 use rrlw_kg10, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13213 implicit none
13214 save
13216 ! Input
13217 integer, intent(in) :: rrtmg_unit
13219 ! Local
13220 character*80 errmess
13221 logical, external :: wrf_dm_on_monitor
13223 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13224 ! and upper atmosphere.
13225 ! Planck fraction mapping levels:
13226 ! Lower: P = 212.7250 mb, T = 223.06 K
13227 ! Upper: P = 95.58350 mb, T = 215.70 K
13229 ! The array KAO contains absorption coefs at the 16 chosen g-values
13230 ! for a range of pressure levels > ~100mb and temperatures. The first
13231 ! index in the array, JT, which runs from 1 to 5, corresponds to
13232 ! different temperatures. More specifically, JT = 3 means that the
13233 ! data are for the corresponding TREF for this pressure level,
13234 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13235 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13236 ! index, JP, runs from 1 to 13 and refers to the corresponding
13237 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13238 ! The third index, IG, goes from 1 to 16, and tells us which
13239 ! g-interval the absorption coefficients are for.
13241 ! The array KBO contains absorption coefs at the 16 chosen g-values
13242 ! for a range of pressure levels < ~100mb and temperatures. The first
13243 ! index in the array, JT, which runs from 1 to 5, corresponds to
13244 ! different temperatures. More specifically, JT = 3 means that the
13245 ! data are for the reference temperature TREF for this pressure
13246 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13247 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13248 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13249 ! reference pressure level (see taumol.f for the value of these
13250 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13251 ! and tells us which g-interval the absorption coefficients are for.
13253 ! The array FORREFO contains the coefficient of the water vapor
13254 ! foreign-continuum (including the energy term). The first
13255 ! index refers to reference temperature (296,260,224,260) and
13256 ! pressure (970,475,219,3 mbar) levels. The second index
13257 ! runs over the g-channel (1 to 16).
13259 ! The array SELFREFO contains the coefficient of the water vapor
13260 ! self-continuum (including the energy term). The first index
13261 ! refers to temperature in 7.2 degree increments. For instance,
13262 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13263 ! etc. The second index runs over the g-channel (1 to 16).
13265 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13267 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13268 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13269 DM_BCAST_MACRO(fracrefao)
13270 DM_BCAST_MACRO(fracrefbo)
13271 DM_BCAST_MACRO(kao)
13272 DM_BCAST_MACRO(kbo)
13273 DM_BCAST_MACRO(selfrefo)
13274 DM_BCAST_MACRO(forrefo)
13276 RETURN
13277 9010 CONTINUE
13278 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13279 CALL wrf_error_fatal(errmess)
13281 end subroutine lw_kgb10
13283 ! **************************************************************************
13284 subroutine lw_kgb11(rrtmg_unit)
13285 ! **************************************************************************
13287 use rrlw_kg11, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, &
13288 kbo_mo2, selfrefo, forrefo
13290 implicit none
13291 save
13293 ! Input
13294 integer, intent(in) :: rrtmg_unit
13296 ! Local
13297 character*80 errmess
13298 logical, external :: wrf_dm_on_monitor
13300 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13301 ! and upper atmosphere.
13302 ! Planck fraction mapping levels:
13303 ! Lower: P=1053.63 mb, T= 294.2 K
13304 ! Upper: P=0.353 mb, T = 262.11 K
13306 ! The array KAO contains absorption coefs at the 16 chosen g-values
13307 ! for a range of pressure levels > ~100mb and temperatures. The first
13308 ! index in the array, JT, which runs from 1 to 5, corresponds to
13309 ! different temperatures. More specifically, JT = 3 means that the
13310 ! data are for the corresponding TREF for this pressure level,
13311 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13312 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13313 ! index, JP, runs from 1 to 13 and refers to the corresponding
13314 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13315 ! The third index, IG, goes from 1 to 16, and tells us which
13316 ! g-interval the absorption coefficients are for.
13318 ! The array KBO contains absorption coefs at the 16 chosen g-values
13319 ! for a range of pressure levels < ~100mb and temperatures. The first
13320 ! index in the array, JT, which runs from 1 to 5, corresponds to
13321 ! different temperatures. More specifically, JT = 3 means that the
13322 ! data are for the reference temperature TREF for this pressure
13323 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13324 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13325 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13326 ! reference pressure level (see taumol.f for the value of these
13327 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13328 ! and tells us which g-interval the absorption coefficients are for.
13330 ! The array KAO_Mxx contains the absorption coefficient for
13331 ! a minor species at the 16 chosen g-values for a reference pressure
13332 ! level below 100~ mb. The first index refers to temperature
13333 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13334 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13335 ! runs over the g-channel (1 to 16).
13337 ! The array KBO_Mxx contains the absorption coefficient for
13338 ! a minor species at the 16 chosen g-values for a reference pressure
13339 ! level above 100~ mb. The first index refers to temperature
13340 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13341 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13342 ! runs over the g-channel (1 to 16).
13344 ! The array FORREFO contains the coefficient of the water vapor
13345 ! foreign-continuum (including the energy term). The first
13346 ! index refers to reference temperature (296,260,224,260) and
13347 ! pressure (970,475,219,3 mbar) levels. The second index
13348 ! runs over the g-channel (1 to 16).
13350 ! The array SELFREFO contains the coefficient of the water vapor
13351 ! self-continuum (including the energy term). The first index
13352 ! refers to temperature in 7.2 degree increments. For instance,
13353 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13354 ! etc. The second index runs over the g-channel (1 to 16).
13356 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13358 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13359 fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
13360 DM_BCAST_MACRO(fracrefao)
13361 DM_BCAST_MACRO(fracrefbo)
13362 DM_BCAST_MACRO(kao)
13363 DM_BCAST_MACRO(kbo)
13364 DM_BCAST_MACRO(kao_mo2)
13365 DM_BCAST_MACRO(kbo_mo2)
13366 DM_BCAST_MACRO(selfrefo)
13367 DM_BCAST_MACRO(forrefo)
13369 RETURN
13370 9010 CONTINUE
13371 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13372 CALL wrf_error_fatal(errmess)
13374 end subroutine lw_kgb11
13376 ! **************************************************************************
13377 subroutine lw_kgb12(rrtmg_unit)
13378 ! **************************************************************************
13380 use rrlw_kg12, only : fracrefao, kao, selfrefo, forrefo
13382 implicit none
13383 save
13385 ! Input
13386 integer, intent(in) :: rrtmg_unit
13388 ! Local
13389 character*80 errmess
13390 logical, external :: wrf_dm_on_monitor
13392 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13393 ! and upper atmosphere.
13394 ! Planck fraction mapping levels:
13395 ! Lower: P = 174.1640 mbar, T= 215.78 K
13397 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13398 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13399 ! of water vapor to CO2. The first index in the array, JS, runs
13400 ! from 1 to 10, and corresponds to different gas column amount ratios,
13401 ! as expressed through the binary species parameter eta, defined as
13402 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13403 ! ratio of the reference MLS column amount value of gas 1
13404 ! to that of gas2.
13405 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13406 ! to different temperatures. More specifically, JT = 3 means that the
13407 ! data are for the reference temperature TREF for this pressure
13408 ! level, JT = 2 refers to the temperature
13409 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13410 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13411 ! to the reference pressure level (e.g. JP = 1 is for a
13412 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13413 ! and tells us which g-interval the absorption coefficients are for.
13415 ! The array FORREFO contains the coefficient of the water vapor
13416 ! foreign-continuum (including the energy term). The first
13417 ! index refers to reference temperature (296,260,224,260) and
13418 ! pressure (970,475,219,3 mbar) levels. The second index
13419 ! runs over the g-channel (1 to 16).
13421 ! The array SELFREFO contains the coefficient of the water vapor
13422 ! self-continuum (including the energy term). The first index
13423 ! refers to temperature in 7.2 degree increments. For instance,
13424 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13425 ! etc. The second index runs over the g-channel (1 to 16).
13427 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13429 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13430 fracrefao, kao, selfrefo, forrefo
13431 DM_BCAST_MACRO(fracrefao)
13432 DM_BCAST_MACRO(kao)
13433 DM_BCAST_MACRO(selfrefo)
13434 DM_BCAST_MACRO(forrefo)
13436 RETURN
13437 9010 CONTINUE
13438 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13439 CALL wrf_error_fatal(errmess)
13441 end subroutine lw_kgb12
13443 ! **************************************************************************
13444 subroutine lw_kgb13(rrtmg_unit)
13445 ! **************************************************************************
13447 use rrlw_kg13, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
13448 kbo_mo3, selfrefo, forrefo
13450 implicit none
13451 save
13453 ! Input
13454 integer, intent(in) :: rrtmg_unit
13456 ! Local
13457 character*80 errmess
13458 logical, external :: wrf_dm_on_monitor
13460 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13461 ! and upper atmosphere.
13462 ! Planck fraction mapping levels:
13463 ! Lower: P=473.4280 mb, T = 259.83 K
13464 ! Upper: P=4.758820 mb, T = 250.85 K
13466 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13467 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13468 ! of water vapor to CO2. The first index in the array, JS, runs
13469 ! from 1 to 10, and corresponds to different gas column amount ratios,
13470 ! as expressed through the binary species parameter eta, defined as
13471 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13472 ! ratio of the reference MLS column amount value of gas 1
13473 ! to that of gas2.
13474 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13475 ! to different temperatures. More specifically, JT = 3 means that the
13476 ! data are for the reference temperature TREF for this pressure
13477 ! level, JT = 2 refers to the temperature
13478 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13479 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13480 ! to the reference pressure level (e.g. JP = 1 is for a
13481 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13482 ! and tells us which g-interval the absorption coefficients are for.
13484 ! The array KAO_Mxx contains the absorption coefficient for
13485 ! a minor species at the 16 chosen g-values for a reference pressure
13486 ! level below 100~ mb. The first index in the array, JS, runs
13487 ! from 1 to 10, and corresponds to different gas column amount ratios,
13488 ! as expressed through the binary species parameter eta, defined as
13489 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13490 ! ratio of the reference MLS column amount value of gas 1
13491 ! to that of gas2. The second index refers to temperature
13492 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13493 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13494 ! runs over the g-channel (1 to 16).
13496 ! The array KBO_Mxx contains the absorption coefficient for
13497 ! a minor species at the 16 chosen g-values for a reference pressure
13498 ! level above 100~ mb. The first index refers to temperature
13499 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13500 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13501 ! runs over the g-channel (1 to 16).
13503 ! The array FORREFO contains the coefficient of the water vapor
13504 ! foreign-continuum (including the energy term). The first
13505 ! index refers to reference temperature (296,260,224,260) and
13506 ! pressure (970,475,219,3 mbar) levels. The second index
13507 ! runs over the g-channel (1 to 16).
13509 ! The array SELFREFO contains the coefficient of the water vapor
13510 ! self-continuum (including the energy term). The first index
13511 ! refers to temperature in 7.2 degree increments. For instance,
13512 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13513 ! etc. The second index runs over the g-channel (1 to 16).
13515 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13517 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13518 fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
13519 DM_BCAST_MACRO(fracrefao)
13520 DM_BCAST_MACRO(fracrefbo)
13521 DM_BCAST_MACRO(kao)
13522 DM_BCAST_MACRO(kao_mco2)
13523 DM_BCAST_MACRO(kao_mco)
13524 DM_BCAST_MACRO(kbo_mo3)
13525 DM_BCAST_MACRO(selfrefo)
13526 DM_BCAST_MACRO(forrefo)
13528 RETURN
13529 9010 CONTINUE
13530 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13531 CALL wrf_error_fatal(errmess)
13533 end subroutine lw_kgb13
13535 ! **************************************************************************
13536 subroutine lw_kgb14(rrtmg_unit)
13537 ! **************************************************************************
13539 use rrlw_kg14, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13541 implicit none
13542 save
13544 ! Input
13545 integer, intent(in) :: rrtmg_unit
13547 ! Local
13548 character*80 errmess
13549 logical, external :: wrf_dm_on_monitor
13551 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13552 ! and upper atmosphere.
13553 ! Planck fraction mapping levels:
13554 ! Lower: P = 142.5940 mb, T = 215.70 K
13555 ! Upper: P = 4.758820 mb, T = 250.85 K
13557 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13558 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13559 ! of water vapor to CO2. The first index in the array, JS, runs
13560 ! from 1 to 10, and corresponds to different gas column amount ratios,
13561 ! as expressed through the binary species parameter eta, defined as
13562 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13563 ! ratio of the reference MLS column amount value of gas 1
13564 ! to that of gas2.
13565 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13566 ! to different temperatures. More specifically, JT = 3 means that the
13567 ! data are for the reference temperature TREF for this pressure
13568 ! level, JT = 2 refers to the temperature
13569 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13570 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13571 ! to the reference pressure level (e.g. JP = 1 is for a
13572 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13573 ! and tells us which g-interval the absorption coefficients are for.
13575 ! The array KBO contains absorption coefs at the 16 chosen g-values
13576 ! for a range of pressure levels < ~100mb and temperatures. The first
13577 ! index in the array, JT, which runs from 1 to 5, corresponds to
13578 ! different temperatures. More specifically, JT = 3 means that the
13579 ! data are for the reference temperature TREF for this pressure
13580 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13581 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13582 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13583 ! reference pressure level (see taumol.f for the value of these
13584 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13585 ! and tells us which g-interval the absorption coefficients are for.
13587 ! The array FORREFO contains the coefficient of the water vapor
13588 ! foreign-continuum (including the energy term). The first
13589 ! index refers to reference temperature (296,260,224,260) and
13590 ! pressure (970,475,219,3 mbar) levels. The second index
13591 ! runs over the g-channel (1 to 16).
13593 ! The array SELFREFO contains the coefficient of the water vapor
13594 ! self-continuum (including the energy term). The first index
13595 ! refers to temperature in 7.2 degree increments. For instance,
13596 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13597 ! etc. The second index runs over the g-channel (1 to 16).
13599 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13601 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13602 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13603 DM_BCAST_MACRO(fracrefao)
13604 DM_BCAST_MACRO(fracrefbo)
13605 DM_BCAST_MACRO(kao)
13606 DM_BCAST_MACRO(kbo)
13607 DM_BCAST_MACRO(selfrefo)
13608 DM_BCAST_MACRO(forrefo)
13610 RETURN
13611 9010 CONTINUE
13612 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13613 CALL wrf_error_fatal(errmess)
13615 end subroutine lw_kgb14
13617 ! **************************************************************************
13618 subroutine lw_kgb15(rrtmg_unit)
13619 ! **************************************************************************
13621 use rrlw_kg15, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
13623 implicit none
13624 save
13626 ! Input
13627 integer, intent(in) :: rrtmg_unit
13629 ! Local
13630 character*80 errmess
13631 logical, external :: wrf_dm_on_monitor
13633 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13634 ! and upper atmosphere.
13635 ! Planck fraction mapping levels:
13636 ! Lower: P = 1053. mb, T = 294.2 K
13638 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13639 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13640 ! of water vapor to CO2. The first index in the array, JS, runs
13641 ! from 1 to 10, and corresponds to different gas column amount ratios,
13642 ! as expressed through the binary species parameter eta, defined as
13643 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13644 ! ratio of the reference MLS column amount value of gas 1
13645 ! to that of gas2.
13646 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13647 ! to different temperatures. More specifically, JT = 3 means that the
13648 ! data are for the reference temperature TREF for this pressure
13649 ! level, JT = 2 refers to the temperature
13650 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13651 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13652 ! to the reference pressure level (e.g. JP = 1 is for a
13653 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13654 ! and tells us which g-interval the absorption coefficients are for.
13656 ! The array KA_Mxx contains the absorption coefficient for
13657 ! a minor species at the 16 chosen g-values for a reference pressure
13658 ! level below 100~ mb. The first index in the array, JS, runs
13659 ! from 1 to 10, and corresponds to different gas column amount ratios,
13660 ! as expressed through the binary species parameter eta, defined as
13661 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13662 ! ratio of the reference MLS column amount value of gas 1
13663 ! to that of gas2. The second index refers to temperature
13664 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13665 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13666 ! runs over the g-channel (1 to 16).
13668 ! The array FORREFO contains the coefficient of the water vapor
13669 ! foreign-continuum (including the energy term). The first
13670 ! index refers to reference temperature (296,260,224,260) and
13671 ! pressure (970,475,219,3 mbar) levels. The second index
13672 ! runs over the g-channel (1 to 16).
13674 ! The array SELFREFO contains the coefficient of the water vapor
13675 ! self-continuum (including the energy term). The first index
13676 ! refers to temperature in 7.2 degree increments. For instance,
13677 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13678 ! etc. The second index runs over the g-channel (1 to 16).
13680 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13682 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13683 fracrefao, kao, kao_mn2, selfrefo, forrefo
13684 DM_BCAST_MACRO(fracrefao)
13685 DM_BCAST_MACRO(kao)
13686 DM_BCAST_MACRO(kao_mn2)
13687 DM_BCAST_MACRO(selfrefo)
13688 DM_BCAST_MACRO(forrefo)
13690 RETURN
13691 9010 CONTINUE
13692 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13693 CALL wrf_error_fatal(errmess)
13695 end subroutine lw_kgb15
13697 ! **************************************************************************
13698 subroutine lw_kgb16(rrtmg_unit)
13699 ! **************************************************************************
13701 use rrlw_kg16, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13703 implicit none
13704 save
13706 ! Input
13707 integer, intent(in) :: rrtmg_unit
13709 ! Local
13710 character*80 errmess
13711 logical, external :: wrf_dm_on_monitor
13713 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13714 ! and upper atmosphere.
13715 ! Planck fraction mapping levels:
13716 ! Lower: P = 387.6100 mbar, T = 250.17 K
13717 ! Upper: P=95.58350 mb, T = 215.70 K
13719 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13720 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13721 ! of water vapor to CO2. The first index in the array, JS, runs
13722 ! from 1 to 10, and corresponds to different gas column amount ratios,
13723 ! as expressed through the binary species parameter eta, defined as
13724 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13725 ! ratio of the reference MLS column amount value of gas 1
13726 ! to that of gas2.
13727 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13728 ! to different temperatures. More specifically, JT = 3 means that the
13729 ! data are for the reference temperature TREF for this pressure
13730 ! level, JT = 2 refers to the temperature
13731 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13732 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13733 ! to the reference pressure level (e.g. JP = 1 is for a
13734 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13735 ! and tells us which g-interval the absorption coefficients are for.
13737 ! The array KBO contains absorption coefs at the 16 chosen g-values
13738 ! for a range of pressure levels < ~100mb and temperatures. The first
13739 ! index in the array, JT, which runs from 1 to 5, corresponds to
13740 ! different temperatures. More specifically, JT = 3 means that the
13741 ! data are for the reference temperature TREF for this pressure
13742 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13743 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13744 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13745 ! reference pressure level (see taumol.f for the value of these
13746 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13747 ! and tells us which g-interval the absorption coefficients are for.
13749 ! The array FORREFO contains the coefficient of the water vapor
13750 ! foreign-continuum (including the energy term). The first
13751 ! index refers to reference temperature (296,260,224,260) and
13752 ! pressure (970,475,219,3 mbar) levels. The second index
13753 ! runs over the g-channel (1 to 16).
13755 ! The array SELFREFO contains the coefficient of the water vapor
13756 ! self-continuum (including the energy term). The first index
13757 ! refers to temperature in 7.2 degree increments. For instance,
13758 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13759 ! etc. The second index runs over the g-channel (1 to 16).
13761 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13763 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13764 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13765 DM_BCAST_MACRO(fracrefao)
13766 DM_BCAST_MACRO(fracrefbo)
13767 DM_BCAST_MACRO(kao)
13768 DM_BCAST_MACRO(kbo)
13769 DM_BCAST_MACRO(selfrefo)
13770 DM_BCAST_MACRO(forrefo)
13772 RETURN
13773 9010 CONTINUE
13774 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13775 CALL wrf_error_fatal(errmess)
13777 end subroutine lw_kgb16
13779 !===============================================================================
13780 subroutine relcalc(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
13781 !-----------------------------------------------------------------------
13782 !
13783 ! Purpose:
13784 ! Compute cloud water size
13785 !
13786 ! Method:
13787 ! analytic formula following the formulation originally developed by J. T. Kiehl
13788 !
13789 ! Author: Phil Rasch
13790 !
13791 !-----------------------------------------------------------------------
13792 implicit none
13793 !------------------------------Arguments--------------------------------
13794 !
13795 ! Input arguments
13796 !
13797 integer, intent(in) :: ncol
13798 integer, intent(in) :: pcols, pver
13799 real, intent(in) :: landfrac(pcols) ! Land fraction
13800 real, intent(in) :: icefrac(pcols) ! Ice fraction
13801 real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
13802 real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
13803 real, intent(in) :: t(pcols,pver) ! Temperature
13805 !
13806 ! Output arguments
13807 !
13808 real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
13809 !
13810 !---------------------------Local workspace-----------------------------
13811 !
13812 integer i,k ! Lon, lev indices
13813 real tmelt ! freezing temperature of fresh water (K)
13814 real rliqland ! liquid drop size if over land
13815 real rliqocean ! liquid drop size if over ocean
13816 real rliqice ! liquid drop size if over sea ice
13817 !
13818 !-----------------------------------------------------------------------
13819 !
13820 tmelt = 273.16
13821 rliqocean = 14.0
13822 rliqice = 14.0
13823 rliqland = 8.0
13824 do k=1,pver
13825 do i=1,ncol
13826 ! jrm Reworked effective radius algorithm
13827 ! Start with temperature-dependent value appropriate for continental air
13828 ! Note: findmcnew has a pressure dependence here
13829 rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(i,k))*0.05))
13830 ! Modify for snow depth over land
13831 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,snowh(i)*10.))
13832 ! Ramp between polluted value over land to clean value over ocean.
13833 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,1.0-landm(i)))
13834 ! Ramp between the resultant value and a sea ice value in the presence of ice.
13835 rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0,max(0.0,icefrac(i)))
13836 ! end jrm
13837 end do
13838 end do
13839 end subroutine relcalc
13840 !===============================================================================
13841 subroutine reicalc(ncol, pcols, pver, t, re)
13842 !
13844 integer, intent(in) :: ncol, pcols, pver
13845 real, intent(out) :: re(pcols,pver)
13846 real, intent(in) :: t(pcols,pver)
13847 real corr
13848 integer i
13849 integer k
13850 integer index
13851 !
13852 ! Tabulated values of re(T) in the temperature interval
13853 ! 180 K -- 274 K; hexagonal columns assumed:
13854 !
13855 !
13856 do k=1,pver
13857 do i=1,ncol
13858 index = int(t(i,k)-179.)
13859 index = min(max(index,1),94)
13860 corr = t(i,k) - int(t(i,k))
13861 re(i,k) = retab(index)*(1.-corr) &
13862 +retab(index+1)*corr
13863 ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
13864 end do
13865 end do
13866 !
13867 return
13868 end subroutine reicalc
13869 !------------------------------------------------------------------
13871 END MODULE module_ra_rrtmg_lw