| blob | eb8023bc403ee40d2810a058080703f0e68e8b28 |
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_ib = kind(1)
22 integer, parameter :: kind_im = kind(1)
23 integer, parameter :: kind_in = kind(1) ! native integer
25 !
26 ! real kinds
27 ! ----------
28 !
29 ! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
30 ! integer, parameter :: kind_rm = selected_real_kind(6) ! 4 byte real
31 ! integer, parameter :: kind_rn = kind(1.0) ! native real
33 #if 0
34 ! Modified for WRF:
35 #if (RWORDSIZE == 8)
36 integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
37 #endif
38 #if (RWORDSIZE == 4)
39 integer, parameter :: kind_rb = selected_real_kind(6) ! 4 byte real
40 #endif
41 #else
42 integer, parameter :: kind_rb = kind(1.0) ! native real
43 #endif
45 end module parkind
47 module parrrtm
49 use parkind ,only : im => kind_im
51 ! implicit none
52 save
54 !------------------------------------------------------------------
55 ! rrtmg_lw main parameters
56 !
57 ! Initial version: JJMorcrette, ECMWF, Jul 1998
58 ! Revised: MJIacono, AER, Jun 2006
59 ! Revised: MJIacono, AER, Aug 2007
60 ! Revised: MJIacono, AER, Aug 2008
61 !------------------------------------------------------------------
63 ! name type purpose
64 ! ----- : ---- : ----------------------------------------------
65 ! mxlay : integer: maximum number of layers
66 ! mg : integer: number of original g-intervals per spectral band
67 ! nbndlw : integer: number of spectral bands
68 ! maxxsec: integer: maximum number of cross-section molecules
69 ! (e.g. cfcs)
70 ! maxinpx: integer:
71 ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw
72 ! ngNN : integer: number of reduced g-intervals per spectral band
73 ! ngsNN : integer: cumulative number of g-intervals per band
74 !------------------------------------------------------------------
76 integer(kind=im), parameter :: mxlay = 203
77 integer(kind=im), parameter :: mg = 16
78 integer(kind=im), parameter :: nbndlw = 16
79 integer(kind=im), parameter :: maxxsec= 4
80 integer(kind=im), parameter :: mxmol = 38
81 integer(kind=im), parameter :: maxinpx= 38
82 integer(kind=im), parameter :: nmol = 7
83 ! Use for 140 g-point model
84 integer(kind=im), parameter :: ngptlw = 140
85 ! Use for 256 g-point model
86 ! integer(kind=im), parameter :: ngptlw = 256
88 ! Use for 140 g-point model
89 integer(kind=im), parameter :: ng1 = 10
90 integer(kind=im), parameter :: ng2 = 12
91 integer(kind=im), parameter :: ng3 = 16
92 integer(kind=im), parameter :: ng4 = 14
93 integer(kind=im), parameter :: ng5 = 16
94 integer(kind=im), parameter :: ng6 = 8
95 integer(kind=im), parameter :: ng7 = 12
96 integer(kind=im), parameter :: ng8 = 8
97 integer(kind=im), parameter :: ng9 = 12
98 integer(kind=im), parameter :: ng10 = 6
99 integer(kind=im), parameter :: ng11 = 8
100 integer(kind=im), parameter :: ng12 = 8
101 integer(kind=im), parameter :: ng13 = 4
102 integer(kind=im), parameter :: ng14 = 2
103 integer(kind=im), parameter :: ng15 = 2
104 integer(kind=im), parameter :: ng16 = 2
106 integer(kind=im), parameter :: ngs1 = 10
107 integer(kind=im), parameter :: ngs2 = 22
108 integer(kind=im), parameter :: ngs3 = 38
109 integer(kind=im), parameter :: ngs4 = 52
110 integer(kind=im), parameter :: ngs5 = 68
111 integer(kind=im), parameter :: ngs6 = 76
112 integer(kind=im), parameter :: ngs7 = 88
113 integer(kind=im), parameter :: ngs8 = 96
114 integer(kind=im), parameter :: ngs9 = 108
115 integer(kind=im), parameter :: ngs10 = 114
116 integer(kind=im), parameter :: ngs11 = 122
117 integer(kind=im), parameter :: ngs12 = 130
118 integer(kind=im), parameter :: ngs13 = 134
119 integer(kind=im), parameter :: ngs14 = 136
120 integer(kind=im), parameter :: ngs15 = 138
122 ! Use for 256 g-point model
123 ! integer(kind=im), parameter :: ng1 = 16
124 ! integer(kind=im), parameter :: ng2 = 16
125 ! integer(kind=im), parameter :: ng3 = 16
126 ! integer(kind=im), parameter :: ng4 = 16
127 ! integer(kind=im), parameter :: ng5 = 16
128 ! integer(kind=im), parameter :: ng6 = 16
129 ! integer(kind=im), parameter :: ng7 = 16
130 ! integer(kind=im), parameter :: ng8 = 16
131 ! integer(kind=im), parameter :: ng9 = 16
132 ! integer(kind=im), parameter :: ng10 = 16
133 ! integer(kind=im), parameter :: ng11 = 16
134 ! integer(kind=im), parameter :: ng12 = 16
135 ! integer(kind=im), parameter :: ng13 = 16
136 ! integer(kind=im), parameter :: ng14 = 16
137 ! integer(kind=im), parameter :: ng15 = 16
138 ! integer(kind=im), parameter :: ng16 = 16
140 ! integer(kind=im), parameter :: ngs1 = 16
141 ! integer(kind=im), parameter :: ngs2 = 32
142 ! integer(kind=im), parameter :: ngs3 = 48
143 ! integer(kind=im), parameter :: ngs4 = 64
144 ! integer(kind=im), parameter :: ngs5 = 80
145 ! integer(kind=im), parameter :: ngs6 = 96
146 ! integer(kind=im), parameter :: ngs7 = 112
147 ! integer(kind=im), parameter :: ngs8 = 128
148 ! integer(kind=im), parameter :: ngs9 = 144
149 ! integer(kind=im), parameter :: ngs10 = 160
150 ! integer(kind=im), parameter :: ngs11 = 176
151 ! integer(kind=im), parameter :: ngs12 = 192
152 ! integer(kind=im), parameter :: ngs13 = 208
153 ! integer(kind=im), parameter :: ngs14 = 224
154 ! integer(kind=im), parameter :: ngs15 = 240
155 ! integer(kind=im), parameter :: ngs16 = 256
157 end module parrrtm
159 module rrlw_cld
161 use parkind, only : rb => kind_rb
163 ! implicit none
164 save
166 !------------------------------------------------------------------
167 ! rrtmg_lw cloud property coefficients
169 ! Revised: MJIacono, AER, jun2006
170 ! Revised: MJIacono, AER, aug2008
171 !------------------------------------------------------------------
173 ! name type purpose
174 ! ----- : ---- : ----------------------------------------------
175 ! abscld1: real :
176 ! absice0: real :
177 ! absice1: real :
178 ! absice2: real :
179 ! absice3: real :
180 ! absliq0: real :
181 ! absliq1: real :
182 !------------------------------------------------------------------
184 real(kind=rb) :: abscld1
185 real(kind=rb) , dimension(2) :: absice0
186 real(kind=rb) , dimension(2,5) :: absice1
187 real(kind=rb) , dimension(43,16) :: absice2
188 real(kind=rb) , dimension(46,16) :: absice3
189 real(kind=rb) :: absliq0
190 real(kind=rb) , dimension(58,16) :: absliq1
192 end module rrlw_cld
194 module rrlw_con
196 use parkind, only : rb => kind_rb
198 ! implicit none
199 save
201 !------------------------------------------------------------------
202 ! rrtmg_lw constants
204 ! Initial version: MJIacono, AER, jun2006
205 ! Revised: MJIacono, AER, aug2008
206 !------------------------------------------------------------------
208 ! name type purpose
209 ! ----- : ---- : ----------------------------------------------
210 ! fluxfac: real : radiance to flux conversion factor
211 ! heatfac: real : flux to heating rate conversion factor
212 !oneminus: real : 1.-1.e-6
213 ! pi : real : pi
214 ! grav : real : acceleration of gravity
215 ! planck : real : planck constant
216 ! boltz : real : boltzmann constant
217 ! clight : real : speed of light
218 ! avogad : real : avogadro constant
219 ! alosmt : real : loschmidt constant
220 ! gascon : real : molar gas constant
221 ! radcn1 : real : first radiation constant
222 ! radcn2 : real : second radiation constant
223 ! sbcnst : real : stefan-boltzmann constant
224 ! secdy : real : seconds per day
225 !------------------------------------------------------------------
227 real(kind=rb) :: fluxfac, heatfac
228 real(kind=rb) :: oneminus, pi, grav
229 real(kind=rb) :: planck, boltz, clight
230 real(kind=rb) :: avogad, alosmt, gascon
231 real(kind=rb) :: radcn1, radcn2
232 real(kind=rb) :: sbcnst, secdy
234 end module rrlw_con
236 module rrlw_kg01
238 use parkind ,only : im => kind_im, rb => kind_rb
240 ! implicit none
241 save
243 !-----------------------------------------------------------------
244 ! rrtmg_lw ORIGINAL abs. coefficients for interval 1
245 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
246 !
247 ! Initial version: JJMorcrette, ECMWF, jul1998
248 ! Revised: MJIacono, AER, jun2006
249 ! Revised: MJIacono, AER, aug2008
250 !-----------------------------------------------------------------
251 !
252 ! name type purpose
253 ! ---- : ---- : ---------------------------------------------
254 !fracrefao: real
255 !fracrefbo: real
256 ! kao : real
257 ! kbo : real
258 ! kao_mn2 : real
259 ! kbo_mn2 : real
260 ! selfrefo: real
261 ! forrefo : real
262 !-----------------------------------------------------------------
264 integer(kind=im), parameter :: no1 = 16
266 real(kind=rb) :: fracrefao(no1) , fracrefbo(no1)
267 real(kind=rb) :: kao(5,13,no1)
268 real(kind=rb) :: kbo(5,13:59,no1)
269 real(kind=rb) :: kao_mn2(19,no1) , kbo_mn2(19,no1)
270 real(kind=rb) :: selfrefo(10,no1), forrefo(4,no1)
272 !-----------------------------------------------------------------
273 ! rrtmg_lw COMBINED abs. coefficients for interval 1
274 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
275 !
276 ! Initial version: JJMorcrette, ECMWF, jul1998
277 ! Revised: MJIacono, AER, jun2006
278 ! Revised: MJIacono, AER, aug2008
279 !-----------------------------------------------------------------
280 !
281 ! name type purpose
282 ! ---- : ---- : ---------------------------------------------
283 !fracrefa : real
284 !fracrefb : real
285 ! ka : real
286 ! kb : real
287 ! absa : real
288 ! absb : real
289 ! ka_mn2 : real
290 ! kb_mn2 : real
291 ! selfref : real
292 ! forref : real
293 !-----------------------------------------------------------------
295 integer(kind=im), parameter :: ng1 = 10
297 real(kind=rb) :: fracrefa(ng1) , fracrefb(ng1)
298 real(kind=rb) :: ka(5,13,ng1) , absa(65,ng1)
299 real(kind=rb) :: kb(5,13:59,ng1), absb(235,ng1)
300 real(kind=rb) :: ka_mn2(19,ng1) , kb_mn2(19,ng1)
301 real(kind=rb) :: selfref(10,ng1), forref(4,ng1)
303 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
305 end module rrlw_kg01
307 module rrlw_kg02
309 use parkind ,only : im => kind_im, rb => kind_rb
311 ! implicit none
312 save
314 !-----------------------------------------------------------------
315 ! rrtmg_lw ORIGINAL abs. coefficients for interval 2
316 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
317 !
318 ! Initial version: JJMorcrette, ECMWF, jul1998
319 ! Revised: MJIacono, AER, jun2006
320 ! Revised: MJIacono, AER, aug2008
321 !-----------------------------------------------------------------
322 !
323 ! name type purpose
324 ! ---- : ---- : ---------------------------------------------
325 !fracrefao: real
326 !fracrefbo: real
327 ! kao : real
328 ! kbo : real
329 ! selfrefo: real
330 ! forrefo : real
331 !-----------------------------------------------------------------
333 integer(kind=im), parameter :: no2 = 16
335 real(kind=rb) :: fracrefao(no2) , fracrefbo(no2)
336 real(kind=rb) :: kao(5,13,no2)
337 real(kind=rb) :: kbo(5,13:59,no2)
338 real(kind=rb) :: selfrefo(10,no2) , forrefo(4,no2)
340 !-----------------------------------------------------------------
341 ! rrtmg_lw COMBINED abs. coefficients for interval 2
342 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
343 !
344 ! Initial version: JJMorcrette, ECMWF, jul1998
345 ! Revised: MJIacono, AER, jun2006
346 ! Revised: MJIacono, AER, aug2008
347 !-----------------------------------------------------------------
348 !
349 ! name type purpose
350 ! ---- : ---- : ---------------------------------------------
351 !fracrefa : real
352 !fracrefb : real
353 ! ka : real
354 ! kb : real
355 ! absa : real
356 ! absb : real
357 ! selfref : real
358 ! forref : real
359 !
360 ! refparam: real
361 !-----------------------------------------------------------------
363 integer(kind=im), parameter :: ng2 = 12
365 real(kind=rb) :: fracrefa(ng2) , fracrefb(ng2)
366 real(kind=rb) :: ka(5,13,ng2) , absa(65,ng2)
367 real(kind=rb) :: kb(5,13:59,ng2), absb(235,ng2)
368 real(kind=rb) :: selfref(10,ng2), forref(4,ng2)
370 real(kind=rb) :: refparam(13)
372 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
374 end module rrlw_kg02
376 module rrlw_kg03
378 use parkind ,only : im => kind_im, rb => kind_rb
380 ! implicit none
381 save
383 !-----------------------------------------------------------------
384 ! rrtmg_lw ORIGINAL abs. coefficients for interval 3
385 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
386 !
387 ! Initial version: JJMorcrette, ECMWF, jul1998
388 ! Revised: MJIacono, AER, jun2006
389 ! Revised: MJIacono, AER, aug2008
390 !-----------------------------------------------------------------
391 !
392 ! name type purpose
393 ! ---- : ---- : ---------------------------------------------
394 !fracrefao: real
395 !fracrefbo: real
396 ! kao : real
397 ! kbo : real
398 ! kao_mn2o: real
399 ! kbo_mn2o: real
400 ! selfrefo: real
401 ! forrefo : real
402 !-----------------------------------------------------------------
404 integer(kind=im), parameter :: no3 = 16
406 real(kind=rb) :: fracrefao(no3,9) ,fracrefbo(no3,5)
407 real(kind=rb) :: kao(9,5,13,no3)
408 real(kind=rb) :: kbo(5,5,13:59,no3)
409 real(kind=rb) :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3)
410 real(kind=rb) :: selfrefo(10,no3)
411 real(kind=rb) :: forrefo(4,no3)
413 !-----------------------------------------------------------------
414 ! rrtmg_lw COMBINED abs. coefficients for interval 3
415 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
416 !
417 ! Initial version: JJMorcrette, ECMWF, jul1998
418 ! Revised: MJIacono, AER, jun2006
419 ! Revised: MJIacono, AER, aug2008
420 !-----------------------------------------------------------------
421 !
422 ! name type purpose
423 ! ---- : ---- : ---------------------------------------------
424 !fracrefa : real
425 !fracrefb : real
426 ! ka : real
427 ! kb : real
428 ! ka_mn2o : real
429 ! kb_mn2o : real
430 ! selfref : real
431 ! forref : real
432 !
433 ! absa : real
434 ! absb : real
435 !-----------------------------------------------------------------
437 integer(kind=im), parameter :: ng3 = 16
439 real(kind=rb) :: fracrefa(ng3,9) ,fracrefb(ng3,5)
440 real(kind=rb) :: ka(9,5,13,ng3) ,absa(585,ng3)
441 real(kind=rb) :: kb(5,5,13:59,ng3),absb(1175,ng3)
442 real(kind=rb) :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3)
443 real(kind=rb) :: selfref(10,ng3)
444 real(kind=rb) :: forref(4,ng3)
446 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
448 end module rrlw_kg03
450 module rrlw_kg04
452 use parkind ,only : im => kind_im, rb => kind_rb
454 ! implicit none
455 save
457 !-----------------------------------------------------------------
458 ! rrtmg_lw ORIGINAL abs. coefficients for interval 4
459 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
460 !
461 ! Initial version: JJMorcrette, ECMWF, jul1998
462 ! Revised: MJIacono, AER, jun2006
463 ! Revised: MJIacono, AER, aug2008
464 !-----------------------------------------------------------------
465 !
466 ! name type purpose
467 ! ---- : ---- : ---------------------------------------------
468 !fracrefao: real
469 !fracrefbo: real
470 ! kao : real
471 ! kbo : real
472 ! selfrefo: real
473 ! forrefo : real
474 !-----------------------------------------------------------------
476 integer(kind=im), parameter :: no4 = 16
478 real(kind=rb) :: fracrefao(no4,9) ,fracrefbo(no4,5)
479 real(kind=rb) :: kao(9,5,13,no4)
480 real(kind=rb) :: kbo(5,5,13:59,no4)
481 real(kind=rb) :: selfrefo(10,no4) ,forrefo(4,no4)
483 !-----------------------------------------------------------------
484 ! rrtmg_lw COMBINED abs. coefficients for interval 4
485 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
486 !
487 ! Initial version: JJMorcrette, ECMWF, jul1998
488 ! Revised: MJIacono, AER, jun2006
489 ! Revised: MJIacono, AER, aug2008
490 !-----------------------------------------------------------------
491 !
492 ! name type purpose
493 ! ---- : ---- : ---------------------------------------------
494 ! absa : real
495 ! absb : real
496 !fracrefa : real
497 !fracrefb : real
498 ! ka : real
499 ! kb : real
500 ! selfref : real
501 ! forref : real
502 !-----------------------------------------------------------------
504 integer(kind=im), parameter :: ng4 = 14
506 real(kind=rb) :: fracrefa(ng4,9) ,fracrefb(ng4,5)
507 real(kind=rb) :: ka(9,5,13,ng4) ,absa(585,ng4)
508 real(kind=rb) :: kb(5,5,13:59,ng4),absb(1175,ng4)
509 real(kind=rb) :: selfref(10,ng4) ,forref(4,ng4)
511 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
513 end module rrlw_kg04
515 module rrlw_kg05
517 use parkind ,only : im => kind_im, rb => kind_rb
519 ! implicit none
520 save
522 !-----------------------------------------------------------------
523 ! rrtmg_lw ORIGINAL abs. coefficients for interval 5
524 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
525 !
526 ! Initial version: JJMorcrette, ECMWF, jul1998
527 ! Revised: MJIacono, AER, jun2006
528 ! Revised: MJIacono, AER, aug2008
529 !-----------------------------------------------------------------
530 !
531 ! name type purpose
532 ! ---- : ---- : ---------------------------------------------
533 !fracrefao: real
534 !fracrefbo: real
535 ! kao : real
536 ! kbo : real
537 ! kao_mo3 : real
538 ! selfrefo: real
539 ! forrefo : real
540 ! ccl4o : real
541 !-----------------------------------------------------------------
543 integer(kind=im), parameter :: no5 = 16
545 real(kind=rb) :: fracrefao(no5,9) ,fracrefbo(no5,5)
546 real(kind=rb) :: kao(9,5,13,no5)
547 real(kind=rb) :: kbo(5,5,13:59,no5)
548 real(kind=rb) :: kao_mo3(9,19,no5)
549 real(kind=rb) :: selfrefo(10,no5)
550 real(kind=rb) :: forrefo(4,no5)
551 real(kind=rb) :: ccl4o(no5)
553 !-----------------------------------------------------------------
554 ! rrtmg_lw COMBINED abs. coefficients for interval 5
555 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
556 !
557 ! Initial version: JJMorcrette, ECMWF, jul1998
558 ! Revised: MJIacono, AER, jun2006
559 ! Revised: MJIacono, AER, aug2008
560 !-----------------------------------------------------------------
561 !
562 ! name type purpose
563 ! ---- : ---- : ---------------------------------------------
564 !fracrefa : real
565 !fracrefb : real
566 ! ka : real
567 ! kb : real
568 ! ka_mo3 : real
569 ! selfref : real
570 ! forref : real
571 ! ccl4 : real
572 !
573 ! absa : real
574 ! absb : real
575 !-----------------------------------------------------------------
577 integer(kind=im), parameter :: ng5 = 16
579 real(kind=rb) :: fracrefa(ng5,9) ,fracrefb(ng5,5)
580 real(kind=rb) :: ka(9,5,13,ng5) ,absa(585,ng5)
581 real(kind=rb) :: kb(5,5,13:59,ng5),absb(1175,ng5)
582 real(kind=rb) :: ka_mo3(9,19,ng5)
583 real(kind=rb) :: selfref(10,ng5)
584 real(kind=rb) :: forref(4,ng5)
585 real(kind=rb) :: ccl4(ng5)
587 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
589 end module rrlw_kg05
591 module rrlw_kg06
593 use parkind ,only : im => kind_im, rb => kind_rb
595 ! implicit none
596 save
598 !-----------------------------------------------------------------
599 ! rrtmg_lw ORIGINAL abs. coefficients for interval 6
600 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
601 !
602 ! Initial version: JJMorcrette, ECMWF, jul1998
603 ! Revised: MJIacono, AER, jun2006
604 ! Revised: MJIacono, AER, aug2008
605 !-----------------------------------------------------------------
606 !
607 ! name type purpose
608 ! ---- : ---- : ---------------------------------------------
609 !fracrefao: real
610 ! kao : real
611 ! kao_mco2: real
612 ! selfrefo: real
613 ! forrefo : real
614 !cfc11adjo: real
615 ! cfc12o : real
616 !-----------------------------------------------------------------
618 integer(kind=im), parameter :: no6 = 16
620 real(kind=rb) , dimension(no6) :: fracrefao
621 real(kind=rb) :: kao(5,13,no6)
622 real(kind=rb) :: kao_mco2(19,no6)
623 real(kind=rb) :: selfrefo(10,no6)
624 real(kind=rb) :: forrefo(4,no6)
626 real(kind=rb) , dimension(no6) :: cfc11adjo
627 real(kind=rb) , dimension(no6) :: cfc12o
629 !-----------------------------------------------------------------
630 ! rrtmg_lw COMBINED abs. coefficients for interval 6
631 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
632 !
633 ! Initial version: JJMorcrette, ECMWF, jul1998
634 ! Revised: MJIacono, AER, jun2006
635 ! Revised: MJIacono, AER, aug2008
636 !-----------------------------------------------------------------
637 !
638 ! name type purpose
639 ! ---- : ---- : ---------------------------------------------
640 !fracrefa : real
641 ! ka : real
642 ! ka_mco2 : real
643 ! selfref : real
644 ! forref : real
645 !cfc11adj : real
646 ! cfc12 : real
647 !
648 ! absa : real
649 !-----------------------------------------------------------------
651 integer(kind=im), parameter :: ng6 = 8
653 real(kind=rb) , dimension(ng6) :: fracrefa
654 real(kind=rb) :: ka(5,13,ng6),absa(65,ng6)
655 real(kind=rb) :: ka_mco2(19,ng6)
656 real(kind=rb) :: selfref(10,ng6)
657 real(kind=rb) :: forref(4,ng6)
659 real(kind=rb) , dimension(ng6) :: cfc11adj
660 real(kind=rb) , dimension(ng6) :: cfc12
662 equivalence (ka(1,1,1),absa(1,1))
664 end module rrlw_kg06
666 module rrlw_kg07
668 use parkind ,only : im => kind_im, rb => kind_rb
670 ! implicit none
671 save
673 !-----------------------------------------------------------------
674 ! rrtmg_lw ORIGINAL abs. coefficients for interval 7
675 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
676 !
677 ! Initial version: JJMorcrette, ECMWF, jul1998
678 ! Revised: MJIacono, AER, jun2006
679 ! Revised: MJIacono, AER, aug2008
680 !-----------------------------------------------------------------
681 !
682 ! name type purpose
683 ! ---- : ---- : ---------------------------------------------
684 !fracrefao: real
685 !fracrefbo: real
686 ! kao : real
687 ! kbo : real
688 ! kao_mco2: real
689 ! kbo_mco2: real
690 ! selfrefo: real
691 ! forrefo : real
692 !-----------------------------------------------------------------
694 integer(kind=im), parameter :: no7 = 16
696 real(kind=rb) , dimension(no7) :: fracrefbo
697 real(kind=rb) :: fracrefao(no7,9)
698 real(kind=rb) :: kao(9,5,13,no7)
699 real(kind=rb) :: kbo(5,13:59,no7)
700 real(kind=rb) :: kao_mco2(9,19,no7)
701 real(kind=rb) :: kbo_mco2(19,no7)
702 real(kind=rb) :: selfrefo(10,no7)
703 real(kind=rb) :: forrefo(4,no7)
705 !-----------------------------------------------------------------
706 ! rrtmg_lw COMBINED abs. coefficients for interval 7
707 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
708 !
709 ! Initial version: JJMorcrette, ECMWF, jul1998
710 ! Revised: MJIacono, AER, jun2006
711 ! Revised: MJIacono, AER, aug2008
712 !-----------------------------------------------------------------
713 !
714 ! name type purpose
715 ! ---- : ---- : ---------------------------------------------
716 !fracrefa : real
717 !fracrefb : real
718 ! ka : real
719 ! kb : real
720 ! ka_mco2 : real
721 ! kb_mco2 : real
722 ! selfref : real
723 ! forref : real
724 !
725 ! absa : real
726 !-----------------------------------------------------------------
728 integer(kind=im), parameter :: ng7 = 12
730 real(kind=rb) , dimension(ng7) :: fracrefb
731 real(kind=rb) :: fracrefa(ng7,9)
732 real(kind=rb) :: ka(9,5,13,ng7) ,absa(585,ng7)
733 real(kind=rb) :: kb(5,13:59,ng7),absb(235,ng7)
734 real(kind=rb) :: ka_mco2(9,19,ng7)
735 real(kind=rb) :: kb_mco2(19,ng7)
736 real(kind=rb) :: selfref(10,ng7)
737 real(kind=rb) :: forref(4,ng7)
739 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
741 end module rrlw_kg07
743 module rrlw_kg08
745 use parkind ,only : im => kind_im, rb => kind_rb
747 ! implicit none
748 save
750 !-----------------------------------------------------------------
751 ! rrtmg_lw ORIGINAL abs. coefficients for interval 8
752 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
753 !
754 ! Initial version: JJMorcrette, ECMWF, jul1998
755 ! Revised: MJIacono, AER, jun2006
756 ! Revised: MJIacono, AER, aug2008
757 !-----------------------------------------------------------------
758 !
759 ! name type purpose
760 ! ---- : ---- : ---------------------------------------------
761 !fracrefao: real
762 !fracrefbo: real
763 ! kao : real
764 ! kbo : real
765 ! kao_mco2: real
766 ! kbo_mco2: real
767 ! kao_mn2o: real
768 ! kbo_mn2o: real
769 ! kao_mo3 : real
770 ! selfrefo: real
771 ! forrefo : real
772 ! cfc12o : real
773 !cfc22adjo: real
774 !-----------------------------------------------------------------
776 integer(kind=im), parameter :: no8 = 16
778 real(kind=rb) , dimension(no8) :: fracrefao
779 real(kind=rb) , dimension(no8) :: fracrefbo
780 real(kind=rb) , dimension(no8) :: cfc12o
781 real(kind=rb) , dimension(no8) :: cfc22adjo
783 real(kind=rb) :: kao(5,13,no8)
784 real(kind=rb) :: kao_mco2(19,no8)
785 real(kind=rb) :: kao_mn2o(19,no8)
786 real(kind=rb) :: kao_mo3(19,no8)
787 real(kind=rb) :: kbo(5,13:59,no8)
788 real(kind=rb) :: kbo_mco2(19,no8)
789 real(kind=rb) :: kbo_mn2o(19,no8)
790 real(kind=rb) :: selfrefo(10,no8)
791 real(kind=rb) :: forrefo(4,no8)
793 !-----------------------------------------------------------------
794 ! rrtmg_lw COMBINED abs. coefficients for interval 8
795 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
796 !
797 ! Initial version: JJMorcrette, ECMWF, jul1998
798 ! Revised: MJIacono, AER, jun2006
799 ! Revised: MJIacono, AER, aug2008
800 !-----------------------------------------------------------------
801 !
802 ! name type purpose
803 ! ---- : ---- : ---------------------------------------------
804 !fracrefa : real
805 !fracrefb : real
806 ! ka : real
807 ! kb : real
808 ! ka_mco2 : real
809 ! kb_mco2 : real
810 ! ka_mn2o : real
811 ! kb_mn2o : real
812 ! ka_mo3 : real
813 ! selfref : real
814 ! forref : real
815 ! cfc12 : real
816 ! cfc22adj: real
817 !
818 ! absa : real
819 ! absb : real
820 !-----------------------------------------------------------------
822 integer(kind=im), parameter :: ng8 = 8
824 real(kind=rb) , dimension(ng8) :: fracrefa
825 real(kind=rb) , dimension(ng8) :: fracrefb
826 real(kind=rb) , dimension(ng8) :: cfc12
827 real(kind=rb) , dimension(ng8) :: cfc22adj
829 real(kind=rb) :: ka(5,13,ng8) ,absa(65,ng8)
830 real(kind=rb) :: kb(5,13:59,ng8) ,absb(235,ng8)
831 real(kind=rb) :: ka_mco2(19,ng8)
832 real(kind=rb) :: ka_mn2o(19,ng8)
833 real(kind=rb) :: ka_mo3(19,ng8)
834 real(kind=rb) :: kb_mco2(19,ng8)
835 real(kind=rb) :: kb_mn2o(19,ng8)
836 real(kind=rb) :: selfref(10,ng8)
837 real(kind=rb) :: forref(4,ng8)
839 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
841 end module rrlw_kg08
843 module rrlw_kg09
845 use parkind ,only : im => kind_im, rb => kind_rb
847 ! implicit none
848 save
850 !-----------------------------------------------------------------
851 ! rrtmg_lw ORIGINAL abs. coefficients for interval 9
852 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
853 !
854 ! Initial version: JJMorcrette, ECMWF, jul1998
855 ! Revised: MJIacono, AER, jun2006
856 ! Revised: MJIacono, AER, aug2008
857 !-----------------------------------------------------------------
858 !
859 ! name type purpose
860 ! ---- : ---- : ---------------------------------------------
861 !fracrefao: real
862 !fracrefbo: real
863 ! kao : real
864 ! kbo : real
865 ! kao_mn2o: real
866 ! kbo_mn2o: real
867 ! selfrefo: real
868 ! forrefo : real
869 !-----------------------------------------------------------------
871 integer(kind=im), parameter :: no9 = 16
873 real(kind=rb) , dimension(no9) :: fracrefbo
875 real(kind=rb) :: fracrefao(no9,9)
876 real(kind=rb) :: kao(9,5,13,no9)
877 real(kind=rb) :: kbo(5,13:59,no9)
878 real(kind=rb) :: kao_mn2o(9,19,no9)
879 real(kind=rb) :: kbo_mn2o(19,no9)
880 real(kind=rb) :: selfrefo(10,no9)
881 real(kind=rb) :: forrefo(4,no9)
883 !-----------------------------------------------------------------
884 ! rrtmg_lw COMBINED abs. coefficients for interval 9
885 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
886 !
887 ! Initial version: JJMorcrette, ECMWF, jul1998
888 ! Revised: MJIacono, AER, jun2006
889 ! Revised: MJIacono, AER, aug2008
890 !-----------------------------------------------------------------
891 !
892 ! name type purpose
893 ! ---- : ---- : ---------------------------------------------
894 !fracrefa : real
895 !fracrefb : real
896 ! ka : real
897 ! kb : real
898 ! ka_mn2o : real
899 ! kb_mn2o : real
900 ! selfref : real
901 ! forref : real
902 !
903 ! absa : real
904 ! absb : real
905 !-----------------------------------------------------------------
907 integer(kind=im), parameter :: ng9 = 12
909 real(kind=rb) , dimension(ng9) :: fracrefb
910 real(kind=rb) :: fracrefa(ng9,9)
911 real(kind=rb) :: ka(9,5,13,ng9) ,absa(585,ng9)
912 real(kind=rb) :: kb(5,13:59,ng9) ,absb(235,ng9)
913 real(kind=rb) :: ka_mn2o(9,19,ng9)
914 real(kind=rb) :: kb_mn2o(19,ng9)
915 real(kind=rb) :: selfref(10,ng9)
916 real(kind=rb) :: forref(4,ng9)
918 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
920 end module rrlw_kg09
922 module rrlw_kg10
924 use parkind ,only : im => kind_im, rb => kind_rb
926 ! implicit none
927 save
929 !-----------------------------------------------------------------
930 ! rrtmg_lw ORIGINAL abs. coefficients for interval 10
931 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
932 !
933 ! Initial version: JJMorcrette, ECMWF, jul1998
934 ! Revised: MJIacono, AER, jun2006
935 ! Revised: MJIacono, AER, aug2008
936 !-----------------------------------------------------------------
937 !
938 ! name type purpose
939 ! ---- : ---- : ---------------------------------------------
940 !fracrefao: real
941 !fracrefbo: real
942 ! kao : real
943 ! kbo : real
944 ! selfrefo: real
945 ! forrefo : real
946 !-----------------------------------------------------------------
948 integer(kind=im), parameter :: no10 = 16
950 real(kind=rb) , dimension(no10) :: fracrefao
951 real(kind=rb) , dimension(no10) :: fracrefbo
953 real(kind=rb) :: kao(5,13,no10)
954 real(kind=rb) :: kbo(5,13:59,no10)
955 real(kind=rb) :: selfrefo(10,no10)
956 real(kind=rb) :: forrefo(4,no10)
958 !-----------------------------------------------------------------
959 ! rrtmg_lw COMBINED abs. coefficients for interval 10
960 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
961 !
962 ! Initial version: JJMorcrette, ECMWF, jul1998
963 ! Revised: MJIacono, AER, jun2006
964 ! Revised: MJIacono, AER, aug2008
965 !-----------------------------------------------------------------
966 !
967 ! name type purpose
968 ! ---- : ---- : ---------------------------------------------
969 !fracrefao: real
970 !fracrefbo: real
971 ! kao : real
972 ! kbo : real
973 ! selfref : real
974 ! forref : real
975 !
976 ! absa : real
977 ! absb : real
978 !-----------------------------------------------------------------
980 integer(kind=im), parameter :: ng10 = 6
982 real(kind=rb) , dimension(ng10) :: fracrefa
983 real(kind=rb) , dimension(ng10) :: fracrefb
985 real(kind=rb) :: ka(5,13,ng10) , absa(65,ng10)
986 real(kind=rb) :: kb(5,13:59,ng10), absb(235,ng10)
987 real(kind=rb) :: selfref(10,ng10)
988 real(kind=rb) :: forref(4,ng10)
990 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
992 end module rrlw_kg10
994 module rrlw_kg11
996 use parkind ,only : im => kind_im, rb => kind_rb
998 ! implicit none
999 save
1001 !-----------------------------------------------------------------
1002 ! rrtmg_lw ORIGINAL abs. coefficients for interval 11
1003 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
1004 !
1005 ! Initial version: JJMorcrette, ECMWF, jul1998
1006 ! Revised: MJIacono, AER, jun2006
1007 ! Revised: MJIacono, AER, aug2008
1008 !-----------------------------------------------------------------
1009 !
1010 ! name type purpose
1011 ! ---- : ---- : ---------------------------------------------
1012 !fracrefao: real
1013 !fracrefbo: real
1014 ! kao : real
1015 ! kbo : real
1016 ! kao_mo2 : real
1017 ! kbo_mo2 : real
1018 ! selfrefo: real
1019 ! forrefo : real
1020 !-----------------------------------------------------------------
1022 integer(kind=im), parameter :: no11 = 16
1024 real(kind=rb) , dimension(no11) :: fracrefao
1025 real(kind=rb) , dimension(no11) :: fracrefbo
1027 real(kind=rb) :: kao(5,13,no11)
1028 real(kind=rb) :: kbo(5,13:59,no11)
1029 real(kind=rb) :: kao_mo2(19,no11)
1030 real(kind=rb) :: kbo_mo2(19,no11)
1031 real(kind=rb) :: selfrefo(10,no11)
1032 real(kind=rb) :: forrefo(4,no11)
1034 !-----------------------------------------------------------------
1035 ! rrtmg_lw COMBINED abs. coefficients for interval 11
1036 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
1037 !
1038 ! Initial version: JJMorcrette, ECMWF, jul1998
1039 ! Revised: MJIacono, AER, jun2006
1040 ! Revised: MJIacono, AER, aug2008
1041 !-----------------------------------------------------------------
1042 !
1043 ! name type purpose
1044 ! ---- : ---- : ---------------------------------------------
1045 !fracrefa : real
1046 !fracrefb : real
1047 ! ka : real
1048 ! kb : real
1049 ! ka_mo2 : real
1050 ! kb_mo2 : real
1051 ! selfref : real
1052 ! forref : real
1053 !
1054 ! absa : real
1055 ! absb : real
1056 !-----------------------------------------------------------------
1058 integer(kind=im), parameter :: ng11 = 8
1060 real(kind=rb) , dimension(ng11) :: fracrefa
1061 real(kind=rb) , dimension(ng11) :: fracrefb
1063 real(kind=rb) :: ka(5,13,ng11) , absa(65,ng11)
1064 real(kind=rb) :: kb(5,13:59,ng11), absb(235,ng11)
1065 real(kind=rb) :: ka_mo2(19,ng11)
1066 real(kind=rb) :: kb_mo2(19,ng11)
1067 real(kind=rb) :: selfref(10,ng11)
1068 real(kind=rb) :: forref(4,ng11)
1070 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1072 end module rrlw_kg11
1074 module rrlw_kg12
1076 use parkind ,only : im => kind_im, rb => kind_rb
1078 ! implicit none
1079 save
1081 !-----------------------------------------------------------------
1082 ! rrtmg_lw ORIGINAL abs. coefficients for interval 12
1083 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1084 !
1085 ! Initial version: JJMorcrette, ECMWF, jul1998
1086 ! Revised: MJIacono, AER, jun2006
1087 ! Revised: MJIacono, AER, aug2008
1088 !-----------------------------------------------------------------
1089 !
1090 ! name type purpose
1091 ! ---- : ---- : ---------------------------------------------
1092 !fracrefao: real
1093 ! kao : real
1094 ! selfrefo: real
1095 ! forrefo : real
1096 !-----------------------------------------------------------------
1098 integer(kind=im), parameter :: no12 = 16
1100 real(kind=rb) :: fracrefao(no12,9)
1101 real(kind=rb) :: kao(9,5,13,no12)
1102 real(kind=rb) :: selfrefo(10,no12)
1103 real(kind=rb) :: forrefo(4,no12)
1105 !-----------------------------------------------------------------
1106 ! rrtmg_lw COMBINED abs. coefficients for interval 12
1107 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1108 !
1109 ! Initial version: JJMorcrette, ECMWF, jul1998
1110 ! Revised: MJIacono, AER, jun2006
1111 ! Revised: MJIacono, AER, aug2008
1112 !-----------------------------------------------------------------
1113 !
1114 ! name type purpose
1115 ! ---- : ---- : ---------------------------------------------
1116 !fracrefa : real
1117 ! ka : real
1118 ! selfref : real
1119 ! forref : real
1120 !
1121 ! absa : real
1122 !-----------------------------------------------------------------
1124 integer(kind=im), parameter :: ng12 = 8
1126 real(kind=rb) :: fracrefa(ng12,9)
1127 real(kind=rb) :: ka(9,5,13,ng12) ,absa(585,ng12)
1128 real(kind=rb) :: selfref(10,ng12)
1129 real(kind=rb) :: forref(4,ng12)
1131 equivalence (ka(1,1,1,1),absa(1,1))
1133 end module rrlw_kg12
1135 module rrlw_kg13
1137 use parkind ,only : im => kind_im, rb => kind_rb
1139 ! implicit none
1140 save
1142 !-----------------------------------------------------------------
1143 ! rrtmg_lw ORIGINAL abs. coefficients for interval 13
1144 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1145 !
1146 ! Initial version: JJMorcrette, ECMWF, jul1998
1147 ! Revised: MJIacono, AER, jun2006
1148 ! Revised: MJIacono, AER, aug2008
1149 !-----------------------------------------------------------------
1150 !
1151 ! name type purpose
1152 ! ---- : ---- : ---------------------------------------------
1153 !fracrefao: real
1154 ! kao : real
1155 ! kao_mco2: real
1156 ! kao_mco : real
1157 ! kbo_mo3 : real
1158 ! selfrefo: real
1159 ! forrefo : real
1160 !-----------------------------------------------------------------
1162 integer(kind=im), parameter :: no13 = 16
1164 real(kind=rb) , dimension(no13) :: fracrefbo
1166 real(kind=rb) :: fracrefao(no13,9)
1167 real(kind=rb) :: kao(9,5,13,no13)
1168 real(kind=rb) :: kao_mco2(9,19,no13)
1169 real(kind=rb) :: kao_mco(9,19,no13)
1170 real(kind=rb) :: kbo_mo3(19,no13)
1171 real(kind=rb) :: selfrefo(10,no13)
1172 real(kind=rb) :: forrefo(4,no13)
1174 !-----------------------------------------------------------------
1175 ! rrtmg_lw COMBINED abs. coefficients for interval 13
1176 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1177 !
1178 ! Initial version: JJMorcrette, ECMWF, jul1998
1179 ! Revised: MJIacono, AER, jun2006
1180 ! Revised: MJIacono, AER, aug2008
1181 !-----------------------------------------------------------------
1182 !
1183 ! name type purpose
1184 ! ---- : ---- : ---------------------------------------------
1185 !fracrefa : real
1186 ! ka : real
1187 ! ka_mco2 : real
1188 ! ka_mco : real
1189 ! kb_mo3 : real
1190 ! selfref : real
1191 ! forref : real
1192 !
1193 ! absa : real
1194 !-----------------------------------------------------------------
1196 integer(kind=im), parameter :: ng13 = 4
1198 real(kind=rb) , dimension(ng13) :: fracrefb
1200 real(kind=rb) :: fracrefa(ng13,9)
1201 real(kind=rb) :: ka(9,5,13,ng13) ,absa(585,ng13)
1202 real(kind=rb) :: ka_mco2(9,19,ng13)
1203 real(kind=rb) :: ka_mco(9,19,ng13)
1204 real(kind=rb) :: kb_mo3(19,ng13)
1205 real(kind=rb) :: selfref(10,ng13)
1206 real(kind=rb) :: forref(4,ng13)
1208 equivalence (ka(1,1,1,1),absa(1,1))
1210 end module rrlw_kg13
1212 module rrlw_kg14
1214 use parkind ,only : im => kind_im, rb => kind_rb
1216 ! implicit none
1217 save
1219 !-----------------------------------------------------------------
1220 ! rrtmg_lw ORIGINAL abs. coefficients for interval 14
1221 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1222 !
1223 ! Initial version: JJMorcrette, ECMWF, jul1998
1224 ! Revised: MJIacono, AER, jun2006
1225 ! Revised: MJIacono, AER, aug2008
1226 !-----------------------------------------------------------------
1227 !
1228 ! name type purpose
1229 ! ---- : ---- : ---------------------------------------------
1230 !fracrefao: real
1231 !fracrefbo: real
1232 ! kao : real
1233 ! kbo : real
1234 ! selfrefo: real
1235 ! forrefo : real
1236 !-----------------------------------------------------------------
1238 integer(kind=im), parameter :: no14 = 16
1240 real(kind=rb) , dimension(no14) :: fracrefao
1241 real(kind=rb) , dimension(no14) :: fracrefbo
1243 real(kind=rb) :: kao(5,13,no14)
1244 real(kind=rb) :: kbo(5,13:59,no14)
1245 real(kind=rb) :: selfrefo(10,no14)
1246 real(kind=rb) :: forrefo(4,no14)
1248 !-----------------------------------------------------------------
1249 ! rrtmg_lw COMBINED abs. coefficients for interval 14
1250 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1251 !
1252 ! Initial version: JJMorcrette, ECMWF, jul1998
1253 ! Revised: MJIacono, AER, jun2006
1254 ! Revised: MJIacono, AER, aug2008
1255 !-----------------------------------------------------------------
1256 !
1257 ! name type purpose
1258 ! ---- : ---- : ---------------------------------------------
1259 !fracrefa : real
1260 !fracrefb : real
1261 ! ka : real
1262 ! kb : real
1263 ! selfref : real
1264 ! forref : real
1265 !
1266 ! absa : real
1267 ! absb : real
1268 !-----------------------------------------------------------------
1270 integer(kind=im), parameter :: ng14 = 2
1272 real(kind=rb) , dimension(ng14) :: fracrefa
1273 real(kind=rb) , dimension(ng14) :: fracrefb
1275 real(kind=rb) :: ka(5,13,ng14) ,absa(65,ng14)
1276 real(kind=rb) :: kb(5,13:59,ng14),absb(235,ng14)
1277 real(kind=rb) :: selfref(10,ng14)
1278 real(kind=rb) :: forref(4,ng14)
1280 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1282 end module rrlw_kg14
1284 module rrlw_kg15
1286 use parkind ,only : im => kind_im, rb => kind_rb
1288 ! implicit none
1289 save
1291 !-----------------------------------------------------------------
1292 ! rrtmg_lw ORIGINAL abs. coefficients for interval 15
1293 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1294 !
1295 ! Initial version: JJMorcrette, ECMWF, jul1998
1296 ! Revised: MJIacono, AER, jun2006
1297 ! Revised: MJIacono, AER, aug2008
1298 !-----------------------------------------------------------------
1299 !
1300 ! name type purpose
1301 ! ---- : ---- : ---------------------------------------------
1302 !fracrefao: real
1303 ! kao : real
1304 ! kao_mn2 : real
1305 ! selfrefo: real
1306 ! forrefo : real
1307 !-----------------------------------------------------------------
1309 integer(kind=im), parameter :: no15 = 16
1311 real(kind=rb) :: fracrefao(no15,9)
1312 real(kind=rb) :: kao(9,5,13,no15)
1313 real(kind=rb) :: kao_mn2(9,19,no15)
1314 real(kind=rb) :: selfrefo(10,no15)
1315 real(kind=rb) :: forrefo(4,no15)
1318 !-----------------------------------------------------------------
1319 ! rrtmg_lw COMBINED abs. coefficients for interval 15
1320 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1321 !
1322 ! Initial version: JJMorcrette, ECMWF, jul1998
1323 ! Revised: MJIacono, AER, jun2006
1324 ! Revised: MJIacono, AER, aug2008
1325 !-----------------------------------------------------------------
1326 !
1327 ! name type purpose
1328 ! ---- : ---- : ---------------------------------------------
1329 !fracrefa : real
1330 ! ka : real
1331 ! ka_mn2 : real
1332 ! selfref : real
1333 ! forref : real
1334 !
1335 ! absa : real
1336 !-----------------------------------------------------------------
1338 integer(kind=im), parameter :: ng15 = 2
1340 real(kind=rb) :: fracrefa(ng15,9)
1341 real(kind=rb) :: ka(9,5,13,ng15) ,absa(585,ng15)
1342 real(kind=rb) :: ka_mn2(9,19,ng15)
1343 real(kind=rb) :: selfref(10,ng15)
1344 real(kind=rb) :: forref(4,ng15)
1346 equivalence (ka(1,1,1,1),absa(1,1))
1348 end module rrlw_kg15
1350 module rrlw_kg16
1352 use parkind ,only : im => kind_im, rb => kind_rb
1354 ! implicit none
1355 save
1357 !-----------------------------------------------------------------
1358 ! rrtmg_lw ORIGINAL abs. coefficients for interval 16
1359 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1360 !
1361 ! Initial version: JJMorcrette, ECMWF, jul1998
1362 ! Revised: MJIacono, AER, jun2006
1363 ! Revised: MJIacono, AER, aug2008
1364 !-----------------------------------------------------------------
1365 !
1366 ! name type purpose
1367 ! ---- : ---- : ---------------------------------------------
1368 !fracrefao: real
1369 ! kao : real
1370 ! kbo : real
1371 ! selfrefo: real
1372 ! forrefo : real
1373 !-----------------------------------------------------------------
1375 integer(kind=im), parameter :: no16 = 16
1377 real(kind=rb) , dimension(no16) :: fracrefbo
1379 real(kind=rb) :: fracrefao(no16,9)
1380 real(kind=rb) :: kao(9,5,13,no16)
1381 real(kind=rb) :: kbo(5,13:59,no16)
1382 real(kind=rb) :: selfrefo(10,no16)
1383 real(kind=rb) :: forrefo(4,no16)
1385 !-----------------------------------------------------------------
1386 ! rrtmg_lw COMBINED abs. coefficients for interval 16
1387 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1388 !
1389 ! Initial version: JJMorcrette, ECMWF, jul1998
1390 ! Revised: MJIacono, AER, jun2006
1391 ! Revised: MJIacono, AER, aug2008
1392 !-----------------------------------------------------------------
1393 !
1394 ! name type purpose
1395 ! ---- : ---- : ---------------------------------------------
1396 !fracrefa : real
1397 ! ka : real
1398 ! kb : real
1399 ! selfref : real
1400 ! forref : real
1401 !
1402 ! absa : real
1403 ! absb : real
1404 !-----------------------------------------------------------------
1406 integer(kind=im), parameter :: ng16 = 2
1408 real(kind=rb) , dimension(ng16) :: fracrefb
1410 real(kind=rb) :: fracrefa(ng16,9)
1411 real(kind=rb) :: ka(9,5,13,ng16) ,absa(585,ng16)
1412 real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
1413 real(kind=rb) :: selfref(10,ng16)
1414 real(kind=rb) :: forref(4,ng16)
1416 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1418 end module rrlw_kg16
1421 module rrlw_ref
1423 use parkind, only : im => kind_im, rb => kind_rb
1425 ! implicit none
1426 save
1428 !------------------------------------------------------------------
1429 ! rrtmg_lw reference atmosphere
1430 ! Based on standard mid-latitude summer profile
1431 !
1432 ! Initial version: JJMorcrette, ECMWF, jul1998
1433 ! Revised: MJIacono, AER, jun2006
1434 ! Revised: MJIacono, AER, aug2008
1435 !------------------------------------------------------------------
1437 ! name type purpose
1438 ! ----- : ---- : ----------------------------------------------
1439 ! pref : real : Reference pressure levels
1440 ! preflog: real : Reference pressure levels, ln(pref)
1441 ! tref : real : Reference temperature levels for MLS profile
1442 ! chi_mls: real :
1443 !------------------------------------------------------------------
1445 real(kind=rb) , dimension(59) :: pref
1446 real(kind=rb) , dimension(59) :: preflog
1447 real(kind=rb) , dimension(59) :: tref
1448 real(kind=rb) :: chi_mls(7,59)
1450 end module rrlw_ref
1452 module rrlw_tbl
1454 use parkind, only : im => kind_im, rb => kind_rb
1456 ! implicit none
1457 save
1459 !------------------------------------------------------------------
1460 ! rrtmg_lw exponential lookup table arrays
1462 ! Initial version: JJMorcrette, ECMWF, jul1998
1463 ! Revised: MJIacono, AER, Jun 2006
1464 ! Revised: MJIacono, AER, Aug 2007
1465 ! Revised: MJIacono, AER, Aug 2008
1466 !------------------------------------------------------------------
1468 ! name type purpose
1469 ! ----- : ---- : ----------------------------------------------
1470 ! ntbl : integer: Lookup table dimension
1471 ! tblint : real : Lookup table conversion factor
1472 ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative
1473 ! transfer)
1474 ! exp_tbl: real : Transmittance lookup table
1475 ! tfn_tbl: real : Tau transition function; i.e. the transition of
1476 ! the Planck function from that for the mean layer
1477 ! temperature to that for the layer boundary
1478 ! temperature as a function of optical depth.
1479 ! The "linear in tau" method is used to make
1480 ! the table.
1481 ! pade : real : Pade constant
1482 ! bpade : real : Inverse of Pade constant
1483 !------------------------------------------------------------------
1485 integer(kind=im), parameter :: ntbl = 10000
1487 real(kind=rb), parameter :: tblint = 10000.0_rb
1489 real(kind=rb) , dimension(0:ntbl) :: tau_tbl
1490 real(kind=rb) , dimension(0:ntbl) :: exp_tbl
1491 real(kind=rb) , dimension(0:ntbl) :: tfn_tbl
1493 real(kind=rb), parameter :: pade = 0.278_rb
1494 real(kind=rb) :: bpade
1496 end module rrlw_tbl
1498 module rrlw_vsn
1500 ! implicit none
1501 save
1503 !------------------------------------------------------------------
1504 ! rrtmg_lw version information
1506 ! Initial version: JJMorcrette, ECMWF, jul1998
1507 ! Revised: MJIacono, AER, jun2006
1508 ! Revised: MJIacono, AER, aug2008
1509 !------------------------------------------------------------------
1511 ! name type purpose
1512 ! ----- : ---- : ----------------------------------------------
1513 !hnamrtm :character:
1514 !hnamini :character:
1515 !hnamcld :character:
1516 !hnamclc :character:
1517 !hnamrtr :character:
1518 !hnamrtx :character:
1519 !hnamrtc :character:
1520 !hnamset :character:
1521 !hnamtau :character:
1522 !hnamatm :character:
1523 !hnamutl :character:
1524 !hnamext :character:
1525 !hnamkg :character:
1526 !
1527 ! hvrrtm :character:
1528 ! hvrini :character:
1529 ! hvrcld :character:
1530 ! hvrclc :character:
1531 ! hvrrtr :character:
1532 ! hvrrtx :character:
1533 ! hvrrtc :character:
1534 ! hvrset :character:
1535 ! hvrtau :character:
1536 ! hvratm :character:
1537 ! hvrutl :character:
1538 ! hvrext :character:
1539 ! hvrkg :character:
1540 !------------------------------------------------------------------
1542 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, &
1543 hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
1544 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, &
1545 hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
1547 character*18 hvrkg
1548 character*20 hnamkg
1550 end module rrlw_vsn
1552 module rrlw_wvn
1554 use parkind, only : im => kind_im, rb => kind_rb
1555 use parrrtm, only : nbndlw, mg, ngptlw, maxinpx
1557 ! implicit none
1558 save
1560 !------------------------------------------------------------------
1561 ! rrtmg_lw spectral information
1563 ! Initial version: JJMorcrette, ECMWF, jul1998
1564 ! Revised: MJIacono, AER, jun2006
1565 ! Revised: MJIacono, AER, aug2008
1566 !------------------------------------------------------------------
1568 ! name type purpose
1569 ! ----- : ---- : ----------------------------------------------
1570 ! ng : integer: Number of original g-intervals in each spectral band
1571 ! nspa : integer: For the lower atmosphere, the number of reference
1572 ! atmospheres that are stored for each spectral band
1573 ! per pressure level and temperature. Each of these
1574 ! atmospheres has different relative amounts of the
1575 ! key species for the band (i.e. different binary
1576 ! species parameters).
1577 ! nspb : integer: Same as nspa for the upper atmosphere
1578 !wavenum1: real : Spectral band lower boundary in wavenumbers
1579 !wavenum2: real : Spectral band upper boundary in wavenumbers
1580 ! delwave: real : Spectral band width in wavenumbers
1581 ! totplnk: real : Integrated Planck value for each band; (band 16
1582 ! includes total from 2600 cm-1 to infinity)
1583 ! Used for calculation across total spectrum
1584 !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1)
1585 ! Used for calculation in band 16 only if
1586 ! individual band output requested
1587 !
1588 ! ngc : integer: The number of new g-intervals in each band
1589 ! ngs : integer: The cumulative sum of new g-intervals for each band
1590 ! ngm : integer: The index of each new g-interval relative to the
1591 ! original 16 g-intervals in each band
1592 ! ngn : integer: The number of original g-intervals that are
1593 ! combined to make each new g-intervals in each band
1594 ! ngb : integer: The band index for each new g-interval
1595 ! wt : real : RRTM weights for the original 16 g-intervals
1596 ! rwgt : real : Weights for combining original 16 g-intervals
1597 ! (256 total) into reduced set of g-intervals
1598 ! (140 total)
1599 ! nxmol : integer: Number of cross-section molecules
1600 ! ixindx : integer: Flag for active cross-sections in calculation
1601 !------------------------------------------------------------------
1603 integer(kind=im) :: ng(nbndlw)
1604 integer(kind=im) :: nspa(nbndlw)
1605 integer(kind=im) :: nspb(nbndlw)
1607 real(kind=rb) :: wavenum1(nbndlw)
1608 real(kind=rb) :: wavenum2(nbndlw)
1609 real(kind=rb) :: delwave(nbndlw)
1611 real(kind=rb) :: totplnk(181,nbndlw)
1612 real(kind=rb) :: totplk16(181)
1614 integer(kind=im) :: ngc(nbndlw)
1615 integer(kind=im) :: ngs(nbndlw)
1616 integer(kind=im) :: ngn(ngptlw)
1617 integer(kind=im) :: ngb(ngptlw)
1618 integer(kind=im) :: ngm(nbndlw*mg)
1620 real(kind=rb) :: wt(mg)
1621 real(kind=rb) :: rwgt(nbndlw*mg)
1623 integer(kind=im) :: nxmol
1624 integer(kind=im) :: ixindx(maxinpx)
1626 end module rrlw_wvn
1628 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
1629 ! author: $Author: trn $
1630 ! revision: $Revision: 1.3 $
1631 ! created: $Date: 2009/04/16 19:54:22 $
1632 !
1634 ! Fortran-95 implementation of the Mersenne Twister 19937, following
1635 ! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10),
1636 ! adapted cosmetically by making the names more general.
1637 ! Users must declare one or more variables of type randomNumberSequence in the calling
1638 ! procedure which are then initialized using a required seed. If the
1639 ! variable is not initialized the random numbers will all be 0.
1640 ! For example:
1641 ! program testRandoms
1642 ! use RandomNumbers
1643 ! type(randomNumberSequence) :: randomNumbers
1644 ! integer :: i
1645 !
1646 ! randomNumbers = new_RandomNumberSequence(seed = 100)
1647 ! do i = 1, 10
1648 ! print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
1649 ! end do
1650 ! end program testRandoms
1651 !
1652 ! Fortran-95 implementation by
1653 ! Robert Pincus
1654 ! NOAA-CIRES Climate Diagnostics Center
1655 ! Boulder, CO 80305
1656 ! email: Robert.Pincus@colorado.edu
1657 !
1658 ! This documentation in the original C program reads:
1659 ! -------------------------------------------------------------
1660 ! A C-program for MT19937, with initialization improved 2002/2/10.
1661 ! Coded by Takuji Nishimura and Makoto Matsumoto.
1662 ! This is a faster version by taking Shawn Cokus's optimization,
1663 ! Matthe Bellew's simplification, Isaku Wada's real version.
1664 !
1665 ! Before using, initialize the state by using init_genrand(seed)
1666 ! or init_by_array(init_key, key_length).
1667 !
1668 ! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
1669 ! All rights reserved.
1670 !
1671 ! Redistribution and use in source and binary forms, with or without
1672 ! modification, are permitted provided that the following conditions
1673 ! are met:
1674 !
1675 ! 1. Redistributions of source code must retain the above copyright
1676 ! notice, this list of conditions and the following disclaimer.
1677 !
1678 ! 2. Redistributions in binary form must reproduce the above copyright
1679 ! notice, this list of conditions and the following disclaimer in the
1680 ! documentation and/or other materials provided with the distribution.
1681 !
1682 ! 3. The names of its contributors may not be used to endorse or promote
1683 ! products derived from this software without specific prior written
1684 ! permission.
1685 !
1686 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1687 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1688 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1689 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
1690 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
1691 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
1692 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
1693 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1694 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1695 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
1696 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1697 !
1698 !
1699 ! Any feedback is very welcome.
1700 ! http://www.math.keio.ac.jp/matumoto/emt.html
1701 ! email: matumoto@math.keio.ac.jp
1702 ! -------------------------------------------------------------
1704 module MersenneTwister
1705 ! -------------------------------------------------------------
1707 use parkind, only : im => kind_im, rb => kind_rb
1709 implicit none
1710 private
1712 ! Algorithm parameters
1713 ! -------
1714 ! Period parameters
1715 integer(kind=im), parameter :: blockSize = 624, &
1716 M = 397, &
1717 MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL)
1718 UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL)
1719 LMASK = 2147483647 ! least significant r bits (0x7fffffffUL)
1720 ! Tempering parameters
1721 integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
1722 TMASKC= -272236544 ! (0xefc60000UL)
1723 ! -------
1725 ! The type containing the state variable
1726 type randomNumberSequence
1727 integer(kind=im) :: currentElement ! = blockSize
1728 integer(kind=im), dimension(0:blockSize -1) :: state ! = 0
1729 end type randomNumberSequence
1731 interface new_RandomNumberSequence
1732 module procedure initialize_scalar, initialize_vector
1733 end interface new_RandomNumberSequence
1735 public :: randomNumberSequence
1736 public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
1737 getRandomInt, getRandomPositiveInt, getRandomReal
1738 ! -------------------------------------------------------------
1739 contains
1740 ! -------------------------------------------------------------
1741 ! Private functions
1742 ! ---------------------------
1743 function mixbits(u, v)
1744 integer(kind=im), intent( in) :: u, v
1745 integer(kind=im) :: mixbits
1747 mixbits = ior(iand(u, UMASK), iand(v, LMASK))
1748 end function mixbits
1749 ! ---------------------------
1750 function twist(u, v)
1751 integer(kind=im), intent( in) :: u, v
1752 integer(kind=im) :: twist
1754 ! Local variable
1755 integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /)
1757 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1758 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1759 end function twist
1760 ! ---------------------------
1761 subroutine nextState(twister)
1762 type(randomNumberSequence), intent(inout) :: twister
1764 ! Local variables
1765 integer(kind=im) :: k
1767 do k = 0, blockSize - M - 1
1768 twister%state(k) = ieor(twister%state(k + M), &
1769 twist(twister%state(k), twister%state(k + 1_im)))
1770 end do
1771 do k = blockSize - M, blockSize - 2
1772 twister%state(k) = ieor(twister%state(k + M - blockSize), &
1773 twist(twister%state(k), twister%state(k + 1_im)))
1774 end do
1775 twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), &
1776 twist(twister%state(blockSize - 1_im), twister%state(0_im)))
1777 twister%currentElement = 0_im
1779 end subroutine nextState
1780 ! ---------------------------
1781 elemental function temper(y)
1782 integer(kind=im), intent(in) :: y
1783 integer(kind=im) :: temper
1785 integer(kind=im) :: x
1787 ! Tempering
1788 x = ieor(y, ishft(y, -11))
1789 x = ieor(x, iand(ishft(x, 7), TMASKB))
1790 x = ieor(x, iand(ishft(x, 15), TMASKC))
1791 temper = ieor(x, ishft(x, -18))
1792 end function temper
1793 ! -------------------------------------------------------------
1794 ! Public (but hidden) functions
1795 ! --------------------
1796 function initialize_scalar(seed) result(twister)
1797 integer(kind=im), intent(in ) :: seed
1798 type(randomNumberSequence) :: twister
1800 integer(kind=im) :: i
1801 ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions,
1802 ! MSBs of the seed affect only MSBs of the array state[].
1803 ! 2002/01/09 modified by Makoto Matsumoto
1805 twister%state(0) = iand(seed, -1_im)
1806 do i = 1, blockSize - 1 ! ubound(twister%state)
1807 twister%state(i) = 1812433253_im * ieor(twister%state(i-1), &
1808 ishft(twister%state(i-1), -30_im)) + i
1809 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1810 end do
1811 twister%currentElement = blockSize
1812 end function initialize_scalar
1813 ! -------------------------------------------------------------
1814 function initialize_vector(seed) result(twister)
1815 integer(kind=im), dimension(0:), intent(in) :: seed
1816 type(randomNumberSequence) :: twister
1818 integer(kind=im) :: i, j, k, nFirstLoop, nWraps
1820 nWraps = 0
1821 twister = initialize_scalar(19650218_im)
1823 nFirstLoop = max(blockSize, size(seed))
1824 do k = 1, nFirstLoop
1825 i = mod(k + nWraps, blockSize)
1826 j = mod(k - 1, size(seed))
1827 if(i == 0) then
1828 twister%state(i) = twister%state(blockSize - 1)
1829 twister%state(1) = ieor(twister%state(1), &
1830 ieor(twister%state(1-1), &
1831 ishft(twister%state(1-1), -30_im)) * 1664525_im) + &
1832 seed(j) + j ! Non-linear
1833 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1834 nWraps = nWraps + 1
1835 else
1836 twister%state(i) = ieor(twister%state(i), &
1837 ieor(twister%state(i-1), &
1838 ishft(twister%state(i-1), -30_im)) * 1664525_im) + &
1839 seed(j) + j ! Non-linear
1840 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1841 end if
1842 end do
1844 !
1845 ! Walk through the state array, beginning where we left off in the block above
1846 !
1847 do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
1848 twister%state(i) = ieor(twister%state(i), &
1849 ieor(twister%state(i-1), &
1850 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1851 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1852 end do
1854 twister%state(0) = twister%state(blockSize - 1)
1856 do i = 1, mod(nFirstLoop, blockSize) + nWraps
1857 twister%state(i) = ieor(twister%state(i), &
1858 ieor(twister%state(i-1), &
1859 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1860 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1861 end do
1863 twister%state(0) = UMASK
1864 twister%currentElement = blockSize
1866 end function initialize_vector
1867 ! -------------------------------------------------------------
1868 ! Public functions
1869 ! --------------------
1870 function getRandomInt(twister)
1871 type(randomNumberSequence), intent(inout) :: twister
1872 integer(kind=im) :: getRandomInt
1873 ! Generate a random integer on the interval [0,0xffffffff]
1874 ! Equivalent to genrand_int32 in the C code.
1875 ! Fortran doesn't have a type that's unsigned like C does,
1876 ! so this is integers in the range -2**31 - 2**31
1877 ! All functions for getting random numbers call this one,
1878 ! then manipulate the result
1880 if(twister%currentElement >= blockSize) call nextState(twister)
1882 getRandomInt = temper(twister%state(twister%currentElement))
1883 twister%currentElement = twister%currentElement + 1
1885 end function getRandomInt
1886 ! --------------------
1887 function getRandomPositiveInt(twister)
1888 type(randomNumberSequence), intent(inout) :: twister
1889 integer(kind=im) :: getRandomPositiveInt
1890 ! Generate a random integer on the interval [0,0x7fffffff]
1891 ! or [0,2**31]
1892 ! Equivalent to genrand_int31 in the C code.
1894 ! Local integers
1895 integer(kind=im) :: localInt
1897 localInt = getRandomInt(twister)
1898 getRandomPositiveInt = ishft(localInt, -1)
1900 end function getRandomPositiveInt
1901 ! --------------------
1902 !! mji - modified Jan 2007, double converted to rrtmg real kind type
1903 function getRandomReal(twister)
1904 type(randomNumberSequence), intent(inout) :: twister
1905 ! double precision :: getRandomReal
1906 real(kind=rb) :: getRandomReal
1907 ! Generate a random number on [0,1]
1908 ! Equivalent to genrand_real1 in the C code
1909 ! The result is stored as double precision but has 32 bit resolution
1911 integer(kind=im) :: localInt
1913 localInt = getRandomInt(twister)
1914 if(localInt < 0) then
1915 ! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
1916 getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb)
1917 else
1918 ! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0)
1919 getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb)
1920 end if
1922 end function getRandomReal
1923 ! --------------------
1924 subroutine finalize_RandomNumberSequence(twister)
1925 type(randomNumberSequence), intent(inout) :: twister
1927 twister%currentElement = blockSize
1928 twister%state(:) = 0_im
1929 end subroutine finalize_RandomNumberSequence
1931 ! --------------------
1933 end module MersenneTwister
1936 module mcica_random_numbers
1938 ! Generic module to wrap random number generators.
1939 ! The module defines a type that identifies the particular stream of random
1940 ! numbers, and has procedures for initializing it and getting real numbers
1941 ! in the range 0 to 1.
1942 ! This version uses the Mersenne Twister to generate random numbers on [0, 1].
1943 !
1944 use MersenneTwister, only: randomNumberSequence, & ! The random number engine.
1945 new_RandomNumberSequence, getRandomReal
1946 !! mji
1947 !! use time_manager_mod, only: time_type, get_date
1949 use parkind, only : im => kind_im, rb => kind_rb
1951 implicit none
1952 private
1954 type randomNumberStream
1955 type(randomNumberSequence) :: theNumbers
1956 end type randomNumberStream
1958 interface getRandomNumbers
1959 module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
1960 end interface getRandomNumbers
1962 interface initializeRandomNumberStream
1963 module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
1964 end interface initializeRandomNumberStream
1966 public :: randomNumberStream, &
1967 initializeRandomNumberStream, getRandomNumbers
1968 !! mji
1969 !! initializeRandomNumberStream, getRandomNumbers, &
1970 !! constructSeed
1971 contains
1972 ! ---------------------------------------------------------
1973 ! Initialization
1974 ! ---------------------------------------------------------
1975 function initializeRandomNumberStream_S(seed) result(new)
1976 integer(kind=im), intent( in) :: seed
1977 type(randomNumberStream) :: new
1979 new%theNumbers = new_RandomNumberSequence(seed)
1981 end function initializeRandomNumberStream_S
1982 ! ---------------------------------------------------------
1983 function initializeRandomNumberStream_V(seed) result(new)
1984 integer(kind=im), dimension(:), intent( in) :: seed
1985 type(randomNumberStream) :: new
1987 new%theNumbers = new_RandomNumberSequence(seed)
1989 end function initializeRandomNumberStream_V
1990 ! ---------------------------------------------------------
1991 ! Procedures for drawing random numbers
1992 ! ---------------------------------------------------------
1993 subroutine getRandomNumber_Scalar(stream, number)
1994 type(randomNumberStream), intent(inout) :: stream
1995 real(kind=rb), intent( out) :: number
1997 number = getRandomReal(stream%theNumbers)
1998 end subroutine getRandomNumber_Scalar
1999 ! ---------------------------------------------------------
2000 subroutine getRandomNumber_1D(stream, numbers)
2001 type(randomNumberStream), intent(inout) :: stream
2002 real(kind=rb), dimension(:), intent( out) :: numbers
2004 ! Local variables
2005 integer(kind=im) :: i
2007 do i = 1, size(numbers)
2008 numbers(i) = getRandomReal(stream%theNumbers)
2009 end do
2010 end subroutine getRandomNumber_1D
2011 ! ---------------------------------------------------------
2012 subroutine getRandomNumber_2D(stream, numbers)
2013 type(randomNumberStream), intent(inout) :: stream
2014 real(kind=rb), dimension(:, :), intent( out) :: numbers
2016 ! Local variables
2017 integer(kind=im) :: i
2019 do i = 1, size(numbers, 2)
2020 call getRandomNumber_1D(stream, numbers(:, i))
2021 end do
2022 end subroutine getRandomNumber_2D
2023 ! mji
2024 ! ! ---------------------------------------------------------
2025 ! ! Constructing a unique seed from grid cell index and model date/time
2026 ! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute
2027 ! ! ---------------------------------------------------------
2028 ! function constructSeed(i, j, time) result(seed)
2029 ! integer(kind=im), intent( in) :: i, j
2030 ! type(time_type), intent( in) :: time
2031 ! integer(kind=im), dimension(8) :: seed
2032 !
2033 ! ! Local variables
2034 ! integer(kind=im) :: year, month, day, hour, minute, second
2035 !
2036 !
2037 ! call get_date(time, year, month, day, hour, minute, second)
2038 ! seed = (/ i, j, year, month, day, hour, minute, second /)
2039 ! end function constructSeed
2041 end module mcica_random_numbers
2043 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2044 ! author: $Author: trn $
2045 ! revision: $Revision: 1.3 $
2046 ! created: $Date: 2009/04/16 19:54:22 $
2047 !
2048 module mcica_subcol_gen_lw
2050 ! --------------------------------------------------------------------------
2051 ! | |
2052 ! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). |
2053 ! | This software may be used, copied, or redistributed as long as it is |
2054 ! | not sold and this copyright notice is reproduced on each copy made. |
2055 ! | This model is provided as is without any express or implied warranties. |
2056 ! | (http://www.rtweb.aer.com/) |
2057 ! | |
2058 ! --------------------------------------------------------------------------
2060 ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
2061 ! Two options are possible:
2062 ! 1) Input cloud physical properties: cloud fraction, ice and liquid water
2063 ! paths, ice fraction, and particle sizes. Output will be stochastic
2064 ! arrays of these variables. (inflag = 1)
2065 ! 2) Input cloud optical properties directly: cloud optical depth, single
2066 ! scattering albedo and asymmetry parameter. Output will be stochastic
2067 ! arrays of these variables. (inflag = 0; longwave scattering is not
2068 ! yet available, ssac and asmc are for future expansion)
2070 ! --------- Modules ----------
2072 use parkind, only : im => kind_im, rb => kind_rb
2073 use parrrtm, only : nbndlw, ngptlw
2074 use rrlw_con, only: grav, pi
2075 use rrlw_wvn, only: ngb
2076 use rrlw_vsn
2078 implicit none
2080 ! public interfaces/functions/subroutines
2081 public :: mcica_subcol_lw, generate_stochastic_clouds
2083 contains
2085 !------------------------------------------------------------------
2086 ! Public subroutines
2087 !------------------------------------------------------------------
2088 ! mji - Add height needed for exponential and exponential-random cloud overlap methods
2089 ! (icld=4 and 5, respectively) along with idcor, juldat and lat used to specify
2090 ! the decorrelation length for these methods
2091 subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
2092 cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, &
2093 hgt, idcor, juldat, lat, &
2094 cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl)
2096 ! ----- Input -----
2097 ! Control
2098 integer(kind=im), intent(in) :: iplon ! column/longitude index
2099 integer(kind=im), intent(in) :: ncol ! number of columns
2100 integer(kind=im), intent(in) :: nlay ! number of model layers
2101 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2102 integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times,
2103 ! permute the seed between each call.
2104 ! between calls for LW and SW, recommended
2105 ! permuteseed differes by 'ngpt'
2106 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2107 ! 0 = kissvec
2108 ! 1 = Mersenne Twister
2110 ! Atmosphere
2111 real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb)
2112 ! Dimensions: (ncol,nlay)
2114 real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
2115 ! Dimensions: (ncol,nlay)
2117 ! Atmosphere/clouds - cldprop
2118 real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction
2119 ! Dimensions: (ncol,nlay)
2120 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2121 ! Dimensions: (nbndlw,ncol,nlay)
2122 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2123 ! Dimensions: (nbndlw,ncol,nlay)
2124 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2125 ! Dimensions: (nbndlw,ncol,nlay)
2126 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2127 ! Dimensions: (ncol,nlay)
2128 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2129 ! Dimensions: (ncol,nlay)
2130 real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path
2131 ! Dimensions: (ncol,nlay)
2132 real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size
2133 ! Dimensions: (ncol,nlay)
2134 real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size
2135 ! Dimensions: (ncol,nlay)
2136 real(kind=rb), intent(in) :: res(:,:) ! snow particle size
2137 ! Dimensions: (ncol,nlay)
2138 integer(kind=im), intent(in) :: idcor ! Decorrelation length type
2139 integer(kind=im), intent(in) :: juldat ! Julian date (day of year, 1-365)
2140 real(kind=rb), intent(in) :: lat ! latitude (degrees, -90 to 90)
2142 ! ----- Output -----
2143 ! Atmosphere/clouds - cldprmc [mcica]
2144 real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
2145 ! Dimensions: (ngptlw,ncol,nlay)
2146 real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
2147 ! Dimensions: (ngptlw,ncol,nlay)
2148 real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
2149 ! Dimensions: (ngptlw,ncol,nlay)
2150 real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow path [mcica]
2151 ! Dimensions: (ngptlw,ncol,nlay)
2152 real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns)
2153 ! Dimensions: (ncol,nlay)
2154 real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns)
2155 ! Dimensions: (ncol,nlay)
2156 real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns)
2157 ! Dimensions: (ncol,nlay)
2158 real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
2159 ! Dimensions: (ngptlw,ncol,nlay)
2160 ! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica]
2161 ! Dimensions: (ngptlw,ncol,nlay)
2162 ! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica]
2163 ! Dimensions: (ngptlw,ncol,nlay)
2165 ! ----- Local -----
2167 ! Stochastic cloud generator variables [mcica]
2168 integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals)
2169 integer(kind=im) :: ilev ! loop index
2171 real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa)
2172 ! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa)
2173 ! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity)
2174 ! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity)
2176 ! MJI - For latitude dependent decorrelation length
2177 real(kind=rb), parameter :: am1 = 1.4315_rb
2178 real(kind=rb), parameter :: am2 = 2.1219_rb
2179 real(kind=rb), parameter :: am4 = -25.584_rb
2180 real(kind=rb), parameter :: amr = 7._rb
2181 real(kind=rb) :: am3
2182 real(kind=rb) :: decorr_len(ncol) ! decorrelation length (meters)
2183 real(kind=rb), parameter :: Zo_default = 2500._rb ! default constant decorrelation length (m)
2185 ! Return if clear sky; or stop if icld out of range
2186 if (icld.eq.0) return
2187 if (icld.lt.0.or.icld.gt.5) then
2188 stop 'MCICA_SUBCOL: INVALID ICLD'
2189 endif
2191 ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns
2194 ! Pass particle sizes to new arrays, no subcolumns for these properties yet
2195 ! Convert pressures from mb to Pa
2197 reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
2198 relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
2199 resnmcl(:ncol,:nlay) = res(:ncol,:nlay)
2200 pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
2202 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components
2204 ! cwp = (q * pdel * 1000.) / gravit)
2205 ! = (kg/kg * kg m-1 s-2 *1000.) / m s-2
2206 ! = (g m-2)
2207 !
2208 ! q = (cwp * gravit) / (pdel *1000.)
2209 ! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
2210 ! = kg/kg
2212 ! do ilev = 1, nlay
2213 ! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2214 ! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2215 ! enddo
2217 ! MJI - Latitude and day of year dependent decorrelation length
2218 if (idcor .eq. 1) then
2219 ! Derive decorrelation length based on day of year and latitude (from NASA GMAO method)
2220 ! Result is in meters
2221 if (juldat .gt. 181) then
2222 am3 = -4._rb * amr / 365._rb * (juldat-272)
2223 else
2224 am3 = 4._rb * amr / 365._rb * (juldat-91)
2225 endif
2226 ! Latitude in radians, decorrelation length in meters
2227 ! decorr_len(:) = ( am1 + am2 * exp(-(lat*180._rb/pi - am3)**2 / (am4*am4)) ) * 1.e3_rb
2228 ! Latitude in degrees, decorrelation length in meters
2229 decorr_len(:) = ( am1 + am2 * exp(-(lat - am3)**2 / (am4*am4)) ) * 1.e3_rb
2230 else
2231 ! Spatially and temporally constant decorrelation length
2232 decorr_len(:) = Zo_default
2233 endif
2235 ! Generate the stochastic subcolumns of cloud optical properties for the longwave;
2236 call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, cswp, tauc, &
2237 hgt, decorr_len, &
2238 cldfmcl, clwpmcl, ciwpmcl, cswpmcl, taucmcl, permuteseed)
2240 end subroutine mcica_subcol_lw
2243 !-------------------------------------------------------------------------------------------------
2244 subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, cswp, tauc, &
2245 hgt, decorr_len, &
2246 cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, tauc_stoch, changeSeed)
2247 !-------------------------------------------------------------------------------------------------
2249 !----------------------------------------------------------------------------------------------------------------
2250 ! ---------------------
2251 ! Contact: Cecile Hannay (hannay@ucar.edu)
2252 !
2253 ! Original code: Based on Raisanen et al., QJRMS, 2004.
2254 !
2255 ! Modifications:
2256 ! 1) Generalized for use with RRTMG and added Mersenne Twister as the default
2257 ! random number generator, which can be changed to the optional kissvec random number generator
2258 ! with flag 'irng'. Some extra functionality has been commented or removed.
2259 ! Michael J. Iacono, AER, Inc., February 2007
2260 ! 2) Activated exponential and exponential/random cloud overlap method
2261 ! Michael J. Iacono, AER, November 2017
2262 !
2263 ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
2264 ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
2265 ! and uniform cloud liquid and cloud ice concentration.
2266 ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
2267 ! and obeys an overlap assumption in the vertical.
2268 !
2269 ! Overlap assumption:
2270 ! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random.
2271 ! The default option is maximum-random (option 2)
2272 ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random
2273 ! This is set with the variable "overlap"
2274 ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
2275 !
2276 ! Seed:
2277 ! If the stochastic cloud generator is called several times during the same timestep,
2278 ! one should change the seed between the call to insure that the subcolumns are different.
2279 ! This is done by changing the argument 'changeSeed'
2280 ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
2281 ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
2282 !
2283 ! PDF assumption:
2284 ! We can use arbitrary complicated PDFS.
2285 ! In the present version, we produce homogeneuous clouds (the simplest case).
2286 ! Future developments include using the PDF scheme of Ben Johnson.
2287 !
2288 ! History file:
2289 ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
2290 ! nsubcol = number of subcolumns
2291 ! overlap = overlap type (1-3)
2292 ! Zo = length scale
2293 ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
2294 ! CLDLIQ_S = mean of the subcolumn cloud water
2295 ! CLDICE_S = mean of the subcolumn cloud ice
2296 !
2297 ! Note:
2298 ! Here: we force that the cloud condensate to be consistent with the cloud fraction
2299 ! i.e we only have cloud condensate when the cell is cloudy.
2300 ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
2301 ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
2302 ! without cloud condensate or the opposite).
2303 !---------------------------------------------------------------------------------------------------------------
2305 use mcica_random_numbers
2306 ! The Mersenne Twister random number engine
2307 use MersenneTwister, only: randomNumberSequence, &
2308 new_RandomNumberSequence, getRandomReal
2310 type(randomNumberSequence) :: randomNumbers
2312 ! -- Arguments
2314 integer(kind=im), intent(in) :: ncol ! number of columns
2315 integer(kind=im), intent(in) :: nlay ! number of layers
2316 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2317 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2318 ! 0 = kissvec
2319 ! 1 = Mersenne Twister
2320 integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
2321 integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed
2323 ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
2324 real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa)
2325 ! Dimensions: (ncol,nlay)
2326 real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m)
2327 ! Dimensions: (ncol,nlay)
2328 real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction
2329 ! Dimensions: (ncol,nlay)
2330 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2331 ! Dimensions: (ncol,nlay)
2332 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2333 ! Dimensions: (ncol,nlay)
2334 real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path
2335 ! Dimensions: (ncol,nlay)
2336 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2337 ! Dimensions: (nbndlw,ncol,nlay)
2338 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2339 ! Dimensions: (nbndlw,ncol,nlay)
2340 ! inactive - for future expansion
2341 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2342 ! Dimensions: (nbndlw,ncol,nlay)
2343 ! inactive - for future expansion
2344 real(kind=rb), intent(in) :: decorr_len(:) ! decorrelation length (meters)
2345 ! Dimensions: (ncol)
2347 real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
2348 ! Dimensions: (ngptlw,ncol,nlay)
2349 real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
2350 ! Dimensions: (ngptlw,ncol,nlay)
2351 real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
2352 ! Dimensions: (ngptlw,ncol,nlay)
2353 real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path
2354 ! Dimensions: (ngptlw,ncol,nlay)
2355 real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
2356 ! Dimensions: (ngptlw,ncol,nlay)
2357 ! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
2358 ! Dimensions: (ngptlw,ncol,nlay)
2359 ! inactive - for future expansion
2360 ! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter
2361 ! Dimensions: (ngptlw,ncol,nlay)
2362 ! inactive - for future expansion
2364 ! -- Local variables
2365 real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction
2367 ! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
2368 ! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction
2369 ! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water
2370 ! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice
2371 ! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth
2372 ! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo
2373 ! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter
2375 ! Set overlap
2376 integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random,
2377 ! 3 = maximum overlap, 4 = exponential,
2378 ! 5 = exponential-random
2379 real(kind=rb) :: Zo_inv(ncol) ! inverse of decorrelation length scale (m)
2380 real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter
2382 ! Constants (min value for cloud fraction and cloud water and ice)
2383 real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
2384 ! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used)
2386 ! Variables related to random number and seed
2387 real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers
2388 integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
2389 real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec)
2390 integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister)
2391 real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister)
2393 ! Flag to identify cloud fraction in subcolumns
2394 logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy
2396 ! Indices
2397 integer(kind=im) :: ilev, isubcol, i, n ! indices
2399 !------------------------------------------------------------------------------------------
2401 ! Check that irng is in bounds; if not, set to default
2402 if (irng .ne. 0) irng = 1
2404 ! Pass input cloud overlap setting to local variable
2405 overlap = icld
2406 Zo_inv(:) = 1._rb / decorr_len(:)
2408 ! Ensure that cloud fractions are in bounds
2409 do ilev = 1, nlay
2410 do i = 1, ncol
2411 cldf(i,ilev) = cld(i,ilev)
2412 if (cldf(i,ilev) < cldmin) then
2413 cldf(i,ilev) = 0._rb
2414 endif
2415 enddo
2416 enddo
2418 ! ----- Create seed --------
2420 ! Advance randum number generator by changeseed values
2421 if (irng.eq.0) then
2422 ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
2423 ! Must use pmid from bottom four layers.
2424 do i=1,ncol
2425 if (pmid(i,1).lt.pmid(i,2)) then
2426 stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
2427 endif
2428 seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im
2429 seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im
2430 seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im
2431 seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im
2432 enddo
2433 do i=1,changeSeed
2434 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2435 enddo
2436 elseif (irng.eq.1) then
2437 randomNumbers = new_RandomNumberSequence(seed = changeSeed)
2438 endif
2441 ! ------ Apply overlap assumption --------
2443 ! generate the random numbers
2445 select case (overlap)
2447 case(1)
2448 ! Random overlap
2449 ! i) pick a random value at every level
2451 if (irng.eq.0) then
2452 do isubcol = 1,nsubcol
2453 do ilev = 1,nlay
2454 call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level
2455 CDF(isubcol,:,ilev) = rand_num
2456 enddo
2457 enddo
2458 elseif (irng.eq.1) then
2459 do isubcol = 1, nsubcol
2460 do i = 1, ncol
2461 do ilev = 1, nlay
2462 rand_num_mt = getRandomReal(randomNumbers)
2463 CDF(isubcol,i,ilev) = rand_num_mt
2464 enddo
2465 enddo
2466 enddo
2467 endif
2469 case(2)
2470 ! Maximum-Random overlap
2471 ! i) pick a random number for top layer.
2472 ! ii) walk down the column:
2473 ! - if the layer above is cloudy, we use the same random number than in the layer above
2474 ! - if the layer above is clear, we use a new random number
2476 if (irng.eq.0) then
2477 do isubcol = 1,nsubcol
2478 do ilev = 1,nlay
2479 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2480 CDF(isubcol,:,ilev) = rand_num
2481 enddo
2482 enddo
2483 elseif (irng.eq.1) then
2484 do isubcol = 1, nsubcol
2485 do i = 1, ncol
2486 do ilev = 1, nlay
2487 rand_num_mt = getRandomReal(randomNumbers)
2488 CDF(isubcol,i,ilev) = rand_num_mt
2489 enddo
2490 enddo
2491 enddo
2492 endif
2494 do ilev = 2,nlay
2495 do i = 1, ncol
2496 do isubcol = 1, nsubcol
2497 if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
2498 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1)
2499 else
2500 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1))
2501 endif
2502 enddo
2503 enddo
2504 enddo
2506 case(3)
2507 ! Maximum overlap
2508 ! i) pick the same random numebr at every level
2510 if (irng.eq.0) then
2511 do isubcol = 1,nsubcol
2512 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2513 do ilev = 1,nlay
2514 CDF(isubcol,:,ilev) = rand_num
2515 enddo
2516 enddo
2517 elseif (irng.eq.1) then
2518 do isubcol = 1, nsubcol
2519 do i = 1, ncol
2520 rand_num_mt = getRandomReal(randomNumbers)
2521 do ilev = 1, nlay
2522 CDF(isubcol,i,ilev) = rand_num_mt
2523 enddo
2524 enddo
2525 enddo
2526 endif
2528 case(4)
2529 ! Exponential overlap: transition from maximum to random cloud overlap increases
2530 ! exponentially with layer thickness and distance through layers
2531 !
2532 ! The random numbers for exponential overlap verify:
2533 ! j=1 RAN(j)=RND1
2534 ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
2535 ! RAN(j) = RND2
2536 ! alpha is obtained from the equation
2537 ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale
2539 ! compute alpha
2540 do i = 1, ncol
2541 alpha(i, 1) = 0._rb
2542 do ilev = 2,nlay
2543 alpha(i, ilev) = exp( -(hgt(i,ilev) - hgt(i,ilev-1)) * Zo_inv(i))
2544 enddo
2545 enddo
2547 ! generate 2 streams of random numbers
2548 if (irng.eq.0) then
2549 do isubcol = 1,nsubcol
2550 do ilev = 1,nlay
2551 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2552 CDF(isubcol, :, ilev) = rand_num
2553 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2554 CDF2(isubcol, :, ilev) = rand_num
2555 enddo
2556 enddo
2557 elseif (irng.eq.1) then
2558 do isubcol = 1, nsubcol
2559 do i = 1, ncol
2560 do ilev = 1, nlay
2561 rand_num_mt = getRandomReal(randomNumbers)
2562 CDF(isubcol,i,ilev) = rand_num_mt
2563 rand_num_mt = getRandomReal(randomNumbers)
2564 CDF2(isubcol,i,ilev) = rand_num_mt
2565 enddo
2566 enddo
2567 enddo
2568 endif
2570 ! generate random numbers
2571 do ilev = 2,nlay
2572 where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
2573 CDF(:,:,ilev) = CDF(:,:,ilev-1)
2574 end where
2575 end do
2577 case(5)
2578 ! Exponential_Random overlap: transition from maximum to random cloud overlap increases
2579 ! exponentially with layer thickness and with distance through adjacent cloudy layers.
2580 ! Non-adjacent blocks of clouds are treated randomly, and each block begins a new
2581 ! exponential transition from maximum to random.
2582 !
2583 ! compute alpha: bottom to top
2584 ! - set alpha to 0 in bottom layer (no layer below for correlation)
2585 do i = 1, ncol
2586 alpha(i, 1) = 0._rb
2587 do ilev = 2,nlay
2588 alpha(i, ilev) = exp( -(hgt(i,ilev) - hgt(i,ilev-1) ) * Zo_inv(i))
2589 ! Decorrelate layers when clear layer follows a cloudy layer to enforce
2590 ! random correlation between non-adjacent cloudy layers
2591 if (cldf(i,ilev) .eq. 0.0_rb .and. cldf(i,ilev-1) .gt. 0.0_rb) then
2592 alpha(i,ilev) = 0.0_rb
2593 endif
2594 end do
2595 end do
2597 ! generate 2 streams of random numbers
2598 ! CDF2 is used to select which sub-columns are vertically correlated relative to alpha
2599 ! CDF is used to select which sub-columns are treated as cloudy relative to cloud fraction
2600 if (irng.eq.0) then
2601 do isubcol = 1,nsubcol
2602 do ilev = 1,nlay
2603 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2604 CDF(isubcol, :, ilev) = rand_num
2605 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2606 CDF2(isubcol, :, ilev) = rand_num
2607 end do
2608 end do
2609 elseif (irng.eq.1) then
2610 do isubcol = 1, nsubcol
2611 do i = 1, ncol
2612 do ilev = 1,nlay
2613 rand_num_mt = getRandomReal(randomNumbers)
2614 CDF(isubcol,i,ilev) = rand_num_mt
2615 rand_num_mt = getRandomReal(randomNumbers)
2616 CDF2(isubcol,i,ilev) = rand_num_mt
2617 enddo
2618 enddo
2619 enddo
2620 endif
2621 ! generate vertical correlations in random number arrays - bottom to top
2622 do ilev = 2,nlay
2623 where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
2624 CDF(:,:,ilev) = CDF(:,:,ilev-1)
2625 end where
2626 end do
2628 end select
2631 ! -- generate subcolumns for homogeneous clouds -----
2632 do ilev = 1,nlay
2633 iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
2634 enddo
2636 ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
2637 ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
2638 ! where there is a cloud, define the subcolumn cloud properties,
2639 ! otherwise set these to zero
2641 do ilev = 1,nlay
2642 do i = 1, ncol
2643 do isubcol = 1, nsubcol
2644 if (iscloudy(isubcol,i,ilev) ) then
2645 cld_stoch(isubcol,i,ilev) = 1._rb
2646 clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
2647 ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
2648 cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
2649 n = ngb(isubcol)
2650 tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
2651 ! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
2652 ! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
2653 else
2654 cld_stoch(isubcol,i,ilev) = 0._rb
2655 clwp_stoch(isubcol,i,ilev) = 0._rb
2656 ciwp_stoch(isubcol,i,ilev) = 0._rb
2657 cswp_stoch(isubcol,i,ilev) = 0._rb
2658 tauc_stoch(isubcol,i,ilev) = 0._rb
2659 ! ssac_stoch(isubcol,i,ilev) = 1._rb
2660 ! asmc_stoch(isubcol,i,ilev) = 1._rb
2661 endif
2662 enddo
2663 enddo
2664 enddo
2666 ! -- compute the means of the subcolumns ---
2667 ! mean_cld_stoch(:,:) = 0._rb
2668 ! mean_clwp_stoch(:,:) = 0._rb
2669 ! mean_ciwp_stoch(:,:) = 0._rb
2670 ! mean_tauc_stoch(:,:) = 0._rb
2671 ! mean_ssac_stoch(:,:) = 0._rb
2672 ! mean_asmc_stoch(:,:) = 0._rb
2673 ! do i = 1, nsubcol
2674 ! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:)
2675 ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:)
2676 ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:)
2677 ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:)
2678 ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:)
2679 ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:)
2680 ! end do
2681 ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
2682 ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
2683 ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
2684 ! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
2685 ! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
2686 ! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
2688 end subroutine generate_stochastic_clouds
2691 !------------------------------------------------------------------
2692 ! Private subroutines
2693 !------------------------------------------------------------------
2695 !--------------------------------------------------------------------------------------------------
2696 subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
2697 !--------------------------------------------------------------------------------------------------
2699 ! public domain code
2700 ! made available from http://www.fortran.com/
2701 ! downloaded by pjr on 03/16/04 for NCAR CAM
2702 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
2704 ! The KISS (Keep It Simple Stupid) random number generator. Combines:
2705 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
2706 ! (2) A 3-shift shift-register generator, period 2^32-1,
2707 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
2708 ! Overall period>2^123;
2709 !
2710 real(kind=rb), dimension(:), intent(inout) :: ran_arr
2711 integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
2712 integer(kind=im) :: i,sz,kiss
2713 integer(kind=im) :: m, k, n
2715 ! inline function
2716 m(k, n) = ieor (k, ishft (k, n) )
2718 sz = size(ran_arr)
2719 do i = 1, sz
2720 seed1(i) = 69069_im * seed1(i) + 1327217885_im
2721 seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
2722 seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
2723 seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
2724 kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
2725 ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
2726 end do
2728 end subroutine kissvec
2730 end module mcica_subcol_gen_lw
2732 ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_cldprmc.f90,v $
2733 ! author: $Author: mike $
2734 ! revision: $Revision: 1.8 $
2735 ! created: $Date: 2009/05/22 21:04:30 $
2736 !
2737 module rrtmg_lw_cldprmc
2739 ! --------------------------------------------------------------------------
2740 ! | |
2741 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
2742 ! | This software may be used, copied, or redistributed as long as it is |
2743 ! | not sold and this copyright notice is reproduced on each copy made. |
2744 ! | This model is provided as is without any express or implied warranties. |
2745 ! | (http://www.rtweb.aer.com/) |
2746 ! | |
2747 ! --------------------------------------------------------------------------
2749 ! --------- Modules ----------
2751 use parkind, only : im => kind_im, rb => kind_rb
2752 use parrrtm, only : ngptlw, nbndlw
2753 use rrlw_cld, only: abscld1, absliq0, absliq1, &
2754 absice0, absice1, absice2, absice3
2755 use rrlw_wvn, only: ngb
2756 use rrlw_vsn, only: hvrclc, hnamclc
2758 implicit none
2760 contains
2762 ! ------------------------------------------------------------------------------
2763 subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
2764 ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc)
2765 ! ------------------------------------------------------------------------------
2767 ! Purpose: Compute the cloud optical depth(s) for each cloudy layer.
2769 ! ------- Input -------
2771 integer(kind=im), intent(in) :: nlayers ! total number of layers
2772 integer(kind=im), intent(in) :: inflag ! see definitions
2773 integer(kind=im), intent(in) :: iceflag ! see definitions
2774 integer(kind=im), intent(in) :: liqflag ! see definitions
2776 real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica]
2777 ! Dimensions: (ngptlw,nlayers)
2778 real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica]
2779 ! Dimensions: (ngptlw,nlayers)
2780 real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica]
2781 ! Dimensions: (ngptlw,nlayers)
2782 real(kind=rb), intent(in) :: cswpmc(:,:) ! cloud snow path [mcica]
2783 ! Dimensions: (ngptlw,nlayers)
2784 real(kind=rb), intent(in) :: relqmc(:) ! liquid particle effective radius (microns)
2785 ! Dimensions: (nlayers)
2786 real(kind=rb), intent(in) :: reicmc(:) ! ice particle effective radius (microns)
2787 ! Dimensions: (nlayers)
2788 real(kind=rb), intent(in) :: resnmc(:) ! snow particle effective radius (microns)
2789 ! Dimensions: (nlayers)
2790 ! specific definition of reicmc depends on setting of iceflag:
2791 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
2792 ! r_ec must be >= 10.0 microns
2793 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
2794 ! r_ec range is limited to 13.0 to 130.0 microns
2795 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
2796 ! r_k range is limited to 5.0 to 131.0 microns
2797 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
2798 ! dge range is limited to 5.0 to 140.0 microns
2799 ! [dge = 1.0315 * r_ec]
2801 ! ------- Output -------
2803 integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands
2804 real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica]
2805 ! Dimensions: (ngptlw,nlayers)
2807 ! ------- Local -------
2809 integer(kind=im) :: lay ! Layer index
2810 integer(kind=im) :: ib ! spectral band index
2811 integer(kind=im) :: ig ! g-point interval index
2812 integer(kind=im) :: index
2813 integer(kind=im) :: icb(nbndlw)
2815 real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients
2816 real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients
2817 real(kind=rb) :: abscosno(ngptlw) ! snow absorption coefficients
2818 real(kind=rb) :: cwp ! cloud water path
2819 real(kind=rb) :: radice ! cloud ice effective size (microns)
2820 real(kind=rb) :: factor !
2821 real(kind=rb) :: fint !
2822 real(kind=rb) :: radliq ! cloud liquid droplet radius (microns)
2823 real(kind=rb) :: radsno ! cloud snow effective size (microns)
2824 real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon
2825 real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities
2826 character*80 errmess
2828 ! ------- Definitions -------
2830 ! Explanation of the method for each value of INFLAG. Values of
2831 ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds.
2832 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
2833 ! requires further user input to specify the method to be used to
2834 ! compute the aborption due to each.
2835 ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray)
2836 ! optical depth are input.
2837 ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud
2838 ! water path (g/m2) are input. The (gray) cloud optical
2839 ! depth is computed as in CCM2.
2840 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
2841 ! water path (g/m2), and cloud ice fraction are input.
2842 ! ICEFLAG = 0: The ice effective radius (microns) is input and the
2843 ! optical depths due to ice clouds are computed as in CCM3.
2844 ! ICEFLAG = 1: The ice effective radius (microns) is input and the
2845 ! optical depths due to ice clouds are computed as in
2846 ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The
2847 ! spectral regions in this work have been matched with
2848 ! the spectral bands in RRTM to as great an extent
2849 ! as possible:
2850 ! E&C 1 IB = 5 RRTM bands 9-16
2851 ! E&C 2 IB = 4 RRTM bands 6-8
2852 ! E&C 3 IB = 3 RRTM bands 3-5
2853 ! E&C 4 IB = 2 RRTM band 2
2854 ! E&C 5 IB = 1 RRTM band 1
2855 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
2856 ! optical properties due to ice clouds are computed from
2857 ! the optical properties stored in the RT code,
2858 ! STREAMER v3.0 (Reference: Key. J., Streamer
2859 ! User's Guide, Cooperative Institute for
2860 ! Meteorological Satellite Studies, 2001, 96 pp.).
2861 ! Valid range of values for re are between 5.0 and
2862 ! 131.0 micron.
2863 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
2864 ! and the optical properties, are calculated as in
2865 ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
2866 ! tables which were appropriately averaged for the
2867 ! bands in RRTM_LW. Linear interpolation is used to
2868 ! get the coefficients from the stored tables.
2869 ! Valid range of values for dge are between 5.0 and
2870 ! 140.0 micron.
2871 ! LIQFLAG = 0: The optical depths due to water clouds are computed as
2872 ! in CCM3.
2873 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
2874 ! and the optical depths due to water clouds are computed
2875 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
2876 ! The values for absorption coefficients appropriate for
2877 ! the spectral bands in RRTM have been obtained for a
2878 ! range of effective radii by an averaging procedure
2879 ! based on the work of J. Pinto (private communication).
2880 ! Linear interpolation is used to get the absorption
2881 ! coefficients for the input effective radius.
2883 data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/
2885 !jm not thread safe hvrclc = '$Revision: 1.8 $'
2887 ncbands = 1
2889 ! This initialization is done in rrtmg_lw_subcol.F90.
2890 ! do lay = 1, nlayers
2891 ! do ig = 1, ngptlw
2892 ! taucmc(ig,lay) = 0.0_rb
2893 ! enddo
2894 ! enddo
2896 ! Main layer loop
2897 do lay = 1, nlayers
2899 do ig = 1, ngptlw
2900 cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
2901 if (cldfmc(ig,lay) .ge. cldmin .and. &
2902 (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
2904 ! Ice clouds and water clouds combined.
2905 if (inflag .eq. 0) then
2906 ! Cloud optical depth already defined in taucmc, return to main program
2907 return
2909 elseif(inflag .eq. 1) then
2910 stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
2911 ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2912 ! taucmc(ig,lay) = abscld1 * cwp
2914 ! Separate treatement of ice clouds and water clouds.
2915 elseif(inflag .ge. 2) then
2916 radice = reicmc(lay)
2918 ! Calculation of absorption coefficients due to ice clouds.
2919 if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then
2920 abscoice(ig) = 0.0_rb
2921 abscosno(ig) = 0.0_rb
2923 elseif (iceflag .eq. 0) then
2924 if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL'
2925 abscoice(ig) = absice0(1) + absice0(2)/radice
2926 abscosno(ig) = 0.0_rb
2928 elseif (iceflag .eq. 1) then
2929 if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
2930 'ICE RADIUS OUT OF BOUNDS'
2931 ncbands = 5
2932 ib = icb(ngb(ig))
2933 abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
2934 abscosno(ig) = 0.0_rb
2936 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
2938 elseif (iceflag .eq. 2) then
2939 if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
2940 ncbands = 16
2941 factor = (radice - 2._rb)/3._rb
2942 index = int(factor)
2943 if (index .eq. 43) index = 42
2944 fint = factor - float(index)
2945 ib = ngb(ig)
2946 abscoice(ig) = &
2947 absice2(index,ib) + fint * &
2948 (absice2(index+1,ib) - (absice2(index,ib)))
2949 abscosno(ig) = 0.0_rb
2951 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
2953 elseif (iceflag .ge. 3) then
2954 if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then
2955 write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
2956 'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
2957 ,ig, lay, ciwpmc(ig,lay), radice
2958 call wrf_error_fatal(errmess)
2959 end if
2960 ncbands = 16
2961 factor = (radice - 2._rb)/3._rb
2962 index = int(factor)
2963 if (index .eq. 46) index = 45
2964 fint = factor - float(index)
2965 ib = ngb(ig)
2966 abscoice(ig) = &
2967 absice3(index,ib) + fint * &
2968 (absice3(index+1,ib) - (absice3(index,ib)))
2969 abscosno(ig) = 0.0_rb
2971 endif
2973 !..Incorporate additional effects due to snow.
2974 if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then
2975 radsno = resnmc(lay)
2976 if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then
2977 write(errmess,'(A,i5,i5,f8.2,f8.2)' ) &
2978 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
2979 ,ig, lay, cswpmc(ig,lay), radsno
2980 call wrf_error_fatal(errmess)
2981 end if
2982 ncbands = 16
2983 factor = (radsno - 2._rb)/3._rb
2984 index = int(factor)
2985 if (index .eq. 46) index = 45
2986 fint = factor - float(index)
2987 ib = ngb(ig)
2988 abscosno(ig) = &
2989 absice3(index,ib) + fint * &
2990 (absice3(index+1,ib) - (absice3(index,ib)))
2991 endif
2994 ! Calculation of absorption coefficients due to water clouds.
2995 if (clwpmc(ig,lay) .eq. 0.0_rb) then
2996 abscoliq(ig) = 0.0_rb
2998 elseif (liqflag .eq. 0) then
2999 abscoliq(ig) = absliq0
3001 elseif (liqflag .eq. 1) then
3002 radliq = relqmc(lay)
3003 if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop &
3004 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
3005 index = int(radliq - 1.5_rb)
3006 if (index .eq. 0) index = 1
3007 if (index .eq. 58) index = 57
3008 fint = radliq - 1.5_rb - float(index)
3009 ib = ngb(ig)
3010 abscoliq(ig) = &
3011 absliq1(index,ib) + fint * &
3012 (absliq1(index+1,ib) - (absliq1(index,ib)))
3013 endif
3015 taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + &
3016 clwpmc(ig,lay) * abscoliq(ig) + &
3017 cswpmc(ig,lay) * abscosno(ig)
3019 endif
3020 endif
3021 enddo
3022 enddo
3024 end subroutine cldprmc
3026 end module rrtmg_lw_cldprmc
3028 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
3029 ! author: $Author: trn $
3030 ! revision: $Revision: 1.3 $
3031 ! created: $Date: 2009/04/16 19:54:22 $
3032 !
3033 module rrtmg_lw_rtrnmc
3035 ! --------------------------------------------------------------------------
3036 ! | |
3037 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
3038 ! | This software may be used, copied, or redistributed as long as it is |
3039 ! | not sold and this copyright notice is reproduced on each copy made. |
3040 ! | This model is provided as is without any express or implied warranties. |
3041 ! | (http://www.rtweb.aer.com/) |
3042 ! | |
3043 ! --------------------------------------------------------------------------
3045 ! --------- Modules ----------
3047 use parkind, only : im => kind_im, rb => kind_rb
3048 use parrrtm, only : mg, nbndlw, ngptlw
3049 use rrlw_con, only: fluxfac, heatfac
3050 use rrlw_wvn, only: delwave, ngb, ngs
3051 use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
3052 use rrlw_vsn, only: hvrrtc, hnamrtc
3054 implicit none
3056 real(kind=rb) :: wtdiff, rec_6
3057 real(kind=rb) :: a0(nbndlw),a1(nbndlw),a2(nbndlw)! diffusivity angle adjustment coefficients
3059 ! This secant and weight corresponds to the standard diffusivity
3060 ! angle. This initial value is redefined below for some bands.
3061 data wtdiff /0.5_rb/
3062 data rec_6 /0.166667_rb/
3064 ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
3065 ! and 1.80) as a function of total column water vapor. The function
3066 ! has been defined to minimize flux and cooling rate errors in these bands
3067 ! over a wide range of precipitable water values.
3068 data a0 / 1.66_rb, 1.55_rb, 1.58_rb, 1.66_rb, &
3069 1.54_rb, 1.454_rb, 1.89_rb, 1.33_rb, &
3070 1.668_rb, 1.66_rb, 1.66_rb, 1.66_rb, &
3071 1.66_rb, 1.66_rb, 1.66_rb, 1.66_rb /
3072 data a1 / 0.00_rb, 0.25_rb, 0.22_rb, 0.00_rb, &
3073 0.13_rb, 0.446_rb, -0.10_rb, 0.40_rb, &
3074 -0.006_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
3075 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
3076 data a2 / 0.00_rb, -12.0_rb, -11.7_rb, 0.00_rb, &
3077 -0.72_rb,-0.243_rb, 0.19_rb,-0.062_rb, &
3078 0.414_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
3079 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
3081 contains
3083 !-----------------------------------------------------------------------------
3084 subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
3085 cldfmc, taucmc, planklay, planklev, plankbnd, &
3086 pwvcm, fracs, taut, &
3087 totuflux, totdflux, fnet, htr, &
3088 totuclfl, totdclfl, fnetc, htrc )
3089 !-----------------------------------------------------------------------------
3090 !
3091 ! Original version: E. J. Mlawer, et al. RRTM_V3.0
3092 ! Revision for GCMs: Michael J. Iacono; October, 2002
3093 ! Revision for F90: Michael J. Iacono; June, 2006
3094 !
3095 ! This program calculates the upward fluxes, downward fluxes, and
3096 ! heating rates for an arbitrary clear or cloudy atmosphere. The input
3097 ! to this program is the atmospheric profile, all Planck function
3098 ! information, and the cloud fraction by layer. A variable diffusivity
3099 ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9
3100 ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
3101 ! the column water vapor, and other bands use a value of 1.66. The Gaussian
3102 ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that
3103 ! use of the emissivity angle for the flux integration can cause errors of
3104 ! 1 to 4 W/m2 within cloudy layers.
3105 ! Clouds are treated with the McICA stochastic approach and maximum-random
3106 ! cloud overlap.
3107 !***************************************************************************
3109 ! ------- Declarations -------
3111 ! ----- Input -----
3112 integer(kind=im), intent(in) :: nlayers ! total number of layers
3113 integer(kind=im), intent(in) :: istart ! beginning band of calculation
3114 integer(kind=im), intent(in) :: iend ! ending band of calculation
3115 integer(kind=im), intent(in) :: iout ! output option flag
3117 ! Atmosphere
3118 real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb)
3119 ! Dimensions: (0:nlayers)
3120 real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm)
3121 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
3122 ! Dimensions: (nbndlw)
3123 real(kind=rb), intent(in) :: planklay(:,:) !
3124 ! Dimensions: (nlayers,nbndlw)
3125 real(kind=rb), intent(in) :: planklev(0:,:) !
3126 ! Dimensions: (0:nlayers,nbndlw)
3127 real(kind=rb), intent(in) :: plankbnd(:) !
3128 ! Dimensions: (nbndlw)
3129 real(kind=rb), intent(in) :: fracs(:,:) !
3130 ! Dimensions: (nlayers,ngptw)
3131 real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths
3132 ! Dimensions: (nlayers,ngptlw)
3134 ! Clouds
3135 integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands
3136 real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica]
3137 ! Dimensions: (ngptlw,nlayers)
3138 real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica]
3139 ! Dimensions: (ngptlw,nlayers)
3141 ! ----- Output -----
3142 real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2)
3143 ! Dimensions: (0:nlayers)
3144 real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2)
3145 ! Dimensions: (0:nlayers)
3146 real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2)
3147 ! Dimensions: (0:nlayers)
3148 real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day)
3149 ! Dimensions: (0:nlayers)
3150 real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2)
3151 ! Dimensions: (0:nlayers)
3152 real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2)
3153 ! Dimensions: (0:nlayers)
3154 real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2)
3155 ! Dimensions: (0:nlayers)
3156 real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day)
3157 ! Dimensions: (0:nlayers)
3159 ! ----- Local -----
3160 ! Declarations for radiative transfer
3161 real(kind=rb) :: abscld(nlayers,ngptlw)
3162 real(kind=rb) :: atot(nlayers)
3163 real(kind=rb) :: atrans(nlayers)
3164 real(kind=rb) :: bbugas(nlayers)
3165 real(kind=rb) :: bbutot(nlayers)
3166 real(kind=rb) :: clrurad(0:nlayers)
3167 real(kind=rb) :: clrdrad(0:nlayers)
3168 real(kind=rb) :: efclfrac(nlayers,ngptlw)
3169 real(kind=rb) :: uflux(0:nlayers)
3170 real(kind=rb) :: dflux(0:nlayers)
3171 real(kind=rb) :: urad(0:nlayers)
3172 real(kind=rb) :: drad(0:nlayers)
3173 real(kind=rb) :: uclfl(0:nlayers)
3174 real(kind=rb) :: dclfl(0:nlayers)
3175 real(kind=rb) :: odcld(nlayers,ngptlw)
3178 real(kind=rb) :: secdiff(nbndlw) ! secant of diffusivity angle
3179 real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
3180 real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
3181 real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
3182 real(kind=rb) :: rad0, reflect, radlu, radclru
3184 integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer
3185 integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices
3186 integer(kind=im) :: igc ! g-point interval counter
3187 integer(kind=im) :: iclddn ! flag for cloud in down path
3188 integer(kind=im) :: ittot, itgas, itr ! lookup table indices
3190 ! ------- Definitions -------
3191 ! input
3192 ! nlayers ! number of model layers
3193 ! ngptlw ! total number of g-point subintervals
3194 ! nbndlw ! number of longwave spectral bands
3195 ! ncbands ! number of spectral bands for clouds
3196 ! secdiff ! diffusivity angle
3197 ! wtdiff ! weight for radiance to flux conversion
3198 ! pavel ! layer pressures (mb)
3199 ! pz ! level (interface) pressures (mb)
3200 ! tavel ! layer temperatures (k)
3201 ! tz ! level (interface) temperatures(mb)
3202 ! tbound ! surface temperature (k)
3203 ! cldfrac ! layer cloud fraction
3204 ! taucloud ! layer cloud optical depth
3205 ! itr ! integer look-up table index
3206 ! icldlyr ! flag for cloudy layers
3207 ! iclddn ! flag for cloud in column at any layer
3208 ! semiss ! surface emissivities for each band
3209 ! reflect ! surface reflectance
3210 ! bpade ! 1/(pade constant)
3211 ! tau_tbl ! clear sky optical depth look-up table
3212 ! exp_tbl ! exponential look-up table for transmittance
3213 ! tfn_tbl ! tau transition function look-up table
3215 ! local
3216 ! atrans ! gaseous absorptivity
3217 ! abscld ! cloud absorptivity
3218 ! atot ! combined gaseous and cloud absorptivity
3219 ! odclr ! clear sky (gaseous) optical depth
3220 ! odcld ! cloud optical depth
3221 ! odtot ! optical depth of gas and cloud
3222 ! tfacgas ! gas-only pade factor, used for planck fn
3223 ! tfactot ! gas and cloud pade factor, used for planck fn
3224 ! bbdgas ! gas-only planck function for downward rt
3225 ! bbugas ! gas-only planck function for upward rt
3226 ! bbdtot ! gas and cloud planck function for downward rt
3227 ! bbutot ! gas and cloud planck function for upward calc.
3228 ! gassrc ! source radiance due to gas only
3229 ! efclfrac ! effective cloud fraction
3230 ! radlu ! spectrally summed upward radiance
3231 ! radclru ! spectrally summed clear sky upward radiance
3232 ! urad ! upward radiance by layer
3233 ! clrurad ! clear sky upward radiance by layer
3234 ! radld ! spectrally summed downward radiance
3235 ! radclrd ! spectrally summed clear sky downward radiance
3236 ! drad ! downward radiance by layer
3237 ! clrdrad ! clear sky downward radiance by layer
3239 ! output
3240 ! totuflux ! upward longwave flux (w/m2)
3241 ! totdflux ! downward longwave flux (w/m2)
3242 ! fnet ! net longwave flux (w/m2)
3243 ! htr ! longwave heating rate (k/day)
3244 ! totuclfl ! clear sky upward longwave flux (w/m2)
3245 ! totdclfl ! clear sky downward longwave flux (w/m2)
3246 ! fnetc ! clear sky net longwave flux (w/m2)
3247 ! htrc ! clear sky longwave heating rate (k/day)
3250 !jm not thread safe hvrrtc = '$Revision: 1.3 $'
3252 do ibnd = 1,nbndlw
3253 if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
3254 secdiff(ibnd) = 1.66_rb
3255 else
3256 secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm)
3257 if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb
3258 if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb
3259 endif
3260 enddo
3262 urad(0) = 0.0_rb
3263 drad(0) = 0.0_rb
3264 totuflux(0) = 0.0_rb
3265 totdflux(0) = 0.0_rb
3266 clrurad(0) = 0.0_rb
3267 clrdrad(0) = 0.0_rb
3268 totuclfl(0) = 0.0_rb
3269 totdclfl(0) = 0.0_rb
3271 do lay = 1, nlayers
3272 urad(lay) = 0.0_rb
3273 drad(lay) = 0.0_rb
3274 totuflux(lay) = 0.0_rb
3275 totdflux(lay) = 0.0_rb
3276 clrurad(lay) = 0.0_rb
3277 clrdrad(lay) = 0.0_rb
3278 totuclfl(lay) = 0.0_rb
3279 totdclfl(lay) = 0.0_rb
3280 icldlyr(lay) = 0
3282 ! Change to band loop?
3283 do ig = 1, ngptlw
3284 if (cldfmc(ig,lay) .eq. 1._rb) then
3285 ib = ngb(ig)
3286 odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay)
3287 transcld = exp(-odcld(lay,ig))
3288 abscld(lay,ig) = 1._rb - transcld
3289 efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay)
3290 icldlyr(lay) = 1
3291 else
3292 odcld(lay,ig) = 0.0_rb
3293 abscld(lay,ig) = 0.0_rb
3294 efclfrac(lay,ig) = 0.0_rb
3295 endif
3296 enddo
3298 enddo
3300 igc = 1
3301 ! Loop over frequency bands.
3302 do iband = istart, iend
3304 ! Reinitialize g-point counter for each band if output for each band is requested.
3305 if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1
3307 ! Loop over g-channels.
3308 1000 continue
3310 ! Radiative transfer starts here.
3311 radld = 0._rb
3312 radclrd = 0._rb
3313 iclddn = 0
3315 ! Downward radiative transfer loop.
3317 do lev = nlayers, 1, -1
3318 plfrac = fracs(lev,igc)
3319 blay = planklay(lev,iband)
3320 dplankup = planklev(lev,iband) - blay
3321 dplankdn = planklev(lev-1,iband) - blay
3322 odepth = secdiff(iband) * taut(lev,igc)
3323 if (odepth .lt. 0.0_rb) odepth = 0.0_rb
3324 ! Cloudy layer
3325 if (icldlyr(lev).eq.1) then
3326 iclddn = 1
3327 odtot = odepth + odcld(lev,igc)
3328 if (odtot .lt. 0.06_rb) then
3329 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3330 odepth_rec = rec_6*odepth
3331 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3333 atot(lev) = odtot - 0.5_rb*odtot*odtot
3334 odtot_rec = rec_6*odtot
3335 bbdtot = plfrac * (blay+dplankdn*odtot_rec)
3336 bbd = plfrac*(blay+dplankdn*odepth_rec)
3337 radld = radld - radld * (atrans(lev) + &
3338 efclfrac(lev,igc) * (1. - atrans(lev))) + &
3339 gassrc + cldfmc(igc,lev) * &
3340 (bbdtot * atot(lev) - gassrc)
3341 drad(lev-1) = drad(lev-1) + radld
3343 bbugas(lev) = plfrac * (blay+dplankup*odepth_rec)
3344 bbutot(lev) = plfrac * (blay+dplankup*odtot_rec)
3346 elseif (odepth .le. 0.06_rb) then
3347 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3348 odepth_rec = rec_6*odepth
3349 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3351 odtot = odepth + odcld(lev,igc)
3352 tblind = odtot/(bpade+odtot)
3353 ittot = tblint*tblind + 0.5_rb
3354 tfactot = tfn_tbl(ittot)
3355 bbdtot = plfrac * (blay + tfactot*dplankdn)
3356 bbd = plfrac*(blay+dplankdn*odepth_rec)
3357 atot(lev) = 1. - exp_tbl(ittot)
3359 radld = radld - radld * (atrans(lev) + &
3360 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3361 gassrc + cldfmc(igc,lev) * &
3362 (bbdtot * atot(lev) - gassrc)
3363 drad(lev-1) = drad(lev-1) + radld
3365 bbugas(lev) = plfrac * (blay + dplankup*odepth_rec)
3366 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3368 else
3370 tblind = odepth/(bpade+odepth)
3371 itgas = tblint*tblind+0.5_rb
3372 odepth = tau_tbl(itgas)
3373 atrans(lev) = 1._rb - exp_tbl(itgas)
3374 tfacgas = tfn_tbl(itgas)
3375 gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
3377 odtot = odepth + odcld(lev,igc)
3378 tblind = odtot/(bpade+odtot)
3379 ittot = tblint*tblind + 0.5_rb
3380 tfactot = tfn_tbl(ittot)
3381 bbdtot = plfrac * (blay + tfactot*dplankdn)
3382 bbd = plfrac*(blay+tfacgas*dplankdn)
3383 atot(lev) = 1._rb - exp_tbl(ittot)
3385 radld = radld - radld * (atrans(lev) + &
3386 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3387 gassrc + cldfmc(igc,lev) * &
3388 (bbdtot * atot(lev) - gassrc)
3389 drad(lev-1) = drad(lev-1) + radld
3390 bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
3391 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3392 endif
3393 ! Clear layer
3394 else
3395 if (odepth .le. 0.06_rb) then
3396 atrans(lev) = odepth-0.5_rb*odepth*odepth
3397 odepth = rec_6*odepth
3398 bbd = plfrac*(blay+dplankdn*odepth)
3399 bbugas(lev) = plfrac*(blay+dplankup*odepth)
3400 else
3401 tblind = odepth/(bpade+odepth)
3402 itr = tblint*tblind+0.5_rb
3403 transc = exp_tbl(itr)
3404 atrans(lev) = 1._rb-transc
3405 tausfac = tfn_tbl(itr)
3406 bbd = plfrac*(blay+tausfac*dplankdn)
3407 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
3408 endif
3409 radld = radld + (bbd-radld)*atrans(lev)
3410 drad(lev-1) = drad(lev-1) + radld
3411 endif
3412 ! Set clear sky stream to total sky stream as long as layers
3413 ! remain clear. Streams diverge when a cloud is reached (iclddn=1),
3414 ! and clear sky stream must be computed separately from that point.
3415 if (iclddn.eq.1) then
3416 radclrd = radclrd + (bbd-radclrd) * atrans(lev)
3417 clrdrad(lev-1) = clrdrad(lev-1) + radclrd
3418 else
3419 radclrd = radld
3420 clrdrad(lev-1) = drad(lev-1)
3421 endif
3422 enddo
3424 ! Spectral emissivity & reflectance
3425 ! Include the contribution of spectrally varying longwave emissivity
3426 ! and reflection from the surface to the upward radiative transfer.
3427 ! Note: Spectral and Lambertian reflection are identical for the
3428 ! diffusivity angle flux integration used here.
3430 rad0 = fracs(1,igc) * plankbnd(iband)
3431 ! Add in specular reflection of surface downward radiance.
3432 reflect = 1._rb - semiss(iband)
3433 radlu = rad0 + reflect * radld
3434 radclru = rad0 + reflect * radclrd
3437 ! Upward radiative transfer loop.
3438 urad(0) = urad(0) + radlu
3439 clrurad(0) = clrurad(0) + radclru
3441 do lev = 1, nlayers
3442 ! Cloudy layer
3443 if (icldlyr(lev) .eq. 1) then
3444 gassrc = bbugas(lev) * atrans(lev)
3445 radlu = radlu - radlu * (atrans(lev) + &
3446 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3447 gassrc + cldfmc(igc,lev) * &
3448 (bbutot(lev) * atot(lev) - gassrc)
3449 urad(lev) = urad(lev) + radlu
3450 ! Clear layer
3451 else
3452 radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
3453 urad(lev) = urad(lev) + radlu
3454 endif
3455 ! Set clear sky stream to total sky stream as long as all layers
3456 ! are clear (iclddn=0). Streams must be calculated separately at
3457 ! all layers when a cloud is present (ICLDDN=1), because surface
3458 ! reflectance is different for each stream.
3459 if (iclddn.eq.1) then
3460 radclru = radclru + (bbugas(lev)-radclru)*atrans(lev)
3461 clrurad(lev) = clrurad(lev) + radclru
3462 else
3463 radclru = radlu
3464 clrurad(lev) = urad(lev)
3465 endif
3466 enddo
3468 ! Increment g-point counter
3469 igc = igc + 1
3470 ! Return to continue radiative transfer for all g-channels in present band
3471 if (igc .le. ngs(iband)) go to 1000
3473 ! Process longwave output from band for total and clear streams.
3474 ! Calculate upward, downward, and net flux.
3475 do lev = nlayers, 0, -1
3476 uflux(lev) = urad(lev)*wtdiff
3477 dflux(lev) = drad(lev)*wtdiff
3478 urad(lev) = 0.0_rb
3479 drad(lev) = 0.0_rb
3480 totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband)
3481 totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband)
3482 uclfl(lev) = clrurad(lev)*wtdiff
3483 dclfl(lev) = clrdrad(lev)*wtdiff
3484 clrurad(lev) = 0.0_rb
3485 clrdrad(lev) = 0.0_rb
3486 totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband)
3487 totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband)
3488 enddo
3490 ! End spectral band loop
3491 enddo
3493 ! Calculate fluxes at surface
3494 totuflux(0) = totuflux(0) * fluxfac
3495 totdflux(0) = totdflux(0) * fluxfac
3496 fnet(0) = totuflux(0) - totdflux(0)
3497 totuclfl(0) = totuclfl(0) * fluxfac
3498 totdclfl(0) = totdclfl(0) * fluxfac
3499 fnetc(0) = totuclfl(0) - totdclfl(0)
3501 ! Calculate fluxes at model levels
3502 do lev = 1, nlayers
3503 totuflux(lev) = totuflux(lev) * fluxfac
3504 totdflux(lev) = totdflux(lev) * fluxfac
3505 fnet(lev) = totuflux(lev) - totdflux(lev)
3506 totuclfl(lev) = totuclfl(lev) * fluxfac
3507 totdclfl(lev) = totdclfl(lev) * fluxfac
3508 fnetc(lev) = totuclfl(lev) - totdclfl(lev)
3509 l = lev - 1
3511 ! Calculate heating rates at model layers
3512 htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev))
3513 htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev))
3514 enddo
3516 ! Set heating rate to zero in top layer
3517 htr(nlayers) = 0.0_rb
3518 htrc(nlayers) = 0.0_rb
3520 end subroutine rtrnmc
3522 end module rrtmg_lw_rtrnmc
3524 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
3525 ! author: $Author: trn $
3526 ! revision: $Revision: 1.3 $
3527 ! created: $Date: 2009/04/16 19:54:22 $
3528 !
3529 module rrtmg_lw_setcoef
3531 ! --------------------------------------------------------------------------
3532 ! | |
3533 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
3534 ! | This software may be used, copied, or redistributed as long as it is |
3535 ! | not sold and this copyright notice is reproduced on each copy made. |
3536 ! | This model is provided as is without any express or implied warranties. |
3537 ! | (http://www.rtweb.aer.com/) |
3538 ! | |
3539 ! --------------------------------------------------------------------------
3541 ! ------- Modules -------
3543 use parkind, only : im => kind_im, rb => kind_rb
3544 use parrrtm, only : nbndlw, mg, maxxsec, mxmol
3545 use rrlw_wvn, only: totplnk, totplk16
3546 use rrlw_ref
3547 use rrlw_vsn, only: hvrset, hnamset
3549 implicit none
3551 contains
3553 !----------------------------------------------------------------------------
3554 subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
3555 coldry, wkl, wbroad, &
3556 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
3557 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
3558 colbrd, fac00, fac01, fac10, fac11, &
3559 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
3560 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
3561 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
3562 selffac, selffrac, indself, forfac, forfrac, indfor, &
3563 minorfrac, scaleminor, scaleminorn2, indminor)
3564 !----------------------------------------------------------------------------
3565 !
3566 ! Purpose: For a given atmosphere, calculate the indices and
3567 ! fractions related to the pressure and temperature interpolations.
3568 ! Also calculate the values of the integrated Planck functions
3569 ! for each band at the level and layer temperatures.
3571 ! ------- Declarations -------
3573 ! ----- Input -----
3574 integer(kind=im), intent(in) :: nlayers ! total number of layers
3575 integer(kind=im), intent(in) :: istart ! beginning band of calculation
3577 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
3578 ! Dimensions: (nlayers)
3579 real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K)
3580 ! Dimensions: (nlayers)
3581 real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K)
3582 ! Dimensions: (0:nlayers)
3583 real(kind=rb), intent(in) :: tbound ! surface temperature (K)
3584 real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
3585 ! Dimensions: (nlayers)
3586 real(kind=rb), intent(in) :: wbroad(:) ! broadening gas column density (mol/cm2)
3587 ! Dimensions: (nlayers)
3588 real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2)
3589 ! Dimensions: (mxmol,nlayers)
3590 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
3591 ! Dimensions: (nbndlw)
3593 ! ----- Output -----
3594 integer(kind=im), intent(out) :: laytrop ! tropopause layer index
3595 integer(kind=im), intent(out) :: jp(:) !
3596 ! Dimensions: (nlayers)
3597 integer(kind=im), intent(out) :: jt(:) !
3598 ! Dimensions: (nlayers)
3599 integer(kind=im), intent(out) :: jt1(:) !
3600 ! Dimensions: (nlayers)
3601 real(kind=rb), intent(out) :: planklay(:,:) !
3602 ! Dimensions: (nlayers,nbndlw)
3603 real(kind=rb), intent(out) :: planklev(0:,:) !
3604 ! Dimensions: (0:nlayers,nbndlw)
3605 real(kind=rb), intent(out) :: plankbnd(:) !
3606 ! Dimensions: (nbndlw)
3608 real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o)
3609 ! Dimensions: (nlayers)
3610 real(kind=rb), intent(out) :: colco2(:) ! column amount (co2)
3611 ! Dimensions: (nlayers)
3612 real(kind=rb), intent(out) :: colo3(:) ! column amount (o3)
3613 ! Dimensions: (nlayers)
3614 real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o)
3615 ! Dimensions: (nlayers)
3616 real(kind=rb), intent(out) :: colco(:) ! column amount (co)
3617 ! Dimensions: (nlayers)
3618 real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4)
3619 ! Dimensions: (nlayers)
3620 real(kind=rb), intent(out) :: colo2(:) ! column amount (o2)
3621 ! Dimensions: (nlayers)
3622 real(kind=rb), intent(out) :: colbrd(:) ! column amount (broadening gases)
3623 ! Dimensions: (nlayers)
3625 integer(kind=im), intent(out) :: indself(:)
3626 ! Dimensions: (nlayers)
3627 integer(kind=im), intent(out) :: indfor(:)
3628 ! Dimensions: (nlayers)
3629 real(kind=rb), intent(out) :: selffac(:)
3630 ! Dimensions: (nlayers)
3631 real(kind=rb), intent(out) :: selffrac(:)
3632 ! Dimensions: (nlayers)
3633 real(kind=rb), intent(out) :: forfac(:)
3634 ! Dimensions: (nlayers)
3635 real(kind=rb), intent(out) :: forfrac(:)
3636 ! Dimensions: (nlayers)
3638 integer(kind=im), intent(out) :: indminor(:)
3639 ! Dimensions: (nlayers)
3640 real(kind=rb), intent(out) :: minorfrac(:)
3641 ! Dimensions: (nlayers)
3642 real(kind=rb), intent(out) :: scaleminor(:)
3643 ! Dimensions: (nlayers)
3644 real(kind=rb), intent(out) :: scaleminorn2(:)
3645 ! Dimensions: (nlayers)
3647 real(kind=rb), intent(out) :: & !
3648 fac00(:), fac01(:), & ! Dimensions: (nlayers)
3649 fac10(:), fac11(:)
3651 real(kind=rb), intent(out) :: & !
3652 rat_h2oco2(:),rat_h2oco2_1(:), &
3653 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
3654 rat_h2on2o(:),rat_h2on2o_1(:), &
3655 rat_h2och4(:),rat_h2och4_1(:), &
3656 rat_n2oco2(:),rat_n2oco2_1(:), &
3657 rat_o3co2(:),rat_o3co2_1(:)
3660 ! ----- Local -----
3661 integer(kind=im) :: indbound, indlev0
3662 integer(kind=im) :: lay, indlay, indlev, iband
3663 integer(kind=im) :: jp1
3664 real(kind=rb) :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
3665 real(kind=rb) :: dbdtlev, dbdtlay
3666 real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp
3669 !jm not thread safe hvrset = '$Revision: 1.3 $'
3671 stpfac = 296._rb/1013._rb
3673 indbound = tbound - 159._rb
3674 if (indbound .lt. 1) then
3675 indbound = 1
3676 elseif (indbound .gt. 180) then
3677 indbound = 180
3678 endif
3679 tbndfrac = tbound - 159._rb - float(indbound)
3680 indlev0 = tz(0) - 159._rb
3681 if (indlev0 .lt. 1) then
3682 indlev0 = 1
3683 elseif (indlev0 .gt. 180) then
3684 indlev0 = 180
3685 endif
3686 t0frac = tz(0) - 159._rb - float(indlev0)
3687 laytrop = 0
3689 ! Begin layer loop
3690 ! Calculate the integrated Planck functions for each band at the
3691 ! surface, level, and layer temperatures.
3692 do lay = 1, nlayers
3693 indlay = tavel(lay) - 159._rb
3694 if (indlay .lt. 1) then
3695 indlay = 1
3696 elseif (indlay .gt. 180) then
3697 indlay = 180
3698 endif
3699 tlayfrac = tavel(lay) - 159._rb - float(indlay)
3700 indlev = tz(lay) - 159._rb
3701 if (indlev .lt. 1) then
3702 indlev = 1
3703 elseif (indlev .gt. 180) then
3704 indlev = 180
3705 endif
3706 tlevfrac = tz(lay) - 159._rb - float(indlev)
3708 ! Begin spectral band loop
3709 do iband = 1, 15
3710 if (lay.eq.1) then
3711 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3712 plankbnd(iband) = semiss(iband) * &
3713 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3714 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3715 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3716 endif
3717 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3718 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3719 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3720 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3721 enddo
3723 ! For band 16, if radiative transfer will be performed on just
3724 ! this band, use integrated Planck values up to 3250 cm-1.
3725 ! If radiative transfer will be performed across all 16 bands,
3726 ! then include in the integrated Planck values for this band
3727 ! contributions from 2600 cm-1 to infinity.
3728 iband = 16
3729 if (istart .eq. 16) then
3730 if (lay.eq.1) then
3731 dbdtlev = totplk16(indbound+1) - totplk16(indbound)
3732 plankbnd(iband) = semiss(iband) * &
3733 (totplk16(indbound) + tbndfrac * dbdtlev)
3734 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3735 planklev(0,iband) = totplk16(indlev0) + &
3736 t0frac * dbdtlev
3737 endif
3738 dbdtlev = totplk16(indlev+1) - totplk16(indlev)
3739 dbdtlay = totplk16(indlay+1) - totplk16(indlay)
3740 planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay
3741 planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev
3742 else
3743 if (lay.eq.1) then
3744 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3745 plankbnd(iband) = semiss(iband) * &
3746 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3747 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3748 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3749 endif
3750 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3751 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3752 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3753 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3754 endif
3756 ! Find the two reference pressures on either side of the
3757 ! layer pressure. Store them in JP and JP1. Store in FP the
3758 ! fraction of the difference (in ln(pressure)) between these
3759 ! two values that the layer pressure lies.
3760 plog = log(pavel(lay))
3761 ! plog = dlog(pavel(lay))
3762 jp(lay) = int(36._rb - 5*(plog+0.04_rb))
3763 if (jp(lay) .lt. 1) then
3764 jp(lay) = 1
3765 elseif (jp(lay) .gt. 58) then
3766 jp(lay) = 58
3767 endif
3768 jp1 = jp(lay) + 1
3769 fp = 5._rb *(preflog(jp(lay)) - plog)
3771 ! Determine, for each reference pressure (JP and JP1), which
3772 ! reference temperature (these are different for each
3773 ! reference pressure) is nearest the layer temperature but does
3774 ! not exceed it. Store these indices in JT and JT1, resp.
3775 ! Store in FT (resp. FT1) the fraction of the way between JT
3776 ! (JT1) and the next highest reference temperature that the
3777 ! layer temperature falls.
3778 jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
3779 if (jt(lay) .lt. 1) then
3780 jt(lay) = 1
3781 elseif (jt(lay) .gt. 4) then
3782 jt(lay) = 4
3783 endif
3784 ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3)
3785 jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
3786 if (jt1(lay) .lt. 1) then
3787 jt1(lay) = 1
3788 elseif (jt1(lay) .gt. 4) then
3789 jt1(lay) = 4
3790 endif
3791 ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3)
3792 water = wkl(1,lay)/coldry(lay)
3793 scalefac = pavel(lay) * stpfac / tavel(lay)
3795 ! If the pressure is less than ~100mb, perform a different
3796 ! set of species interpolations.
3797 if (plog .le. 4.56_rb) go to 5300
3798 laytrop = laytrop + 1
3800 forfac(lay) = scalefac / (1.+water)
3801 factor = (332.0_rb-tavel(lay))/36.0_rb
3802 indfor(lay) = min(2, max(1, int(factor)))
3803 forfrac(lay) = factor - float(indfor(lay))
3805 ! Set up factors needed to separately include the water vapor
3806 ! self-continuum in the calculation of absorption coefficient.
3807 selffac(lay) = water * forfac(lay)
3808 factor = (tavel(lay)-188.0_rb)/7.2_rb
3809 indself(lay) = min(9, max(1, int(factor)-7))
3810 selffrac(lay) = factor - float(indself(lay) + 7)
3812 ! Set up factors needed to separately include the minor gases
3813 ! in the calculation of absorption coefficient
3814 scaleminor(lay) = pavel(lay)/tavel(lay)
3815 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3816 *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3817 factor = (tavel(lay)-180.8_rb)/7.2_rb
3818 indminor(lay) = min(18, max(1, int(factor)))
3819 minorfrac(lay) = factor - float(indminor(lay))
3821 ! Setup reference ratio to be used in calculation of binary
3822 ! species parameter in lower atmosphere.
3823 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3824 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3826 rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay))
3827 rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1)
3829 rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay))
3830 rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1)
3832 rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay))
3833 rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1)
3835 rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay))
3836 rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3838 ! Calculate needed column amounts.
3839 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3840 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3841 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3842 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3843 colco(lay) = 1.e-20_rb * wkl(5,lay)
3844 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3845 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3846 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3847 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3848 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3849 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3850 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3851 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3852 go to 5400
3854 ! Above laytrop.
3855 5300 continue
3857 forfac(lay) = scalefac / (1.+water)
3858 factor = (tavel(lay)-188.0_rb)/36.0_rb
3859 indfor(lay) = 3
3860 forfrac(lay) = factor - 1.0_rb
3862 ! Set up factors needed to separately include the water vapor
3863 ! self-continuum in the calculation of absorption coefficient.
3864 selffac(lay) = water * forfac(lay)
3866 ! Set up factors needed to separately include the minor gases
3867 ! in the calculation of absorption coefficient
3868 scaleminor(lay) = pavel(lay)/tavel(lay)
3869 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3870 * (wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3871 factor = (tavel(lay)-180.8_rb)/7.2_rb
3872 indminor(lay) = min(18, max(1, int(factor)))
3873 minorfrac(lay) = factor - float(indminor(lay))
3875 ! Setup reference ratio to be used in calculation of binary
3876 ! species parameter in upper atmosphere.
3877 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3878 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3880 rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay))
3881 rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3883 ! Calculate needed column amounts.
3884 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3885 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3886 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3887 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3888 colco(lay) = 1.e-20_rb * wkl(5,lay)
3889 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3890 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3891 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3892 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3893 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3894 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3895 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3896 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3897 5400 continue
3899 ! We have now isolated the layer ln pressure and temperature,
3900 ! between two reference pressures and two reference temperatures
3901 ! (for each reference pressure). We multiply the pressure
3902 ! fraction FP with the appropriate temperature fractions to get
3903 ! the factors that will be needed for the interpolation that yields
3904 ! the optical depths (performed in routines TAUGBn for band n).`
3906 compfp = 1. - fp
3907 fac10(lay) = compfp * ft
3908 fac00(lay) = compfp * (1._rb - ft)
3909 fac11(lay) = fp * ft1
3910 fac01(lay) = fp * (1._rb - ft1)
3912 ! Rescale selffac and forfac for use in taumol
3913 selffac(lay) = colh2o(lay)*selffac(lay)
3914 forfac(lay) = colh2o(lay)*forfac(lay)
3916 ! End layer loop
3917 enddo
3919 end subroutine setcoef
3921 !***************************************************************************
3922 subroutine lwatmref
3923 !***************************************************************************
3925 save
3927 ! These pressures are chosen such that the ln of the first pressure
3928 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
3929 ! each subsequent ln(pressure) differs from the previous one by 0.2.
3931 pref(:) = (/ &
3932 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
3933 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
3934 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
3935 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
3936 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
3937 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
3938 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
3939 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
3940 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
3941 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
3942 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
3943 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/)
3945 preflog(:) = (/ &
3946 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
3947 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
3948 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
3949 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
3950 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
3951 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
3952 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
3953 -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
3954 -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
3955 -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
3956 -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
3957 -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/)
3959 ! These are the temperatures associated with the respective
3960 ! pressures for the mls standard atmosphere.
3962 tref(:) = (/ &
3963 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
3964 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
3965 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
3966 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
3967 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
3968 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
3969 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
3970 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
3971 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
3972 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
3973 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
3974 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/)
3976 chi_mls(1,1:12) = (/ &
3977 1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, &
3978 7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, &
3979 4.3082e-06_rb, 3.3319e-06_rb/)
3980 chi_mls(1,13:59) = (/ &
3981 3.2039e-06_rb, 3.1619e-06_rb, 3.2524e-06_rb, 3.4226e-06_rb, 3.6288e-06_rb, &
3982 3.9148e-06_rb, 4.1488e-06_rb, 4.3081e-06_rb, 4.4420e-06_rb, 4.5778e-06_rb, &
3983 4.7087e-06_rb, 4.7943e-06_rb, 4.8697e-06_rb, 4.9260e-06_rb, 4.9669e-06_rb, &
3984 4.9963e-06_rb, 5.0527e-06_rb, 5.1266e-06_rb, 5.2503e-06_rb, 5.3571e-06_rb, &
3985 5.4509e-06_rb, 5.4830e-06_rb, 5.5000e-06_rb, 5.5000e-06_rb, 5.4536e-06_rb, &
3986 5.4047e-06_rb, 5.3558e-06_rb, 5.2533e-06_rb, 5.1436e-06_rb, 5.0340e-06_rb, &
3987 4.8766e-06_rb, 4.6979e-06_rb, 4.5191e-06_rb, 4.3360e-06_rb, 4.1442e-06_rb, &
3988 3.9523e-06_rb, 3.7605e-06_rb, 3.5722e-06_rb, 3.3855e-06_rb, 3.1988e-06_rb, &
3989 3.0121e-06_rb, 2.8262e-06_rb, 2.6407e-06_rb, 2.4552e-06_rb, 2.2696e-06_rb, &
3990 4.3360e-06_rb, 4.1442e-06_rb/)
3991 chi_mls(2,1:12) = (/ &
3992 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3993 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3994 3.5500e-04_rb, 3.5500e-04_rb/)
3995 chi_mls(2,13:59) = (/ &
3996 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3997 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3998 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3999 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4000 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4001 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4002 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4003 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4004 3.5500e-04_rb, 3.5471e-04_rb, 3.5427e-04_rb, 3.5384e-04_rb, 3.5340e-04_rb, &
4005 3.5500e-04_rb, 3.5500e-04_rb/)
4006 chi_mls(3,1:12) = (/ &
4007 3.0170e-08_rb, 3.4725e-08_rb, 4.2477e-08_rb, 5.2759e-08_rb, 6.6944e-08_rb, &
4008 8.7130e-08_rb, 1.1391e-07_rb, 1.5677e-07_rb, 2.1788e-07_rb, 3.2443e-07_rb, &
4009 4.6594e-07_rb, 5.6806e-07_rb/)
4010 chi_mls(3,13:59) = (/ &
4011 6.9607e-07_rb, 1.1186e-06_rb, 1.7618e-06_rb, 2.3269e-06_rb, 2.9577e-06_rb, &
4012 3.6593e-06_rb, 4.5950e-06_rb, 5.3189e-06_rb, 5.9618e-06_rb, 6.5113e-06_rb, &
4013 7.0635e-06_rb, 7.6917e-06_rb, 8.2577e-06_rb, 8.7082e-06_rb, 8.8325e-06_rb, &
4014 8.7149e-06_rb, 8.0943e-06_rb, 7.3307e-06_rb, 6.3101e-06_rb, 5.3672e-06_rb, &
4015 4.4829e-06_rb, 3.8391e-06_rb, 3.2827e-06_rb, 2.8235e-06_rb, 2.4906e-06_rb, &
4016 2.1645e-06_rb, 1.8385e-06_rb, 1.6618e-06_rb, 1.5052e-06_rb, 1.3485e-06_rb, &
4017 1.1972e-06_rb, 1.0482e-06_rb, 8.9926e-07_rb, 7.6343e-07_rb, 6.5381e-07_rb, &
4018 5.4419e-07_rb, 4.3456e-07_rb, 3.6421e-07_rb, 3.1194e-07_rb, 2.5967e-07_rb, &
4019 2.0740e-07_rb, 1.9146e-07_rb, 1.9364e-07_rb, 1.9582e-07_rb, 1.9800e-07_rb, &
4020 7.6343e-07_rb, 6.5381e-07_rb/)
4021 chi_mls(4,1:12) = (/ &
4022 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, &
4023 3.1965e-07_rb, 3.1532e-07_rb, 3.0383e-07_rb, 2.9422e-07_rb, 2.8495e-07_rb, &
4024 2.7671e-07_rb, 2.6471e-07_rb/)
4025 chi_mls(4,13:59) = (/ &
4026 2.4285e-07_rb, 2.0955e-07_rb, 1.7195e-07_rb, 1.3749e-07_rb, 1.1332e-07_rb, &
4027 1.0035e-07_rb, 9.1281e-08_rb, 8.5463e-08_rb, 8.0363e-08_rb, 7.3372e-08_rb, &
4028 6.5975e-08_rb, 5.6039e-08_rb, 4.7090e-08_rb, 3.9977e-08_rb, 3.2979e-08_rb, &
4029 2.6064e-08_rb, 2.1066e-08_rb, 1.6592e-08_rb, 1.3017e-08_rb, 1.0090e-08_rb, &
4030 7.6249e-09_rb, 6.1159e-09_rb, 4.6672e-09_rb, 3.2857e-09_rb, 2.8484e-09_rb, &
4031 2.4620e-09_rb, 2.0756e-09_rb, 1.8551e-09_rb, 1.6568e-09_rb, 1.4584e-09_rb, &
4032 1.3195e-09_rb, 1.2072e-09_rb, 1.0948e-09_rb, 9.9780e-10_rb, 9.3126e-10_rb, &
4033 8.6472e-10_rb, 7.9818e-10_rb, 7.5138e-10_rb, 7.1367e-10_rb, 6.7596e-10_rb, &
4034 6.3825e-10_rb, 6.0981e-10_rb, 5.8600e-10_rb, 5.6218e-10_rb, 5.3837e-10_rb, &
4035 9.9780e-10_rb, 9.3126e-10_rb/)
4036 chi_mls(5,1:12) = (/ &
4037 1.5000e-07_rb, 1.4306e-07_rb, 1.3474e-07_rb, 1.3061e-07_rb, 1.2793e-07_rb, &
4038 1.2038e-07_rb, 1.0798e-07_rb, 9.4238e-08_rb, 7.9488e-08_rb, 6.1386e-08_rb, &
4039 4.5563e-08_rb, 3.3475e-08_rb/)
4040 chi_mls(5,13:59) = (/ &
4041 2.5118e-08_rb, 1.8671e-08_rb, 1.4349e-08_rb, 1.2501e-08_rb, 1.2407e-08_rb, &
4042 1.3472e-08_rb, 1.4900e-08_rb, 1.6079e-08_rb, 1.7156e-08_rb, 1.8616e-08_rb, &
4043 2.0106e-08_rb, 2.1654e-08_rb, 2.3096e-08_rb, 2.4340e-08_rb, 2.5643e-08_rb, &
4044 2.6990e-08_rb, 2.8456e-08_rb, 2.9854e-08_rb, 3.0943e-08_rb, 3.2023e-08_rb, &
4045 3.3101e-08_rb, 3.4260e-08_rb, 3.5360e-08_rb, 3.6397e-08_rb, 3.7310e-08_rb, &
4046 3.8217e-08_rb, 3.9123e-08_rb, 4.1303e-08_rb, 4.3652e-08_rb, 4.6002e-08_rb, &
4047 5.0289e-08_rb, 5.5446e-08_rb, 6.0603e-08_rb, 6.8946e-08_rb, 8.3652e-08_rb, &
4048 9.8357e-08_rb, 1.1306e-07_rb, 1.4766e-07_rb, 1.9142e-07_rb, 2.3518e-07_rb, &
4049 2.7894e-07_rb, 3.5001e-07_rb, 4.3469e-07_rb, 5.1938e-07_rb, 6.0407e-07_rb, &
4050 6.8946e-08_rb, 8.3652e-08_rb/)
4051 chi_mls(6,1:12) = (/ &
4052 1.7000e-06_rb, 1.7000e-06_rb, 1.6999e-06_rb, 1.6904e-06_rb, 1.6671e-06_rb, &
4053 1.6351e-06_rb, 1.6098e-06_rb, 1.5590e-06_rb, 1.5120e-06_rb, 1.4741e-06_rb, &
4054 1.4385e-06_rb, 1.4002e-06_rb/)
4055 chi_mls(6,13:59) = (/ &
4056 1.3573e-06_rb, 1.3130e-06_rb, 1.2512e-06_rb, 1.1668e-06_rb, 1.0553e-06_rb, &
4057 9.3281e-07_rb, 8.1217e-07_rb, 7.5239e-07_rb, 7.0728e-07_rb, 6.6722e-07_rb, &
4058 6.2733e-07_rb, 5.8604e-07_rb, 5.4769e-07_rb, 5.1480e-07_rb, 4.8206e-07_rb, &
4059 4.4943e-07_rb, 4.1702e-07_rb, 3.8460e-07_rb, 3.5200e-07_rb, 3.1926e-07_rb, &
4060 2.8646e-07_rb, 2.5498e-07_rb, 2.2474e-07_rb, 1.9588e-07_rb, 1.8295e-07_rb, &
4061 1.7089e-07_rb, 1.5882e-07_rb, 1.5536e-07_rb, 1.5304e-07_rb, 1.5072e-07_rb, &
4062 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4063 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4064 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4065 1.5000e-07_rb, 1.5000e-07_rb/)
4066 chi_mls(7,1:12) = (/ &
4067 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4068 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4069 0.2090_rb, 0.2090_rb/)
4070 chi_mls(7,13:59) = (/ &
4071 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4072 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4073 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4074 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4075 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4076 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4077 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4078 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4079 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
4080 0.2090_rb, 0.2090_rb/)
4082 end subroutine lwatmref
4084 !***************************************************************************
4085 subroutine lwavplank
4086 !***************************************************************************
4088 save
4090 totplnk(1:50, 1) = (/ &
4091 0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, &
4092 0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, &
4093 0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, &
4094 0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, &
4095 0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, &
4096 0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, &
4097 0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, &
4098 0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, &
4099 0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, &
4100 0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/)
4101 totplnk(51:100, 1) = (/ &
4102 0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, &
4103 0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, &
4104 0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, &
4105 0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, &
4106 0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, &
4107 0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, &
4108 0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, &
4109 0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, &
4110 0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, &
4111 0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/)
4112 totplnk(101:150, 1) = (/ &
4113 0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, &
4114 0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, &
4115 0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, &
4116 0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, &
4117 0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, &
4118 0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, &
4119 0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, &
4120 0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, &
4121 0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, &
4122 0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/)
4123 totplnk(151:181, 1) = (/ &
4124 0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, &
4125 0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, &
4126 0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, &
4127 0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, &
4128 0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, &
4129 0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, &
4130 0.65247e-05_rb/)
4131 totplnk(1:50, 2) = (/ &
4132 0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, &
4133 0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, &
4134 0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, &
4135 0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, &
4136 0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, &
4137 0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, &
4138 0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, &
4139 0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, &
4140 0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, &
4141 0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/)
4142 totplnk(51:100, 2) = (/ &
4143 0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, &
4144 0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, &
4145 0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, &
4146 0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, &
4147 0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, &
4148 0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, &
4149 0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, &
4150 0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, &
4151 0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, &
4152 0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/)
4153 totplnk(101:150, 2) = (/ &
4154 0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, &
4155 0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, &
4156 0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, &
4157 0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, &
4158 0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, &
4159 0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, &
4160 0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, &
4161 0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, &
4162 0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, &
4163 0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/)
4164 totplnk(151:181, 2) = (/ &
4165 0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, &
4166 0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, &
4167 0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, &
4168 0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, &
4169 0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, &
4170 0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, &
4171 0.17998e-04_rb/)
4172 totplnk(1:50, 3) = (/ &
4173 1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, &
4174 1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, &
4175 1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, &
4176 2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, &
4177 2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, &
4178 2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, &
4179 3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, &
4180 3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, &
4181 3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, &
4182 4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/)
4183 totplnk(51:100, 3) = (/ &
4184 4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, &
4185 4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, &
4186 5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, &
4187 5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, &
4188 6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, &
4189 6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, &
4190 7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, &
4191 8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, &
4192 8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, &
4193 9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/)
4194 totplnk(101:150, 3) = (/ &
4195 9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, &
4196 1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, &
4197 1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, &
4198 1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, &
4199 1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, &
4200 1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, &
4201 1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, &
4202 1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, &
4203 1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, &
4204 1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/)
4205 totplnk(151:181, 3) = (/ &
4206 1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, &
4207 1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, &
4208 1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, &
4209 1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, &
4210 1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, &
4211 2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, &
4212 2.15414e-05_rb/)
4213 totplnk(1:50, 4) = (/ &
4214 8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, &
4215 1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, &
4216 1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, &
4217 1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, &
4218 1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, &
4219 2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, &
4220 2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, &
4221 2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, &
4222 2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, &
4223 3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/)
4224 totplnk(51:100, 4) = (/ &
4225 3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, &
4226 4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, &
4227 4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, &
4228 5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, &
4229 5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, &
4230 6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, &
4231 6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, &
4232 7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, &
4233 7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, &
4234 8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/)
4235 totplnk(101:150, 4) = (/ &
4236 9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, &
4237 9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, &
4238 1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, &
4239 1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, &
4240 1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, &
4241 1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, &
4242 1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, &
4243 1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, &
4244 1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, &
4245 1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/)
4246 totplnk(151:181, 4) = (/ &
4247 1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, &
4248 1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, &
4249 1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, &
4250 1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, &
4251 2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, &
4252 2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, &
4253 2.23158e-05_rb/)
4254 totplnk(1:50, 5) = (/ &
4255 5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, &
4256 7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, &
4257 8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, &
4258 1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, &
4259 1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, &
4260 1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, &
4261 1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, &
4262 1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, &
4263 2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, &
4264 2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/)
4265 totplnk(51:100, 5) = (/ &
4266 2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, &
4267 3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, &
4268 3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, &
4269 4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, &
4270 4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, &
4271 5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, &
4272 5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, &
4273 6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, &
4274 6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, &
4275 7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/)
4276 totplnk(101:150, 5) = (/ &
4277 7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, &
4278 8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, &
4279 9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, &
4280 9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, &
4281 1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, &
4282 1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, &
4283 1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, &
4284 1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, &
4285 1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, &
4286 1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/)
4287 totplnk(151:181, 5) = (/ &
4288 1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, &
4289 1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, &
4290 1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, &
4291 1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, &
4292 1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, &
4293 2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, &
4294 2.17931e-05_rb/)
4295 totplnk(1:50, 6) = (/ &
4296 2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, &
4297 3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, &
4298 4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, &
4299 5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, &
4300 6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, &
4301 8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, &
4302 9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, &
4303 1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, &
4304 1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, &
4305 1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/)
4306 totplnk(51:100, 6) = (/ &
4307 1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, &
4308 2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, &
4309 2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, &
4310 2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, &
4311 3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, &
4312 3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, &
4313 3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, &
4314 4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, &
4315 4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, &
4316 5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/)
4317 totplnk(101:150, 6) = (/ &
4318 6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, &
4319 6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, &
4320 7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, &
4321 7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, &
4322 8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, &
4323 9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, &
4324 1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, &
4325 1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, &
4326 1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, &
4327 1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/)
4328 totplnk(151:181, 6) = (/ &
4329 1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, &
4330 1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, &
4331 1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, &
4332 1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, &
4333 1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, &
4334 1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, &
4335 1.96471e-05_rb/)
4336 totplnk(1:50, 7) = (/ &
4337 1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, &
4338 1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, &
4339 2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, &
4340 2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, &
4341 3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, &
4342 4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, &
4343 5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, &
4344 6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, &
4345 7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, &
4346 9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/)
4347 totplnk(51:100, 7) = (/ &
4348 1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, &
4349 1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, &
4350 1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, &
4351 1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, &
4352 2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, &
4353 2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, &
4354 2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, &
4355 3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, &
4356 3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, &
4357 3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/)
4358 totplnk(101:150, 7) = (/ &
4359 4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, &
4360 4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, &
4361 5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, &
4362 5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, &
4363 6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, &
4364 7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, &
4365 7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, &
4366 8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, &
4367 9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, &
4368 1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/)
4369 totplnk(151:181, 7) = (/ &
4370 1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, &
4371 1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, &
4372 1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, &
4373 1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, &
4374 1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, &
4375 1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, &
4376 1.68640e-05_rb/)
4377 totplnk(1:50, 8) = (/ &
4378 6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, &
4379 9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, &
4380 1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, &
4381 1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, &
4382 2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, &
4383 2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, &
4384 3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, &
4385 4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, &
4386 5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, &
4387 6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/)
4388 totplnk(51:100, 8) = (/ &
4389 7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, &
4390 8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, &
4391 1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, &
4392 1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, &
4393 1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, &
4394 1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, &
4395 1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, &
4396 2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, &
4397 2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, &
4398 2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/)
4399 totplnk(101:150, 8) = (/ &
4400 3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, &
4401 3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, &
4402 4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, &
4403 4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, &
4404 5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, &
4405 5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, &
4406 6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, &
4407 6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, &
4408 7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, &
4409 8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/)
4410 totplnk(151:181, 8) = (/ &
4411 9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, &
4412 9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, &
4413 1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, &
4414 1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, &
4415 1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, &
4416 1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, &
4417 1.45267e-05_rb/)
4418 totplnk(1:50, 9) = (/ &
4419 2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, &
4420 3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, &
4421 5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, &
4422 6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, &
4423 9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, &
4424 1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, &
4425 1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, &
4426 2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, &
4427 2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, &
4428 3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/)
4429 totplnk(51:100, 9) = (/ &
4430 3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, &
4431 4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, &
4432 5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, &
4433 7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, &
4434 8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, &
4435 9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, &
4436 1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, &
4437 1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, &
4438 1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, &
4439 1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/)
4440 totplnk(101:150, 9) = (/ &
4441 2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, &
4442 2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, &
4443 2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, &
4444 3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, &
4445 3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, &
4446 3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, &
4447 4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, &
4448 4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, &
4449 5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, &
4450 5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/)
4451 totplnk(151:181, 9) = (/ &
4452 6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, &
4453 7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, &
4454 7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, &
4455 8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, &
4456 9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, &
4457 1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, &
4458 1.10781e-05_rb/)
4459 totplnk(1:50,10) = (/ &
4460 8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, &
4461 1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, &
4462 1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, &
4463 2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, &
4464 3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, &
4465 5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, &
4466 6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, &
4467 8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, &
4468 1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, &
4469 1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/)
4470 totplnk(51:100,10) = (/ &
4471 1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, &
4472 2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, &
4473 2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, &
4474 3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, &
4475 4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, &
4476 5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, &
4477 6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, &
4478 7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, &
4479 9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, &
4480 1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/)
4481 totplnk(101:150,10) = (/ &
4482 1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, &
4483 1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, &
4484 1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, &
4485 1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, &
4486 2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, &
4487 2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, &
4488 2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, &
4489 3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, &
4490 3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, &
4491 4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/)
4492 totplnk(151:181,10) = (/ &
4493 4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, &
4494 5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, &
4495 5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, &
4496 6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, &
4497 6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, &
4498 7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, &
4499 8.14138e-06_rb/)
4500 totplnk(1:50,11) = (/ &
4501 2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, &
4502 3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, &
4503 5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, &
4504 8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, &
4505 1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, &
4506 1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, &
4507 2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, &
4508 3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, &
4509 4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, &
4510 5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/)
4511 totplnk(51:100,11) = (/ &
4512 7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, &
4513 9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, &
4514 1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, &
4515 1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, &
4516 1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, &
4517 2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, &
4518 3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, &
4519 3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, &
4520 4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, &
4521 5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/)
4522 totplnk(101:150,11) = (/ &
4523 6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, &
4524 7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, &
4525 8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, &
4526 1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, &
4527 1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, &
4528 1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, &
4529 1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, &
4530 1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, &
4531 2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, &
4532 2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/)
4533 totplnk(151:181,11) = (/ &
4534 2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, &
4535 3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, &
4536 3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, &
4537 3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, &
4538 4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, &
4539 4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, &
4540 5.19332e-06_rb/)
4541 totplnk(1:50,12) = (/ &
4542 2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, &
4543 4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, &
4544 7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, &
4545 1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, &
4546 1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, &
4547 2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, &
4548 4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, &
4549 5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, &
4550 8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, &
4551 1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/)
4552 totplnk(51:100,12) = (/ &
4553 1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, &
4554 2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, &
4555 2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, &
4556 3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, &
4557 4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, &
4558 6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, &
4559 8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, &
4560 1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, &
4561 1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, &
4562 1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/)
4563 totplnk(101:150,12) = (/ &
4564 1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, &
4565 2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, &
4566 2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, &
4567 3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, &
4568 4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, &
4569 5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, &
4570 5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, &
4571 6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, &
4572 8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, &
4573 9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/)
4574 totplnk(151:181,12) = (/ &
4575 1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, &
4576 1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, &
4577 1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, &
4578 1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, &
4579 1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, &
4580 2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, &
4581 2.41619e-06_rb/)
4582 totplnk(1:50,13) = (/ &
4583 4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, &
4584 8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, &
4585 1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, &
4586 2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, &
4587 3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, &
4588 6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, &
4589 9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, &
4590 1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, &
4591 2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, &
4592 3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/)
4593 totplnk(51:100,13) = (/ &
4594 4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, &
4595 6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, &
4596 8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, &
4597 1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, &
4598 1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, &
4599 2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, &
4600 2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, &
4601 3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, &
4602 4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, &
4603 6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/)
4604 totplnk(101:150,13) = (/ &
4605 7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, &
4606 9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, &
4607 1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, &
4608 1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, &
4609 1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, &
4610 2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, &
4611 2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, &
4612 3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, &
4613 3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, &
4614 4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/)
4615 totplnk(151:181,13) = (/ &
4616 5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, &
4617 6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, &
4618 7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, &
4619 8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, &
4620 9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, &
4621 1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, &
4622 1.28049e-06_rb/)
4623 totplnk(1:50,14) = (/ &
4624 1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, &
4625 2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, &
4626 4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, &
4627 8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, &
4628 1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, &
4629 2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, &
4630 3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, &
4631 5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, &
4632 8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, &
4633 1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/)
4634 totplnk(51:100,14) = (/ &
4635 1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, &
4636 2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, &
4637 4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, &
4638 5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, &
4639 7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, &
4640 1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, &
4641 1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, &
4642 1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, &
4643 2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, &
4644 3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/)
4645 totplnk(101:150,14) = (/ &
4646 4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, &
4647 5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, &
4648 6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, &
4649 8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, &
4650 1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, &
4651 1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, &
4652 1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, &
4653 1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, &
4654 2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, &
4655 2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/)
4656 totplnk(151:181,14) = (/ &
4657 3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, &
4658 3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, &
4659 4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, &
4660 5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, &
4661 6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, &
4662 7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, &
4663 8.27050e-07_rb/)
4664 totplnk(1:50,15) = (/ &
4665 3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, &
4666 7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, &
4667 1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, &
4668 2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, &
4669 4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, &
4670 7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, &
4671 1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, &
4672 2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, &
4673 3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, &
4674 5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/)
4675 totplnk(51:100,15) = (/ &
4676 7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, &
4677 1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, &
4678 1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, &
4679 2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, &
4680 3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, &
4681 4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, &
4682 6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, &
4683 8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, &
4684 1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, &
4685 1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/)
4686 totplnk(101:150,15) = (/ &
4687 1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, &
4688 2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, &
4689 3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, &
4690 4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, &
4691 5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, &
4692 6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, &
4693 8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, &
4694 1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, &
4695 1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, &
4696 1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/)
4697 totplnk(151:181,15) = (/ &
4698 1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, &
4699 2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, &
4700 2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, &
4701 3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, &
4702 3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, &
4703 4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, &
4704 4.96535e-07_rb/)
4705 totplnk(1:50,16) = (/ &
4706 0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, &
4707 0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, &
4708 0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, &
4709 0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, &
4710 0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, &
4711 0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, &
4712 0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, &
4713 0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, &
4714 0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, &
4715 0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/)
4716 totplnk(51:100,16) = (/ &
4717 0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, &
4718 0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, &
4719 0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, &
4720 0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, &
4721 0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, &
4722 0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, &
4723 0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, &
4724 0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, &
4725 0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, &
4726 0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/)
4727 totplnk(101:150,16) = (/ &
4728 0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, &
4729 0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, &
4730 0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, &
4731 0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, &
4732 0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, &
4733 0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, &
4734 0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, &
4735 0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, &
4736 0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, &
4737 0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/)
4738 totplnk(151:181,16) = (/ &
4739 0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, &
4740 0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, &
4741 0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, &
4742 0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, &
4743 0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, &
4744 0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, &
4745 0.16823e-06_rb/)
4746 totplk16(1:50) = (/ &
4747 0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, &
4748 0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, &
4749 0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, &
4750 0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, &
4751 0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, &
4752 0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, &
4753 0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, &
4754 0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, &
4755 0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, &
4756 0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/)
4757 totplk16(51:100) = (/ &
4758 0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, &
4759 0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, &
4760 0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, &
4761 0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, &
4762 0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, &
4763 0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, &
4764 0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, &
4765 0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, &
4766 0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, &
4767 0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/)
4768 totplk16(101:150) = (/ &
4769 0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, &
4770 0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, &
4771 0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, &
4772 0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, &
4773 0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, &
4774 0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, &
4775 0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, &
4776 0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, &
4777 0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, &
4778 0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/)
4779 totplk16(151:181) = (/ &
4780 0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, &
4781 0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, &
4782 0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, &
4783 0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, &
4784 0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, &
4785 0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, &
4786 0.14841e-06_rb/)
4788 end subroutine lwavplank
4790 end module rrtmg_lw_setcoef
4792 ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_taumol.f90,v $
4793 ! author: $Author: mike $
4794 ! revision: $Revision: 1.7 $
4795 ! created: $Date: 2009/10/20 15:08:37 $
4796 !
4797 module rrtmg_lw_taumol
4799 ! --------------------------------------------------------------------------
4800 ! | |
4801 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
4802 ! | This software may be used, copied, or redistributed as long as it is |
4803 ! | not sold and this copyright notice is reproduced on each copy made. |
4804 ! | This model is provided as is without any express or implied warranties. |
4805 ! | (http://www.rtweb.aer.com/) |
4806 ! | |
4807 ! --------------------------------------------------------------------------
4809 ! ------- Modules -------
4811 use parkind, only : im => kind_im, rb => kind_rb
4812 use parrrtm, only : mg, nbndlw, maxxsec, ngptlw
4813 use rrlw_con, only: oneminus
4814 use rrlw_wvn, only: nspa, nspb
4815 use rrlw_vsn, only: hvrtau, hnamtau
4817 implicit none
4819 contains
4821 !----------------------------------------------------------------------------
4822 subroutine taumol(nlayers, pavel, wx, coldry, &
4823 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
4824 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
4825 colbrd, fac00, fac01, fac10, fac11, &
4826 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
4827 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
4828 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
4829 selffac, selffrac, indself, forfac, forfrac, indfor, &
4830 minorfrac, scaleminor, scaleminorn2, indminor, &
4831 fracs, taug)
4832 !----------------------------------------------------------------------------
4834 ! *******************************************************************************
4835 ! * *
4836 ! * Optical depths developed for the *
4837 ! * *
4838 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
4839 ! * *
4840 ! * *
4841 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
4842 ! * 131 HARTWELL AVENUE *
4843 ! * LEXINGTON, MA 02421 *
4844 ! * *
4845 ! * *
4846 ! * ELI J. MLAWER *
4847 ! * JENNIFER DELAMERE *
4848 ! * STEVEN J. TAUBMAN *
4849 ! * SHEPARD A. CLOUGH *
4850 ! * *
4851 ! * *
4852 ! * *
4853 ! * *
4854 ! * email: mlawer@aer.com *
4855 ! * email: jdelamer@aer.com *
4856 ! * *
4857 ! * The authors wish to acknowledge the contributions of the *
4858 ! * following people: Karen Cady-Pereira, Patrick D. Brown, *
4859 ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
4860 ! * *
4861 ! *******************************************************************************
4862 ! * *
4863 ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. *
4864 ! * *
4865 ! *******************************************************************************
4866 ! * TAUMOL *
4867 ! * *
4868 ! * This file contains the subroutines TAUGBn (where n goes from *
4869 ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions *
4870 ! * per g-value and layer for band n. *
4871 ! * *
4872 ! * Output: optical depths (unitless) *
4873 ! * fractions needed to compute Planck functions at every layer *
4874 ! * and g-value *
4875 ! * *
4876 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
4877 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
4878 ! * *
4879 ! * Input *
4880 ! * *
4881 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
4882 ! * COMMON /PRECISE/ ONEMINUS *
4883 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
4884 ! * & PZ(0:MXLAY),TZ(0:MXLAY) *
4885 ! * COMMON /PROFDATA/ LAYTROP, *
4886 ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), *
4887 ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), *
4888 ! * & COLO2(MXLAY)
4889 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
4890 ! * & FAC10(MXLAY),FAC11(MXLAY) *
4891 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
4892 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
4893 ! * *
4894 ! * Description: *
4895 ! * NG(IBAND) - number of g-values in band IBAND *
4896 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
4897 ! * atmospheres that are stored for band IBAND per *
4898 ! * pressure level and temperature. Each of these *
4899 ! * atmospheres has different relative amounts of the *
4900 ! * key species for the band (i.e. different binary *
4901 ! * species parameters). *
4902 ! * NSPB(IBAND) - same for upper atmosphere *
4903 ! * ONEMINUS - since problems are caused in some cases by interpolation *
4904 ! * parameters equal to or greater than 1, for these cases *
4905 ! * these parameters are set to this value, slightly < 1. *
4906 ! * PAVEL - layer pressures (mb) *
4907 ! * TAVEL - layer temperatures (degrees K) *
4908 ! * PZ - level pressures (mb) *
4909 ! * TZ - level temperatures (degrees K) *
4910 ! * LAYTROP - layer at which switch is made from one combination of *
4911 ! * key species to another *
4912 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
4913 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
4914 ! * respectively (molecules/cm**2) *
4915 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
4916 ! * compute the interpolation factors that multiply the *
4917 ! * appropriate reference k-values. A value of 0 (1) for *
4918 ! * i,j indicates that the corresponding factor multiplies *
4919 ! * reference k-value for the lower (higher) of the two *
4920 ! * appropriate temperatures, and altitudes, respectively. *
4921 ! * JP - the index of the lower (in altitude) of the two appropriate *
4922 ! * reference pressure levels needed for interpolation *
4923 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
4924 ! * temperatures needed for interpolation (for pressure *
4925 ! * levels JP and JP+1, respectively) *
4926 ! * SELFFAC - scale factor needed for water vapor self-continuum, equals *
4927 ! * (water vapor density)/(atmospheric density at 296K and *
4928 ! * 1013 mb) *
4929 ! * SELFFRAC - factor needed for temperature interpolation of reference *
4930 ! * water vapor self-continuum data *
4931 ! * INDSELF - index of the lower of the two appropriate reference *
4932 ! * temperatures needed for the self-continuum interpolation *
4933 ! * FORFAC - scale factor needed for water vapor foreign-continuum. *
4934 ! * FORFRAC - factor needed for temperature interpolation of reference *
4935 ! * water vapor foreign-continuum data *
4936 ! * INDFOR - index of the lower of the two appropriate reference *
4937 ! * temperatures needed for the foreign-continuum interpolation *
4938 ! * *
4939 ! * Data input *
4940 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
4941 ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' *
4942 ! * (note: n is the band number,'MGAS' is the species name of the minor *
4943 ! * gas) *
4944 ! * *
4945 ! * Description: *
4946 ! * KA - k-values for low reference atmospheres (key-species only) *
4947 ! * (units: cm**2/molecule) *
4948 ! * KB - k-values for high reference atmospheres (key-species only) *
4949 ! * (units: cm**2/molecule) *
4950 ! * KA_M'MGAS' - k-values for low reference atmosphere minor species *
4951 ! * (units: cm**2/molecule) *
4952 ! * KB_M'MGAS' - k-values for high reference atmosphere minor species *
4953 ! * (units: cm**2/molecule) *
4954 ! * SELFREF - k-values for water vapor self-continuum for reference *
4955 ! * atmospheres (used below LAYTROP) *
4956 ! * (units: cm**2/molecule) *
4957 ! * FORREF - k-values for water vapor foreign-continuum for reference *
4958 ! * atmospheres (used below/above LAYTROP) *
4959 ! * (units: cm**2/molecule) *
4960 ! * *
4961 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
4962 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
4963 ! * *
4964 !*******************************************************************************
4966 ! ------- Declarations -------
4968 ! ----- Input -----
4969 integer(kind=im), intent(in) :: nlayers ! total number of layers
4970 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
4971 ! Dimensions: (nlayers)
4972 real(kind=rb), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2)
4973 ! Dimensions: (maxxsec,nlayers)
4974 real(kind=rb), intent(in) :: coldry(:) ! column amount (dry air)
4975 ! Dimensions: (nlayers)
4977 integer(kind=im), intent(in) :: laytrop ! tropopause layer index
4978 integer(kind=im), intent(in) :: jp(:) !
4979 ! Dimensions: (nlayers)
4980 integer(kind=im), intent(in) :: jt(:) !
4981 ! Dimensions: (nlayers)
4982 integer(kind=im), intent(in) :: jt1(:) !
4983 ! Dimensions: (nlayers)
4984 real(kind=rb), intent(in) :: planklay(:,:) !
4985 ! Dimensions: (nlayers,nbndlw)
4986 real(kind=rb), intent(in) :: planklev(0:,:) !
4987 ! Dimensions: (nlayers,nbndlw)
4988 real(kind=rb), intent(in) :: plankbnd(:) !
4989 ! Dimensions: (nbndlw)
4991 real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o)
4992 ! Dimensions: (nlayers)
4993 real(kind=rb), intent(in) :: colco2(:) ! column amount (co2)
4994 ! Dimensions: (nlayers)
4995 real(kind=rb), intent(in) :: colo3(:) ! column amount (o3)
4996 ! Dimensions: (nlayers)
4997 real(kind=rb), intent(in) :: coln2o(:) ! column amount (n2o)
4998 ! Dimensions: (nlayers)
4999 real(kind=rb), intent(in) :: colco(:) ! column amount (co)
5000 ! Dimensions: (nlayers)
5001 real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4)
5002 ! Dimensions: (nlayers)
5003 real(kind=rb), intent(in) :: colo2(:) ! column amount (o2)
5004 ! Dimensions: (nlayers)
5005 real(kind=rb), intent(in) :: colbrd(:) ! column amount (broadening gases)
5006 ! Dimensions: (nlayers)
5008 integer(kind=im), intent(in) :: indself(:)
5009 ! Dimensions: (nlayers)
5010 integer(kind=im), intent(in) :: indfor(:)
5011 ! Dimensions: (nlayers)
5012 real(kind=rb), intent(in) :: selffac(:)
5013 ! Dimensions: (nlayers)
5014 real(kind=rb), intent(in) :: selffrac(:)
5015 ! Dimensions: (nlayers)
5016 real(kind=rb), intent(in) :: forfac(:)
5017 ! Dimensions: (nlayers)
5018 real(kind=rb), intent(in) :: forfrac(:)
5019 ! Dimensions: (nlayers)
5021 integer(kind=im), intent(in) :: indminor(:)
5022 ! Dimensions: (nlayers)
5023 real(kind=rb), intent(in) :: minorfrac(:)
5024 ! Dimensions: (nlayers)
5025 real(kind=rb), intent(in) :: scaleminor(:)
5026 ! Dimensions: (nlayers)
5027 real(kind=rb), intent(in) :: scaleminorn2(:)
5028 ! Dimensions: (nlayers)
5030 real(kind=rb), intent(in) :: & !
5031 fac00(:), fac01(:), & ! Dimensions: (nlayers)
5032 fac10(:), fac11(:)
5033 real(kind=rb), intent(in) :: & !
5034 rat_h2oco2(:),rat_h2oco2_1(:), &
5035 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
5036 rat_h2on2o(:),rat_h2on2o_1(:), &
5037 rat_h2och4(:),rat_h2och4_1(:), &
5038 rat_n2oco2(:),rat_n2oco2_1(:), &
5039 rat_o3co2(:),rat_o3co2_1(:)
5041 ! ----- Output -----
5042 real(kind=rb), intent(out) :: fracs(:,:) ! planck fractions
5043 ! Dimensions: (nlayers,ngptlw)
5044 real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth
5045 ! Dimensions: (nlayers,ngptlw)
5047 !jm not thread safe hvrtau = '$Revision: 1.7 $'
5049 ! Calculate gaseous optical depth and planck fractions for each spectral band.
5051 call taugb1
5052 call taugb2
5053 call taugb3
5054 call taugb4
5055 call taugb5
5056 call taugb6
5057 call taugb7
5058 call taugb8
5059 call taugb9
5060 call taugb10
5061 call taugb11
5062 call taugb12
5063 call taugb13
5064 call taugb14
5065 call taugb15
5066 call taugb16
5068 contains
5070 !----------------------------------------------------------------------------
5071 subroutine taugb1
5072 !----------------------------------------------------------------------------
5074 ! ------- Modifications -------
5075 ! Written by Eli J. Mlawer, Atmospheric & Environmental Research.
5076 ! Revised by Michael J. Iacono, Atmospheric & Environmental Research.
5077 !
5078 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
5079 ! (high key - h2o; high minor - n2)
5080 !
5081 ! note: previous versions of rrtm band 1:
5082 ! 10-250 cm-1 (low - h2o; high - h2o)
5083 !----------------------------------------------------------------------------
5085 ! ------- Modules -------
5087 use parrrtm, only : ng1
5088 use rrlw_kg01, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5089 ka_mn2, kb_mn2, selfref, forref
5091 ! ------- Declarations -------
5093 ! Local
5094 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5095 real(kind=rb) :: pp, corradj, scalen2, tauself, taufor, taun2
5098 ! Minor gas mapping levels:
5099 ! lower - n2, p = 142.5490 mbar, t = 215.70 k
5100 ! upper - n2, p = 142.5490 mbar, t = 215.70 k
5102 ! Compute the optical depth by interpolating in ln(pressure) and
5103 ! temperature. Below laytrop, the water vapor self-continuum and
5104 ! foreign continuum is interpolated (in temperature) separately.
5106 ! Lower atmosphere loop
5107 do lay = 1, laytrop
5109 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1
5110 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1
5111 inds = indself(lay)
5112 indf = indfor(lay)
5113 indm = indminor(lay)
5114 pp = pavel(lay)
5115 corradj = 1.
5116 if (pp .lt. 250._rb) then
5117 corradj = 1._rb - 0.15_rb * (250._rb-pp) / 154.4_rb
5118 endif
5120 scalen2 = colbrd(lay) * scaleminorn2(lay)
5121 do ig = 1, ng1
5122 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5123 (selfref(inds+1,ig) - selfref(inds,ig)))
5124 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5125 (forref(indf+1,ig) - forref(indf,ig)))
5126 taun2 = scalen2*(ka_mn2(indm,ig) + &
5127 minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig)))
5128 taug(lay,ig) = corradj * (colh2o(lay) * &
5129 (fac00(lay) * absa(ind0,ig) + &
5130 fac10(lay) * absa(ind0+1,ig) + &
5131 fac01(lay) * absa(ind1,ig) + &
5132 fac11(lay) * absa(ind1+1,ig)) &
5133 + tauself + taufor + taun2)
5134 fracs(lay,ig) = fracrefa(ig)
5135 enddo
5136 enddo
5138 ! Upper atmosphere loop
5139 do lay = laytrop+1, nlayers
5141 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1
5142 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1
5143 indf = indfor(lay)
5144 indm = indminor(lay)
5145 pp = pavel(lay)
5146 corradj = 1._rb - 0.15_rb * (pp / 95.6_rb)
5148 scalen2 = colbrd(lay) * scaleminorn2(lay)
5149 do ig = 1, ng1
5150 taufor = forfac(lay) * (forref(indf,ig) + &
5151 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5152 taun2 = scalen2*(kb_mn2(indm,ig) + &
5153 minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig)))
5154 taug(lay,ig) = corradj * (colh2o(lay) * &
5155 (fac00(lay) * absb(ind0,ig) + &
5156 fac10(lay) * absb(ind0+1,ig) + &
5157 fac01(lay) * absb(ind1,ig) + &
5158 fac11(lay) * absb(ind1+1,ig)) &
5159 + taufor + taun2)
5160 fracs(lay,ig) = fracrefb(ig)
5161 enddo
5162 enddo
5164 end subroutine taugb1
5166 !----------------------------------------------------------------------------
5167 subroutine taugb2
5168 !----------------------------------------------------------------------------
5169 !
5170 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
5171 !
5172 ! note: previous version of rrtm band 2:
5173 ! 250 - 500 cm-1 (low - h2o; high - h2o)
5174 !----------------------------------------------------------------------------
5176 ! ------- Modules -------
5178 use parrrtm, only : ng2, ngs1
5179 use rrlw_kg02, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5180 selfref, forref
5182 ! ------- Declarations -------
5184 ! Local
5185 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5186 real(kind=rb) :: pp, corradj, tauself, taufor
5189 ! Compute the optical depth by interpolating in ln(pressure) and
5190 ! temperature. Below laytrop, the water vapor self-continuum and
5191 ! foreign continuum is interpolated (in temperature) separately.
5193 ! Lower atmosphere loop
5194 do lay = 1, laytrop
5196 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
5197 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
5198 inds = indself(lay)
5199 indf = indfor(lay)
5200 pp = pavel(lay)
5201 corradj = 1._rb - .05_rb * (pp - 100._rb) / 900._rb
5202 do ig = 1, ng2
5203 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5204 (selfref(inds+1,ig) - selfref(inds,ig)))
5205 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5206 (forref(indf+1,ig) - forref(indf,ig)))
5207 taug(lay,ngs1+ig) = corradj * (colh2o(lay) * &
5208 (fac00(lay) * absa(ind0,ig) + &
5209 fac10(lay) * absa(ind0+1,ig) + &
5210 fac01(lay) * absa(ind1,ig) + &
5211 fac11(lay) * absa(ind1+1,ig)) &
5212 + tauself + taufor)
5213 fracs(lay,ngs1+ig) = fracrefa(ig)
5214 enddo
5215 enddo
5217 ! Upper atmosphere loop
5218 do lay = laytrop+1, nlayers
5220 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
5221 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
5222 indf = indfor(lay)
5223 do ig = 1, ng2
5224 taufor = forfac(lay) * (forref(indf,ig) + &
5225 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5226 taug(lay,ngs1+ig) = colh2o(lay) * &
5227 (fac00(lay) * absb(ind0,ig) + &
5228 fac10(lay) * absb(ind0+1,ig) + &
5229 fac01(lay) * absb(ind1,ig) + &
5230 fac11(lay) * absb(ind1+1,ig)) &
5231 + taufor
5232 fracs(lay,ngs1+ig) = fracrefb(ig)
5233 enddo
5234 enddo
5236 end subroutine taugb2
5238 !----------------------------------------------------------------------------
5239 subroutine taugb3
5240 !----------------------------------------------------------------------------
5241 !
5242 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
5243 ! (high key - h2o,co2; high minor - n2o)
5244 !----------------------------------------------------------------------------
5246 ! ------- Modules -------
5248 use parrrtm, only : ng3, ngs2
5249 use rrlw_ref, only : chi_mls
5250 use rrlw_kg03, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5251 ka_mn2o, kb_mn2o, selfref, forref
5253 ! ------- Declarations -------
5255 ! Local
5256 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5257 integer(kind=im) :: js, js1, jmn2o, jpl
5258 real(kind=rb) :: speccomb, specparm, specmult, fs
5259 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5260 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, &
5261 fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
5262 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5263 real(kind=rb) :: p, p4, fk0, fk1, fk2
5264 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5265 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5266 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
5267 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
5268 real(kind=rb) :: tau_major, tau_major1
5271 ! Minor gas mapping levels:
5272 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
5273 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
5275 ! P = 212.725 mb
5276 refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
5278 ! P = 95.58 mb
5279 refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
5281 ! P = 706.270mb
5282 refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
5284 ! P = 95.58 mb
5285 refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
5287 ! Compute the optical depth by interpolating in ln(pressure) and
5288 ! temperature, and appropriate species. Below laytrop, the water vapor
5289 ! self-continuum and foreign continuum is interpolated (in temperature)
5290 ! separately.
5292 ! Lower atmosphere loop
5293 do lay = 1, laytrop
5295 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5296 specparm = colh2o(lay)/speccomb
5297 if (specparm .ge. oneminus) specparm = oneminus
5298 specmult = 8._rb*(specparm)
5299 js = 1 + int(specmult)
5300 fs = mod(specmult,1.0_rb)
5302 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5303 specparm1 = colh2o(lay)/speccomb1
5304 if (specparm1 .ge. oneminus) specparm1 = oneminus
5305 specmult1 = 8._rb*(specparm1)
5306 js1 = 1 + int(specmult1)
5307 fs1 = mod(specmult1,1.0_rb)
5309 speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay)
5310 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5311 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5312 specmult_mn2o = 8._rb*specparm_mn2o
5313 jmn2o = 1 + int(specmult_mn2o)
5314 fmn2o = mod(specmult_mn2o,1.0_rb)
5315 fmn2omf = minorfrac(lay)*fmn2o
5316 ! In atmospheres where the amount of N2O is too great to be considered
5317 ! a minor species, adjust the column amount of N2O by an empirical factor
5318 ! to obtain the proper contribution.
5319 chi_n2o = coln2o(lay)/coldry(lay)
5320 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
5321 if (ratn2o .gt. 1.5_rb) then
5322 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5323 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5324 else
5325 adjcoln2o = coln2o(lay)
5326 endif
5328 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5329 specparm_planck = colh2o(lay)/speccomb_planck
5330 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5331 specmult_planck = 8._rb*specparm_planck
5332 jpl= 1 + int(specmult_planck)
5333 fpl = mod(specmult_planck,1.0_rb)
5335 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js
5336 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1
5337 inds = indself(lay)
5338 indf = indfor(lay)
5339 indm = indminor(lay)
5341 if (specparm .lt. 0.125_rb) then
5342 p = fs - 1
5343 p4 = p**4
5344 fk0 = p4
5345 fk1 = 1 - p - 2.0_rb*p4
5346 fk2 = p + p4
5347 fac000 = fk0*fac00(lay)
5348 fac100 = fk1*fac00(lay)
5349 fac200 = fk2*fac00(lay)
5350 fac010 = fk0*fac10(lay)
5351 fac110 = fk1*fac10(lay)
5352 fac210 = fk2*fac10(lay)
5353 else if (specparm .gt. 0.875_rb) then
5354 p = -fs
5355 p4 = p**4
5356 fk0 = p4
5357 fk1 = 1 - p - 2.0_rb*p4
5358 fk2 = p + p4
5359 fac000 = fk0*fac00(lay)
5360 fac100 = fk1*fac00(lay)
5361 fac200 = fk2*fac00(lay)
5362 fac010 = fk0*fac10(lay)
5363 fac110 = fk1*fac10(lay)
5364 fac210 = fk2*fac10(lay)
5365 else
5366 fac000 = (1._rb - fs) * fac00(lay)
5367 fac010 = (1._rb - fs) * fac10(lay)
5368 fac100 = fs * fac00(lay)
5369 fac110 = fs * fac10(lay)
5370 endif
5371 if (specparm1 .lt. 0.125_rb) then
5372 p = fs1 - 1
5373 p4 = p**4
5374 fk0 = p4
5375 fk1 = 1 - p - 2.0_rb*p4
5376 fk2 = p + p4
5377 fac001 = fk0*fac01(lay)
5378 fac101 = fk1*fac01(lay)
5379 fac201 = fk2*fac01(lay)
5380 fac011 = fk0*fac11(lay)
5381 fac111 = fk1*fac11(lay)
5382 fac211 = fk2*fac11(lay)
5383 else if (specparm1 .gt. 0.875_rb) then
5384 p = -fs1
5385 p4 = p**4
5386 fk0 = p4
5387 fk1 = 1 - p - 2.0_rb*p4
5388 fk2 = p + p4
5389 fac001 = fk0*fac01(lay)
5390 fac101 = fk1*fac01(lay)
5391 fac201 = fk2*fac01(lay)
5392 fac011 = fk0*fac11(lay)
5393 fac111 = fk1*fac11(lay)
5394 fac211 = fk2*fac11(lay)
5395 else
5396 fac001 = (1._rb - fs1) * fac01(lay)
5397 fac011 = (1._rb - fs1) * fac11(lay)
5398 fac101 = fs1 * fac01(lay)
5399 fac111 = fs1 * fac11(lay)
5400 endif
5402 do ig = 1, ng3
5403 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5404 (selfref(inds+1,ig) - selfref(inds,ig)))
5405 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5406 (forref(indf+1,ig) - forref(indf,ig)))
5407 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
5408 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
5409 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5410 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
5411 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5413 if (specparm .lt. 0.125_rb) then
5414 tau_major = speccomb * &
5415 (fac000 * absa(ind0,ig) + &
5416 fac100 * absa(ind0+1,ig) + &
5417 fac200 * absa(ind0+2,ig) + &
5418 fac010 * absa(ind0+9,ig) + &
5419 fac110 * absa(ind0+10,ig) + &
5420 fac210 * absa(ind0+11,ig))
5421 else if (specparm .gt. 0.875_rb) then
5422 tau_major = speccomb * &
5423 (fac200 * absa(ind0-1,ig) + &
5424 fac100 * absa(ind0,ig) + &
5425 fac000 * absa(ind0+1,ig) + &
5426 fac210 * absa(ind0+8,ig) + &
5427 fac110 * absa(ind0+9,ig) + &
5428 fac010 * absa(ind0+10,ig))
5429 else
5430 tau_major = speccomb * &
5431 (fac000 * absa(ind0,ig) + &
5432 fac100 * absa(ind0+1,ig) + &
5433 fac010 * absa(ind0+9,ig) + &
5434 fac110 * absa(ind0+10,ig))
5435 endif
5437 if (specparm1 .lt. 0.125_rb) then
5438 tau_major1 = speccomb1 * &
5439 (fac001 * absa(ind1,ig) + &
5440 fac101 * absa(ind1+1,ig) + &
5441 fac201 * absa(ind1+2,ig) + &
5442 fac011 * absa(ind1+9,ig) + &
5443 fac111 * absa(ind1+10,ig) + &
5444 fac211 * absa(ind1+11,ig))
5445 else if (specparm1 .gt. 0.875_rb) then
5446 tau_major1 = speccomb1 * &
5447 (fac201 * absa(ind1-1,ig) + &
5448 fac101 * absa(ind1,ig) + &
5449 fac001 * absa(ind1+1,ig) + &
5450 fac211 * absa(ind1+8,ig) + &
5451 fac111 * absa(ind1+9,ig) + &
5452 fac011 * absa(ind1+10,ig))
5453 else
5454 tau_major1 = speccomb1 * &
5455 (fac001 * absa(ind1,ig) + &
5456 fac101 * absa(ind1+1,ig) + &
5457 fac011 * absa(ind1+9,ig) + &
5458 fac111 * absa(ind1+10,ig))
5459 endif
5461 taug(lay,ngs2+ig) = tau_major + tau_major1 &
5462 + tauself + taufor &
5463 + adjcoln2o*absn2o
5464 fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
5465 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5466 enddo
5467 enddo
5469 ! Upper atmosphere loop
5470 do lay = laytrop+1, nlayers
5472 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5473 specparm = colh2o(lay)/speccomb
5474 if (specparm .ge. oneminus) specparm = oneminus
5475 specmult = 4._rb*(specparm)
5476 js = 1 + int(specmult)
5477 fs = mod(specmult,1.0_rb)
5479 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5480 specparm1 = colh2o(lay)/speccomb1
5481 if (specparm1 .ge. oneminus) specparm1 = oneminus
5482 specmult1 = 4._rb*(specparm1)
5483 js1 = 1 + int(specmult1)
5484 fs1 = mod(specmult1,1.0_rb)
5486 fac000 = (1._rb - fs) * fac00(lay)
5487 fac010 = (1._rb - fs) * fac10(lay)
5488 fac100 = fs * fac00(lay)
5489 fac110 = fs * fac10(lay)
5490 fac001 = (1._rb - fs1) * fac01(lay)
5491 fac011 = (1._rb - fs1) * fac11(lay)
5492 fac101 = fs1 * fac01(lay)
5493 fac111 = fs1 * fac11(lay)
5495 speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay)
5496 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5497 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5498 specmult_mn2o = 4._rb*specparm_mn2o
5499 jmn2o = 1 + int(specmult_mn2o)
5500 fmn2o = mod(specmult_mn2o,1.0_rb)
5501 fmn2omf = minorfrac(lay)*fmn2o
5502 ! In atmospheres where the amount of N2O is too great to be considered
5503 ! a minor species, adjust the column amount of N2O by an empirical factor
5504 ! to obtain the proper contribution.
5505 chi_n2o = coln2o(lay)/coldry(lay)
5506 ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1)
5507 if (ratn2o .gt. 1.5_rb) then
5508 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5509 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5510 else
5511 adjcoln2o = coln2o(lay)
5512 endif
5514 speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay)
5515 specparm_planck = colh2o(lay)/speccomb_planck
5516 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5517 specmult_planck = 4._rb*specparm_planck
5518 jpl= 1 + int(specmult_planck)
5519 fpl = mod(specmult_planck,1.0_rb)
5521 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
5522 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1
5523 indf = indfor(lay)
5524 indm = indminor(lay)
5526 do ig = 1, ng3
5527 taufor = forfac(lay) * (forref(indf,ig) + &
5528 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5529 n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * &
5530 (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig))
5531 n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5532 (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig))
5533 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5534 taug(lay,ngs2+ig) = speccomb * &
5535 (fac000 * absb(ind0,ig) + &
5536 fac100 * absb(ind0+1,ig) + &
5537 fac010 * absb(ind0+5,ig) + &
5538 fac110 * absb(ind0+6,ig)) &
5539 + speccomb1 * &
5540 (fac001 * absb(ind1,ig) + &
5541 fac101 * absb(ind1+1,ig) + &
5542 fac011 * absb(ind1+5,ig) + &
5543 fac111 * absb(ind1+6,ig)) &
5544 + taufor &
5545 + adjcoln2o*absn2o
5546 fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * &
5547 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5548 enddo
5549 enddo
5551 end subroutine taugb3
5553 !----------------------------------------------------------------------------
5554 subroutine taugb4
5555 !----------------------------------------------------------------------------
5556 !
5557 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
5558 !----------------------------------------------------------------------------
5560 ! ------- Modules -------
5562 use parrrtm, only : ng4, ngs3
5563 use rrlw_ref, only : chi_mls
5564 use rrlw_kg04, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5565 selfref, forref
5567 ! ------- Declarations -------
5569 ! Local
5570 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5571 integer(kind=im) :: js, js1, jpl
5572 real(kind=rb) :: speccomb, specparm, specmult, fs
5573 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5574 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5575 real(kind=rb) :: p, p4, fk0, fk1, fk2
5576 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5577 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5578 real(kind=rb) :: tauself, taufor
5579 real(kind=rb) :: refrat_planck_a, refrat_planck_b
5580 real(kind=rb) :: tau_major, tau_major1
5583 ! P = 142.5940 mb
5584 refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
5586 ! P = 95.58350 mb
5587 refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
5589 ! Compute the optical depth by interpolating in ln(pressure) and
5590 ! temperature, and appropriate species. Below laytrop, the water
5591 ! vapor self-continuum and foreign continuum is interpolated (in temperature)
5592 ! separately.
5594 ! Lower atmosphere loop
5595 do lay = 1, laytrop
5597 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5598 specparm = colh2o(lay)/speccomb
5599 if (specparm .ge. oneminus) specparm = oneminus
5600 specmult = 8._rb*(specparm)
5601 js = 1 + int(specmult)
5602 fs = mod(specmult,1.0_rb)
5604 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5605 specparm1 = colh2o(lay)/speccomb1
5606 if (specparm1 .ge. oneminus) specparm1 = oneminus
5607 specmult1 = 8._rb*(specparm1)
5608 js1 = 1 + int(specmult1)
5609 fs1 = mod(specmult1,1.0_rb)
5611 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5612 specparm_planck = colh2o(lay)/speccomb_planck
5613 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5614 specmult_planck = 8._rb*specparm_planck
5615 jpl= 1 + int(specmult_planck)
5616 fpl = mod(specmult_planck,1.0_rb)
5618 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js
5619 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1
5620 inds = indself(lay)
5621 indf = indfor(lay)
5623 if (specparm .lt. 0.125_rb) then
5624 p = fs - 1
5625 p4 = p**4
5626 fk0 = p4
5627 fk1 = 1 - p - 2.0_rb*p4
5628 fk2 = p + p4
5629 fac000 = fk0*fac00(lay)
5630 fac100 = fk1*fac00(lay)
5631 fac200 = fk2*fac00(lay)
5632 fac010 = fk0*fac10(lay)
5633 fac110 = fk1*fac10(lay)
5634 fac210 = fk2*fac10(lay)
5635 else if (specparm .gt. 0.875_rb) then
5636 p = -fs
5637 p4 = p**4
5638 fk0 = p4
5639 fk1 = 1 - p - 2.0_rb*p4
5640 fk2 = p + p4
5641 fac000 = fk0*fac00(lay)
5642 fac100 = fk1*fac00(lay)
5643 fac200 = fk2*fac00(lay)
5644 fac010 = fk0*fac10(lay)
5645 fac110 = fk1*fac10(lay)
5646 fac210 = fk2*fac10(lay)
5647 else
5648 fac000 = (1._rb - fs) * fac00(lay)
5649 fac010 = (1._rb - fs) * fac10(lay)
5650 fac100 = fs * fac00(lay)
5651 fac110 = fs * fac10(lay)
5652 endif
5654 if (specparm1 .lt. 0.125_rb) then
5655 p = fs1 - 1
5656 p4 = p**4
5657 fk0 = p4
5658 fk1 = 1 - p - 2.0_rb*p4
5659 fk2 = p + p4
5660 fac001 = fk0*fac01(lay)
5661 fac101 = fk1*fac01(lay)
5662 fac201 = fk2*fac01(lay)
5663 fac011 = fk0*fac11(lay)
5664 fac111 = fk1*fac11(lay)
5665 fac211 = fk2*fac11(lay)
5666 else if (specparm1 .gt. 0.875_rb) then
5667 p = -fs1
5668 p4 = p**4
5669 fk0 = p4
5670 fk1 = 1 - p - 2.0_rb*p4
5671 fk2 = p + p4
5672 fac001 = fk0*fac01(lay)
5673 fac101 = fk1*fac01(lay)
5674 fac201 = fk2*fac01(lay)
5675 fac011 = fk0*fac11(lay)
5676 fac111 = fk1*fac11(lay)
5677 fac211 = fk2*fac11(lay)
5678 else
5679 fac001 = (1._rb - fs1) * fac01(lay)
5680 fac011 = (1._rb - fs1) * fac11(lay)
5681 fac101 = fs1 * fac01(lay)
5682 fac111 = fs1 * fac11(lay)
5683 endif
5685 do ig = 1, ng4
5686 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5687 (selfref(inds+1,ig) - selfref(inds,ig)))
5688 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5689 (forref(indf+1,ig) - forref(indf,ig)))
5691 if (specparm .lt. 0.125_rb) then
5692 tau_major = speccomb * &
5693 (fac000 * absa(ind0,ig) + &
5694 fac100 * absa(ind0+1,ig) + &
5695 fac200 * absa(ind0+2,ig) + &
5696 fac010 * absa(ind0+9,ig) + &
5697 fac110 * absa(ind0+10,ig) + &
5698 fac210 * absa(ind0+11,ig))
5699 else if (specparm .gt. 0.875_rb) then
5700 tau_major = speccomb * &
5701 (fac200 * absa(ind0-1,ig) + &
5702 fac100 * absa(ind0,ig) + &
5703 fac000 * absa(ind0+1,ig) + &
5704 fac210 * absa(ind0+8,ig) + &
5705 fac110 * absa(ind0+9,ig) + &
5706 fac010 * absa(ind0+10,ig))
5707 else
5708 tau_major = speccomb * &
5709 (fac000 * absa(ind0,ig) + &
5710 fac100 * absa(ind0+1,ig) + &
5711 fac010 * absa(ind0+9,ig) + &
5712 fac110 * absa(ind0+10,ig))
5713 endif
5715 if (specparm1 .lt. 0.125_rb) then
5716 tau_major1 = speccomb1 * &
5717 (fac001 * absa(ind1,ig) + &
5718 fac101 * absa(ind1+1,ig) + &
5719 fac201 * absa(ind1+2,ig) + &
5720 fac011 * absa(ind1+9,ig) + &
5721 fac111 * absa(ind1+10,ig) + &
5722 fac211 * absa(ind1+11,ig))
5723 else if (specparm1 .gt. 0.875_rb) then
5724 tau_major1 = speccomb1 * &
5725 (fac201 * absa(ind1-1,ig) + &
5726 fac101 * absa(ind1,ig) + &
5727 fac001 * absa(ind1+1,ig) + &
5728 fac211 * absa(ind1+8,ig) + &
5729 fac111 * absa(ind1+9,ig) + &
5730 fac011 * absa(ind1+10,ig))
5731 else
5732 tau_major1 = speccomb1 * &
5733 (fac001 * absa(ind1,ig) + &
5734 fac101 * absa(ind1+1,ig) + &
5735 fac011 * absa(ind1+9,ig) + &
5736 fac111 * absa(ind1+10,ig))
5737 endif
5739 taug(lay,ngs3+ig) = tau_major + tau_major1 &
5740 + tauself + taufor
5741 fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
5742 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5743 enddo
5744 enddo
5746 ! Upper atmosphere loop
5747 do lay = laytrop+1, nlayers
5749 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
5750 specparm = colo3(lay)/speccomb
5751 if (specparm .ge. oneminus) specparm = oneminus
5752 specmult = 4._rb*(specparm)
5753 js = 1 + int(specmult)
5754 fs = mod(specmult,1.0_rb)
5756 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
5757 specparm1 = colo3(lay)/speccomb1
5758 if (specparm1 .ge. oneminus) specparm1 = oneminus
5759 specmult1 = 4._rb*(specparm1)
5760 js1 = 1 + int(specmult1)
5761 fs1 = mod(specmult1,1.0_rb)
5763 fac000 = (1._rb - fs) * fac00(lay)
5764 fac010 = (1._rb - fs) * fac10(lay)
5765 fac100 = fs * fac00(lay)
5766 fac110 = fs * fac10(lay)
5767 fac001 = (1._rb - fs1) * fac01(lay)
5768 fac011 = (1._rb - fs1) * fac11(lay)
5769 fac101 = fs1 * fac01(lay)
5770 fac111 = fs1 * fac11(lay)
5772 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5773 specparm_planck = colo3(lay)/speccomb_planck
5774 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5775 specmult_planck = 4._rb*specparm_planck
5776 jpl= 1 + int(specmult_planck)
5777 fpl = mod(specmult_planck,1.0_rb)
5779 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js
5780 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1
5782 do ig = 1, ng4
5783 taug(lay,ngs3+ig) = speccomb * &
5784 (fac000 * absb(ind0,ig) + &
5785 fac100 * absb(ind0+1,ig) + &
5786 fac010 * absb(ind0+5,ig) + &
5787 fac110 * absb(ind0+6,ig)) &
5788 + speccomb1 * &
5789 (fac001 * absb(ind1,ig) + &
5790 fac101 * absb(ind1+1,ig) + &
5791 fac011 * absb(ind1+5,ig) + &
5792 fac111 * absb(ind1+6,ig))
5793 fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * &
5794 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5795 enddo
5797 ! Empirical modification to code to improve stratospheric cooling rates
5798 ! for co2. Revised to apply weighting for g-point reduction in this band.
5800 taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92
5801 taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88
5802 taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07
5803 taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1
5804 taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99
5805 taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88
5806 taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943
5808 enddo
5810 end subroutine taugb4
5812 !----------------------------------------------------------------------------
5813 subroutine taugb5
5814 !----------------------------------------------------------------------------
5815 !
5816 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
5817 ! (high key - o3,co2)
5818 !----------------------------------------------------------------------------
5820 ! ------- Modules -------
5822 use parrrtm, only : ng5, ngs4
5823 use rrlw_ref, only : chi_mls
5824 use rrlw_kg05, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5825 ka_mo3, selfref, forref, ccl4
5827 ! ------- Declarations -------
5829 ! Local
5830 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5831 integer(kind=im) :: js, js1, jmo3, jpl
5832 real(kind=rb) :: speccomb, specparm, specmult, fs
5833 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5834 real(kind=rb) :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
5835 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5836 real(kind=rb) :: p, p4, fk0, fk1, fk2
5837 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5838 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5839 real(kind=rb) :: tauself, taufor, o3m1, o3m2, abso3
5840 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a
5841 real(kind=rb) :: tau_major, tau_major1
5844 ! Minor gas mapping level :
5845 ! lower - o3, p = 317.34 mbar, t = 240.77 k
5846 ! lower - ccl4
5848 ! Calculate reference ratio to be used in calculation of Planck
5849 ! fraction in lower/upper atmosphere.
5851 ! P = 473.420 mb
5852 refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
5854 ! P = 0.2369 mb
5855 refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
5857 ! P = 317.3480
5858 refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
5860 ! Compute the optical depth by interpolating in ln(pressure) and
5861 ! temperature, and appropriate species. Below laytrop, the
5862 ! water vapor self-continuum and foreign continuum is
5863 ! interpolated (in temperature) separately.
5865 ! Lower atmosphere loop
5866 do lay = 1, laytrop
5868 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5869 specparm = colh2o(lay)/speccomb
5870 if (specparm .ge. oneminus) specparm = oneminus
5871 specmult = 8._rb*(specparm)
5872 js = 1 + int(specmult)
5873 fs = mod(specmult,1.0_rb)
5875 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5876 specparm1 = colh2o(lay)/speccomb1
5877 if (specparm1 .ge. oneminus) specparm1 = oneminus
5878 specmult1 = 8._rb*(specparm1)
5879 js1 = 1 + int(specmult1)
5880 fs1 = mod(specmult1,1.0_rb)
5882 speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay)
5883 specparm_mo3 = colh2o(lay)/speccomb_mo3
5884 if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus
5885 specmult_mo3 = 8._rb*specparm_mo3
5886 jmo3 = 1 + int(specmult_mo3)
5887 fmo3 = mod(specmult_mo3,1.0_rb)
5889 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5890 specparm_planck = colh2o(lay)/speccomb_planck
5891 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5892 specmult_planck = 8._rb*specparm_planck
5893 jpl= 1 + int(specmult_planck)
5894 fpl = mod(specmult_planck,1.0_rb)
5896 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js
5897 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1
5898 inds = indself(lay)
5899 indf = indfor(lay)
5900 indm = indminor(lay)
5902 if (specparm .lt. 0.125_rb) then
5903 p = fs - 1
5904 p4 = p**4
5905 fk0 = p4
5906 fk1 = 1 - p - 2.0_rb*p4
5907 fk2 = p + p4
5908 fac000 = fk0*fac00(lay)
5909 fac100 = fk1*fac00(lay)
5910 fac200 = fk2*fac00(lay)
5911 fac010 = fk0*fac10(lay)
5912 fac110 = fk1*fac10(lay)
5913 fac210 = fk2*fac10(lay)
5914 else if (specparm .gt. 0.875_rb) then
5915 p = -fs
5916 p4 = p**4
5917 fk0 = p4
5918 fk1 = 1 - p - 2.0_rb*p4
5919 fk2 = p + p4
5920 fac000 = fk0*fac00(lay)
5921 fac100 = fk1*fac00(lay)
5922 fac200 = fk2*fac00(lay)
5923 fac010 = fk0*fac10(lay)
5924 fac110 = fk1*fac10(lay)
5925 fac210 = fk2*fac10(lay)
5926 else
5927 fac000 = (1._rb - fs) * fac00(lay)
5928 fac010 = (1._rb - fs) * fac10(lay)
5929 fac100 = fs * fac00(lay)
5930 fac110 = fs * fac10(lay)
5931 endif
5933 if (specparm1 .lt. 0.125_rb) then
5934 p = fs1 - 1
5935 p4 = p**4
5936 fk0 = p4
5937 fk1 = 1 - p - 2.0_rb*p4
5938 fk2 = p + p4
5939 fac001 = fk0*fac01(lay)
5940 fac101 = fk1*fac01(lay)
5941 fac201 = fk2*fac01(lay)
5942 fac011 = fk0*fac11(lay)
5943 fac111 = fk1*fac11(lay)
5944 fac211 = fk2*fac11(lay)
5945 else if (specparm1 .gt. 0.875_rb) then
5946 p = -fs1
5947 p4 = p**4
5948 fk0 = p4
5949 fk1 = 1 - p - 2.0_rb*p4
5950 fk2 = p + p4
5951 fac001 = fk0*fac01(lay)
5952 fac101 = fk1*fac01(lay)
5953 fac201 = fk2*fac01(lay)
5954 fac011 = fk0*fac11(lay)
5955 fac111 = fk1*fac11(lay)
5956 fac211 = fk2*fac11(lay)
5957 else
5958 fac001 = (1._rb - fs1) * fac01(lay)
5959 fac011 = (1._rb - fs1) * fac11(lay)
5960 fac101 = fs1 * fac01(lay)
5961 fac111 = fs1 * fac11(lay)
5962 endif
5964 do ig = 1, ng5
5965 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5966 (selfref(inds+1,ig) - selfref(inds,ig)))
5967 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5968 (forref(indf+1,ig) - forref(indf,ig)))
5969 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
5970 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
5971 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
5972 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
5973 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
5975 if (specparm .lt. 0.125_rb) then
5976 tau_major = speccomb * &
5977 (fac000 * absa(ind0,ig) + &
5978 fac100 * absa(ind0+1,ig) + &
5979 fac200 * absa(ind0+2,ig) + &
5980 fac010 * absa(ind0+9,ig) + &
5981 fac110 * absa(ind0+10,ig) + &
5982 fac210 * absa(ind0+11,ig))
5983 else if (specparm .gt. 0.875_rb) then
5984 tau_major = speccomb * &
5985 (fac200 * absa(ind0-1,ig) + &
5986 fac100 * absa(ind0,ig) + &
5987 fac000 * absa(ind0+1,ig) + &
5988 fac210 * absa(ind0+8,ig) + &
5989 fac110 * absa(ind0+9,ig) + &
5990 fac010 * absa(ind0+10,ig))
5991 else
5992 tau_major = speccomb * &
5993 (fac000 * absa(ind0,ig) + &
5994 fac100 * absa(ind0+1,ig) + &
5995 fac010 * absa(ind0+9,ig) + &
5996 fac110 * absa(ind0+10,ig))
5997 endif
5999 if (specparm1 .lt. 0.125_rb) then
6000 tau_major1 = speccomb1 * &
6001 (fac001 * absa(ind1,ig) + &
6002 fac101 * absa(ind1+1,ig) + &
6003 fac201 * absa(ind1+2,ig) + &
6004 fac011 * absa(ind1+9,ig) + &
6005 fac111 * absa(ind1+10,ig) + &
6006 fac211 * absa(ind1+11,ig))
6007 else if (specparm1 .gt. 0.875_rb) then
6008 tau_major1 = speccomb1 * &
6009 (fac201 * absa(ind1-1,ig) + &
6010 fac101 * absa(ind1,ig) + &
6011 fac001 * absa(ind1+1,ig) + &
6012 fac211 * absa(ind1+8,ig) + &
6013 fac111 * absa(ind1+9,ig) + &
6014 fac011 * absa(ind1+10,ig))
6015 else
6016 tau_major1 = speccomb1 * &
6017 (fac001 * absa(ind1,ig) + &
6018 fac101 * absa(ind1+1,ig) + &
6019 fac011 * absa(ind1+9,ig) + &
6020 fac111 * absa(ind1+10,ig))
6021 endif
6023 taug(lay,ngs4+ig) = tau_major + tau_major1 &
6024 + tauself + taufor &
6025 + abso3*colo3(lay) &
6026 + wx(1,lay) * ccl4(ig)
6027 fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
6028 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6029 enddo
6030 enddo
6032 ! Upper atmosphere loop
6033 do lay = laytrop+1, nlayers
6035 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
6036 specparm = colo3(lay)/speccomb
6037 if (specparm .ge. oneminus) specparm = oneminus
6038 specmult = 4._rb*(specparm)
6039 js = 1 + int(specmult)
6040 fs = mod(specmult,1.0_rb)
6042 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
6043 specparm1 = colo3(lay)/speccomb1
6044 if (specparm1 .ge. oneminus) specparm1 = oneminus
6045 specmult1 = 4._rb*(specparm1)
6046 js1 = 1 + int(specmult1)
6047 fs1 = mod(specmult1,1.0_rb)
6049 fac000 = (1._rb - fs) * fac00(lay)
6050 fac010 = (1._rb - fs) * fac10(lay)
6051 fac100 = fs * fac00(lay)
6052 fac110 = fs * fac10(lay)
6053 fac001 = (1._rb - fs1) * fac01(lay)
6054 fac011 = (1._rb - fs1) * fac11(lay)
6055 fac101 = fs1 * fac01(lay)
6056 fac111 = fs1 * fac11(lay)
6058 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
6059 specparm_planck = colo3(lay)/speccomb_planck
6060 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6061 specmult_planck = 4._rb*specparm_planck
6062 jpl= 1 + int(specmult_planck)
6063 fpl = mod(specmult_planck,1.0_rb)
6065 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js
6066 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1
6068 do ig = 1, ng5
6069 taug(lay,ngs4+ig) = speccomb * &
6070 (fac000 * absb(ind0,ig) + &
6071 fac100 * absb(ind0+1,ig) + &
6072 fac010 * absb(ind0+5,ig) + &
6073 fac110 * absb(ind0+6,ig)) &
6074 + speccomb1 * &
6075 (fac001 * absb(ind1,ig) + &
6076 fac101 * absb(ind1+1,ig) + &
6077 fac011 * absb(ind1+5,ig) + &
6078 fac111 * absb(ind1+6,ig)) &
6079 + wx(1,lay) * ccl4(ig)
6080 fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * &
6081 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
6082 enddo
6083 enddo
6085 end subroutine taugb5
6087 !----------------------------------------------------------------------------
6088 subroutine taugb6
6089 !----------------------------------------------------------------------------
6090 !
6091 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
6092 ! (high key - nothing; high minor - cfc11, cfc12)
6093 !----------------------------------------------------------------------------
6095 ! ------- Modules -------
6097 use parrrtm, only : ngs5
6098 ! use parrrtm, only : ng6, ngs5
6099 use rrlw_ref, only : chi_mls
6100 use rrlw_kg06
6101 ! use rrlw_kg06, only : fracrefa, absa, ka, ka_mco2, &
6102 ! selfref, forref, cfc11adj, cfc12
6104 ! ------- Declarations -------
6106 ! Local
6107 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6108 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6109 real(kind=rb) :: tauself, taufor, absco2
6112 ! Minor gas mapping level:
6113 ! lower - co2, p = 706.2720 mb, t = 294.2 k
6114 ! upper - cfc11, cfc12
6116 ! Compute the optical depth by interpolating in ln(pressure) and
6117 ! temperature. The water vapor self-continuum and foreign continuum
6118 ! is interpolated (in temperature) separately.
6120 ! Lower atmosphere loop
6121 do lay = 1, laytrop
6123 ! In atmospheres where the amount of CO2 is too great to be considered
6124 ! a minor species, adjust the column amount of CO2 by an empirical factor
6125 ! to obtain the proper contribution.
6126 chi_co2 = colco2(lay)/(coldry(lay))
6127 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6128 if (ratco2 .gt. 3.0_rb) then
6129 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb
6130 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6131 else
6132 adjcolco2 = colco2(lay)
6133 endif
6135 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1
6136 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1
6137 inds = indself(lay)
6138 indf = indfor(lay)
6139 indm = indminor(lay)
6141 do ig = 1, ng6
6142 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6143 (selfref(inds+1,ig) - selfref(inds,ig)))
6144 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6145 (forref(indf+1,ig) - forref(indf,ig)))
6146 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
6147 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6148 taug(lay,ngs5+ig) = colh2o(lay) * &
6149 (fac00(lay) * absa(ind0,ig) + &
6150 fac10(lay) * absa(ind0+1,ig) + &
6151 fac01(lay) * absa(ind1,ig) + &
6152 fac11(lay) * absa(ind1+1,ig)) &
6153 + tauself + taufor &
6154 + adjcolco2 * absco2 &
6155 + wx(2,lay) * cfc11adj(ig) &
6156 + wx(3,lay) * cfc12(ig)
6157 fracs(lay,ngs5+ig) = fracrefa(ig)
6158 enddo
6159 enddo
6161 ! Upper atmosphere loop
6162 ! Nothing important goes on above laytrop in this band.
6163 do lay = laytrop+1, nlayers
6165 do ig = 1, ng6
6166 taug(lay,ngs5+ig) = 0.0_rb &
6167 + wx(2,lay) * cfc11adj(ig) &
6168 + wx(3,lay) * cfc12(ig)
6169 fracs(lay,ngs5+ig) = fracrefa(ig)
6170 enddo
6171 enddo
6173 end subroutine taugb6
6175 !----------------------------------------------------------------------------
6176 subroutine taugb7
6177 !----------------------------------------------------------------------------
6178 !
6179 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
6180 ! (high key - o3; high minor - co2)
6181 !----------------------------------------------------------------------------
6183 ! ------- Modules -------
6185 use parrrtm, only : ng7, ngs6
6186 use rrlw_ref, only : chi_mls
6187 use rrlw_kg07, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6188 ka_mco2, kb_mco2, selfref, forref
6190 ! ------- Declarations -------
6192 ! Local
6193 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6194 integer(kind=im) :: js, js1, jmco2, jpl
6195 real(kind=rb) :: speccomb, specparm, specmult, fs
6196 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6197 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
6198 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6199 real(kind=rb) :: p, p4, fk0, fk1, fk2
6200 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6201 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6202 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
6203 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6204 real(kind=rb) :: refrat_planck_a, refrat_m_a
6205 real(kind=rb) :: tau_major, tau_major1
6208 ! Minor gas mapping level :
6209 ! lower - co2, p = 706.2620 mbar, t= 278.94 k
6210 ! upper - co2, p = 12.9350 mbar, t = 234.01 k
6212 ! Calculate reference ratio to be used in calculation of Planck
6213 ! fraction in lower atmosphere.
6215 ! P = 706.2620 mb
6216 refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
6218 ! P = 706.2720 mb
6219 refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
6221 ! Compute the optical depth by interpolating in ln(pressure),
6222 ! temperature, and appropriate species. Below laytrop, the water
6223 ! vapor self-continuum and foreign continuum is interpolated
6224 ! (in temperature) separately.
6226 ! Lower atmosphere loop
6227 do lay = 1, laytrop
6229 speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay)
6230 specparm = colh2o(lay)/speccomb
6231 if (specparm .ge. oneminus) specparm = oneminus
6232 specmult = 8._rb*(specparm)
6233 js = 1 + int(specmult)
6234 fs = mod(specmult,1.0_rb)
6236 speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay)
6237 specparm1 = colh2o(lay)/speccomb1
6238 if (specparm1 .ge. oneminus) specparm1 = oneminus
6239 specmult1 = 8._rb*(specparm1)
6240 js1 = 1 + int(specmult1)
6241 fs1 = mod(specmult1,1.0_rb)
6243 speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay)
6244 specparm_mco2 = colh2o(lay)/speccomb_mco2
6245 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
6246 specmult_mco2 = 8._rb*specparm_mco2
6248 jmco2 = 1 + int(specmult_mco2)
6249 fmco2 = mod(specmult_mco2,1.0_rb)
6251 ! In atmospheres where the amount of CO2 is too great to be considered
6252 ! a minor species, adjust the column amount of CO2 by an empirical factor
6253 ! to obtain the proper contribution.
6254 chi_co2 = colco2(lay)/(coldry(lay))
6255 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6256 if (ratco2 .gt. 3.0_rb) then
6257 adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb
6258 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6259 else
6260 adjcolco2 = colco2(lay)
6261 endif
6263 speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay)
6264 specparm_planck = colh2o(lay)/speccomb_planck
6265 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6266 specmult_planck = 8._rb*specparm_planck
6267 jpl= 1 + int(specmult_planck)
6268 fpl = mod(specmult_planck,1.0_rb)
6270 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js
6271 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1
6272 inds = indself(lay)
6273 indf = indfor(lay)
6274 indm = indminor(lay)
6276 if (specparm .lt. 0.125_rb) then
6277 p = fs - 1
6278 p4 = p**4
6279 fk0 = p4
6280 fk1 = 1 - p - 2.0_rb*p4
6281 fk2 = p + p4
6282 fac000 = fk0*fac00(lay)
6283 fac100 = fk1*fac00(lay)
6284 fac200 = fk2*fac00(lay)
6285 fac010 = fk0*fac10(lay)
6286 fac110 = fk1*fac10(lay)
6287 fac210 = fk2*fac10(lay)
6288 else if (specparm .gt. 0.875_rb) then
6289 p = -fs
6290 p4 = p**4
6291 fk0 = p4
6292 fk1 = 1 - p - 2.0_rb*p4
6293 fk2 = p + p4
6294 fac000 = fk0*fac00(lay)
6295 fac100 = fk1*fac00(lay)
6296 fac200 = fk2*fac00(lay)
6297 fac010 = fk0*fac10(lay)
6298 fac110 = fk1*fac10(lay)
6299 fac210 = fk2*fac10(lay)
6300 else
6301 fac000 = (1._rb - fs) * fac00(lay)
6302 fac010 = (1._rb - fs) * fac10(lay)
6303 fac100 = fs * fac00(lay)
6304 fac110 = fs * fac10(lay)
6305 endif
6306 if (specparm1 .lt. 0.125_rb) then
6307 p = fs1 - 1
6308 p4 = p**4
6309 fk0 = p4
6310 fk1 = 1 - p - 2.0_rb*p4
6311 fk2 = p + p4
6312 fac001 = fk0*fac01(lay)
6313 fac101 = fk1*fac01(lay)
6314 fac201 = fk2*fac01(lay)
6315 fac011 = fk0*fac11(lay)
6316 fac111 = fk1*fac11(lay)
6317 fac211 = fk2*fac11(lay)
6318 else if (specparm1 .gt. 0.875_rb) then
6319 p = -fs1
6320 p4 = p**4
6321 fk0 = p4
6322 fk1 = 1 - p - 2.0_rb*p4
6323 fk2 = p + p4
6324 fac001 = fk0*fac01(lay)
6325 fac101 = fk1*fac01(lay)
6326 fac201 = fk2*fac01(lay)
6327 fac011 = fk0*fac11(lay)
6328 fac111 = fk1*fac11(lay)
6329 fac211 = fk2*fac11(lay)
6330 else
6331 fac001 = (1._rb - fs1) * fac01(lay)
6332 fac011 = (1._rb - fs1) * fac11(lay)
6333 fac101 = fs1 * fac01(lay)
6334 fac111 = fs1 * fac11(lay)
6335 endif
6337 do ig = 1, ng7
6338 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6339 (selfref(inds+1,ig) - selfref(inds,ig)))
6340 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6341 (forref(indf+1,ig) - forref(indf,ig)))
6342 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
6343 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6344 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
6345 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6346 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6348 if (specparm .lt. 0.125_rb) then
6349 tau_major = speccomb * &
6350 (fac000 * absa(ind0,ig) + &
6351 fac100 * absa(ind0+1,ig) + &
6352 fac200 * absa(ind0+2,ig) + &
6353 fac010 * absa(ind0+9,ig) + &
6354 fac110 * absa(ind0+10,ig) + &
6355 fac210 * absa(ind0+11,ig))
6356 else if (specparm .gt. 0.875_rb) then
6357 tau_major = speccomb * &
6358 (fac200 * absa(ind0-1,ig) + &
6359 fac100 * absa(ind0,ig) + &
6360 fac000 * absa(ind0+1,ig) + &
6361 fac210 * absa(ind0+8,ig) + &
6362 fac110 * absa(ind0+9,ig) + &
6363 fac010 * absa(ind0+10,ig))
6364 else
6365 tau_major = speccomb * &
6366 (fac000 * absa(ind0,ig) + &
6367 fac100 * absa(ind0+1,ig) + &
6368 fac010 * absa(ind0+9,ig) + &
6369 fac110 * absa(ind0+10,ig))
6370 endif
6372 if (specparm1 .lt. 0.125_rb) then
6373 tau_major1 = speccomb1 * &
6374 (fac001 * absa(ind1,ig) + &
6375 fac101 * absa(ind1+1,ig) + &
6376 fac201 * absa(ind1+2,ig) + &
6377 fac011 * absa(ind1+9,ig) + &
6378 fac111 * absa(ind1+10,ig) + &
6379 fac211 * absa(ind1+11,ig))
6380 else if (specparm1 .gt. 0.875_rb) then
6381 tau_major1 = speccomb1 * &
6382 (fac201 * absa(ind1-1,ig) + &
6383 fac101 * absa(ind1,ig) + &
6384 fac001 * absa(ind1+1,ig) + &
6385 fac211 * absa(ind1+8,ig) + &
6386 fac111 * absa(ind1+9,ig) + &
6387 fac011 * absa(ind1+10,ig))
6388 else
6389 tau_major1 = speccomb1 * &
6390 (fac001 * absa(ind1,ig) + &
6391 fac101 * absa(ind1+1,ig) + &
6392 fac011 * absa(ind1+9,ig) + &
6393 fac111 * absa(ind1+10,ig))
6394 endif
6396 taug(lay,ngs6+ig) = tau_major + tau_major1 &
6397 + tauself + taufor &
6398 + adjcolco2*absco2
6399 fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
6400 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6401 enddo
6402 enddo
6404 ! Upper atmosphere loop
6405 do lay = laytrop+1, nlayers
6407 ! In atmospheres where the amount of CO2 is too great to be considered
6408 ! a minor species, adjust the column amount of CO2 by an empirical factor
6409 ! to obtain the proper contribution.
6410 chi_co2 = colco2(lay)/(coldry(lay))
6411 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6412 if (ratco2 .gt. 3.0_rb) then
6413 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb
6414 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6415 else
6416 adjcolco2 = colco2(lay)
6417 endif
6419 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1
6420 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1
6421 indm = indminor(lay)
6423 do ig = 1, ng7
6424 absco2 = kb_mco2(indm,ig) + minorfrac(lay) * &
6425 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))
6426 taug(lay,ngs6+ig) = colo3(lay) * &
6427 (fac00(lay) * absb(ind0,ig) + &
6428 fac10(lay) * absb(ind0+1,ig) + &
6429 fac01(lay) * absb(ind1,ig) + &
6430 fac11(lay) * absb(ind1+1,ig)) &
6431 + adjcolco2 * absco2
6432 fracs(lay,ngs6+ig) = fracrefb(ig)
6433 enddo
6435 ! Empirical modification to code to improve stratospheric cooling rates
6436 ! for o3. Revised to apply weighting for g-point reduction in this band.
6438 taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_rb
6439 taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_rb
6440 taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_rb
6441 taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_rb
6442 taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_rb
6443 taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_rb
6445 enddo
6447 end subroutine taugb7
6449 !----------------------------------------------------------------------------
6450 subroutine taugb8
6451 !----------------------------------------------------------------------------
6452 !
6453 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
6454 ! (high key - o3; high minor - co2, n2o)
6455 !----------------------------------------------------------------------------
6457 ! ------- Modules -------
6459 use parrrtm, only : ng8, ngs7
6460 use rrlw_ref, only : chi_mls
6461 use rrlw_kg08, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6462 ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o, &
6463 selfref, forref, cfc12, cfc22adj
6465 ! ------- Declarations -------
6467 ! Local
6468 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6469 real(kind=rb) :: tauself, taufor, absco2, abso3, absn2o
6470 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6473 ! Minor gas mapping level:
6474 ! lower - co2, p = 1053.63 mb, t = 294.2 k
6475 ! lower - o3, p = 317.348 mb, t = 240.77 k
6476 ! lower - n2o, p = 706.2720 mb, t= 278.94 k
6477 ! lower - cfc12,cfc11
6478 ! upper - co2, p = 35.1632 mb, t = 223.28 k
6479 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k
6481 ! Compute the optical depth by interpolating in ln(pressure) and
6482 ! temperature, and appropriate species. Below laytrop, the water vapor
6483 ! self-continuum and foreign continuum is interpolated (in temperature)
6484 ! separately.
6486 ! Lower atmosphere loop
6487 do lay = 1, laytrop
6489 ! In atmospheres where the amount of CO2 is too great to be considered
6490 ! a minor species, adjust the column amount of CO2 by an empirical factor
6491 ! to obtain the proper contribution.
6492 chi_co2 = colco2(lay)/(coldry(lay))
6493 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6494 if (ratco2 .gt. 3.0_rb) then
6495 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6496 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6497 else
6498 adjcolco2 = colco2(lay)
6499 endif
6501 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
6502 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
6503 inds = indself(lay)
6504 indf = indfor(lay)
6505 indm = indminor(lay)
6507 do ig = 1, ng8
6508 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6509 (selfref(inds+1,ig) - selfref(inds,ig)))
6510 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6511 (forref(indf+1,ig) - forref(indf,ig)))
6512 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
6513 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6514 abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * &
6515 (ka_mo3(indm+1,ig) - ka_mo3(indm,ig)))
6516 absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * &
6517 (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig)))
6518 taug(lay,ngs7+ig) = colh2o(lay) * &
6519 (fac00(lay) * absa(ind0,ig) + &
6520 fac10(lay) * absa(ind0+1,ig) + &
6521 fac01(lay) * absa(ind1,ig) + &
6522 fac11(lay) * absa(ind1+1,ig)) &
6523 + tauself + taufor &
6524 + adjcolco2*absco2 &
6525 + colo3(lay) * abso3 &
6526 + coln2o(lay) * absn2o &
6527 + wx(3,lay) * cfc12(ig) &
6528 + wx(4,lay) * cfc22adj(ig)
6529 fracs(lay,ngs7+ig) = fracrefa(ig)
6530 enddo
6531 enddo
6533 ! Upper atmosphere loop
6534 do lay = laytrop+1, nlayers
6536 ! In atmospheres where the amount of CO2 is too great to be considered
6537 ! a minor species, adjust the column amount of CO2 by an empirical factor
6538 ! to obtain the proper contribution.
6539 chi_co2 = colco2(lay)/coldry(lay)
6540 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6541 if (ratco2 .gt. 3.0_rb) then
6542 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6543 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb
6544 else
6545 adjcolco2 = colco2(lay)
6546 endif
6548 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1
6549 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1
6550 indm = indminor(lay)
6552 do ig = 1, ng8
6553 absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * &
6554 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)))
6555 absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * &
6556 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)))
6557 taug(lay,ngs7+ig) = colo3(lay) * &
6558 (fac00(lay) * absb(ind0,ig) + &
6559 fac10(lay) * absb(ind0+1,ig) + &
6560 fac01(lay) * absb(ind1,ig) + &
6561 fac11(lay) * absb(ind1+1,ig)) &
6562 + adjcolco2*absco2 &
6563 + coln2o(lay)*absn2o &
6564 + wx(3,lay) * cfc12(ig) &
6565 + wx(4,lay) * cfc22adj(ig)
6566 fracs(lay,ngs7+ig) = fracrefb(ig)
6567 enddo
6568 enddo
6570 end subroutine taugb8
6572 !----------------------------------------------------------------------------
6573 subroutine taugb9
6574 !----------------------------------------------------------------------------
6575 !
6576 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
6577 ! (high key - ch4; high minor - n2o)
6578 !----------------------------------------------------------------------------
6580 ! ------- Modules -------
6582 use parrrtm, only : ng9, ngs8
6583 use rrlw_ref, only : chi_mls
6584 use rrlw_kg09, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6585 ka_mn2o, kb_mn2o, selfref, forref
6587 ! ------- Declarations -------
6589 ! Local
6590 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6591 integer(kind=im) :: js, js1, jmn2o, jpl
6592 real(kind=rb) :: speccomb, specparm, specmult, fs
6593 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6594 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
6595 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6596 real(kind=rb) :: p, p4, fk0, fk1, fk2
6597 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6598 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6599 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
6600 real(kind=rb) :: chi_n2o, ratn2o, adjfac, adjcoln2o
6601 real(kind=rb) :: refrat_planck_a, refrat_m_a
6602 real(kind=rb) :: tau_major, tau_major1
6605 ! Minor gas mapping level :
6606 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
6607 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
6609 ! Calculate reference ratio to be used in calculation of Planck
6610 ! fraction in lower/upper atmosphere.
6612 ! P = 212 mb
6613 refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
6615 ! P = 706.272 mb
6616 refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
6618 ! Compute the optical depth by interpolating in ln(pressure),
6619 ! temperature, and appropriate species. Below laytrop, the water
6620 ! vapor self-continuum and foreign continuum is interpolated
6621 ! (in temperature) separately.
6623 ! Lower atmosphere loop
6624 do lay = 1, laytrop
6626 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
6627 specparm = colh2o(lay)/speccomb
6628 if (specparm .ge. oneminus) specparm = oneminus
6629 specmult = 8._rb*(specparm)
6630 js = 1 + int(specmult)
6631 fs = mod(specmult,1.0_rb)
6633 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
6634 specparm1 = colh2o(lay)/speccomb1
6635 if (specparm1 .ge. oneminus) specparm1 = oneminus
6636 specmult1 = 8._rb*(specparm1)
6637 js1 = 1 + int(specmult1)
6638 fs1 = mod(specmult1,1.0_rb)
6640 speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay)
6641 specparm_mn2o = colh2o(lay)/speccomb_mn2o
6642 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
6643 specmult_mn2o = 8._rb*specparm_mn2o
6644 jmn2o = 1 + int(specmult_mn2o)
6645 fmn2o = mod(specmult_mn2o,1.0_rb)
6647 ! In atmospheres where the amount of N2O is too great to be considered
6648 ! a minor species, adjust the column amount of N2O by an empirical factor
6649 ! to obtain the proper contribution.
6650 chi_n2o = coln2o(lay)/(coldry(lay))
6651 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6652 if (ratn2o .gt. 1.5_rb) then
6653 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6654 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6655 else
6656 adjcoln2o = coln2o(lay)
6657 endif
6659 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
6660 specparm_planck = colh2o(lay)/speccomb_planck
6661 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6662 specmult_planck = 8._rb*specparm_planck
6663 jpl= 1 + int(specmult_planck)
6664 fpl = mod(specmult_planck,1.0_rb)
6666 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js
6667 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1
6668 inds = indself(lay)
6669 indf = indfor(lay)
6670 indm = indminor(lay)
6672 if (specparm .lt. 0.125_rb) then
6673 p = fs - 1
6674 p4 = p**4
6675 fk0 = p4
6676 fk1 = 1 - p - 2.0_rb*p4
6677 fk2 = p + p4
6678 fac000 = fk0*fac00(lay)
6679 fac100 = fk1*fac00(lay)
6680 fac200 = fk2*fac00(lay)
6681 fac010 = fk0*fac10(lay)
6682 fac110 = fk1*fac10(lay)
6683 fac210 = fk2*fac10(lay)
6684 else if (specparm .gt. 0.875_rb) then
6685 p = -fs
6686 p4 = p**4
6687 fk0 = p4
6688 fk1 = 1 - p - 2.0_rb*p4
6689 fk2 = p + p4
6690 fac000 = fk0*fac00(lay)
6691 fac100 = fk1*fac00(lay)
6692 fac200 = fk2*fac00(lay)
6693 fac010 = fk0*fac10(lay)
6694 fac110 = fk1*fac10(lay)
6695 fac210 = fk2*fac10(lay)
6696 else
6697 fac000 = (1._rb - fs) * fac00(lay)
6698 fac010 = (1._rb - fs) * fac10(lay)
6699 fac100 = fs * fac00(lay)
6700 fac110 = fs * fac10(lay)
6701 endif
6703 if (specparm1 .lt. 0.125_rb) then
6704 p = fs1 - 1
6705 p4 = p**4
6706 fk0 = p4
6707 fk1 = 1 - p - 2.0_rb*p4
6708 fk2 = p + p4
6709 fac001 = fk0*fac01(lay)
6710 fac101 = fk1*fac01(lay)
6711 fac201 = fk2*fac01(lay)
6712 fac011 = fk0*fac11(lay)
6713 fac111 = fk1*fac11(lay)
6714 fac211 = fk2*fac11(lay)
6715 else if (specparm1 .gt. 0.875_rb) then
6716 p = -fs1
6717 p4 = p**4
6718 fk0 = p4
6719 fk1 = 1 - p - 2.0_rb*p4
6720 fk2 = p + p4
6721 fac001 = fk0*fac01(lay)
6722 fac101 = fk1*fac01(lay)
6723 fac201 = fk2*fac01(lay)
6724 fac011 = fk0*fac11(lay)
6725 fac111 = fk1*fac11(lay)
6726 fac211 = fk2*fac11(lay)
6727 else
6728 fac001 = (1._rb - fs1) * fac01(lay)
6729 fac011 = (1._rb - fs1) * fac11(lay)
6730 fac101 = fs1 * fac01(lay)
6731 fac111 = fs1 * fac11(lay)
6732 endif
6734 do ig = 1, ng9
6735 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6736 (selfref(inds+1,ig) - selfref(inds,ig)))
6737 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6738 (forref(indf+1,ig) - forref(indf,ig)))
6739 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
6740 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6741 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
6742 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6743 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6745 if (specparm .lt. 0.125_rb) then
6746 tau_major = speccomb * &
6747 (fac000 * absa(ind0,ig) + &
6748 fac100 * absa(ind0+1,ig) + &
6749 fac200 * absa(ind0+2,ig) + &
6750 fac010 * absa(ind0+9,ig) + &
6751 fac110 * absa(ind0+10,ig) + &
6752 fac210 * absa(ind0+11,ig))
6753 else if (specparm .gt. 0.875_rb) then
6754 tau_major = speccomb * &
6755 (fac200 * absa(ind0-1,ig) + &
6756 fac100 * absa(ind0,ig) + &
6757 fac000 * absa(ind0+1,ig) + &
6758 fac210 * absa(ind0+8,ig) + &
6759 fac110 * absa(ind0+9,ig) + &
6760 fac010 * absa(ind0+10,ig))
6761 else
6762 tau_major = speccomb * &
6763 (fac000 * absa(ind0,ig) + &
6764 fac100 * absa(ind0+1,ig) + &
6765 fac010 * absa(ind0+9,ig) + &
6766 fac110 * absa(ind0+10,ig))
6767 endif
6769 if (specparm1 .lt. 0.125_rb) then
6770 tau_major1 = speccomb1 * &
6771 (fac001 * absa(ind1,ig) + &
6772 fac101 * absa(ind1+1,ig) + &
6773 fac201 * absa(ind1+2,ig) + &
6774 fac011 * absa(ind1+9,ig) + &
6775 fac111 * absa(ind1+10,ig) + &
6776 fac211 * absa(ind1+11,ig))
6777 else if (specparm1 .gt. 0.875_rb) then
6778 tau_major1 = speccomb1 * &
6779 (fac201 * absa(ind1-1,ig) + &
6780 fac101 * absa(ind1,ig) + &
6781 fac001 * absa(ind1+1,ig) + &
6782 fac211 * absa(ind1+8,ig) + &
6783 fac111 * absa(ind1+9,ig) + &
6784 fac011 * absa(ind1+10,ig))
6785 else
6786 tau_major1 = speccomb1 * &
6787 (fac001 * absa(ind1,ig) + &
6788 fac101 * absa(ind1+1,ig) + &
6789 fac011 * absa(ind1+9,ig) + &
6790 fac111 * absa(ind1+10,ig))
6791 endif
6793 taug(lay,ngs8+ig) = tau_major + tau_major1 &
6794 + tauself + taufor &
6795 + adjcoln2o*absn2o
6796 fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
6797 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6798 enddo
6799 enddo
6801 ! Upper atmosphere loop
6802 do lay = laytrop+1, nlayers
6804 ! In atmospheres where the amount of N2O is too great to be considered
6805 ! a minor species, adjust the column amount of N2O by an empirical factor
6806 ! to obtain the proper contribution.
6807 chi_n2o = coln2o(lay)/(coldry(lay))
6808 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6809 if (ratn2o .gt. 1.5_rb) then
6810 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6811 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6812 else
6813 adjcoln2o = coln2o(lay)
6814 endif
6816 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1
6817 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1
6818 indm = indminor(lay)
6820 do ig = 1, ng9
6821 absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * &
6822 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))
6823 taug(lay,ngs8+ig) = colch4(lay) * &
6824 (fac00(lay) * absb(ind0,ig) + &
6825 fac10(lay) * absb(ind0+1,ig) + &
6826 fac01(lay) * absb(ind1,ig) + &
6827 fac11(lay) * absb(ind1+1,ig)) &
6828 + adjcoln2o*absn2o
6829 fracs(lay,ngs8+ig) = fracrefb(ig)
6830 enddo
6831 enddo
6833 end subroutine taugb9
6835 !----------------------------------------------------------------------------
6836 subroutine taugb10
6837 !----------------------------------------------------------------------------
6838 !
6839 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
6840 !----------------------------------------------------------------------------
6842 ! ------- Modules -------
6844 use parrrtm, only : ng10, ngs9
6845 use rrlw_kg10, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6846 selfref, forref
6848 ! ------- Declarations -------
6850 ! Local
6851 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6852 real(kind=rb) :: tauself, taufor
6855 ! Compute the optical depth by interpolating in ln(pressure) and
6856 ! temperature. Below laytrop, the water vapor self-continuum and
6857 ! foreign continuum is interpolated (in temperature) separately.
6859 ! Lower atmosphere loop
6860 do lay = 1, laytrop
6861 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1
6862 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1
6863 inds = indself(lay)
6864 indf = indfor(lay)
6866 do ig = 1, ng10
6867 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6868 (selfref(inds+1,ig) - selfref(inds,ig)))
6869 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6870 (forref(indf+1,ig) - forref(indf,ig)))
6871 taug(lay,ngs9+ig) = colh2o(lay) * &
6872 (fac00(lay) * absa(ind0,ig) + &
6873 fac10(lay) * absa(ind0+1,ig) + &
6874 fac01(lay) * absa(ind1,ig) + &
6875 fac11(lay) * absa(ind1+1,ig)) &
6876 + tauself + taufor
6877 fracs(lay,ngs9+ig) = fracrefa(ig)
6878 enddo
6879 enddo
6881 ! Upper atmosphere loop
6882 do lay = laytrop+1, nlayers
6883 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1
6884 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1
6885 indf = indfor(lay)
6887 do ig = 1, ng10
6888 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6889 (forref(indf+1,ig) - forref(indf,ig)))
6890 taug(lay,ngs9+ig) = colh2o(lay) * &
6891 (fac00(lay) * absb(ind0,ig) + &
6892 fac10(lay) * absb(ind0+1,ig) + &
6893 fac01(lay) * absb(ind1,ig) + &
6894 fac11(lay) * absb(ind1+1,ig)) &
6895 + taufor
6896 fracs(lay,ngs9+ig) = fracrefb(ig)
6897 enddo
6898 enddo
6900 end subroutine taugb10
6902 !----------------------------------------------------------------------------
6903 subroutine taugb11
6904 !----------------------------------------------------------------------------
6905 !
6906 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
6907 ! (high key - h2o; high minor - o2)
6908 !----------------------------------------------------------------------------
6910 ! ------- Modules -------
6912 use parrrtm, only : ng11, ngs10
6913 use rrlw_kg11, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6914 ka_mo2, kb_mo2, selfref, forref
6916 ! ------- Declarations -------
6918 ! Local
6919 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6920 real(kind=rb) :: scaleo2, tauself, taufor, tauo2
6923 ! Minor gas mapping level :
6924 ! lower - o2, p = 706.2720 mbar, t = 278.94 k
6925 ! upper - o2, p = 4.758820 mbarm t = 250.85 k
6927 ! Compute the optical depth by interpolating in ln(pressure) and
6928 ! temperature. Below laytrop, the water vapor self-continuum and
6929 ! foreign continuum is interpolated (in temperature) separately.
6931 ! Lower atmosphere loop
6932 do lay = 1, laytrop
6933 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1
6934 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1
6935 inds = indself(lay)
6936 indf = indfor(lay)
6937 indm = indminor(lay)
6938 scaleo2 = colo2(lay)*scaleminor(lay)
6939 do ig = 1, ng11
6940 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6941 (selfref(inds+1,ig) - selfref(inds,ig)))
6942 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6943 (forref(indf+1,ig) - forref(indf,ig)))
6944 tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * &
6945 (ka_mo2(indm+1,ig) - ka_mo2(indm,ig)))
6946 taug(lay,ngs10+ig) = colh2o(lay) * &
6947 (fac00(lay) * absa(ind0,ig) + &
6948 fac10(lay) * absa(ind0+1,ig) + &
6949 fac01(lay) * absa(ind1,ig) + &
6950 fac11(lay) * absa(ind1+1,ig)) &
6951 + tauself + taufor &
6952 + tauo2
6953 fracs(lay,ngs10+ig) = fracrefa(ig)
6954 enddo
6955 enddo
6957 ! Upper atmosphere loop
6958 do lay = laytrop+1, nlayers
6959 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1
6960 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1
6961 indf = indfor(lay)
6962 indm = indminor(lay)
6963 scaleo2 = colo2(lay)*scaleminor(lay)
6964 do ig = 1, ng11
6965 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6966 (forref(indf+1,ig) - forref(indf,ig)))
6967 tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * &
6968 (kb_mo2(indm+1,ig) - kb_mo2(indm,ig)))
6969 taug(lay,ngs10+ig) = colh2o(lay) * &
6970 (fac00(lay) * absb(ind0,ig) + &
6971 fac10(lay) * absb(ind0+1,ig) + &
6972 fac01(lay) * absb(ind1,ig) + &
6973 fac11(lay) * absb(ind1+1,ig)) &
6974 + taufor &
6975 + tauo2
6976 fracs(lay,ngs10+ig) = fracrefb(ig)
6977 enddo
6978 enddo
6980 end subroutine taugb11
6982 !----------------------------------------------------------------------------
6983 subroutine taugb12
6984 !----------------------------------------------------------------------------
6985 !
6986 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
6987 !----------------------------------------------------------------------------
6989 ! ------- Modules -------
6991 use parrrtm, only : ng12, ngs11
6992 use rrlw_ref, only : chi_mls
6993 use rrlw_kg12, only : fracrefa, absa, ka, &
6994 selfref, forref
6996 ! ------- Declarations -------
6998 ! Local
6999 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7000 integer(kind=im) :: js, js1, jpl
7001 real(kind=rb) :: speccomb, specparm, specmult, fs
7002 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7003 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7004 real(kind=rb) :: p, p4, fk0, fk1, fk2
7005 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7006 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7007 real(kind=rb) :: tauself, taufor
7008 real(kind=rb) :: refrat_planck_a
7009 real(kind=rb) :: tau_major, tau_major1
7012 ! Calculate reference ratio to be used in calculation of Planck
7013 ! fraction in lower/upper atmosphere.
7015 ! P = 174.164 mb
7016 refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
7018 ! Compute the optical depth by interpolating in ln(pressure),
7019 ! temperature, and appropriate species. Below laytrop, the water
7020 ! vapor self-continuum adn foreign continuum is interpolated
7021 ! (in temperature) separately.
7023 ! Lower atmosphere loop
7024 do lay = 1, laytrop
7026 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
7027 specparm = colh2o(lay)/speccomb
7028 if (specparm .ge. oneminus) specparm = oneminus
7029 specmult = 8._rb*(specparm)
7030 js = 1 + int(specmult)
7031 fs = mod(specmult,1.0_rb)
7033 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
7034 specparm1 = colh2o(lay)/speccomb1
7035 if (specparm1 .ge. oneminus) specparm1 = oneminus
7036 specmult1 = 8._rb*(specparm1)
7037 js1 = 1 + int(specmult1)
7038 fs1 = mod(specmult1,1.0_rb)
7040 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
7041 specparm_planck = colh2o(lay)/speccomb_planck
7042 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7043 specmult_planck = 8._rb*specparm_planck
7044 jpl= 1 + int(specmult_planck)
7045 fpl = mod(specmult_planck,1.0_rb)
7047 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js
7048 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1
7049 inds = indself(lay)
7050 indf = indfor(lay)
7052 if (specparm .lt. 0.125_rb) then
7053 p = fs - 1
7054 p4 = p**4
7055 fk0 = p4
7056 fk1 = 1 - p - 2.0_rb*p4
7057 fk2 = p + p4
7058 fac000 = fk0*fac00(lay)
7059 fac100 = fk1*fac00(lay)
7060 fac200 = fk2*fac00(lay)
7061 fac010 = fk0*fac10(lay)
7062 fac110 = fk1*fac10(lay)
7063 fac210 = fk2*fac10(lay)
7064 else if (specparm .gt. 0.875_rb) then
7065 p = -fs
7066 p4 = p**4
7067 fk0 = p4
7068 fk1 = 1 - p - 2.0_rb*p4
7069 fk2 = p + p4
7070 fac000 = fk0*fac00(lay)
7071 fac100 = fk1*fac00(lay)
7072 fac200 = fk2*fac00(lay)
7073 fac010 = fk0*fac10(lay)
7074 fac110 = fk1*fac10(lay)
7075 fac210 = fk2*fac10(lay)
7076 else
7077 fac000 = (1._rb - fs) * fac00(lay)
7078 fac010 = (1._rb - fs) * fac10(lay)
7079 fac100 = fs * fac00(lay)
7080 fac110 = fs * fac10(lay)
7081 endif
7083 if (specparm1 .lt. 0.125_rb) then
7084 p = fs1 - 1
7085 p4 = p**4
7086 fk0 = p4
7087 fk1 = 1 - p - 2.0_rb*p4
7088 fk2 = p + p4
7089 fac001 = fk0*fac01(lay)
7090 fac101 = fk1*fac01(lay)
7091 fac201 = fk2*fac01(lay)
7092 fac011 = fk0*fac11(lay)
7093 fac111 = fk1*fac11(lay)
7094 fac211 = fk2*fac11(lay)
7095 else if (specparm1 .gt. 0.875_rb) then
7096 p = -fs1
7097 p4 = p**4
7098 fk0 = p4
7099 fk1 = 1 - p - 2.0_rb*p4
7100 fk2 = p + p4
7101 fac001 = fk0*fac01(lay)
7102 fac101 = fk1*fac01(lay)
7103 fac201 = fk2*fac01(lay)
7104 fac011 = fk0*fac11(lay)
7105 fac111 = fk1*fac11(lay)
7106 fac211 = fk2*fac11(lay)
7107 else
7108 fac001 = (1._rb - fs1) * fac01(lay)
7109 fac011 = (1._rb - fs1) * fac11(lay)
7110 fac101 = fs1 * fac01(lay)
7111 fac111 = fs1 * fac11(lay)
7112 endif
7114 do ig = 1, ng12
7115 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7116 (selfref(inds+1,ig) - selfref(inds,ig)))
7117 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7118 (forref(indf+1,ig) - forref(indf,ig)))
7120 if (specparm .lt. 0.125_rb) then
7121 tau_major = speccomb * &
7122 (fac000 * absa(ind0,ig) + &
7123 fac100 * absa(ind0+1,ig) + &
7124 fac200 * absa(ind0+2,ig) + &
7125 fac010 * absa(ind0+9,ig) + &
7126 fac110 * absa(ind0+10,ig) + &
7127 fac210 * absa(ind0+11,ig))
7128 else if (specparm .gt. 0.875_rb) then
7129 tau_major = speccomb * &
7130 (fac200 * absa(ind0-1,ig) + &
7131 fac100 * absa(ind0,ig) + &
7132 fac000 * absa(ind0+1,ig) + &
7133 fac210 * absa(ind0+8,ig) + &
7134 fac110 * absa(ind0+9,ig) + &
7135 fac010 * absa(ind0+10,ig))
7136 else
7137 tau_major = speccomb * &
7138 (fac000 * absa(ind0,ig) + &
7139 fac100 * absa(ind0+1,ig) + &
7140 fac010 * absa(ind0+9,ig) + &
7141 fac110 * absa(ind0+10,ig))
7142 endif
7144 if (specparm1 .lt. 0.125_rb) then
7145 tau_major1 = speccomb1 * &
7146 (fac001 * absa(ind1,ig) + &
7147 fac101 * absa(ind1+1,ig) + &
7148 fac201 * absa(ind1+2,ig) + &
7149 fac011 * absa(ind1+9,ig) + &
7150 fac111 * absa(ind1+10,ig) + &
7151 fac211 * absa(ind1+11,ig))
7152 else if (specparm1 .gt. 0.875_rb) then
7153 tau_major1 = speccomb1 * &
7154 (fac201 * absa(ind1-1,ig) + &
7155 fac101 * absa(ind1,ig) + &
7156 fac001 * absa(ind1+1,ig) + &
7157 fac211 * absa(ind1+8,ig) + &
7158 fac111 * absa(ind1+9,ig) + &
7159 fac011 * absa(ind1+10,ig))
7160 else
7161 tau_major1 = speccomb1 * &
7162 (fac001 * absa(ind1,ig) + &
7163 fac101 * absa(ind1+1,ig) + &
7164 fac011 * absa(ind1+9,ig) + &
7165 fac111 * absa(ind1+10,ig))
7166 endif
7168 taug(lay,ngs11+ig) = tau_major + tau_major1 &
7169 + tauself + taufor
7170 fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
7171 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7172 enddo
7173 enddo
7175 ! Upper atmosphere loop
7176 do lay = laytrop+1, nlayers
7178 do ig = 1, ng12
7179 taug(lay,ngs11+ig) = 0.0_rb
7180 fracs(lay,ngs11+ig) = 0.0_rb
7181 enddo
7182 enddo
7184 end subroutine taugb12
7186 !----------------------------------------------------------------------------
7187 subroutine taugb13
7188 !----------------------------------------------------------------------------
7189 !
7190 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
7191 !----------------------------------------------------------------------------
7193 ! ------- Modules -------
7195 use parrrtm, only : ng13, ngs12
7196 use rrlw_ref, only : chi_mls
7197 use rrlw_kg13, only : fracrefa, fracrefb, absa, ka, &
7198 ka_mco2, ka_mco, kb_mo3, selfref, forref
7200 ! ------- Declarations -------
7202 ! Local
7203 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7204 integer(kind=im) :: js, js1, jmco2, jmco, jpl
7205 real(kind=rb) :: speccomb, specparm, specmult, fs
7206 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7207 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
7208 real(kind=rb) :: speccomb_mco, specparm_mco, specmult_mco, fmco
7209 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7210 real(kind=rb) :: p, p4, fk0, fk1, fk2
7211 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7212 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7213 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
7214 real(kind=rb) :: com1, com2, absco, abso3
7215 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
7216 real(kind=rb) :: refrat_planck_a, refrat_m_a, refrat_m_a3
7217 real(kind=rb) :: tau_major, tau_major1
7219 ! Minor gas mapping levels :
7220 ! lower - co2, p = 1053.63 mb, t = 294.2 k
7221 ! lower - co, p = 706 mb, t = 278.94 k
7222 ! upper - o3, p = 95.5835 mb, t = 215.7 k
7224 ! Calculate reference ratio to be used in calculation of Planck
7225 ! fraction in lower/upper atmosphere.
7227 ! P = 473.420 mb (Level 5)
7228 refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
7230 ! P = 1053. (Level 1)
7231 refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
7233 ! P = 706. (Level 3)
7234 refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
7236 ! Compute the optical depth by interpolating in ln(pressure),
7237 ! temperature, and appropriate species. Below laytrop, the water
7238 ! vapor self-continuum and foreign continuum is interpolated
7239 ! (in temperature) separately.
7241 ! Lower atmosphere loop
7242 do lay = 1, laytrop
7244 speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay)
7245 specparm = colh2o(lay)/speccomb
7246 if (specparm .ge. oneminus) specparm = oneminus
7247 specmult = 8._rb*(specparm)
7248 js = 1 + int(specmult)
7249 fs = mod(specmult,1.0_rb)
7251 speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay)
7252 specparm1 = colh2o(lay)/speccomb1
7253 if (specparm1 .ge. oneminus) specparm1 = oneminus
7254 specmult1 = 8._rb*(specparm1)
7255 js1 = 1 + int(specmult1)
7256 fs1 = mod(specmult1,1.0_rb)
7258 speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay)
7259 specparm_mco2 = colh2o(lay)/speccomb_mco2
7260 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
7261 specmult_mco2 = 8._rb*specparm_mco2
7262 jmco2 = 1 + int(specmult_mco2)
7263 fmco2 = mod(specmult_mco2,1.0_rb)
7265 ! In atmospheres where the amount of CO2 is too great to be considered
7266 ! a minor species, adjust the column amount of CO2 by an empirical factor
7267 ! to obtain the proper contribution.
7268 chi_co2 = colco2(lay)/(coldry(lay))
7269 ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb
7270 if (ratco2 .gt. 3.0_rb) then
7271 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb
7272 adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb
7273 else
7274 adjcolco2 = colco2(lay)
7275 endif
7277 speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay)
7278 specparm_mco = colh2o(lay)/speccomb_mco
7279 if (specparm_mco .ge. oneminus) specparm_mco = oneminus
7280 specmult_mco = 8._rb*specparm_mco
7281 jmco = 1 + int(specmult_mco)
7282 fmco = mod(specmult_mco,1.0_rb)
7284 speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay)
7285 specparm_planck = colh2o(lay)/speccomb_planck
7286 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7287 specmult_planck = 8._rb*specparm_planck
7288 jpl= 1 + int(specmult_planck)
7289 fpl = mod(specmult_planck,1.0_rb)
7291 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js
7292 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1
7293 inds = indself(lay)
7294 indf = indfor(lay)
7295 indm = indminor(lay)
7297 if (specparm .lt. 0.125_rb) then
7298 p = fs - 1
7299 p4 = p**4
7300 fk0 = p4
7301 fk1 = 1 - p - 2.0_rb*p4
7302 fk2 = p + p4
7303 fac000 = fk0*fac00(lay)
7304 fac100 = fk1*fac00(lay)
7305 fac200 = fk2*fac00(lay)
7306 fac010 = fk0*fac10(lay)
7307 fac110 = fk1*fac10(lay)
7308 fac210 = fk2*fac10(lay)
7309 else if (specparm .gt. 0.875_rb) then
7310 p = -fs
7311 p4 = p**4
7312 fk0 = p4
7313 fk1 = 1 - p - 2.0_rb*p4
7314 fk2 = p + p4
7315 fac000 = fk0*fac00(lay)
7316 fac100 = fk1*fac00(lay)
7317 fac200 = fk2*fac00(lay)
7318 fac010 = fk0*fac10(lay)
7319 fac110 = fk1*fac10(lay)
7320 fac210 = fk2*fac10(lay)
7321 else
7322 fac000 = (1._rb - fs) * fac00(lay)
7323 fac010 = (1._rb - fs) * fac10(lay)
7324 fac100 = fs * fac00(lay)
7325 fac110 = fs * fac10(lay)
7326 endif
7328 if (specparm1 .lt. 0.125_rb) then
7329 p = fs1 - 1
7330 p4 = p**4
7331 fk0 = p4
7332 fk1 = 1 - p - 2.0_rb*p4
7333 fk2 = p + p4
7334 fac001 = fk0*fac01(lay)
7335 fac101 = fk1*fac01(lay)
7336 fac201 = fk2*fac01(lay)
7337 fac011 = fk0*fac11(lay)
7338 fac111 = fk1*fac11(lay)
7339 fac211 = fk2*fac11(lay)
7340 else if (specparm1 .gt. 0.875_rb) then
7341 p = -fs1
7342 p4 = p**4
7343 fk0 = p4
7344 fk1 = 1 - p - 2.0_rb*p4
7345 fk2 = p + p4
7346 fac001 = fk0*fac01(lay)
7347 fac101 = fk1*fac01(lay)
7348 fac201 = fk2*fac01(lay)
7349 fac011 = fk0*fac11(lay)
7350 fac111 = fk1*fac11(lay)
7351 fac211 = fk2*fac11(lay)
7352 else
7353 fac001 = (1._rb - fs1) * fac01(lay)
7354 fac011 = (1._rb - fs1) * fac11(lay)
7355 fac101 = fs1 * fac01(lay)
7356 fac111 = fs1 * fac11(lay)
7357 endif
7359 do ig = 1, ng13
7360 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7361 (selfref(inds+1,ig) - selfref(inds,ig)))
7362 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7363 (forref(indf+1,ig) - forref(indf,ig)))
7364 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
7365 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7366 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
7367 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7368 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7369 com1 = ka_mco(jmco,indm,ig) + fmco * &
7370 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7371 com2 = ka_mco(jmco,indm+1,ig) + fmco * &
7372 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7373 absco = com1 + minorfrac(lay) * (com2 - com1)
7375 if (specparm .lt. 0.125_rb) then
7376 tau_major = speccomb * &
7377 (fac000 * absa(ind0,ig) + &
7378 fac100 * absa(ind0+1,ig) + &
7379 fac200 * absa(ind0+2,ig) + &
7380 fac010 * absa(ind0+9,ig) + &
7381 fac110 * absa(ind0+10,ig) + &
7382 fac210 * absa(ind0+11,ig))
7383 else if (specparm .gt. 0.875_rb) then
7384 tau_major = speccomb * &
7385 (fac200 * absa(ind0-1,ig) + &
7386 fac100 * absa(ind0,ig) + &
7387 fac000 * absa(ind0+1,ig) + &
7388 fac210 * absa(ind0+8,ig) + &
7389 fac110 * absa(ind0+9,ig) + &
7390 fac010 * absa(ind0+10,ig))
7391 else
7392 tau_major = speccomb * &
7393 (fac000 * absa(ind0,ig) + &
7394 fac100 * absa(ind0+1,ig) + &
7395 fac010 * absa(ind0+9,ig) + &
7396 fac110 * absa(ind0+10,ig))
7397 endif
7399 if (specparm1 .lt. 0.125_rb) then
7400 tau_major1 = speccomb1 * &
7401 (fac001 * absa(ind1,ig) + &
7402 fac101 * absa(ind1+1,ig) + &
7403 fac201 * absa(ind1+2,ig) + &
7404 fac011 * absa(ind1+9,ig) + &
7405 fac111 * absa(ind1+10,ig) + &
7406 fac211 * absa(ind1+11,ig))
7407 else if (specparm1 .gt. 0.875_rb) then
7408 tau_major1 = speccomb1 * &
7409 (fac201 * absa(ind1-1,ig) + &
7410 fac101 * absa(ind1,ig) + &
7411 fac001 * absa(ind1+1,ig) + &
7412 fac211 * absa(ind1+8,ig) + &
7413 fac111 * absa(ind1+9,ig) + &
7414 fac011 * absa(ind1+10,ig))
7415 else
7416 tau_major1 = speccomb1 * &
7417 (fac001 * absa(ind1,ig) + &
7418 fac101 * absa(ind1+1,ig) + &
7419 fac011 * absa(ind1+9,ig) + &
7420 fac111 * absa(ind1+10,ig))
7421 endif
7423 taug(lay,ngs12+ig) = tau_major + tau_major1 &
7424 + tauself + taufor &
7425 + adjcolco2*absco2 &
7426 + colco(lay)*absco
7427 fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
7428 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7429 enddo
7430 enddo
7432 ! Upper atmosphere loop
7433 do lay = laytrop+1, nlayers
7434 indm = indminor(lay)
7435 do ig = 1, ng13
7436 abso3 = kb_mo3(indm,ig) + minorfrac(lay) * &
7437 (kb_mo3(indm+1,ig) - kb_mo3(indm,ig))
7438 taug(lay,ngs12+ig) = colo3(lay)*abso3
7439 fracs(lay,ngs12+ig) = fracrefb(ig)
7440 enddo
7441 enddo
7443 end subroutine taugb13
7445 !----------------------------------------------------------------------------
7446 subroutine taugb14
7447 !----------------------------------------------------------------------------
7448 !
7449 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
7450 !----------------------------------------------------------------------------
7452 ! ------- Modules -------
7454 use parrrtm, only : ng14, ngs13
7455 use rrlw_kg14, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7456 selfref, forref
7458 ! ------- Declarations -------
7460 ! Local
7461 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7462 real(kind=rb) :: tauself, taufor
7465 ! Compute the optical depth by interpolating in ln(pressure) and
7466 ! temperature. Below laytrop, the water vapor self-continuum
7467 ! and foreign continuum is interpolated (in temperature) separately.
7469 ! Lower atmosphere loop
7470 do lay = 1, laytrop
7471 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1
7472 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1
7473 inds = indself(lay)
7474 indf = indfor(lay)
7475 do ig = 1, ng14
7476 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
7477 (selfref(inds+1,ig) - selfref(inds,ig)))
7478 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7479 (forref(indf+1,ig) - forref(indf,ig)))
7480 taug(lay,ngs13+ig) = colco2(lay) * &
7481 (fac00(lay) * absa(ind0,ig) + &
7482 fac10(lay) * absa(ind0+1,ig) + &
7483 fac01(lay) * absa(ind1,ig) + &
7484 fac11(lay) * absa(ind1+1,ig)) &
7485 + tauself + taufor
7486 fracs(lay,ngs13+ig) = fracrefa(ig)
7487 enddo
7488 enddo
7490 ! Upper atmosphere loop
7491 do lay = laytrop+1, nlayers
7492 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1
7493 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1
7494 do ig = 1, ng14
7495 taug(lay,ngs13+ig) = colco2(lay) * &
7496 (fac00(lay) * absb(ind0,ig) + &
7497 fac10(lay) * absb(ind0+1,ig) + &
7498 fac01(lay) * absb(ind1,ig) + &
7499 fac11(lay) * absb(ind1+1,ig))
7500 fracs(lay,ngs13+ig) = fracrefb(ig)
7501 enddo
7502 enddo
7504 end subroutine taugb14
7506 !----------------------------------------------------------------------------
7507 subroutine taugb15
7508 !----------------------------------------------------------------------------
7509 !
7510 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
7511 ! (high - nothing)
7512 !----------------------------------------------------------------------------
7514 ! ------- Modules -------
7516 use parrrtm, only : ng15, ngs14
7517 use rrlw_ref, only : chi_mls
7518 use rrlw_kg15, only : fracrefa, absa, ka, &
7519 ka_mn2, selfref, forref
7521 ! ------- Declarations -------
7523 ! Local
7524 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7525 integer(kind=im) :: js, js1, jmn2, jpl
7526 real(kind=rb) :: speccomb, specparm, specmult, fs
7527 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7528 real(kind=rb) :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
7529 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7530 real(kind=rb) :: p, p4, fk0, fk1, fk2
7531 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7532 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7533 real(kind=rb) :: scalen2, tauself, taufor, n2m1, n2m2, taun2
7534 real(kind=rb) :: refrat_planck_a, refrat_m_a
7535 real(kind=rb) :: tau_major, tau_major1
7538 ! Minor gas mapping level :
7539 ! Lower - Nitrogen Continuum, P = 1053., T = 294.
7541 ! Calculate reference ratio to be used in calculation of Planck
7542 ! fraction in lower atmosphere.
7543 ! P = 1053. mb (Level 1)
7544 refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
7546 ! P = 1053.
7547 refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
7549 ! Compute the optical depth by interpolating in ln(pressure),
7550 ! temperature, and appropriate species. Below laytrop, the water
7551 ! vapor self-continuum and foreign continuum is interpolated
7552 ! (in temperature) separately.
7554 ! Lower atmosphere loop
7555 do lay = 1, laytrop
7557 speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay)
7558 specparm = coln2o(lay)/speccomb
7559 if (specparm .ge. oneminus) specparm = oneminus
7560 specmult = 8._rb*(specparm)
7561 js = 1 + int(specmult)
7562 fs = mod(specmult,1.0_rb)
7564 speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay)
7565 specparm1 = coln2o(lay)/speccomb1
7566 if (specparm1 .ge. oneminus) specparm1 = oneminus
7567 specmult1 = 8._rb*(specparm1)
7568 js1 = 1 + int(specmult1)
7569 fs1 = mod(specmult1,1.0_rb)
7571 speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay)
7572 specparm_mn2 = coln2o(lay)/speccomb_mn2
7573 if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus
7574 specmult_mn2 = 8._rb*specparm_mn2
7575 jmn2 = 1 + int(specmult_mn2)
7576 fmn2 = mod(specmult_mn2,1.0_rb)
7578 speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay)
7579 specparm_planck = coln2o(lay)/speccomb_planck
7580 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7581 specmult_planck = 8._rb*specparm_planck
7582 jpl= 1 + int(specmult_planck)
7583 fpl = mod(specmult_planck,1.0_rb)
7585 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js
7586 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1
7587 inds = indself(lay)
7588 indf = indfor(lay)
7589 indm = indminor(lay)
7591 scalen2 = colbrd(lay)*scaleminor(lay)
7593 if (specparm .lt. 0.125_rb) then
7594 p = fs - 1
7595 p4 = p**4
7596 fk0 = p4
7597 fk1 = 1 - p - 2.0_rb*p4
7598 fk2 = p + p4
7599 fac000 = fk0*fac00(lay)
7600 fac100 = fk1*fac00(lay)
7601 fac200 = fk2*fac00(lay)
7602 fac010 = fk0*fac10(lay)
7603 fac110 = fk1*fac10(lay)
7604 fac210 = fk2*fac10(lay)
7605 else if (specparm .gt. 0.875_rb) then
7606 p = -fs
7607 p4 = p**4
7608 fk0 = p4
7609 fk1 = 1 - p - 2.0_rb*p4
7610 fk2 = p + p4
7611 fac000 = fk0*fac00(lay)
7612 fac100 = fk1*fac00(lay)
7613 fac200 = fk2*fac00(lay)
7614 fac010 = fk0*fac10(lay)
7615 fac110 = fk1*fac10(lay)
7616 fac210 = fk2*fac10(lay)
7617 else
7618 fac000 = (1._rb - fs) * fac00(lay)
7619 fac010 = (1._rb - fs) * fac10(lay)
7620 fac100 = fs * fac00(lay)
7621 fac110 = fs * fac10(lay)
7622 endif
7623 if (specparm1 .lt. 0.125_rb) then
7624 p = fs1 - 1
7625 p4 = p**4
7626 fk0 = p4
7627 fk1 = 1 - p - 2.0_rb*p4
7628 fk2 = p + p4
7629 fac001 = fk0*fac01(lay)
7630 fac101 = fk1*fac01(lay)
7631 fac201 = fk2*fac01(lay)
7632 fac011 = fk0*fac11(lay)
7633 fac111 = fk1*fac11(lay)
7634 fac211 = fk2*fac11(lay)
7635 else if (specparm1 .gt. 0.875_rb) then
7636 p = -fs1
7637 p4 = p**4
7638 fk0 = p4
7639 fk1 = 1 - p - 2.0_rb*p4
7640 fk2 = p + p4
7641 fac001 = fk0*fac01(lay)
7642 fac101 = fk1*fac01(lay)
7643 fac201 = fk2*fac01(lay)
7644 fac011 = fk0*fac11(lay)
7645 fac111 = fk1*fac11(lay)
7646 fac211 = fk2*fac11(lay)
7647 else
7648 fac001 = (1._rb - fs1) * fac01(lay)
7649 fac011 = (1._rb - fs1) * fac11(lay)
7650 fac101 = fs1 * fac01(lay)
7651 fac111 = fs1 * fac11(lay)
7652 endif
7654 do ig = 1, ng15
7655 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7656 (selfref(inds+1,ig) - selfref(inds,ig)))
7657 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7658 (forref(indf+1,ig) - forref(indf,ig)))
7659 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
7660 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7661 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
7662 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7663 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7665 if (specparm .lt. 0.125_rb) then
7666 tau_major = speccomb * &
7667 (fac000 * absa(ind0,ig) + &
7668 fac100 * absa(ind0+1,ig) + &
7669 fac200 * absa(ind0+2,ig) + &
7670 fac010 * absa(ind0+9,ig) + &
7671 fac110 * absa(ind0+10,ig) + &
7672 fac210 * absa(ind0+11,ig))
7673 else if (specparm .gt. 0.875_rb) then
7674 tau_major = speccomb * &
7675 (fac200 * absa(ind0-1,ig) + &
7676 fac100 * absa(ind0,ig) + &
7677 fac000 * absa(ind0+1,ig) + &
7678 fac210 * absa(ind0+8,ig) + &
7679 fac110 * absa(ind0+9,ig) + &
7680 fac010 * absa(ind0+10,ig))
7681 else
7682 tau_major = speccomb * &
7683 (fac000 * absa(ind0,ig) + &
7684 fac100 * absa(ind0+1,ig) + &
7685 fac010 * absa(ind0+9,ig) + &
7686 fac110 * absa(ind0+10,ig))
7687 endif
7689 if (specparm1 .lt. 0.125_rb) then
7690 tau_major1 = speccomb1 * &
7691 (fac001 * absa(ind1,ig) + &
7692 fac101 * absa(ind1+1,ig) + &
7693 fac201 * absa(ind1+2,ig) + &
7694 fac011 * absa(ind1+9,ig) + &
7695 fac111 * absa(ind1+10,ig) + &
7696 fac211 * absa(ind1+11,ig))
7697 else if (specparm1 .gt. 0.875_rb) then
7698 tau_major1 = speccomb1 * &
7699 (fac201 * absa(ind1-1,ig) + &
7700 fac101 * absa(ind1,ig) + &
7701 fac001 * absa(ind1+1,ig) + &
7702 fac211 * absa(ind1+8,ig) + &
7703 fac111 * absa(ind1+9,ig) + &
7704 fac011 * absa(ind1+10,ig))
7705 else
7706 tau_major1 = speccomb1 * &
7707 (fac001 * absa(ind1,ig) + &
7708 fac101 * absa(ind1+1,ig) + &
7709 fac011 * absa(ind1+9,ig) + &
7710 fac111 * absa(ind1+10,ig))
7711 endif
7713 taug(lay,ngs14+ig) = tau_major + tau_major1 &
7714 + tauself + taufor &
7715 + taun2
7716 fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
7717 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7718 enddo
7719 enddo
7721 ! Upper atmosphere loop
7722 do lay = laytrop+1, nlayers
7723 do ig = 1, ng15
7724 taug(lay,ngs14+ig) = 0.0_rb
7725 fracs(lay,ngs14+ig) = 0.0_rb
7726 enddo
7727 enddo
7729 end subroutine taugb15
7731 !----------------------------------------------------------------------------
7732 subroutine taugb16
7733 !----------------------------------------------------------------------------
7734 !
7735 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
7736 !----------------------------------------------------------------------------
7738 ! ------- Modules -------
7740 use parrrtm, only : ng16, ngs15
7741 use rrlw_ref, only : chi_mls
7742 use rrlw_kg16, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7743 selfref, forref
7745 ! ------- Declarations -------
7747 ! Local
7748 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7749 integer(kind=im) :: js, js1, jpl
7750 real(kind=rb) :: speccomb, specparm, specmult, fs
7751 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7752 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7753 real(kind=rb) :: p, p4, fk0, fk1, fk2
7754 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7755 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7756 real(kind=rb) :: tauself, taufor
7757 real(kind=rb) :: refrat_planck_a
7758 real(kind=rb) :: tau_major, tau_major1
7761 ! Calculate reference ratio to be used in calculation of Planck
7762 ! fraction in lower atmosphere.
7764 ! P = 387. mb (Level 6)
7765 refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
7767 ! Compute the optical depth by interpolating in ln(pressure),
7768 ! temperature,and appropriate species. Below laytrop, the water
7769 ! vapor self-continuum and foreign continuum is interpolated
7770 ! (in temperature) separately.
7772 ! Lower atmosphere loop
7773 do lay = 1, laytrop
7775 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
7776 specparm = colh2o(lay)/speccomb
7777 if (specparm .ge. oneminus) specparm = oneminus
7778 specmult = 8._rb*(specparm)
7779 js = 1 + int(specmult)
7780 fs = mod(specmult,1.0_rb)
7782 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
7783 specparm1 = colh2o(lay)/speccomb1
7784 if (specparm1 .ge. oneminus) specparm1 = oneminus
7785 specmult1 = 8._rb*(specparm1)
7786 js1 = 1 + int(specmult1)
7787 fs1 = mod(specmult1,1.0_rb)
7789 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
7790 specparm_planck = colh2o(lay)/speccomb_planck
7791 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7792 specmult_planck = 8._rb*specparm_planck
7793 jpl= 1 + int(specmult_planck)
7794 fpl = mod(specmult_planck,1.0_rb)
7796 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
7797 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1
7798 inds = indself(lay)
7799 indf = indfor(lay)
7801 if (specparm .lt. 0.125_rb) then
7802 p = fs - 1
7803 p4 = p**4
7804 fk0 = p4
7805 fk1 = 1 - p - 2.0_rb*p4
7806 fk2 = p + p4
7807 fac000 = fk0*fac00(lay)
7808 fac100 = fk1*fac00(lay)
7809 fac200 = fk2*fac00(lay)
7810 fac010 = fk0*fac10(lay)
7811 fac110 = fk1*fac10(lay)
7812 fac210 = fk2*fac10(lay)
7813 else if (specparm .gt. 0.875_rb) then
7814 p = -fs
7815 p4 = p**4
7816 fk0 = p4
7817 fk1 = 1 - p - 2.0_rb*p4
7818 fk2 = p + p4
7819 fac000 = fk0*fac00(lay)
7820 fac100 = fk1*fac00(lay)
7821 fac200 = fk2*fac00(lay)
7822 fac010 = fk0*fac10(lay)
7823 fac110 = fk1*fac10(lay)
7824 fac210 = fk2*fac10(lay)
7825 else
7826 fac000 = (1._rb - fs) * fac00(lay)
7827 fac010 = (1._rb - fs) * fac10(lay)
7828 fac100 = fs * fac00(lay)
7829 fac110 = fs * fac10(lay)
7830 endif
7832 if (specparm1 .lt. 0.125_rb) then
7833 p = fs1 - 1
7834 p4 = p**4
7835 fk0 = p4
7836 fk1 = 1 - p - 2.0_rb*p4
7837 fk2 = p + p4
7838 fac001 = fk0*fac01(lay)
7839 fac101 = fk1*fac01(lay)
7840 fac201 = fk2*fac01(lay)
7841 fac011 = fk0*fac11(lay)
7842 fac111 = fk1*fac11(lay)
7843 fac211 = fk2*fac11(lay)
7844 else if (specparm1 .gt. 0.875_rb) then
7845 p = -fs1
7846 p4 = p**4
7847 fk0 = p4
7848 fk1 = 1 - p - 2.0_rb*p4
7849 fk2 = p + p4
7850 fac001 = fk0*fac01(lay)
7851 fac101 = fk1*fac01(lay)
7852 fac201 = fk2*fac01(lay)
7853 fac011 = fk0*fac11(lay)
7854 fac111 = fk1*fac11(lay)
7855 fac211 = fk2*fac11(lay)
7856 else
7857 fac001 = (1._rb - fs1) * fac01(lay)
7858 fac011 = (1._rb - fs1) * fac11(lay)
7859 fac101 = fs1 * fac01(lay)
7860 fac111 = fs1 * fac11(lay)
7861 endif
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)))
7869 if (specparm .lt. 0.125_rb) then
7870 tau_major = speccomb * &
7871 (fac000 * absa(ind0,ig) + &
7872 fac100 * absa(ind0+1,ig) + &
7873 fac200 * absa(ind0+2,ig) + &
7874 fac010 * absa(ind0+9,ig) + &
7875 fac110 * absa(ind0+10,ig) + &
7876 fac210 * absa(ind0+11,ig))
7877 else if (specparm .gt. 0.875_rb) then
7878 tau_major = speccomb * &
7879 (fac200 * absa(ind0-1,ig) + &
7880 fac100 * absa(ind0,ig) + &
7881 fac000 * absa(ind0+1,ig) + &
7882 fac210 * absa(ind0+8,ig) + &
7883 fac110 * absa(ind0+9,ig) + &
7884 fac010 * absa(ind0+10,ig))
7885 else
7886 tau_major = speccomb * &
7887 (fac000 * absa(ind0,ig) + &
7888 fac100 * absa(ind0+1,ig) + &
7889 fac010 * absa(ind0+9,ig) + &
7890 fac110 * absa(ind0+10,ig))
7891 endif
7893 if (specparm1 .lt. 0.125_rb) then
7894 tau_major1 = speccomb1 * &
7895 (fac001 * absa(ind1,ig) + &
7896 fac101 * absa(ind1+1,ig) + &
7897 fac201 * absa(ind1+2,ig) + &
7898 fac011 * absa(ind1+9,ig) + &
7899 fac111 * absa(ind1+10,ig) + &
7900 fac211 * absa(ind1+11,ig))
7901 else if (specparm1 .gt. 0.875_rb) then
7902 tau_major1 = speccomb1 * &
7903 (fac201 * absa(ind1-1,ig) + &
7904 fac101 * absa(ind1,ig) + &
7905 fac001 * absa(ind1+1,ig) + &
7906 fac211 * absa(ind1+8,ig) + &
7907 fac111 * absa(ind1+9,ig) + &
7908 fac011 * absa(ind1+10,ig))
7909 else
7910 tau_major1 = speccomb1 * &
7911 (fac001 * absa(ind1,ig) + &
7912 fac101 * absa(ind1+1,ig) + &
7913 fac011 * absa(ind1+9,ig) + &
7914 fac111 * absa(ind1+10,ig))
7915 endif
7917 taug(lay,ngs15+ig) = tau_major + tau_major1 &
7918 + tauself + taufor
7919 fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
7920 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7921 enddo
7922 enddo
7924 ! Upper atmosphere loop
7925 do lay = laytrop+1, nlayers
7926 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
7927 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
7928 do ig = 1, ng16
7929 taug(lay,ngs15+ig) = colch4(lay) * &
7930 (fac00(lay) * absb(ind0,ig) + &
7931 fac10(lay) * absb(ind0+1,ig) + &
7932 fac01(lay) * absb(ind1,ig) + &
7933 fac11(lay) * absb(ind1+1,ig))
7934 fracs(lay,ngs15+ig) = fracrefb(ig)
7935 enddo
7936 enddo
7938 end subroutine taugb16
7940 end subroutine taumol
7942 end module rrtmg_lw_taumol
7944 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
7945 ! author: $Author: trn $
7946 ! revision: $Revision: 1.3 $
7947 ! created: $Date: 2009/04/16 19:54:22 $
7948 !
7949 module rrtmg_lw_init
7951 ! --------------------------------------------------------------------------
7952 ! | |
7953 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
7954 ! | This software may be used, copied, or redistributed as long as it is |
7955 ! | not sold and this copyright notice is reproduced on each copy made. |
7956 ! | This model is provided as is without any express or implied warranties. |
7957 ! | (http://www.rtweb.aer.com/) |
7958 ! | |
7959 ! --------------------------------------------------------------------------
7961 ! ------- Modules -------
7962 use parkind, only : im => kind_im, rb => kind_rb
7963 use rrlw_wvn
7964 use rrtmg_lw_setcoef, only: lwatmref, lwavplank
7966 ! Steven Cavallo: added for buffer layer adjustment
7967 implicit none
7969 integer , save :: nlayers
7971 contains
7973 ! **************************************************************************
7974 subroutine rrtmg_lw_ini(cpdair)
7975 ! **************************************************************************
7976 !
7977 ! Original version: Michael J. Iacono; July, 1998
7978 ! First revision for GCMs: September, 1998
7979 ! Second revision for RRTM_V3.0: September, 2002
7980 !
7981 ! This subroutine performs calculations necessary for the initialization
7982 ! of the longwave model. Lookup tables are computed for use in the LW
7983 ! radiative transfer, and input absorption coefficient data for each
7984 ! spectral band are reduced from 256 g-point intervals to 140.
7985 ! **************************************************************************
7987 use parrrtm, only : mg, nbndlw, ngptlw
7988 use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
7989 use rrlw_vsn, only: hvrini, hnamini
7991 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
7992 ! at constant pressure at 273 K
7993 ! (J kg-1 K-1)
7995 ! ------- Local -------
7997 integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr
7998 integer(kind=im) :: igcsm, iprsm
8000 real(kind=rb) :: wtsum, wtsm(mg) !
8001 real(kind=rb) :: tfn !
8003 real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table
8005 ! ------- Definitions -------
8006 ! Arrays for 10000-point look-up tables:
8007 ! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
8008 ! EXP_TBL Exponential lookup table for ransmittance
8009 ! TFN_TBL Tau transition function; i.e. the transition of the Planck
8010 ! function from that for the mean layer temperature to that for
8011 ! the layer boundary temperature as a function of optical depth.
8012 ! The "linear in tau" method is used to make the table.
8013 ! PADE Pade approximation constant (= 0.278)
8014 ! BPADE Inverse of the Pade approximation constant
8015 !
8017 !jm not thread safe hvrini = '$Revision: 1.3 $'
8019 ! Initialize model data
8020 call lwdatinit(cpdair)
8021 call lwcmbdat ! g-point interval reduction data
8022 call lwcldpr ! cloud optical properties
8023 call lwatmref ! reference MLS profile
8024 call lwavplank ! Planck function
8025 ! Moved to module_ra_rrtmg_lw for WRF
8026 ! call lw_kgb01 ! molecular absorption coefficients
8027 ! call lw_kgb02
8028 ! call lw_kgb03
8029 ! call lw_kgb04
8030 ! call lw_kgb05
8031 ! call lw_kgb06
8032 ! call lw_kgb07
8033 ! call lw_kgb08
8034 ! call lw_kgb09
8035 ! call lw_kgb10
8036 ! call lw_kgb11
8037 ! call lw_kgb12
8038 ! call lw_kgb13
8039 ! call lw_kgb14
8040 ! call lw_kgb15
8041 ! call lw_kgb16
8043 ! Compute lookup tables for transmittance, tau transition function,
8044 ! and clear sky tau (for the cloudy sky radiative transfer). Tau is
8045 ! computed as a function of the tau transition function, transmittance
8046 ! is calculated as a function of tau, and the tau transition function
8047 ! is calculated using the linear in tau formulation at values of tau
8048 ! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables
8049 ! are computed at intervals of 0.001. The inverse of the constant used
8050 ! in the Pade approximation to the tau transition function is set to b.
8052 tau_tbl(0) = 0.0_rb
8053 tau_tbl(ntbl) = 1.e10_rb
8054 exp_tbl(0) = 1.0_rb
8055 exp_tbl(ntbl) = expeps
8056 tfn_tbl(0) = 0.0_rb
8057 tfn_tbl(ntbl) = 1.0_rb
8058 bpade = 1.0_rb / pade
8059 do itr = 1, ntbl-1
8060 tfn = float(itr) / float(ntbl)
8061 tau_tbl(itr) = bpade * tfn / (1._rb - tfn)
8062 exp_tbl(itr) = exp(-tau_tbl(itr))
8063 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
8064 if (tau_tbl(itr) .lt. 0.06_rb) then
8065 tfn_tbl(itr) = tau_tbl(itr)/6._rb
8066 else
8067 tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
8068 endif
8069 enddo
8071 ! Perform g-point reduction from 16 per band (256 total points) to
8072 ! a band dependant number (140 total points) for all absorption
8073 ! coefficient input data and Planck fraction input data.
8074 ! Compute relative weighting for new g-point combinations.
8076 igcsm = 0
8077 do ibnd = 1,nbndlw
8078 iprsm = 0
8079 if (ngc(ibnd).lt.mg) then
8080 do igc = 1,ngc(ibnd)
8081 igcsm = igcsm + 1
8082 wtsum = 0._rb
8083 do ipr = 1, ngn(igcsm)
8084 iprsm = iprsm + 1
8085 wtsum = wtsum + wt(iprsm)
8086 enddo
8087 wtsm(igc) = wtsum
8088 enddo
8089 do ig = 1, ng(ibnd)
8090 ind = (ibnd-1)*mg + ig
8091 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
8092 enddo
8093 else
8094 do ig = 1, ng(ibnd)
8095 igcsm = igcsm + 1
8096 ind = (ibnd-1)*mg + ig
8097 rwgt(ind) = 1.0_rb
8098 enddo
8099 endif
8100 enddo
8102 ! Reduce g-points for absorption coefficient data in each LW spectral band.
8104 call cmbgb1
8105 call cmbgb2
8106 call cmbgb3
8107 call cmbgb4
8108 call cmbgb5
8109 call cmbgb6
8110 call cmbgb7
8111 call cmbgb8
8112 call cmbgb9
8113 call cmbgb10
8114 call cmbgb11
8115 call cmbgb12
8116 call cmbgb13
8117 call cmbgb14
8118 call cmbgb15
8119 call cmbgb16
8121 end subroutine rrtmg_lw_ini
8123 !***************************************************************************
8124 subroutine lwdatinit(cpdair)
8125 !***************************************************************************
8127 ! --------- Modules ----------
8129 use parrrtm, only : maxxsec, maxinpx
8130 use rrlw_con, only: heatfac, grav, planck, boltz, &
8131 clight, avogad, alosmt, gascon, radcn1, radcn2, &
8132 sbcnst, secdy, fluxfac, oneminus, pi
8133 use rrlw_vsn
8135 save
8137 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
8138 ! at constant pressure at 273 K
8139 ! (J kg-1 K-1)
8141 ! Longwave spectral band limits (wavenumbers)
8142 wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb, &
8143 980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb, &
8144 2080._rb,2250._rb,2380._rb,2600._rb/)
8145 wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb, &
8146 1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb, &
8147 2250._rb,2380._rb,2600._rb,3250._rb/)
8148 delwave(:) = (/340._rb, 150._rb, 130._rb, 70._rb, 120._rb, 160._rb, &
8149 100._rb, 100._rb, 210._rb, 90._rb, 320._rb, 280._rb, &
8150 170._rb, 130._rb, 220._rb, 650._rb/)
8152 ! Spectral band information
8153 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
8154 nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
8155 nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
8157 ! nxmol - number of cross-sections input by user
8158 ! ixindx(i) - index of cross-section molecule corresponding to Ith
8159 ! cross-section specified by user
8160 ! = 0 -- not allowed in rrtm
8161 ! = 1 -- ccl4
8162 ! = 2 -- cfc11
8163 ! = 3 -- cfc12
8164 ! = 4 -- cfc22
8165 nxmol = 4
8166 ixindx(1) = 1
8167 ixindx(2) = 2
8168 ixindx(3) = 3
8169 ixindx(4) = 4
8170 ixindx(5:maxinpx) = 0
8172 ! Fundamental physical constants from NIST 2002
8174 grav = 9.8066_rb ! Acceleration of gravity
8175 ! (m s-2)
8176 planck = 6.62606876e-27_rb ! Planck constant
8177 ! (ergs s; g cm2 s-1)
8178 boltz = 1.3806503e-16_rb ! Boltzmann constant
8179 ! (ergs K-1; g cm2 s-2 K-1)
8180 clight = 2.99792458e+10_rb ! Speed of light in a vacuum
8181 ! (cm s-1)
8182 avogad = 6.02214199e+23_rb ! Avogadro constant
8183 ! (mol-1)
8184 alosmt = 2.6867775e+19_rb ! Loschmidt constant
8185 ! (cm-3)
8186 gascon = 8.31447200e+07_rb ! Molar gas constant
8187 ! (ergs mol-1 K-1)
8188 radcn1 = 1.191042722e-12_rb ! First radiation constant
8189 ! (W cm2 sr-1)
8190 radcn2 = 1.4387752_rb ! Second radiation constant
8191 ! (cm K)
8192 sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
8193 ! (W cm-2 K-4)
8194 secdy = 8.6400e4_rb ! Number of seconds per day
8195 ! (s d-1)
8197 !jm moved here for thread safety, 20141107
8198 oneminus = 1._rb - 1.e-6_rb
8199 pi = 2._rb * asin(1._rb)
8200 fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4
8202 !
8203 ! units are generally cgs
8204 !
8205 ! The first and second radiation constants are taken from NIST.
8206 ! They were previously obtained from the relations:
8207 ! radcn1 = 2.*planck*clight*clight*1.e-07
8208 ! radcn2 = planck*clight/boltz
8210 ! Heatfac is the factor by which delta-flux / delta-pressure is
8211 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
8212 ! the heating rate in units of degrees/day. It is equal to:
8213 ! Original value:
8214 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8215 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
8216 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8217 ! = (9.8066)(86400)(1e-5)/(1.004)
8218 ! heatfac = 8.4391_rb
8219 !
8220 ! Modified value for consistency with CAM3:
8221 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8222 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
8223 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8224 ! = (9.80616)(86400)(1e-5)/(1.00464)
8225 ! heatfac = 8.43339130434_rb
8226 !
8227 ! Calculated value:
8228 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
8229 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
8230 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
8231 heatfac = grav * secdy / (cpdair * 1.e2_rb)
8233 end subroutine lwdatinit
8235 !***************************************************************************
8236 subroutine lwcmbdat
8237 !***************************************************************************
8239 save
8241 ! ------- Definitions -------
8242 ! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
8243 ! This mapping from 256 to 140 points has been carefully selected to
8244 ! minimize the effect on the resulting fluxes and cooling rates, and
8245 ! caution should be used if the mapping is modified. The full 256
8246 ! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
8247 ! ngptlw The total number of new g-points
8248 ! ngc The number of new g-points in each band
8249 ! ngs The cumulative sum of new g-points for each band
8250 ! ngm The index of each new g-point relative to the original
8251 ! 16 g-points for each band.
8252 ! ngn The number of original g-points that are combined to make
8253 ! each new g-point in each band.
8254 ! ngb The band index for each new g-point.
8255 ! wt RRTM weights for 16 g-points.
8257 ! ------- Data statements -------
8258 ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
8259 ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
8260 ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1
8261 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2
8262 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3
8263 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4
8264 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5
8265 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6
8266 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7
8267 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8
8268 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9
8269 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10
8270 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11
8271 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12
8272 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13
8273 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14
8274 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15
8275 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16
8276 ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1
8277 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2
8278 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3
8279 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4
8280 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5
8281 2,2,2,2,2,2,2,2, & ! band 6
8282 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7
8283 2,2,2,2,2,2,2,2, & ! band 8
8284 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9
8285 2,2,2,2,4,4, & ! band 10
8286 1,1,2,2,2,2,3,3, & ! band 11
8287 1,1,1,1,2,2,4,4, & ! band 12
8288 3,3,4,6, & ! band 13
8289 8,8, & ! band 14
8290 8,8, & ! band 15
8291 4,12/) ! band 16
8292 ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1
8293 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2
8294 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3
8295 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4
8296 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5
8297 6,6,6,6,6,6,6,6, & ! band 6
8298 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7
8299 8,8,8,8,8,8,8,8, & ! band 8
8300 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9
8301 10,10,10,10,10,10, & ! band 10
8302 11,11,11,11,11,11,11,11, & ! band 11
8303 12,12,12,12,12,12,12,12, & ! band 12
8304 13,13,13,13, & ! band 13
8305 14,14, & ! band 14
8306 15,15, & ! band 15
8307 16,16/) ! band 16
8308 wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
8309 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
8310 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
8311 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
8312 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
8313 0.0000750000_rb/)
8315 end subroutine lwcmbdat
8317 !***************************************************************************
8318 subroutine cmbgb1
8319 !***************************************************************************
8320 !
8321 ! Original version: MJIacono; July 1998
8322 ! Revision for GCMs: MJIacono; September 1998
8323 ! Revision for RRTMG: MJIacono, September 2002
8324 ! Revision for F90 reformatting: MJIacono, June 2006
8325 !
8326 ! The subroutines CMBGB1->CMBGB16 input the absorption coefficient
8327 ! data for each band, which are defined for 16 g-points and 16 spectral
8328 ! bands. The data are combined with appropriate weighting following the
8329 ! g-point mapping arrays specified in RRTMINIT. Plank fraction data
8330 ! in arrays FRACREFA and FRACREFB are combined without weighting. All
8331 ! g-point reduced data are put into new arrays for use in RRTM.
8332 !
8333 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
8334 ! (high key - h2o; high minor - n2)
8335 ! note: previous versions of rrtm band 1:
8336 ! 10-250 cm-1 (low - h2o; high - h2o)
8337 !***************************************************************************
8339 use parrrtm, only : mg, nbndlw, ngptlw, ng1
8340 use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
8341 selfrefo, forrefo, &
8342 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, &
8343 selfref, forref
8345 ! ------- Local -------
8346 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8347 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
8350 do jt = 1,5
8351 do jp = 1,13
8352 iprsm = 0
8353 do igc = 1,ngc(1)
8354 sumk = 0.
8355 do ipr = 1, ngn(igc)
8356 iprsm = iprsm + 1
8357 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
8358 enddo
8359 ka(jt,jp,igc) = sumk
8360 enddo
8361 enddo
8362 do jp = 13,59
8363 iprsm = 0
8364 do igc = 1,ngc(1)
8365 sumk = 0.
8366 do ipr = 1, ngn(igc)
8367 iprsm = iprsm + 1
8368 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
8369 enddo
8370 kb(jt,jp,igc) = sumk
8371 enddo
8372 enddo
8373 enddo
8375 do jt = 1,10
8376 iprsm = 0
8377 do igc = 1,ngc(1)
8378 sumk = 0.
8379 do ipr = 1, ngn(igc)
8380 iprsm = iprsm + 1
8381 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
8382 enddo
8383 selfref(jt,igc) = sumk
8384 enddo
8385 enddo
8387 do jt = 1,4
8388 iprsm = 0
8389 do igc = 1,ngc(1)
8390 sumk = 0.
8391 do ipr = 1, ngn(igc)
8392 iprsm = iprsm + 1
8393 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
8394 enddo
8395 forref(jt,igc) = sumk
8396 enddo
8397 enddo
8399 do jt = 1,19
8400 iprsm = 0
8401 do igc = 1,ngc(1)
8402 sumk1 = 0.
8403 sumk2 = 0.
8404 do ipr = 1, ngn(igc)
8405 iprsm = iprsm + 1
8406 sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
8407 sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
8408 enddo
8409 ka_mn2(jt,igc) = sumk1
8410 kb_mn2(jt,igc) = sumk2
8411 enddo
8412 enddo
8414 iprsm = 0
8415 do igc = 1,ngc(1)
8416 sumf1 = 0.
8417 sumf2 = 0.
8418 do ipr = 1, ngn(igc)
8419 iprsm = iprsm + 1
8420 sumf1= sumf1+ fracrefao(iprsm)
8421 sumf2= sumf2+ fracrefbo(iprsm)
8422 enddo
8423 fracrefa(igc) = sumf1
8424 fracrefb(igc) = sumf2
8425 enddo
8427 end subroutine cmbgb1
8429 !***************************************************************************
8430 subroutine cmbgb2
8431 !***************************************************************************
8432 !
8433 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
8434 !
8435 ! note: previous version of rrtm band 2:
8436 ! 250 - 500 cm-1 (low - h2o; high - h2o)
8437 !***************************************************************************
8439 use parrrtm, only : mg, nbndlw, ngptlw, ng2
8440 use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8441 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8443 ! ------- Local -------
8444 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8445 real(kind=rb) :: sumk, sumf1, sumf2
8448 do jt = 1,5
8449 do jp = 1,13
8450 iprsm = 0
8451 do igc = 1,ngc(2)
8452 sumk = 0.
8453 do ipr = 1, ngn(ngs(1)+igc)
8454 iprsm = iprsm + 1
8455 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
8456 enddo
8457 ka(jt,jp,igc) = sumk
8458 enddo
8459 enddo
8460 do jp = 13,59
8461 iprsm = 0
8462 do igc = 1,ngc(2)
8463 sumk = 0.
8464 do ipr = 1, ngn(ngs(1)+igc)
8465 iprsm = iprsm + 1
8466 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
8467 enddo
8468 kb(jt,jp,igc) = sumk
8469 enddo
8470 enddo
8471 enddo
8473 do jt = 1,10
8474 iprsm = 0
8475 do igc = 1,ngc(2)
8476 sumk = 0.
8477 do ipr = 1, ngn(ngs(1)+igc)
8478 iprsm = iprsm + 1
8479 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
8480 enddo
8481 selfref(jt,igc) = sumk
8482 enddo
8483 enddo
8485 do jt = 1,4
8486 iprsm = 0
8487 do igc = 1,ngc(2)
8488 sumk = 0.
8489 do ipr = 1, ngn(ngs(1)+igc)
8490 iprsm = iprsm + 1
8491 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
8492 enddo
8493 forref(jt,igc) = sumk
8494 enddo
8495 enddo
8497 iprsm = 0
8498 do igc = 1,ngc(2)
8499 sumf1 = 0.
8500 sumf2 = 0.
8501 do ipr = 1, ngn(ngs(1)+igc)
8502 iprsm = iprsm + 1
8503 sumf1= sumf1+ fracrefao(iprsm)
8504 sumf2= sumf2+ fracrefbo(iprsm)
8505 enddo
8506 fracrefa(igc) = sumf1
8507 fracrefb(igc) = sumf2
8508 enddo
8510 end subroutine cmbgb2
8512 !***************************************************************************
8513 subroutine cmbgb3
8514 !***************************************************************************
8515 !
8516 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
8517 ! (high key - h2o,co2; high minor - n2o)
8518 !
8519 ! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
8520 !***************************************************************************
8522 use parrrtm, only : mg, nbndlw, ngptlw, ng3
8523 use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
8524 selfrefo, forrefo, &
8525 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, &
8526 selfref, forref
8528 ! ------- Local -------
8529 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8530 real(kind=rb) :: sumk, sumf
8533 do jn = 1,9
8534 do jt = 1,5
8535 do jp = 1,13
8536 iprsm = 0
8537 do igc = 1,ngc(3)
8538 sumk = 0.
8539 do ipr = 1, ngn(ngs(2)+igc)
8540 iprsm = iprsm + 1
8541 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8542 enddo
8543 ka(jn,jt,jp,igc) = sumk
8544 enddo
8545 enddo
8546 enddo
8547 enddo
8548 do jn = 1,5
8549 do jt = 1,5
8550 do jp = 13,59
8551 iprsm = 0
8552 do igc = 1,ngc(3)
8553 sumk = 0.
8554 do ipr = 1, ngn(ngs(2)+igc)
8555 iprsm = iprsm + 1
8556 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8557 enddo
8558 kb(jn,jt,jp,igc) = sumk
8559 enddo
8560 enddo
8561 enddo
8562 enddo
8564 do jn = 1,9
8565 do jt = 1,19
8566 iprsm = 0
8567 do igc = 1,ngc(3)
8568 sumk = 0.
8569 do ipr = 1, ngn(ngs(2)+igc)
8570 iprsm = iprsm + 1
8571 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8572 enddo
8573 ka_mn2o(jn,jt,igc) = sumk
8574 enddo
8575 enddo
8576 enddo
8578 do jn = 1,5
8579 do jt = 1,19
8580 iprsm = 0
8581 do igc = 1,ngc(3)
8582 sumk = 0.
8583 do ipr = 1, ngn(ngs(2)+igc)
8584 iprsm = iprsm + 1
8585 sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8586 enddo
8587 kb_mn2o(jn,jt,igc) = sumk
8588 enddo
8589 enddo
8590 enddo
8592 do jt = 1,10
8593 iprsm = 0
8594 do igc = 1,ngc(3)
8595 sumk = 0.
8596 do ipr = 1, ngn(ngs(2)+igc)
8597 iprsm = iprsm + 1
8598 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
8599 enddo
8600 selfref(jt,igc) = sumk
8601 enddo
8602 enddo
8604 do jt = 1,4
8605 iprsm = 0
8606 do igc = 1,ngc(3)
8607 sumk = 0.
8608 do ipr = 1, ngn(ngs(2)+igc)
8609 iprsm = iprsm + 1
8610 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
8611 enddo
8612 forref(jt,igc) = sumk
8613 enddo
8614 enddo
8616 do jp = 1,9
8617 iprsm = 0
8618 do igc = 1,ngc(3)
8619 sumf = 0.
8620 do ipr = 1, ngn(ngs(2)+igc)
8621 iprsm = iprsm + 1
8622 sumf = sumf + fracrefao(iprsm,jp)
8623 enddo
8624 fracrefa(igc,jp) = sumf
8625 enddo
8626 enddo
8628 do jp = 1,5
8629 iprsm = 0
8630 do igc = 1,ngc(3)
8631 sumf = 0.
8632 do ipr = 1, ngn(ngs(2)+igc)
8633 iprsm = iprsm + 1
8634 sumf = sumf + fracrefbo(iprsm,jp)
8635 enddo
8636 fracrefb(igc,jp) = sumf
8637 enddo
8638 enddo
8640 end subroutine cmbgb3
8642 !***************************************************************************
8643 subroutine cmbgb4
8644 !***************************************************************************
8645 !
8646 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
8647 !
8648 ! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
8649 !***************************************************************************
8651 use parrrtm, only : mg, nbndlw, ngptlw, ng4
8652 use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8653 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8655 ! ------- Local -------
8656 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8657 real(kind=rb) :: sumk, sumf
8660 do jn = 1,9
8661 do jt = 1,5
8662 do jp = 1,13
8663 iprsm = 0
8664 do igc = 1,ngc(4)
8665 sumk = 0.
8666 do ipr = 1, ngn(ngs(3)+igc)
8667 iprsm = iprsm + 1
8668 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8669 enddo
8670 ka(jn,jt,jp,igc) = sumk
8671 enddo
8672 enddo
8673 enddo
8674 enddo
8675 do jn = 1,5
8676 do jt = 1,5
8677 do jp = 13,59
8678 iprsm = 0
8679 do igc = 1,ngc(4)
8680 sumk = 0.
8681 do ipr = 1, ngn(ngs(3)+igc)
8682 iprsm = iprsm + 1
8683 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8684 enddo
8685 kb(jn,jt,jp,igc) = sumk
8686 enddo
8687 enddo
8688 enddo
8689 enddo
8691 do jt = 1,10
8692 iprsm = 0
8693 do igc = 1,ngc(4)
8694 sumk = 0.
8695 do ipr = 1, ngn(ngs(3)+igc)
8696 iprsm = iprsm + 1
8697 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
8698 enddo
8699 selfref(jt,igc) = sumk
8700 enddo
8701 enddo
8703 do jt = 1,4
8704 iprsm = 0
8705 do igc = 1,ngc(4)
8706 sumk = 0.
8707 do ipr = 1, ngn(ngs(3)+igc)
8708 iprsm = iprsm + 1
8709 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
8710 enddo
8711 forref(jt,igc) = sumk
8712 enddo
8713 enddo
8715 do jp = 1,9
8716 iprsm = 0
8717 do igc = 1,ngc(4)
8718 sumf = 0.
8719 do ipr = 1, ngn(ngs(3)+igc)
8720 iprsm = iprsm + 1
8721 sumf = sumf + fracrefao(iprsm,jp)
8722 enddo
8723 fracrefa(igc,jp) = sumf
8724 enddo
8725 enddo
8727 do jp = 1,5
8728 iprsm = 0
8729 do igc = 1,ngc(4)
8730 sumf = 0.
8731 do ipr = 1, ngn(ngs(3)+igc)
8732 iprsm = iprsm + 1
8733 sumf = sumf + fracrefbo(iprsm,jp)
8734 enddo
8735 fracrefb(igc,jp) = sumf
8736 enddo
8737 enddo
8739 end subroutine cmbgb4
8741 !***************************************************************************
8742 subroutine cmbgb5
8743 !***************************************************************************
8744 !
8745 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
8746 ! (high key - o3,co2)
8747 !
8748 ! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
8749 !***************************************************************************
8751 use parrrtm, only : mg, nbndlw, ngptlw, ng5
8752 use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
8753 selfrefo, forrefo, &
8754 fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
8755 selfref, forref
8757 ! ------- Local -------
8758 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8759 real(kind=rb) :: sumk, sumf
8762 do jn = 1,9
8763 do jt = 1,5
8764 do jp = 1,13
8765 iprsm = 0
8766 do igc = 1,ngc(5)
8767 sumk = 0.
8768 do ipr = 1, ngn(ngs(4)+igc)
8769 iprsm = iprsm + 1
8770 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8771 enddo
8772 ka(jn,jt,jp,igc) = sumk
8773 enddo
8774 enddo
8775 enddo
8776 enddo
8777 do jn = 1,5
8778 do jt = 1,5
8779 do jp = 13,59
8780 iprsm = 0
8781 do igc = 1,ngc(5)
8782 sumk = 0.
8783 do ipr = 1, ngn(ngs(4)+igc)
8784 iprsm = iprsm + 1
8785 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8786 enddo
8787 kb(jn,jt,jp,igc) = sumk
8788 enddo
8789 enddo
8790 enddo
8791 enddo
8793 do jn = 1,9
8794 do jt = 1,19
8795 iprsm = 0
8796 do igc = 1,ngc(5)
8797 sumk = 0.
8798 do ipr = 1, ngn(ngs(4)+igc)
8799 iprsm = iprsm + 1
8800 sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
8801 enddo
8802 ka_mo3(jn,jt,igc) = sumk
8803 enddo
8804 enddo
8805 enddo
8807 do jt = 1,10
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 + selfrefo(jt,iprsm)*rwgt(iprsm+64)
8814 enddo
8815 selfref(jt,igc) = sumk
8816 enddo
8817 enddo
8819 do jt = 1,4
8820 iprsm = 0
8821 do igc = 1,ngc(5)
8822 sumk = 0.
8823 do ipr = 1, ngn(ngs(4)+igc)
8824 iprsm = iprsm + 1
8825 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
8826 enddo
8827 forref(jt,igc) = sumk
8828 enddo
8829 enddo
8831 do jp = 1,9
8832 iprsm = 0
8833 do igc = 1,ngc(5)
8834 sumf = 0.
8835 do ipr = 1, ngn(ngs(4)+igc)
8836 iprsm = iprsm + 1
8837 sumf = sumf + fracrefao(iprsm,jp)
8838 enddo
8839 fracrefa(igc,jp) = sumf
8840 enddo
8841 enddo
8843 do jp = 1,5
8844 iprsm = 0
8845 do igc = 1,ngc(5)
8846 sumf = 0.
8847 do ipr = 1, ngn(ngs(4)+igc)
8848 iprsm = iprsm + 1
8849 sumf = sumf + fracrefbo(iprsm,jp)
8850 enddo
8851 fracrefb(igc,jp) = sumf
8852 enddo
8853 enddo
8855 iprsm = 0
8856 do igc = 1,ngc(5)
8857 sumk = 0.
8858 do ipr = 1, ngn(ngs(4)+igc)
8859 iprsm = iprsm + 1
8860 sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
8861 enddo
8862 ccl4(igc) = sumk
8863 enddo
8865 end subroutine cmbgb5
8867 !***************************************************************************
8868 subroutine cmbgb6
8869 !***************************************************************************
8870 !
8871 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
8872 ! (high key - nothing; high minor - cfc11, cfc12)
8873 !
8874 ! old band 6: 820-980 cm-1 (low - h2o; high - nothing)
8875 !***************************************************************************
8877 use parrrtm, only : mg, nbndlw, ngptlw
8878 ! use parrrtm, only : mg, nbndlw, ngptlw, ng6
8879 use rrlw_kg06
8880 ! use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
8881 ! selfrefo, forrefo, &
8882 ! fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, &
8883 ! selfref, forref
8885 ! ------- Local -------
8886 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8887 real(kind=rb) :: sumk, sumf, sumk1, sumk2
8890 do jt = 1,5
8891 do jp = 1,13
8892 iprsm = 0
8893 do igc = 1,ngc(6)
8894 sumk = 0.
8895 do ipr = 1, ngn(ngs(5)+igc)
8896 iprsm = iprsm + 1
8897 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
8898 enddo
8899 ka(jt,jp,igc) = sumk
8900 enddo
8901 enddo
8902 enddo
8904 do jt = 1,19
8905 iprsm = 0
8906 do igc = 1,ngc(6)
8907 sumk = 0.
8908 do ipr = 1, ngn(ngs(5)+igc)
8909 iprsm = iprsm + 1
8910 sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
8911 enddo
8912 ka_mco2(jt,igc) = sumk
8913 enddo
8914 enddo
8916 do jt = 1,10
8917 iprsm = 0
8918 do igc = 1,ngc(6)
8919 sumk = 0.
8920 do ipr = 1, ngn(ngs(5)+igc)
8921 iprsm = iprsm + 1
8922 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
8923 enddo
8924 selfref(jt,igc) = sumk
8925 enddo
8926 enddo
8928 do jt = 1,4
8929 iprsm = 0
8930 do igc = 1,ngc(6)
8931 sumk = 0.
8932 do ipr = 1, ngn(ngs(5)+igc)
8933 iprsm = iprsm + 1
8934 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
8935 enddo
8936 forref(jt,igc) = sumk
8937 enddo
8938 enddo
8940 iprsm = 0
8941 do igc = 1,ngc(6)
8942 sumf = 0.
8943 sumk1= 0.
8944 sumk2= 0.
8945 do ipr = 1, ngn(ngs(5)+igc)
8946 iprsm = iprsm + 1
8947 sumf = sumf + fracrefao(iprsm)
8948 sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
8949 sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
8950 enddo
8951 fracrefa(igc) = sumf
8952 cfc11adj(igc) = sumk1
8953 cfc12(igc) = sumk2
8954 enddo
8956 end subroutine cmbgb6
8958 !***************************************************************************
8959 subroutine cmbgb7
8960 !***************************************************************************
8961 !
8962 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
8963 ! (high key - o3; high minor - co2)
8964 !
8965 ! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
8966 !***************************************************************************
8968 use parrrtm, only : mg, nbndlw, ngptlw, ng7
8969 use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
8970 selfrefo, forrefo, &
8971 fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, &
8972 selfref, forref
8974 ! ------- Local -------
8975 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8976 real(kind=rb) :: sumk, sumf
8979 do jn = 1,9
8980 do jt = 1,5
8981 do jp = 1,13
8982 iprsm = 0
8983 do igc = 1,ngc(7)
8984 sumk = 0.
8985 do ipr = 1, ngn(ngs(6)+igc)
8986 iprsm = iprsm + 1
8987 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
8988 enddo
8989 ka(jn,jt,jp,igc) = sumk
8990 enddo
8991 enddo
8992 enddo
8993 enddo
8994 do jt = 1,5
8995 do jp = 13,59
8996 iprsm = 0
8997 do igc = 1,ngc(7)
8998 sumk = 0.
8999 do ipr = 1, ngn(ngs(6)+igc)
9000 iprsm = iprsm + 1
9001 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
9002 enddo
9003 kb(jt,jp,igc) = sumk
9004 enddo
9005 enddo
9006 enddo
9008 do jn = 1,9
9009 do jt = 1,19
9010 iprsm = 0
9011 do igc = 1,ngc(7)
9012 sumk = 0.
9013 do ipr = 1, ngn(ngs(6)+igc)
9014 iprsm = iprsm + 1
9015 sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
9016 enddo
9017 ka_mco2(jn,jt,igc) = sumk
9018 enddo
9019 enddo
9020 enddo
9022 do jt = 1,19
9023 iprsm = 0
9024 do igc = 1,ngc(7)
9025 sumk = 0.
9026 do ipr = 1, ngn(ngs(6)+igc)
9027 iprsm = iprsm + 1
9028 sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
9029 enddo
9030 kb_mco2(jt,igc) = sumk
9031 enddo
9032 enddo
9034 do jt = 1,10
9035 iprsm = 0
9036 do igc = 1,ngc(7)
9037 sumk = 0.
9038 do ipr = 1, ngn(ngs(6)+igc)
9039 iprsm = iprsm + 1
9040 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
9041 enddo
9042 selfref(jt,igc) = sumk
9043 enddo
9044 enddo
9046 do jt = 1,4
9047 iprsm = 0
9048 do igc = 1,ngc(7)
9049 sumk = 0.
9050 do ipr = 1, ngn(ngs(6)+igc)
9051 iprsm = iprsm + 1
9052 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
9053 enddo
9054 forref(jt,igc) = sumk
9055 enddo
9056 enddo
9058 do jp = 1,9
9059 iprsm = 0
9060 do igc = 1,ngc(7)
9061 sumf = 0.
9062 do ipr = 1, ngn(ngs(6)+igc)
9063 iprsm = iprsm + 1
9064 sumf = sumf + fracrefao(iprsm,jp)
9065 enddo
9066 fracrefa(igc,jp) = sumf
9067 enddo
9068 enddo
9070 iprsm = 0
9071 do igc = 1,ngc(7)
9072 sumf = 0.
9073 do ipr = 1, ngn(ngs(6)+igc)
9074 iprsm = iprsm + 1
9075 sumf = sumf + fracrefbo(iprsm)
9076 enddo
9077 fracrefb(igc) = sumf
9078 enddo
9080 end subroutine cmbgb7
9082 !***************************************************************************
9083 subroutine cmbgb8
9084 !***************************************************************************
9085 !
9086 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
9087 ! (high key - o3; high minor - co2, n2o)
9088 !
9089 ! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
9090 !***************************************************************************
9092 use parrrtm, only : mg, nbndlw, ngptlw, ng8
9093 use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
9094 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
9095 cfc12o, cfc22adjo, &
9096 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, &
9097 ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, &
9098 cfc12, cfc22adj
9100 ! ------- Local -------
9101 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9102 real(kind=rb) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
9105 do jt = 1,5
9106 do jp = 1,13
9107 iprsm = 0
9108 do igc = 1,ngc(8)
9109 sumk = 0.
9110 do ipr = 1, ngn(ngs(7)+igc)
9111 iprsm = iprsm + 1
9112 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
9113 enddo
9114 ka(jt,jp,igc) = sumk
9115 enddo
9116 enddo
9117 enddo
9118 do jt = 1,5
9119 do jp = 13,59
9120 iprsm = 0
9121 do igc = 1,ngc(8)
9122 sumk = 0.
9123 do ipr = 1, ngn(ngs(7)+igc)
9124 iprsm = iprsm + 1
9125 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
9126 enddo
9127 kb(jt,jp,igc) = sumk
9128 enddo
9129 enddo
9130 enddo
9132 do jt = 1,10
9133 iprsm = 0
9134 do igc = 1,ngc(8)
9135 sumk = 0.
9136 do ipr = 1, ngn(ngs(7)+igc)
9137 iprsm = iprsm + 1
9138 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
9139 enddo
9140 selfref(jt,igc) = sumk
9141 enddo
9142 enddo
9144 do jt = 1,4
9145 iprsm = 0
9146 do igc = 1,ngc(8)
9147 sumk = 0.
9148 do ipr = 1, ngn(ngs(7)+igc)
9149 iprsm = iprsm + 1
9150 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
9151 enddo
9152 forref(jt,igc) = sumk
9153 enddo
9154 enddo
9156 do jt = 1,19
9157 iprsm = 0
9158 do igc = 1,ngc(8)
9159 sumk1 = 0.
9160 sumk2 = 0.
9161 sumk3 = 0.
9162 sumk4 = 0.
9163 sumk5 = 0.
9164 do ipr = 1, ngn(ngs(7)+igc)
9165 iprsm = iprsm + 1
9166 sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
9167 sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
9168 sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
9169 sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
9170 sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
9171 enddo
9172 ka_mco2(jt,igc) = sumk1
9173 kb_mco2(jt,igc) = sumk2
9174 ka_mo3(jt,igc) = sumk3
9175 ka_mn2o(jt,igc) = sumk4
9176 kb_mn2o(jt,igc) = sumk5
9177 enddo
9178 enddo
9180 iprsm = 0
9181 do igc = 1,ngc(8)
9182 sumf1= 0.
9183 sumf2= 0.
9184 sumk1= 0.
9185 sumk2= 0.
9186 do ipr = 1, ngn(ngs(7)+igc)
9187 iprsm = iprsm + 1
9188 sumf1= sumf1+ fracrefao(iprsm)
9189 sumf2= sumf2+ fracrefbo(iprsm)
9190 sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
9191 sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
9192 enddo
9193 fracrefa(igc) = sumf1
9194 fracrefb(igc) = sumf2
9195 cfc12(igc) = sumk1
9196 cfc22adj(igc) = sumk2
9197 enddo
9199 end subroutine cmbgb8
9201 !***************************************************************************
9202 subroutine cmbgb9
9203 !***************************************************************************
9204 !
9205 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
9206 ! (high key - ch4; high minor - n2o)!
9208 ! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
9209 !***************************************************************************
9211 use parrrtm, only : mg, nbndlw, ngptlw, ng9
9212 use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, &
9213 kbo, kbo_mn2o, selfrefo, forrefo, &
9214 fracrefa, fracrefb, absa, ka, ka_mn2o, &
9215 absb, kb, kb_mn2o, selfref, forref
9217 ! ------- Local -------
9218 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9219 real(kind=rb) :: sumk, sumf
9222 do jn = 1,9
9223 do jt = 1,5
9224 do jp = 1,13
9225 iprsm = 0
9226 do igc = 1,ngc(9)
9227 sumk = 0.
9228 do ipr = 1, ngn(ngs(8)+igc)
9229 iprsm = iprsm + 1
9230 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
9231 enddo
9232 ka(jn,jt,jp,igc) = sumk
9233 enddo
9234 enddo
9235 enddo
9236 enddo
9238 do jt = 1,5
9239 do jp = 13,59
9240 iprsm = 0
9241 do igc = 1,ngc(9)
9242 sumk = 0.
9243 do ipr = 1, ngn(ngs(8)+igc)
9244 iprsm = iprsm + 1
9245 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
9246 enddo
9247 kb(jt,jp,igc) = sumk
9248 enddo
9249 enddo
9250 enddo
9252 do jn = 1,9
9253 do jt = 1,19
9254 iprsm = 0
9255 do igc = 1,ngc(9)
9256 sumk = 0.
9257 do ipr = 1, ngn(ngs(8)+igc)
9258 iprsm = iprsm + 1
9259 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
9260 enddo
9261 ka_mn2o(jn,jt,igc) = sumk
9262 enddo
9263 enddo
9264 enddo
9266 do jt = 1,19
9267 iprsm = 0
9268 do igc = 1,ngc(9)
9269 sumk = 0.
9270 do ipr = 1, ngn(ngs(8)+igc)
9271 iprsm = iprsm + 1
9272 sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
9273 enddo
9274 kb_mn2o(jt,igc) = sumk
9275 enddo
9276 enddo
9278 do jt = 1,10
9279 iprsm = 0
9280 do igc = 1,ngc(9)
9281 sumk = 0.
9282 do ipr = 1, ngn(ngs(8)+igc)
9283 iprsm = iprsm + 1
9284 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
9285 enddo
9286 selfref(jt,igc) = sumk
9287 enddo
9288 enddo
9290 do jt = 1,4
9291 iprsm = 0
9292 do igc = 1,ngc(9)
9293 sumk = 0.
9294 do ipr = 1, ngn(ngs(8)+igc)
9295 iprsm = iprsm + 1
9296 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
9297 enddo
9298 forref(jt,igc) = sumk
9299 enddo
9300 enddo
9302 do jp = 1,9
9303 iprsm = 0
9304 do igc = 1,ngc(9)
9305 sumf = 0.
9306 do ipr = 1, ngn(ngs(8)+igc)
9307 iprsm = iprsm + 1
9308 sumf = sumf + fracrefao(iprsm,jp)
9309 enddo
9310 fracrefa(igc,jp) = sumf
9311 enddo
9312 enddo
9314 iprsm = 0
9315 do igc = 1,ngc(9)
9316 sumf = 0.
9317 do ipr = 1, ngn(ngs(8)+igc)
9318 iprsm = iprsm + 1
9319 sumf = sumf + fracrefbo(iprsm)
9320 enddo
9321 fracrefb(igc) = sumf
9322 enddo
9324 end subroutine cmbgb9
9326 !***************************************************************************
9327 subroutine cmbgb10
9328 !***************************************************************************
9329 !
9330 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
9331 !
9332 ! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
9333 !***************************************************************************
9335 use parrrtm, only : mg, nbndlw, ngptlw, ng10
9336 use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, &
9337 selfrefo, forrefo, &
9338 fracrefa, fracrefb, absa, ka, absb, kb, &
9339 selfref, forref
9341 ! ------- Local -------
9342 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9343 real(kind=rb) :: sumk, sumf1, sumf2
9346 do jt = 1,5
9347 do jp = 1,13
9348 iprsm = 0
9349 do igc = 1,ngc(10)
9350 sumk = 0.
9351 do ipr = 1, ngn(ngs(9)+igc)
9352 iprsm = iprsm + 1
9353 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
9354 enddo
9355 ka(jt,jp,igc) = sumk
9356 enddo
9357 enddo
9358 enddo
9360 do jt = 1,5
9361 do jp = 13,59
9362 iprsm = 0
9363 do igc = 1,ngc(10)
9364 sumk = 0.
9365 do ipr = 1, ngn(ngs(9)+igc)
9366 iprsm = iprsm + 1
9367 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
9368 enddo
9369 kb(jt,jp,igc) = sumk
9370 enddo
9371 enddo
9372 enddo
9374 do jt = 1,10
9375 iprsm = 0
9376 do igc = 1,ngc(10)
9377 sumk = 0.
9378 do ipr = 1, ngn(ngs(9)+igc)
9379 iprsm = iprsm + 1
9380 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
9381 enddo
9382 selfref(jt,igc) = sumk
9383 enddo
9384 enddo
9386 do jt = 1,4
9387 iprsm = 0
9388 do igc = 1,ngc(10)
9389 sumk = 0.
9390 do ipr = 1, ngn(ngs(9)+igc)
9391 iprsm = iprsm + 1
9392 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
9393 enddo
9394 forref(jt,igc) = sumk
9395 enddo
9396 enddo
9398 iprsm = 0
9399 do igc = 1,ngc(10)
9400 sumf1= 0.
9401 sumf2= 0.
9402 do ipr = 1, ngn(ngs(9)+igc)
9403 iprsm = iprsm + 1
9404 sumf1= sumf1+ fracrefao(iprsm)
9405 sumf2= sumf2+ fracrefbo(iprsm)
9406 enddo
9407 fracrefa(igc) = sumf1
9408 fracrefb(igc) = sumf2
9409 enddo
9411 end subroutine cmbgb10
9413 !***************************************************************************
9414 subroutine cmbgb11
9415 !***************************************************************************
9416 !
9417 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9418 ! (high key - h2o; high minor - o2)
9419 !
9420 ! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9421 ! (high key - h2o; high minor - o2)
9422 !***************************************************************************
9424 use parrrtm, only : mg, nbndlw, ngptlw, ng11
9425 use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, &
9426 kbo, kbo_mo2, selfrefo, forrefo, &
9427 fracrefa, fracrefb, absa, ka, ka_mo2, &
9428 absb, kb, kb_mo2, selfref, forref
9430 ! ------- Local -------
9431 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9432 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
9435 do jt = 1,5
9436 do jp = 1,13
9437 iprsm = 0
9438 do igc = 1,ngc(11)
9439 sumk = 0.
9440 do ipr = 1, ngn(ngs(10)+igc)
9441 iprsm = iprsm + 1
9442 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
9443 enddo
9444 ka(jt,jp,igc) = sumk
9445 enddo
9446 enddo
9447 enddo
9448 do jt = 1,5
9449 do jp = 13,59
9450 iprsm = 0
9451 do igc = 1,ngc(11)
9452 sumk = 0.
9453 do ipr = 1, ngn(ngs(10)+igc)
9454 iprsm = iprsm + 1
9455 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
9456 enddo
9457 kb(jt,jp,igc) = sumk
9458 enddo
9459 enddo
9460 enddo
9462 do jt = 1,19
9463 iprsm = 0
9464 do igc = 1,ngc(11)
9465 sumk1 = 0.
9466 sumk2 = 0.
9467 do ipr = 1, ngn(ngs(10)+igc)
9468 iprsm = iprsm + 1
9469 sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
9470 sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
9471 enddo
9472 ka_mo2(jt,igc) = sumk1
9473 kb_mo2(jt,igc) = sumk2
9474 enddo
9475 enddo
9477 do jt = 1,10
9478 iprsm = 0
9479 do igc = 1,ngc(11)
9480 sumk = 0.
9481 do ipr = 1, ngn(ngs(10)+igc)
9482 iprsm = iprsm + 1
9483 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
9484 enddo
9485 selfref(jt,igc) = sumk
9486 enddo
9487 enddo
9489 do jt = 1,4
9490 iprsm = 0
9491 do igc = 1,ngc(11)
9492 sumk = 0.
9493 do ipr = 1, ngn(ngs(10)+igc)
9494 iprsm = iprsm + 1
9495 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
9496 enddo
9497 forref(jt,igc) = sumk
9498 enddo
9499 enddo
9501 iprsm = 0
9502 do igc = 1,ngc(11)
9503 sumf1= 0.
9504 sumf2= 0.
9505 do ipr = 1, ngn(ngs(10)+igc)
9506 iprsm = iprsm + 1
9507 sumf1= sumf1+ fracrefao(iprsm)
9508 sumf2= sumf2+ fracrefbo(iprsm)
9509 enddo
9510 fracrefa(igc) = sumf1
9511 fracrefb(igc) = sumf2
9512 enddo
9514 end subroutine cmbgb11
9516 !***************************************************************************
9517 subroutine cmbgb12
9518 !***************************************************************************
9519 !
9520 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9521 !
9522 ! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9523 !***************************************************************************
9525 use parrrtm, only : mg, nbndlw, ngptlw, ng12
9526 use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, &
9527 fracrefa, absa, ka, selfref, forref
9529 ! ------- Local -------
9530 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9531 real(kind=rb) :: sumk, sumf
9534 do jn = 1,9
9535 do jt = 1,5
9536 do jp = 1,13
9537 iprsm = 0
9538 do igc = 1,ngc(12)
9539 sumk = 0.
9540 do ipr = 1, ngn(ngs(11)+igc)
9541 iprsm = iprsm + 1
9542 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
9543 enddo
9544 ka(jn,jt,jp,igc) = sumk
9545 enddo
9546 enddo
9547 enddo
9548 enddo
9550 do jt = 1,10
9551 iprsm = 0
9552 do igc = 1,ngc(12)
9553 sumk = 0.
9554 do ipr = 1, ngn(ngs(11)+igc)
9555 iprsm = iprsm + 1
9556 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
9557 enddo
9558 selfref(jt,igc) = sumk
9559 enddo
9560 enddo
9562 do jt = 1,4
9563 iprsm = 0
9564 do igc = 1,ngc(12)
9565 sumk = 0.
9566 do ipr = 1, ngn(ngs(11)+igc)
9567 iprsm = iprsm + 1
9568 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
9569 enddo
9570 forref(jt,igc) = sumk
9571 enddo
9572 enddo
9574 do jp = 1,9
9575 iprsm = 0
9576 do igc = 1,ngc(12)
9577 sumf = 0.
9578 do ipr = 1, ngn(ngs(11)+igc)
9579 iprsm = iprsm + 1
9580 sumf = sumf + fracrefao(iprsm,jp)
9581 enddo
9582 fracrefa(igc,jp) = sumf
9583 enddo
9584 enddo
9586 end subroutine cmbgb12
9588 !***************************************************************************
9589 subroutine cmbgb13
9590 !***************************************************************************
9591 !
9592 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
9593 !
9594 ! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
9595 !***************************************************************************
9597 use parrrtm, only : mg, nbndlw, ngptlw, ng13
9598 use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
9599 kbo_mo3, selfrefo, forrefo, &
9600 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, &
9601 kb_mo3, selfref, forref
9603 ! ------- Local -------
9604 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9605 real(kind=rb) :: sumk, sumk1, sumk2, sumf
9608 do jn = 1,9
9609 do jt = 1,5
9610 do jp = 1,13
9611 iprsm = 0
9612 do igc = 1,ngc(13)
9613 sumk = 0.
9614 do ipr = 1, ngn(ngs(12)+igc)
9615 iprsm = iprsm + 1
9616 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
9617 enddo
9618 ka(jn,jt,jp,igc) = sumk
9619 enddo
9620 enddo
9621 enddo
9622 enddo
9624 do jn = 1,9
9625 do jt = 1,19
9626 iprsm = 0
9627 do igc = 1,ngc(13)
9628 sumk1 = 0.
9629 sumk2 = 0.
9630 do ipr = 1, ngn(ngs(12)+igc)
9631 iprsm = iprsm + 1
9632 sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
9633 sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
9634 enddo
9635 ka_mco2(jn,jt,igc) = sumk1
9636 ka_mco(jn,jt,igc) = sumk2
9637 enddo
9638 enddo
9639 enddo
9641 do jt = 1,19
9642 iprsm = 0
9643 do igc = 1,ngc(13)
9644 sumk = 0.
9645 do ipr = 1, ngn(ngs(12)+igc)
9646 iprsm = iprsm + 1
9647 sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
9648 enddo
9649 kb_mo3(jt,igc) = sumk
9650 enddo
9651 enddo
9653 do jt = 1,10
9654 iprsm = 0
9655 do igc = 1,ngc(13)
9656 sumk = 0.
9657 do ipr = 1, ngn(ngs(12)+igc)
9658 iprsm = iprsm + 1
9659 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
9660 enddo
9661 selfref(jt,igc) = sumk
9662 enddo
9663 enddo
9665 do jt = 1,4
9666 iprsm = 0
9667 do igc = 1,ngc(13)
9668 sumk = 0.
9669 do ipr = 1, ngn(ngs(12)+igc)
9670 iprsm = iprsm + 1
9671 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
9672 enddo
9673 forref(jt,igc) = sumk
9674 enddo
9675 enddo
9677 iprsm = 0
9678 do igc = 1,ngc(13)
9679 sumf = 0.
9680 do ipr = 1, ngn(ngs(12)+igc)
9681 iprsm = iprsm + 1
9682 sumf = sumf + fracrefbo(iprsm)
9683 enddo
9684 fracrefb(igc) = sumf
9685 enddo
9687 do jp = 1,9
9688 iprsm = 0
9689 do igc = 1,ngc(13)
9690 sumf = 0.
9691 do ipr = 1, ngn(ngs(12)+igc)
9692 iprsm = iprsm + 1
9693 sumf = sumf + fracrefao(iprsm,jp)
9694 enddo
9695 fracrefa(igc,jp) = sumf
9696 enddo
9697 enddo
9699 end subroutine cmbgb13
9701 !***************************************************************************
9702 subroutine cmbgb14
9703 !***************************************************************************
9704 !
9705 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
9706 !
9707 ! old band 14: 2250-2380 cm-1 (low - co2; high - co2)
9708 !***************************************************************************
9710 use parrrtm, only : mg, nbndlw, ngptlw, ng14
9711 use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, &
9712 selfrefo, forrefo, &
9713 fracrefa, fracrefb, absa, ka, absb, kb, &
9714 selfref, forref
9716 ! ------- Local -------
9717 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9718 real(kind=rb) :: sumk, sumf1, sumf2
9721 do jt = 1,5
9722 do jp = 1,13
9723 iprsm = 0
9724 do igc = 1,ngc(14)
9725 sumk = 0.
9726 do ipr = 1, ngn(ngs(13)+igc)
9727 iprsm = iprsm + 1
9728 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
9729 enddo
9730 ka(jt,jp,igc) = sumk
9731 enddo
9732 enddo
9733 enddo
9735 do jt = 1,5
9736 do jp = 13,59
9737 iprsm = 0
9738 do igc = 1,ngc(14)
9739 sumk = 0.
9740 do ipr = 1, ngn(ngs(13)+igc)
9741 iprsm = iprsm + 1
9742 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
9743 enddo
9744 kb(jt,jp,igc) = sumk
9745 enddo
9746 enddo
9747 enddo
9749 do jt = 1,10
9750 iprsm = 0
9751 do igc = 1,ngc(14)
9752 sumk = 0.
9753 do ipr = 1, ngn(ngs(13)+igc)
9754 iprsm = iprsm + 1
9755 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
9756 enddo
9757 selfref(jt,igc) = sumk
9758 enddo
9759 enddo
9761 do jt = 1,4
9762 iprsm = 0
9763 do igc = 1,ngc(14)
9764 sumk = 0.
9765 do ipr = 1, ngn(ngs(13)+igc)
9766 iprsm = iprsm + 1
9767 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
9768 enddo
9769 forref(jt,igc) = sumk
9770 enddo
9771 enddo
9773 iprsm = 0
9774 do igc = 1,ngc(14)
9775 sumf1= 0.
9776 sumf2= 0.
9777 do ipr = 1, ngn(ngs(13)+igc)
9778 iprsm = iprsm + 1
9779 sumf1= sumf1+ fracrefao(iprsm)
9780 sumf2= sumf2+ fracrefbo(iprsm)
9781 enddo
9782 fracrefa(igc) = sumf1
9783 fracrefb(igc) = sumf2
9784 enddo
9786 end subroutine cmbgb14
9788 !***************************************************************************
9789 subroutine cmbgb15
9790 !***************************************************************************
9791 !
9792 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
9793 ! (high - nothing)
9794 !
9795 ! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
9796 !***************************************************************************
9798 use parrrtm, only : mg, nbndlw, ngptlw, ng15
9799 use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
9800 fracrefa, absa, ka, ka_mn2, selfref, forref
9802 ! ------- Local -------
9803 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9804 real(kind=rb) :: sumk, sumf
9807 do jn = 1,9
9808 do jt = 1,5
9809 do jp = 1,13
9810 iprsm = 0
9811 do igc = 1,ngc(15)
9812 sumk = 0.
9813 do ipr = 1, ngn(ngs(14)+igc)
9814 iprsm = iprsm + 1
9815 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
9816 enddo
9817 ka(jn,jt,jp,igc) = sumk
9818 enddo
9819 enddo
9820 enddo
9821 enddo
9823 do jn = 1,9
9824 do jt = 1,19
9825 iprsm = 0
9826 do igc = 1,ngc(15)
9827 sumk = 0.
9828 do ipr = 1, ngn(ngs(14)+igc)
9829 iprsm = iprsm + 1
9830 sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
9831 enddo
9832 ka_mn2(jn,jt,igc) = sumk
9833 enddo
9834 enddo
9835 enddo
9837 do jt = 1,10
9838 iprsm = 0
9839 do igc = 1,ngc(15)
9840 sumk = 0.
9841 do ipr = 1, ngn(ngs(14)+igc)
9842 iprsm = iprsm + 1
9843 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
9844 enddo
9845 selfref(jt,igc) = sumk
9846 enddo
9847 enddo
9849 do jt = 1,4
9850 iprsm = 0
9851 do igc = 1,ngc(15)
9852 sumk = 0.
9853 do ipr = 1, ngn(ngs(14)+igc)
9854 iprsm = iprsm + 1
9855 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
9856 enddo
9857 forref(jt,igc) = sumk
9858 enddo
9859 enddo
9861 do jp = 1,9
9862 iprsm = 0
9863 do igc = 1,ngc(15)
9864 sumf = 0.
9865 do ipr = 1, ngn(ngs(14)+igc)
9866 iprsm = iprsm + 1
9867 sumf = sumf + fracrefao(iprsm,jp)
9868 enddo
9869 fracrefa(igc,jp) = sumf
9870 enddo
9871 enddo
9873 end subroutine cmbgb15
9875 !***************************************************************************
9876 subroutine cmbgb16
9877 !***************************************************************************
9878 !
9879 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
9880 !
9881 ! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
9882 !***************************************************************************
9884 use parrrtm, only : mg, nbndlw, ngptlw, ng16
9885 use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
9886 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
9888 ! ------- Local -------
9889 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9890 real(kind=rb) :: sumk, sumf
9893 do jn = 1,9
9894 do jt = 1,5
9895 do jp = 1,13
9896 iprsm = 0
9897 do igc = 1,ngc(16)
9898 sumk = 0.
9899 do ipr = 1, ngn(ngs(15)+igc)
9900 iprsm = iprsm + 1
9901 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
9902 enddo
9903 ka(jn,jt,jp,igc) = sumk
9904 enddo
9905 enddo
9906 enddo
9907 enddo
9909 do jt = 1,5
9910 do jp = 13,59
9911 iprsm = 0
9912 do igc = 1,ngc(16)
9913 sumk = 0.
9914 do ipr = 1, ngn(ngs(15)+igc)
9915 iprsm = iprsm + 1
9916 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
9917 enddo
9918 kb(jt,jp,igc) = sumk
9919 enddo
9920 enddo
9921 enddo
9923 do jt = 1,10
9924 iprsm = 0
9925 do igc = 1,ngc(16)
9926 sumk = 0.
9927 do ipr = 1, ngn(ngs(15)+igc)
9928 iprsm = iprsm + 1
9929 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
9930 enddo
9931 selfref(jt,igc) = sumk
9932 enddo
9933 enddo
9935 do jt = 1,4
9936 iprsm = 0
9937 do igc = 1,ngc(16)
9938 sumk = 0.
9939 do ipr = 1, ngn(ngs(15)+igc)
9940 iprsm = iprsm + 1
9941 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
9942 enddo
9943 forref(jt,igc) = sumk
9944 enddo
9945 enddo
9947 iprsm = 0
9948 do igc = 1,ngc(16)
9949 sumf = 0.
9950 do ipr = 1, ngn(ngs(15)+igc)
9951 iprsm = iprsm + 1
9952 sumf = sumf + fracrefbo(iprsm)
9953 enddo
9954 fracrefb(igc) = sumf
9955 enddo
9957 do jp = 1,9
9958 iprsm = 0
9959 do igc = 1,ngc(16)
9960 sumf = 0.
9961 do ipr = 1, ngn(ngs(15)+igc)
9962 iprsm = iprsm + 1
9963 sumf = sumf + fracrefao(iprsm,jp)
9964 enddo
9965 fracrefa(igc,jp) = sumf
9966 enddo
9967 enddo
9969 end subroutine cmbgb16
9971 !***************************************************************************
9972 subroutine lwcldpr
9973 !***************************************************************************
9975 ! --------- Modules ----------
9977 use rrlw_cld, only: abscld1, absliq0, absliq1, &
9978 absice0, absice1, absice2, absice3
9980 save
9982 ! ABSCLDn is the liquid water absorption coefficient (m2/g).
9983 ! For INFLAG = 1.
9984 abscld1 = 0.0602410_rb
9985 !
9986 ! Everything below is for INFLAG = 2.
9988 ! ABSICEn(J,IB) are the parameters needed to compute the liquid water
9989 ! absorption coefficient in spectral region IB for ICEFLAG=n. The units
9990 ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)).
9991 ! For ICEFLAG = 0.
9993 absice0(:)= (/0.005_rb, 1.0_rb/)
9995 ! For ICEFLAG = 1.
9996 absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/)
9997 absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /)
9999 ! For ICEFLAG = 2. In each band, the absorption
10000 ! coefficients are listed for a range of effective radii from 5.0
10001 ! to 131.0 microns in increments of 3.0 microns.
10002 ! Spherical Ice Particle Parameterization
10003 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10004 absice2(:,1) = (/ &
10005 ! band 1
10006 7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, &
10007 3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, &
10008 2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, &
10009 2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, &
10010 1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, &
10011 1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, &
10012 1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, &
10013 8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, &
10014 7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/)
10015 absice2(:,2) = (/ &
10016 ! band 2
10017 2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, &
10018 2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, &
10019 2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, &
10020 1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, &
10021 1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, &
10022 1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, &
10023 9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, &
10024 7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, &
10025 5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/)
10026 absice2(:,3) = (/ &
10027 ! band 3
10028 1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, &
10029 4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, &
10030 2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, &
10031 2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, &
10032 1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, &
10033 1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, &
10034 9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, &
10035 7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, &
10036 5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/)
10037 absice2(:,4) = (/ &
10038 ! band 4
10039 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, &
10040 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, &
10041 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, &
10042 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, &
10043 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, &
10044 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, &
10045 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, &
10046 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, &
10047 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/)
10048 absice2(:,5) = (/ &
10049 ! band 5
10050 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, &
10051 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, &
10052 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, &
10053 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, &
10054 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, &
10055 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, &
10056 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, &
10057 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, &
10058 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/)
10059 absice2(:,6) = (/ &
10060 ! band 6
10061 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, &
10062 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, &
10063 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, &
10064 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, &
10065 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, &
10066 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, &
10067 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, &
10068 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, &
10069 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/)
10070 absice2(:,7) = (/ &
10071 ! band 7
10072 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, &
10073 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, &
10074 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, &
10075 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, &
10076 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, &
10077 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, &
10078 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, &
10079 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, &
10080 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/)
10081 absice2(:,8) = (/ &
10082 ! band 8
10083 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, &
10084 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, &
10085 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, &
10086 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, &
10087 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, &
10088 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, &
10089 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, &
10090 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, &
10091 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/)
10092 absice2(:,9) = (/ &
10093 ! band 9
10094 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, &
10095 4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, &
10096 2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, &
10097 1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, &
10098 1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, &
10099 1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, &
10100 8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, &
10101 7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, &
10102 6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/)
10103 absice2(:,10) = (/ &
10104 ! band 10
10105 1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, &
10106 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, &
10107 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, &
10108 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, &
10109 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, &
10110 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, &
10111 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, &
10112 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, &
10113 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/)
10114 absice2(:,11) = (/ &
10115 ! band 11
10116 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, &
10117 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, &
10118 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, &
10119 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, &
10120 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, &
10121 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, &
10122 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, &
10123 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, &
10124 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/)
10125 absice2(:,12) = (/ &
10126 ! band 12
10127 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, &
10128 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, &
10129 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, &
10130 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, &
10131 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, &
10132 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, &
10133 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, &
10134 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, &
10135 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/)
10136 absice2(:,13) = (/ &
10137 ! band 13
10138 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, &
10139 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, &
10140 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, &
10141 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, &
10142 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, &
10143 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, &
10144 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, &
10145 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, &
10146 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/)
10147 absice2(:,14) = (/ &
10148 ! band 14
10149 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, &
10150 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, &
10151 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, &
10152 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, &
10153 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, &
10154 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, &
10155 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, &
10156 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, &
10157 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/)
10158 absice2(:,15) = (/ &
10159 ! band 15
10160 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, &
10161 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, &
10162 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, &
10163 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, &
10164 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, &
10165 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, &
10166 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, &
10167 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, &
10168 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/)
10169 absice2(:,16) = (/ &
10170 ! band 16
10171 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, &
10172 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, &
10173 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, &
10174 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, &
10175 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, &
10176 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, &
10177 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, &
10178 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, &
10179 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/)
10181 ! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in
10182 ! increments of 3 microns.
10183 ! units = m2/g
10184 ! Hexagonal Ice Particle Parameterization
10185 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10186 absice3(:,1) = (/ &
10187 ! band 1
10188 3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, &
10189 5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, &
10190 3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, &
10191 2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, &
10192 1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, &
10193 1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, &
10194 1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, &
10195 1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, &
10196 1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, &
10197 9.602126e-03_rb/)
10198 absice3(:,2) = (/ &
10199 ! band 2
10200 3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, &
10201 2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, &
10202 2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, &
10203 1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, &
10204 1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, &
10205 1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, &
10206 1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, &
10207 8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, &
10208 7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, &
10209 6.326424e-03_rb/)
10210 absice3(:,3) = (/ &
10211 ! band 3
10212 6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, &
10213 5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, &
10214 3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, &
10215 2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, &
10216 1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, &
10217 1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, &
10218 1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, &
10219 9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, &
10220 8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, &
10221 6.769036e-03_rb/)
10222 absice3(:,4) = (/ &
10223 ! band 4
10224 1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, &
10225 6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, &
10226 3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, &
10227 2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, &
10228 1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, &
10229 1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, &
10230 1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, &
10231 1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, &
10232 8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, &
10233 7.621418e-03_rb/)
10234 absice3(:,5) = (/ &
10235 ! band 5
10236 2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, &
10237 7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, &
10238 4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, &
10239 2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, &
10240 2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, &
10241 1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, &
10242 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, &
10243 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, &
10244 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, &
10245 7.890412e-03_rb/)
10246 absice3(:,6) = (/ &
10247 ! band 6
10248 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, &
10249 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, &
10250 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, &
10251 2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, &
10252 1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, &
10253 1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, &
10254 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, &
10255 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, &
10256 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, &
10257 8.114723e-03_rb/)
10258 absice3(:,7) = (/ &
10259 ! band 7
10260 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, &
10261 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, &
10262 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, &
10263 2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, &
10264 1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, &
10265 1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, &
10266 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, &
10267 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, &
10268 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, &
10269 7.026186e-03_rb/)
10270 absice3(:,8) = (/ &
10271 ! band 8
10272 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, &
10273 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, &
10274 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, &
10275 2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, &
10276 1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, &
10277 1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, &
10278 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, &
10279 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, &
10280 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, &
10281 7.060305e-03_rb/)
10282 absice3(:,9) = (/ &
10283 ! band 9
10284 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, &
10285 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, &
10286 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, &
10287 2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, &
10288 1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, &
10289 1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, &
10290 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, &
10291 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, &
10292 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, &
10293 7.964013e-03_rb/)
10294 absice3(:,10) = (/ &
10295 ! band 10
10296 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, &
10297 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, &
10298 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, &
10299 2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, &
10300 1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, &
10301 1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, &
10302 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, &
10303 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, &
10304 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, &
10305 8.442725e-03_rb/)
10306 absice3(:,11) = (/ &
10307 ! band 11
10308 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, &
10309 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, &
10310 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, &
10311 2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, &
10312 1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, &
10313 1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, &
10314 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, &
10315 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, &
10316 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, &
10317 8.422115e-03_rb/)
10318 absice3(:,12) = (/ &
10319 ! band 12
10320 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, &
10321 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, &
10322 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, &
10323 1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, &
10324 1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, &
10325 1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, &
10326 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, &
10327 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, &
10328 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, &
10329 7.947730e-03_rb/)
10330 absice3(:,13) = (/ &
10331 ! band 13
10332 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, &
10333 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, &
10334 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, &
10335 2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, &
10336 1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, &
10337 1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, &
10338 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, &
10339 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, &
10340 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, &
10341 8.652951e-03_rb/)
10342 absice3(:,14) = (/ &
10343 ! band 14
10344 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, &
10345 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, &
10346 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, &
10347 2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, &
10348 1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, &
10349 1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, &
10350 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, &
10351 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, &
10352 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, &
10353 8.785184e-03_rb/)
10354 absice3(:,15) = (/ &
10355 ! band 15
10356 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, &
10357 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, &
10358 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, &
10359 1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, &
10360 1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, &
10361 1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, &
10362 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, &
10363 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, &
10364 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, &
10365 8.560232e-03_rb/)
10366 absice3(:,16) = (/ &
10367 ! band 16
10368 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, &
10369 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, &
10370 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, &
10371 2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, &
10372 1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, &
10373 1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, &
10374 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, &
10375 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, &
10376 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, &
10377 8.123136e-03_rb/)
10379 ! For LIQFLAG = 0.
10380 absliq0 = 0.0903614_rb
10382 ! For LIQFLAG = 1. In each band, the absorption
10383 ! coefficients are listed for a range of effective radii from 2.5
10384 ! to 59.5 microns in increments of 1.0 micron.
10385 absliq1(:, 1) = (/ &
10386 ! band 1
10387 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, &
10388 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, &
10389 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, &
10390 5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, &
10391 4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, &
10392 3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, &
10393 3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, &
10394 2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, &
10395 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, &
10396 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, &
10397 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, &
10398 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/)
10399 absliq1(:, 2) = (/ &
10400 ! band 2
10401 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, &
10402 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, &
10403 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, &
10404 5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, &
10405 4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, &
10406 3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, &
10407 2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, &
10408 2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, &
10409 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, &
10410 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, &
10411 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, &
10412 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/)
10413 absliq1(:, 3) = (/ &
10414 ! band 3
10415 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, &
10416 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, &
10417 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, &
10418 5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, &
10419 4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, &
10420 3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, &
10421 2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, &
10422 2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, &
10423 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, &
10424 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, &
10425 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, &
10426 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/)
10427 absliq1(:, 4) = (/ &
10428 ! band 4
10429 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, &
10430 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, &
10431 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, &
10432 5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, &
10433 3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, &
10434 3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, &
10435 2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, &
10436 2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, &
10437 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, &
10438 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, &
10439 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, &
10440 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/)
10441 absliq1(:, 5) = (/ &
10442 ! band 5
10443 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, &
10444 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, &
10445 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, &
10446 5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, &
10447 3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, &
10448 3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, &
10449 2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, &
10450 2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, &
10451 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, &
10452 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, &
10453 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, &
10454 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/)
10455 absliq1(:, 6) = (/ &
10456 ! band 6
10457 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, &
10458 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, &
10459 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, &
10460 4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, &
10461 3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, &
10462 3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, &
10463 2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, &
10464 2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, &
10465 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, &
10466 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, &
10467 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, &
10468 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/)
10469 absliq1(:, 7) = (/ &
10470 ! band 7
10471 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, &
10472 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, &
10473 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, &
10474 4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, &
10475 3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, &
10476 2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, &
10477 2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, &
10478 2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, &
10479 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, &
10480 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, &
10481 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, &
10482 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/)
10483 absliq1(:, 8) = (/ &
10484 ! band 8
10485 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, &
10486 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, &
10487 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, &
10488 4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, &
10489 3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, &
10490 2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, &
10491 2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, &
10492 2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, &
10493 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, &
10494 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, &
10495 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, &
10496 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/)
10497 absliq1(:, 9) = (/ &
10498 ! band 9
10499 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, &
10500 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, &
10501 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, &
10502 4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, &
10503 3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, &
10504 2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, &
10505 2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, &
10506 2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, &
10507 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, &
10508 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, &
10509 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, &
10510 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/)
10511 absliq1(:,10) = (/ &
10512 ! band 10
10513 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, &
10514 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, &
10515 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, &
10516 4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, &
10517 3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, &
10518 2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, &
10519 2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, &
10520 2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, &
10521 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, &
10522 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, &
10523 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, &
10524 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/)
10525 absliq1(:,11) = (/ &
10526 ! band 11
10527 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, &
10528 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, &
10529 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, &
10530 4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, &
10531 3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, &
10532 2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, &
10533 2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, &
10534 2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, &
10535 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, &
10536 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, &
10537 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, &
10538 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/)
10539 absliq1(:,12) = (/ &
10540 ! band 12
10541 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, &
10542 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, &
10543 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, &
10544 2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, &
10545 2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, &
10546 2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, &
10547 1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, &
10548 1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, &
10549 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, &
10550 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, &
10551 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, &
10552 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/)
10553 absliq1(:,13) = (/ &
10554 ! band 13
10555 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, &
10556 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, &
10557 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, &
10558 3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, &
10559 2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, &
10560 2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, &
10561 2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, &
10562 1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, &
10563 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, &
10564 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, &
10565 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, &
10566 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/)
10567 absliq1(:,14) = (/ &
10568 ! band 14
10569 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, &
10570 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, &
10571 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, &
10572 2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, &
10573 2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, &
10574 2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, &
10575 1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, &
10576 1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, &
10577 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, &
10578 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, &
10579 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, &
10580 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/)
10581 absliq1(:,15) = (/ &
10582 ! band 15
10583 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, &
10584 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, &
10585 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, &
10586 1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, &
10587 1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, &
10588 1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, &
10589 1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, &
10590 1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, &
10591 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, &
10592 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, &
10593 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, &
10594 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/)
10595 absliq1(:,16) = (/ &
10596 ! band 16
10597 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, &
10598 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, &
10599 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, &
10600 2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, &
10601 2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, &
10602 2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, &
10603 1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, &
10604 1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, &
10605 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, &
10606 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, &
10607 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, &
10608 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/)
10610 end subroutine lwcldpr
10612 end module rrtmg_lw_init
10614 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
10615 ! author: $Author: trn $
10616 ! revision: $Revision: 1.3 $
10617 ! created: $Date: 2009/04/16 19:54:22 $
10618 !
10619 module rrtmg_lw_rad
10621 ! --------------------------------------------------------------------------
10622 ! | |
10623 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
10624 ! | This software may be used, copied, or redistributed as long as it is |
10625 ! | not sold and this copyright notice is reproduced on each copy made. |
10626 ! | This model is provided as is without any express or implied warranties. |
10627 ! | (http://www.rtweb.aer.com/) |
10628 ! | |
10629 ! --------------------------------------------------------------------------
10630 !
10631 ! ****************************************************************************
10632 ! * *
10633 ! * RRTMG_LW *
10634 ! * *
10635 ! * *
10636 ! * *
10637 ! * a rapid radiative transfer model *
10638 ! * for the longwave region *
10639 ! * for application to general circulation models *
10640 ! * *
10641 ! * *
10642 ! * Atmospheric and Environmental Research, Inc. *
10643 ! * 131 Hartwell Avenue *
10644 ! * Lexington, MA 02421 *
10645 ! * *
10646 ! * *
10647 ! * Eli J. Mlawer *
10648 ! * Jennifer S. Delamere *
10649 ! * Michael J. Iacono *
10650 ! * Shepard A. Clough *
10651 ! * *
10652 ! * *
10653 ! * *
10654 ! * *
10655 ! * *
10656 ! * *
10657 ! * email: miacono@aer.com *
10658 ! * email: emlawer@aer.com *
10659 ! * email: jdelamer@aer.com *
10660 ! * *
10661 ! * The authors wish to acknowledge the contributions of the *
10662 ! * following people: Steven J. Taubman, Karen Cady-Pereira, *
10663 ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
10664 ! * *
10665 ! ****************************************************************************
10667 ! -------- Modules --------
10668 use parkind, only : im => kind_im, rb => kind_rb
10669 use rrlw_vsn
10670 use mcica_subcol_gen_lw, only: mcica_subcol_lw
10671 use rrtmg_lw_cldprmc, only: cldprmc
10672 ! *** Move the required call to rrtmg_lw_ini below and the following
10673 ! use association to the GCM initialization area ***
10674 ! use rrtmg_lw_init, only: rrtmg_lw_ini
10675 use rrtmg_lw_rtrnmc, only: rtrnmc
10676 use rrtmg_lw_setcoef, only: setcoef
10677 use rrtmg_lw_taumol, only: taumol
10679 implicit none
10681 ! public interfaces/functions/subroutines
10682 public :: rrtmg_lw, inatm
10684 !------------------------------------------------------------------
10685 contains
10686 !------------------------------------------------------------------
10688 !------------------------------------------------------------------
10689 ! Public subroutines
10690 !------------------------------------------------------------------
10692 subroutine rrtmg_lw &
10693 (ncol ,nlay ,icld , &
10694 play ,plev ,tlay ,tlev ,tsfc , &
10695 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
10696 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
10697 inflglw ,iceflglw,liqflglw,cldfmcl , &
10698 taucmcl ,ciwpmcl ,clwpmcl , cswpmcl ,reicmcl ,relqmcl , resnmcl , &
10699 tauaer , &
10700 uflx ,dflx ,hr ,uflxc ,dflxc, hrc, &
10701 uflxcln ,dflxcln, calc_clean_atm_diag )
10703 ! -------- Description --------
10705 ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation
10706 ! model for application to GCMs, that has been adapted from RRTM_LW for
10707 ! improved efficiency.
10708 !
10709 ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization
10710 ! area, since this has to be called only once.
10711 !
10712 ! This routine:
10713 ! a) calls INATM to read in the atmospheric profile from GCM;
10714 ! all layering in RRTMG is ordered from surface to toa.
10715 ! b) calls CLDPRMC to set cloud optical depth for McICA based
10716 ! on input cloud properties
10717 ! c) calls SETCOEF to calculate various quantities needed for
10718 ! the radiative transfer algorithm
10719 ! d) calls TAUMOL to calculate gaseous optical depths for each
10720 ! of the 16 spectral bands
10721 ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the
10722 ! radiative transfer calculation using McICA, the Monte-Carlo
10723 ! Independent Column Approximation, to represent sub-grid scale
10724 ! cloud variability
10725 ! f) passes the necessary fluxes and cooling rates back to GCM
10726 !
10727 ! Two modes of operation are possible:
10728 ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
10729 ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM.
10730 !
10731 ! 1) Standard, single forward model calculation (imca = 0)
10732 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
10733 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
10734 !
10735 ! This call to RRTMG_LW must be preceeded by a call to the module
10736 ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
10737 ! which will provide the cloud physical or cloud optical properties
10738 ! on the RRTMG quadrature point (ngpt) dimension.
10739 ! Two random number generators are available for use when imca = 1.
10740 ! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
10741 ! 1) KISSVEC (irnd = 0)
10742 ! 2) Mersenne-Twister (irnd = 1)
10743 !
10744 ! Two methods of cloud property input are possible:
10745 ! Cloud properties can be input in one of two ways (controlled by input
10746 ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
10747 ! and subroutine rrtmg_lw_cldprop.f90 for further details):
10748 !
10749 ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
10750 ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);
10751 ! cloud optical properties are calculated by cldprop or cldprmc based
10752 ! on input settings of iceflglw and liqflglw. Ice particle size provided
10753 ! must be appropriately defined for the ice parameterization selected.
10754 !
10755 ! One method of aerosol property input is possible:
10756 ! Aerosol properties can be input in only one way (controlled by input
10757 ! flag iaer; see text file rrtmg_lw_instructions for further details):
10758 !
10759 ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10);
10760 ! band average optical depth at the mid-point of each spectral band.
10761 ! RRTMG_LW currently treats only aerosol absorption;
10762 ! scattering capability is not presently available.
10763 !
10764 !
10765 ! ------- Modifications -------
10766 !
10767 ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced
10768 ! set of g-points for application to GCMs.
10769 !
10770 !-- Original version (derived from RRTM_LW), reduction of g-points, other
10771 ! revisions for use with GCMs.
10772 ! 1999: M. J. Iacono, AER, Inc.
10773 !-- Adapted for use with NCAR/CAM.
10774 ! May 2004: M. J. Iacono, AER, Inc.
10775 !-- Revised to add McICA capability.
10776 ! Nov 2005: M. J. Iacono, AER, Inc.
10777 !-- Conversion to F90 formatting for consistency with rrtmg_sw.
10778 ! Feb 2007: M. J. Iacono, AER, Inc.
10779 !-- Modifications to formatting to use assumed-shape arrays.
10780 ! Aug 2007: M. J. Iacono, AER, Inc.
10781 !-- Modified to add longwave aerosol absorption.
10782 ! Apr 2008: M. J. Iacono, AER, Inc.
10784 ! --------- Modules ----------
10786 use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol
10787 use rrlw_con, only: fluxfac, heatfac, oneminus, pi
10788 use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
10790 ! ------- Declarations -------
10792 ! ----- Input -----
10793 integer(kind=im), intent(in) :: ncol ! Number of horizontal columns
10794 integer(kind=im), intent(in) :: nlay ! Number of model layers
10795 integer(kind=im), intent(inout) :: icld ! Cloud overlap method
10796 ! 0: Clear only
10797 ! 1: Random
10798 ! 2: Maximum/random
10799 ! 3: Maximum
10800 ! 4: Exponential
10801 ! 5: Exponential/random
10802 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
10803 ! Dimensions: (ncol,nlay)
10804 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
10805 ! Dimensions: (ncol,nlay+1)
10806 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
10807 ! Dimensions: (ncol,nlay)
10808 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
10809 ! Dimensions: (ncol,nlay+1)
10810 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
10811 ! Dimensions: (ncol)
10812 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
10813 ! Dimensions: (ncol,nlay)
10814 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
10815 ! Dimensions: (ncol,nlay)
10816 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
10817 ! Dimensions: (ncol,nlay)
10818 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
10819 ! Dimensions: (ncol,nlay)
10820 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
10821 ! Dimensions: (ncol,nlay)
10822 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
10823 ! Dimensions: (ncol,nlay)
10824 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
10825 ! Dimensions: (ncol,nlay)
10826 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
10827 ! Dimensions: (ncol,nlay)
10828 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
10829 ! Dimensions: (ncol,nlay)
10830 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
10831 ! Dimensions: (ncol,nlay)
10832 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
10833 ! Dimensions: (ncol,nbndlw)
10835 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
10836 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
10837 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
10839 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
10840 ! Dimensions: (ngptlw,ncol,nlay)
10841 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
10842 ! Dimensions: (ngptlw,ncol,nlay)
10843 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
10844 ! Dimensions: (ngptlw,ncol,nlay)
10845 real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
10846 ! Dimensions: (ngptlw,ncol,nlay)
10847 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice particle effective size (microns)
10848 ! Dimensions: (ncol,nlay)
10849 ! specific definition of reicmcl depends on setting of iceflglw:
10850 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
10851 ! r_ec must be >= 10.0 microns
10852 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
10853 ! r_ec range is limited to 13.0 to 130.0 microns
10854 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
10855 ! r_k range is limited to 5.0 to 131.0 microns
10856 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
10857 ! dge range is limited to 5.0 to 140.0 microns
10858 ! [dge = 1.0315 * r_ec]
10859 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
10860 ! Dimensions: (ncol,nlay)
10861 real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective radius (microns)
10862 ! Dimensions: (ncol,nlay)
10863 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
10864 ! Dimensions: (ngptlw,ncol,nlay)
10865 ! real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
10866 ! Dimensions: (ngptlw,ncol,nlay)
10867 ! for future expansion
10868 ! lw scattering not yet available
10869 ! real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
10870 ! Dimensions: (ngptlw,ncol,nlay)
10871 ! for future expansion
10872 ! lw scattering not yet available
10873 real(kind=rb), intent(in) :: tauaer(:,:,:) ! aerosol optical depth
10874 ! at mid-point of LW spectral bands
10875 ! Dimensions: (ncol,nlay,nbndlw)
10876 ! real(kind=rb), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo
10877 ! Dimensions: (ncol,nlay,nbndlw)
10878 ! for future expansion
10879 ! (lw aerosols/scattering not yet available)
10880 ! real(kind=rb), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter
10881 ! Dimensions: (ncol,nlay,nbndlw)
10882 ! for future expansion
10883 ! (lw aerosols/scattering not yet available)
10884 integer, intent(in) :: calc_clean_atm_diag ! Control for clean air diagnositic calls for WRF-Chem
10886 ! ----- Output -----
10888 real(kind=rb), intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2)
10889 ! Dimensions: (ncol,nlay+1)
10890 real(kind=rb), intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2)
10891 ! Dimensions: (ncol,nlay+1)
10892 real(kind=rb), intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d)
10893 ! Dimensions: (ncol,nlay)
10894 real(kind=rb), intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2)
10895 ! Dimensions: (ncol,nlay+1)
10896 real(kind=rb), intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2)
10897 ! Dimensions: (ncol,nlay+1)
10898 real(kind=rb), intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d)
10899 ! Dimensions: (ncol,nlay)
10900 real(kind=rb), intent(out) :: uflxcln(:,:) ! Clean sky longwave upward flux (W/m2)
10901 ! Dimensions: (ncol,nlay+1)
10902 real(kind=rb), intent(out) :: dflxcln(:,:) ! Clean sky longwave downward flux (W/m2)
10903 ! Dimensions: (ncol,nlay+1)
10905 ! ----- Local -----
10907 ! Control
10908 integer(kind=im) :: nlayers ! total number of layers
10909 integer(kind=im) :: istart ! beginning band of calculation
10910 integer(kind=im) :: iend ! ending band of calculation
10911 integer(kind=im) :: iout ! output option flag (inactive)
10912 integer(kind=im) :: iaer ! aerosol option flag
10913 integer(kind=im) :: iplon ! column loop index
10914 integer(kind=im) :: imca ! flag for mcica [0=off, 1=on]
10915 integer(kind=im) :: ims ! value for changing mcica permute seed
10916 integer(kind=im) :: k ! layer loop index
10917 integer(kind=im) :: ig ! g-point loop index
10919 ! Atmosphere
10920 real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb)
10921 real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K)
10922 real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb)
10923 real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K)
10924 real(kind=rb) :: tbound ! surface temperature (K)
10925 real(kind=rb) :: coldry(nlay+1) ! dry air column density (mol/cm2)
10926 real(kind=rb) :: wbrodl(nlay+1) ! broadening gas column density (mol/cm2)
10927 real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2)
10928 real(kind=rb) :: wx(maxxsec,nlay+1) ! cross-section amounts (mol/cm-2)
10929 real(kind=rb) :: pwvcm ! precipitable water vapor (cm)
10930 real(kind=rb) :: semiss(nbndlw) ! lw surface emissivity
10931 real(kind=rb) :: fracs(nlay+1,ngptlw) !
10932 real(kind=rb) :: taug(nlay+1,ngptlw) ! gaseous optical depths
10933 real(kind=rb) :: taut(nlay+1,ngptlw) ! gaseous + aerosol optical depths
10935 real(kind=rb) :: taua(nlay+1,nbndlw) ! aerosol optical depth
10936 ! real(kind=rb) :: ssaa(nlay+1,nbndlw) ! aerosol single scattering albedo
10937 ! for future expansion
10938 ! (lw aerosols/scattering not yet available)
10939 ! real(kind=rb) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter
10940 ! for future expansion
10941 ! (lw aerosols/scattering not yet available)
10943 ! Atmosphere - setcoef
10944 integer(kind=im) :: laytrop ! tropopause layer index
10945 integer(kind=im) :: jp(nlay+1) ! lookup table index
10946 integer(kind=im) :: jt(nlay+1) ! lookup table index
10947 integer(kind=im) :: jt1(nlay+1) ! lookup table index
10948 real(kind=rb) :: planklay(nlay+1,nbndlw)!
10949 real(kind=rb) :: planklev(0:nlay+1,nbndlw)!
10950 real(kind=rb) :: plankbnd(nbndlw) !
10952 real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o)
10953 real(kind=rb) :: colco2(nlay+1) ! column amount (co2)
10954 real(kind=rb) :: colo3(nlay+1) ! column amount (o3)
10955 real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o)
10956 real(kind=rb) :: colco(nlay+1) ! column amount (co)
10957 real(kind=rb) :: colch4(nlay+1) ! column amount (ch4)
10958 real(kind=rb) :: colo2(nlay+1) ! column amount (o2)
10959 real(kind=rb) :: colbrd(nlay+1) ! column amount (broadening gases)
10961 integer(kind=im) :: indself(nlay+1)
10962 integer(kind=im) :: indfor(nlay+1)
10963 real(kind=rb) :: selffac(nlay+1)
10964 real(kind=rb) :: selffrac(nlay+1)
10965 real(kind=rb) :: forfac(nlay+1)
10966 real(kind=rb) :: forfrac(nlay+1)
10968 integer(kind=im) :: indminor(nlay+1)
10969 real(kind=rb) :: minorfrac(nlay+1)
10970 real(kind=rb) :: scaleminor(nlay+1)
10971 real(kind=rb) :: scaleminorn2(nlay+1)
10973 real(kind=rb) :: & !
10974 fac00(nlay+1), fac01(nlay+1), &
10975 fac10(nlay+1), fac11(nlay+1)
10976 real(kind=rb) :: & !
10977 rat_h2oco2(nlay+1),rat_h2oco2_1(nlay+1), &
10978 rat_h2oo3(nlay+1),rat_h2oo3_1(nlay+1), &
10979 rat_h2on2o(nlay+1),rat_h2on2o_1(nlay+1), &
10980 rat_h2och4(nlay+1),rat_h2och4_1(nlay+1), &
10981 rat_n2oco2(nlay+1),rat_n2oco2_1(nlay+1), &
10982 rat_o3co2(nlay+1),rat_o3co2_1(nlay+1)
10984 ! Atmosphere/clouds - cldprop
10985 integer(kind=im) :: ncbands ! number of cloud spectral bands
10986 integer(kind=im) :: inflag ! flag for cloud property method
10987 integer(kind=im) :: iceflag ! flag for ice cloud properties
10988 integer(kind=im) :: liqflag ! flag for liquid cloud properties
10990 ! Atmosphere/clouds - cldprmc [mcica]
10991 real(kind=rb) :: cldfmc(ngptlw,nlay+1) ! cloud fraction [mcica]
10992 real(kind=rb) :: ciwpmc(ngptlw,nlay+1) ! in-cloud ice water path [mcica]
10993 real(kind=rb) :: clwpmc(ngptlw,nlay+1) ! in-cloud liquid water path [mcica]
10994 real(kind=rb) :: cswpmc(ngptlw,nlay+1) ! in-cloud snow path [mcica]
10995 real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns)
10996 real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns)
10997 real(kind=rb) :: resnmc(nlay+1) ! snow particle effective size (microns)
10998 real(kind=rb) :: taucmc(ngptlw,nlay+1) ! in-cloud optical depth [mcica]
10999 ! real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica]
11000 ! for future expansion
11001 ! (lw scattering not yet available)
11002 ! real(kind=rb) :: asmcmc(ngptlw,nlay+1) ! in-cloud asymmetry parameter [mcica]
11003 ! for future expansion
11004 ! (lw scattering not yet available)
11006 ! Output
11007 real(kind=rb) :: totuflux(0:nlay+1) ! upward longwave flux (w/m2)
11008 real(kind=rb) :: totdflux(0:nlay+1) ! downward longwave flux (w/m2)
11009 real(kind=rb) :: fnet(0:nlay+1) ! net longwave flux (w/m2)
11010 real(kind=rb) :: htr(0:nlay+1) ! longwave heating rate (k/day)
11011 real(kind=rb) :: totuclfl(0:nlay+1) ! clear sky upward longwave flux (w/m2)
11012 real(kind=rb) :: totdclfl(0:nlay+1) ! clear sky downward longwave flux (w/m2)
11013 real(kind=rb) :: fnetc(0:nlay+1) ! clear sky net longwave flux (w/m2)
11014 real(kind=rb) :: htrc(0:nlay+1) ! clear sky longwave heating rate (k/day)
11015 real(kind=rb) :: totuclnlfl(0:nlay+1) ! clean sky upward longwave flux (w/m2)
11016 real(kind=rb) :: totdclnlfl(0:nlay+1) ! clean sky downward longwave flux (w/m2)
11017 real(kind=rb) :: fnetcln(0:nlay+1) ! clean sky net longwave flux (w/m2)
11018 real(kind=rb) :: htrcln(0:nlay+1) ! clean sky longwave heating rate (k/day)
11020 !
11021 ! Initializations
11023 !jm not thread safe oneminus = 1._rb - 1.e-6_rb
11024 !jm not thread safe pi = 2._rb * asin(1._rb)
11025 !jm not thread safe fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4
11026 istart = 1
11027 iend = 16
11028 iout = 0
11029 ims = 1
11031 ! Set imca to select calculation type:
11032 ! imca = 0, use standard forward model calculation
11033 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
11035 ! *** This version uses McICA (imca = 1) ***
11037 ! Set icld to select of clear or cloud calculation and cloud overlap method
11038 ! icld = 0, clear only
11039 ! icld = 1, with clouds using random cloud overlap
11040 ! icld = 2, with clouds using maximum/random cloud overlap
11041 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
11042 ! icld = 4, with clouds using exponential cloud overlap (McICA only)
11043 ! icld = 5, with clouds using exponential/random cloud overlap (McICA only)
11045 ! Set iaer to select aerosol option
11046 ! iaer = 0, no aerosols
11047 ! icld = 10, input total aerosol optical depth (tauaer) directly
11048 iaer = 10
11050 ! Call model and data initialization, compute lookup tables, perform
11051 ! reduction of g-points from 256 to 140 for input absorption coefficient
11052 ! data and other arrays.
11053 !
11054 ! In a GCM this call should be placed in the model initialization
11055 ! area, since this has to be called only once.
11056 ! call rrtmg_lw_ini(cpdair)
11058 ! This is the main longitude/column loop within RRTMG.
11059 do iplon = 1, ncol
11061 ! Prepare atmospheric profile from GCM for use in RRTMG, and define
11062 ! other input parameters.
11064 call inatm (iplon, nlay, icld, iaer, &
11065 play, plev, tlay, tlev, tsfc, h2ovmr, &
11066 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
11067 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
11068 cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, &
11069 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
11070 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
11071 cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua)
11073 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
11074 ! input cloud physical properties. Select method based on choices described
11075 ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
11076 ! effective radius must be passed into cldprop. Cloud fraction and cloud
11077 ! optical depth are transferred to rrtmg_lw arrays in cldprop.
11079 call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, &
11080 clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc)
11082 ! Calculate information needed by the radiative transfer routine
11083 ! that is specific to this atmosphere, especially some of the
11084 ! coefficients and indices needed to compute the optical depths
11085 ! by interpolating data from stored reference atmospheres.
11087 call setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
11088 coldry, wkl, wbrodl, &
11089 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
11090 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
11091 colbrd, fac00, fac01, fac10, fac11, &
11092 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
11093 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
11094 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
11095 selffac, selffrac, indself, forfac, forfrac, indfor, &
11096 minorfrac, scaleminor, scaleminorn2, indminor)
11098 ! Calculate the gaseous optical depths and Planck fractions for
11099 ! each longwave spectral band.
11101 call taumol(nlayers, pavel, wx, coldry, &
11102 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
11103 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
11104 colbrd, fac00, fac01, fac10, fac11, &
11105 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
11106 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
11107 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
11108 selffac, selffrac, indself, forfac, forfrac, indfor, &
11109 minorfrac, scaleminor, scaleminorn2, indminor, &
11110 fracs, taug)
11113 ! Combine gaseous and aerosol optical depths, if aerosol active
11114 if (iaer .eq. 0) then
11115 do k = 1, nlayers
11116 do ig = 1, ngptlw
11117 taut(k,ig) = taug(k,ig)
11118 enddo
11119 enddo
11120 elseif (iaer .eq. 10) then
11121 do k = 1, nlayers
11122 do ig = 1, ngptlw
11123 taut(k,ig) = taug(k,ig) + taua(k,ngb(ig))
11124 enddo
11125 enddo
11126 endif
11128 ! Call the radiative transfer routine.
11129 ! Either routine can be called to do clear sky calculation. If clouds
11130 ! are present, then select routine based on cloud overlap assumption
11131 ! to be used. Clear sky calculation is done simultaneously.
11132 ! For McICA, RTRNMC is called for clear and cloudy calculations.
11134 #if (WRF_CHEM == 1)
11135 ! Call the radiative transfer routine for "clean" sky first,
11136 ! passing taug rather than taut so we have no aerosol influence.
11137 ! We will keep totuclnlfl, totdclnlfl, fnetcln, and htrcln,
11138 ! and then overwrite the rest with the second call to rtrnmc.
11139 if(calc_clean_atm_diag .gt. 0)then
11140 call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
11141 cldfmc, taucmc, planklay, planklev, plankbnd, &
11142 pwvcm, fracs, taug, &
11143 totuclnlfl, totdclnlfl, fnetcln, htrcln, &
11144 totuclfl, totdclfl, fnetc, htrc )
11145 else
11146 do k = 0, nlayers
11147 totuclnlfl(k) = 0.0
11148 totdclnlfl(k) = 0.0
11149 end do
11150 end if
11151 #else
11152 do k = 0, nlayers
11153 totuclnlfl(k) = 0.0
11154 totdclnlfl(k) = 0.0
11155 end do
11156 #endif
11157 call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
11158 cldfmc, taucmc, planklay, planklev, plankbnd, &
11159 pwvcm, fracs, taut, &
11160 totuflux, totdflux, fnet, htr, &
11161 totuclfl, totdclfl, fnetc, htrc )
11163 ! Transfer up and down fluxes and heating rate to output arrays.
11164 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
11166 do k = 0, nlayers
11167 uflx(iplon,k+1) = totuflux(k)
11168 dflx(iplon,k+1) = totdflux(k)
11169 uflxc(iplon,k+1) = totuclfl(k)
11170 dflxc(iplon,k+1) = totdclfl(k)
11171 uflxcln(iplon,k+1) = totuclnlfl(k)
11172 dflxcln(iplon,k+1) = totdclnlfl(k)
11173 enddo
11174 do k = 0, nlayers-1
11175 hr(iplon,k+1) = htr(k)
11176 hrc(iplon,k+1) = htrc(k)
11177 enddo
11179 enddo
11181 end subroutine rrtmg_lw
11183 !***************************************************************************
11184 subroutine inatm (iplon, nlay, icld, iaer, &
11185 play, plev, tlay, tlev, tsfc, h2ovmr, &
11186 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
11187 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
11188 cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, &
11189 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
11190 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
11191 cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua)
11192 !***************************************************************************
11193 !
11194 ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
11195 ! Set other RRTMG_LW input parameters.
11196 !
11197 !***************************************************************************
11199 ! --------- Modules ----------
11201 use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol
11202 use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad
11203 use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
11205 ! ------- Declarations -------
11207 ! ----- Input -----
11208 integer(kind=im), intent(in) :: iplon ! column loop index
11209 integer(kind=im), intent(in) :: nlay ! Number of model layers
11210 integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag
11211 integer(kind=im), intent(in) :: iaer ! aerosol option flag
11213 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
11214 ! Dimensions: (ncol,nlay)
11215 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
11216 ! Dimensions: (ncol,nlay+1)
11217 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
11218 ! Dimensions: (ncol,nlay)
11219 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
11220 ! Dimensions: (ncol,nlay+1)
11221 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
11222 ! Dimensions: (ncol)
11223 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
11224 ! Dimensions: (ncol,nlay)
11225 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
11226 ! Dimensions: (ncol,nlay)
11227 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
11228 ! Dimensions: (ncol,nlay)
11229 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
11230 ! Dimensions: (ncol,nlay)
11231 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
11232 ! Dimensions: (ncol,nlay)
11233 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
11234 ! Dimensions: (ncol,nlay)
11235 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
11236 ! Dimensions: (ncol,nlay)
11237 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
11238 ! Dimensions: (ncol,nlay)
11239 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
11240 ! Dimensions: (ncol,nlay)
11241 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
11242 ! Dimensions: (ncol,nlay)
11243 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
11244 ! Dimensions: (ncol,nbndlw)
11246 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
11247 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
11248 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
11250 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
11251 ! Dimensions: (ngptlw,ncol,nlay)
11252 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
11253 ! Dimensions: (ngptlw,ncol,nlay)
11254 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
11255 ! Dimensions: (ngptlw,ncol,nlay)
11256 real(kind=rb), intent(in) :: cswpmcl(:,:,:) ! In-cloud snow water path (g/m2)
11257 ! Dimensions: (ngptlw,ncol,nlay)
11258 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
11259 ! Dimensions: (ncol,nlay)
11260 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns)
11261 ! Dimensions: (ncol,nlay)
11262 real(kind=rb), intent(in) :: resnmcl(:,:) ! Snow effective size (microns)
11263 ! Dimensions: (ncol,nlay)
11264 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
11265 ! Dimensions: (ngptlw,ncol,nlay)
11266 real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth
11267 ! Dimensions: (ncol,nlay,nbndlw)
11269 ! ----- Output -----
11270 ! Atmosphere
11271 integer(kind=im), intent(out) :: nlayers ! number of layers
11273 real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb)
11274 ! Dimensions: (nlay)
11275 real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K)
11276 ! Dimensions: (nlay)
11277 real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb)
11278 ! Dimensions: (0:nlay)
11279 real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K)
11280 ! Dimensions: (0:nlay)
11281 real(kind=rb), intent(out) :: tbound ! surface temperature (K)
11282 real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2)
11283 ! Dimensions: (nlay)
11284 real(kind=rb), intent(out) :: wbrodl(:) ! broadening gas column density (mol/cm2)
11285 ! Dimensions: (nlay)
11286 real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2)
11287 ! Dimensions: (mxmol,nlay)
11288 real(kind=rb), intent(out) :: wx(:,:) ! cross-section amounts (mol/cm-2)
11289 ! Dimensions: (maxxsec,nlay)
11290 real(kind=rb), intent(out) :: pwvcm ! precipitable water vapor (cm)
11291 real(kind=rb), intent(out) :: semiss(:) ! lw surface emissivity
11292 ! Dimensions: (nbndlw)
11294 ! Atmosphere/clouds - cldprop
11295 integer(kind=im), intent(out) :: inflag ! flag for cloud property method
11296 integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties
11297 integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties
11299 real(kind=rb), intent(out) :: cldfmc(:,:) ! cloud fraction [mcica]
11300 ! Dimensions: (ngptlw,nlay)
11301 real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path [mcica]
11302 ! Dimensions: (ngptlw,nlay)
11303 real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path [mcica]
11304 ! Dimensions: (ngptlw,nlay)
11305 real(kind=rb), intent(out) :: cswpmc(:,:) ! in-cloud snow path [mcica]
11306 ! Dimensions: (ngptlw,nlay)
11307 real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns)
11308 ! Dimensions: (nlay)
11309 real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns)
11310 ! Dimensions: (nlay)
11311 real(kind=rb), intent(out) :: resnmc(:) ! snow effective size (microns)
11312 ! Dimensions: (nlay)
11313 real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth [mcica]
11314 ! Dimensions: (ngptlw,nlay)
11315 real(kind=rb), intent(out) :: taua(:,:) ! aerosol optical depth
11316 ! Dimensions: (nlay,nbndlw)
11319 ! ----- Local -----
11320 real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol)
11321 real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol)
11322 ! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol)
11323 ! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol)
11324 ! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol)
11325 ! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
11326 ! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
11327 ! real(kind=rb), parameter :: amc11 = 137.3684_rb ! Molecular weight of CFC11 (g/mol) - CCL3F
11328 ! real(kind=rb), parameter :: amc12 = 120.9138_rb ! Molecular weight of CFC12 (g/mol) - CCL2F2
11329 ! real(kind=rb), parameter :: amc22 = 86.4688_rb ! Molecular weight of CFC22 (g/mol) - CHCLF2
11330 ! real(kind=rb), parameter :: amcl4 = 153.823_rb ! Molecular weight of CCL4 (g/mol) - CCL4
11332 ! Set molecular weight ratios (for converting mmr to vmr)
11333 ! e.g. h2ovmr = h2ommr * amdw)
11334 real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor
11335 real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide
11336 real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone
11337 real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane
11338 real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide
11339 real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
11340 real(kind=rb), parameter :: amdc1 = 0.210852_rb ! Molecular weight of dry air / CFC11
11341 real(kind=rb), parameter :: amdc2 = 0.239546_rb ! Molecular weight of dry air / CFC12
11343 integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices
11344 real(kind=rb) :: amm, amttl, wvttl, wvsh, summol
11346 ! Add one to nlayers here to include extra model layer at top of atmosphere
11347 nlayers = nlay
11349 ! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts
11350 ! into RRTM arrays below.
11352 wkl(:,:) = 0.0_rb
11353 wx(:,:) = 0.0_rb
11354 cldfmc(:,:) = 0.0_rb
11355 taucmc(:,:) = 0.0_rb
11356 ciwpmc(:,:) = 0.0_rb
11357 clwpmc(:,:) = 0.0_rb
11358 cswpmc(:,:) = 0.0_rb
11359 reicmc(:) = 0.0_rb
11360 relqmc(:) = 0.0_rb
11361 resnmc(:) = 0.0_rb
11362 taua(:,:) = 0.0_rb
11363 amttl = 0.0_rb
11364 wvttl = 0.0_rb
11366 ! Set surface temperature.
11367 tbound = tsfc(iplon)
11369 ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature,
11370 ! and molecular amounts.
11371 ! Pressures are input in mb, or are converted to mb here.
11372 ! Molecular amounts are input in volume mixing ratio, or are converted from
11373 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
11374 ! here. These are then converted to molecular amount (molec/cm2) below.
11375 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
11376 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
11377 ! correction to account for h2o in the layer. The molecular weight of moist
11378 ! air (amm) is calculated for each layer.
11379 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
11380 ! assumes GCM input fields are also bottom to top. Input layer indexing
11381 ! from GCM fields should be reversed here if necessary.
11383 pz(0) = plev(iplon,1)
11384 tz(0) = tlev(iplon,1)
11385 do l = 1, nlayers
11386 pavel(l) = play(iplon,l)
11387 tavel(l) = tlay(iplon,l)
11388 pz(l) = plev(iplon,l+1)
11389 tz(l) = tlev(iplon,l+1)
11390 ! For h2o input in vmr:
11391 wkl(1,l) = h2ovmr(iplon,l)
11392 ! For h2o input in mmr:
11393 ! wkl(1,l) = h2o(iplon,l)*amdw
11394 ! For h2o input in specific humidity;
11395 ! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
11396 wkl(2,l) = co2vmr(iplon,l)
11397 wkl(3,l) = o3vmr(iplon,l)
11398 wkl(4,l) = n2ovmr(iplon,l)
11399 wkl(6,l) = ch4vmr(iplon,l)
11400 wkl(7,l) = o2vmr(iplon,l)
11401 amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
11402 coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
11403 (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
11404 enddo
11406 ! Set cross section molecule amounts from input; convert to vmr if necessary
11407 do l=1, nlayers
11408 wx(1,l) = ccl4vmr(iplon,l)
11409 wx(2,l) = cfc11vmr(iplon,l)
11410 wx(3,l) = cfc12vmr(iplon,l)
11411 wx(4,l) = cfc22vmr(iplon,l)
11412 enddo
11414 ! The following section can be used to set values for an additional layer (from
11415 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
11416 ! Temperature and molecular amounts in the extra model layer are set to
11417 ! their values in the top GCM model layer, though these can be modified
11418 ! here if necessary.
11419 ! If this feature is utilized, increase nlayers by one above, limit the two
11420 ! loops above to (nlayers-1), and set the top most (extra) layer values here.
11422 ! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
11423 ! tavel(nlayers) = tavel(nlayers-1)
11424 ! pz(nlayers) = 1.e-4_rb
11425 ! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
11426 ! tz(nlayers) = tz(nlayers-1)
11427 ! wkl(1,nlayers) = wkl(1,nlayers-1)
11428 ! wkl(2,nlayers) = wkl(2,nlayers-1)
11429 ! wkl(3,nlayers) = wkl(3,nlayers-1)
11430 ! wkl(4,nlayers) = wkl(4,nlayers-1)
11431 ! wkl(6,nlayers) = wkl(6,nlayers-1)
11432 ! wkl(7,nlayers) = wkl(7,nlayers-1)
11433 ! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
11434 ! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
11435 ! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
11436 ! wx(1,nlayers) = wx(1,nlayers-1)
11437 ! wx(2,nlayers) = wx(2,nlayers-1)
11438 ! wx(3,nlayers) = wx(3,nlayers-1)
11439 ! wx(4,nlayers) = wx(4,nlayers-1)
11441 ! At this point all molecular amounts in wkl and wx are in volume mixing ratio;
11442 ! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable
11443 ! water vapor for diffusivity angle adjustments in rtrn and rtrnmr.
11445 do l = 1, nlayers
11446 summol = 0.0_rb
11447 do imol = 2, nmol
11448 summol = summol + wkl(imol,l)
11449 enddo
11450 wbrodl(l) = coldry(l) * (1._rb - summol)
11451 do imol = 1, nmol
11452 wkl(imol,l) = coldry(l) * wkl(imol,l)
11453 enddo
11454 amttl = amttl + coldry(l)+wkl(1,l)
11455 wvttl = wvttl + wkl(1,l)
11456 do ix = 1,maxxsec
11457 if (ixindx(ix) .ne. 0) then
11458 wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb
11459 endif
11460 enddo
11461 enddo
11463 wvsh = (amw * wvttl) / (amd * amttl)
11464 pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav)
11466 ! Set spectral surface emissivity for each longwave band.
11468 do n=1,nbndlw
11469 semiss(n) = emis(iplon,n)
11470 ! semiss(n) = 1.0_rb
11471 enddo
11473 ! Transfer aerosol optical properties to RRTM variable;
11474 ! modify to reverse layer indexing here if necessary.
11476 if (iaer .ge. 1) then
11477 do l = 1, nlayers
11478 do ib = 1, nbndlw
11479 taua(l,ib) = tauaer(iplon,l,ib)
11480 enddo
11481 enddo
11482 endif
11484 ! Transfer cloud fraction and cloud optical properties to RRTM variables,
11485 ! modify to reverse layer indexing here if necessary.
11487 if (icld .ge. 1) then
11488 inflag = inflglw
11489 iceflag = iceflglw
11490 liqflag = liqflglw
11492 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
11493 ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw)
11495 do l = 1, nlayers
11496 do ig = 1, ngptlw
11497 cldfmc(ig,l) = cldfmcl(ig,iplon,l)
11498 taucmc(ig,l) = taucmcl(ig,iplon,l)
11499 ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
11500 clwpmc(ig,l) = clwpmcl(ig,iplon,l)
11501 cswpmc(ig,l) = cswpmcl(ig,iplon,l)
11502 enddo
11503 reicmc(l) = reicmcl(iplon,l)
11504 relqmc(l) = relqmcl(iplon,l)
11505 resnmc(l) = resnmcl(iplon,l)
11506 enddo
11508 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
11510 ! cldfmc(:,nlayers) = 0.0_rb
11511 ! taucmc(:,nlayers) = 0.0_rb
11512 ! ciwpmc(:,nlayers) = 0.0_rb
11513 ! clwpmc(:,nlayers) = 0.0_rb
11514 ! reicmc(nlayers) = 0.0_rb
11515 ! relqmc(nlayers) = 0.0_rb
11516 ! taua(nlayers,:) = 0.0_rb
11518 endif
11520 end subroutine inatm
11522 end module rrtmg_lw_rad
11524 !------------------------------------------------------------------
11525 MODULE module_ra_rrtmg_lw
11527 use module_model_constants, only : cp
11528 use module_wrf_error
11529 #if (HWRF == 1)
11530 USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF
11531 #else
11532 USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT
11533 #endif
11534 !use module_dm
11536 use parrrtm, only : nbndlw, ngptlw
11537 use rrtmg_lw_init, only: rrtmg_lw_ini
11538 use rrtmg_lw_rad, only: rrtmg_lw
11539 use mcica_subcol_gen_lw, only: mcica_subcol_lw
11541 real retab(95)
11542 data retab / &
11543 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
11544 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
11545 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
11546 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
11547 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
11548 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
11549 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
11550 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
11551 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
11552 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
11553 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
11554 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
11555 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
11556 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
11557 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
11558 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
11559 !
11560 save retab
11561 ! For buffer layer adjustment. Steven Cavallo, Dec 2010.
11562 integer , save :: nlayers
11563 real, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb
11565 CONTAINS
11567 !------------------------------------------------------------------
11568 SUBROUTINE RRTMG_LWRAD( &
11569 rthratenlw, &
11570 rthratenlwc, &
11571 lwupt, lwuptc, lwuptcln, lwdnt, lwdntc, lwdntcln, &
11572 lwupb, lwupbc, lwupbcln, lwdnb, lwdnbc, lwdnbcln, &
11573 ! lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
11574 glw, olr, lwcf, emiss, &
11575 p8w, p3d, pi3d, &
11576 dz8w, tsk, t3d, t8w, rho3d, r, g, &
11577 icloud, warm_rain, cldfra3d, &
11578 cldovrlp,idcor,xlat, &
11579 lradius,iradius, &
11580 is_cammgmp_used, &
11581 f_ice_phy, f_rain_phy, &
11582 xland, xice, snow, &
11583 qv3d, qc3d, qr3d, &
11584 qi3d, qs3d, qg3d, &
11585 o3input, o33d, &
11586 f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
11587 re_cloud, re_ice, re_snow, & ! G. Thompson
11588 has_reqc, has_reqi, has_reqs, & ! G. Thompson
11589 tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
11590 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
11591 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
11592 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao
11593 aer_ra_feedback, & !czhao
11594 !jdfcz progn,prescribe, & !czhao
11595 progn,calc_clean_atm_diag, & !czhao
11596 qndrop3d,f_qndrop, & !czhao
11597 !ccc added for time varying gases.
11598 yr,julian,ghg_input, &
11599 !ccc
11600 mp_physics, &
11601 ids,ide, jds,jde, kds,kde, &
11602 ims,ime, jms,jme, kms,kme, &
11603 its,ite, jts,jte, kts,kte, &
11604 lwupflx, lwupflxc, lwdnflx, lwdnflxc &
11605 )
11606 !------------------------------------------------------------------
11607 !ccc To use clWRF time varying trace gases
11608 USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
11610 IMPLICIT NONE
11611 !------------------------------------------------------------------
11612 LOGICAL, INTENT(IN ) :: warm_rain
11613 LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
11614 !
11615 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
11616 ims,ime, jms,jme, kms,kme, &
11617 its,ite, jts,jte, kts,kte
11619 INTEGER, INTENT(IN ) :: ICLOUD, GHG_INPUT
11620 INTEGER, INTENT(IN ) :: MP_PHYSICS
11621 !
11622 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11623 INTENT(IN ) :: dz8w, &
11624 t3d, &
11625 t8w, &
11626 p8w, &
11627 p3d, &
11628 pi3d, &
11629 rho3d
11631 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11632 INTENT(INOUT) :: RTHRATENLW, &
11633 RTHRATENLWC
11635 REAL, DIMENSION( ims:ime, jms:jme ) , &
11636 INTENT(INOUT) :: GLW, &
11637 OLR, &
11638 LWCF
11640 REAL, DIMENSION( ims:ime, jms:jme ) , &
11641 INTENT(IN ) :: EMISS, &
11642 TSK
11644 REAL, INTENT(IN ) :: R,G
11646 REAL, DIMENSION( ims:ime, jms:jme ) , &
11647 INTENT(IN ) :: XLAND, &
11648 XICE, &
11649 SNOW
11650 ! Added for time-varying trace gases.
11651 INTEGER, INTENT(IN ) :: yr
11652 REAL, INTENT(IN ) :: julian
11654 !
11655 ! Optional
11656 !
11657 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11658 OPTIONAL , &
11659 INTENT(IN ) :: &
11660 CLDFRA3D, &
11661 LRADIUS, &
11662 IRADIUS, &
11664 QV3D, &
11665 QC3D, &
11666 QR3D, &
11667 QI3D, &
11668 QS3D, &
11669 QG3D, &
11670 QNDROP3D
11672 !..Added by G. Thompson to couple cloud physics effective radii.
11673 REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: &
11674 re_cloud, &
11675 re_ice, &
11676 re_snow
11677 INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
11679 real pi,third,relconst,lwpmin,rhoh2o
11681 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11682 OPTIONAL , &
11683 INTENT(IN ) :: &
11684 F_ICE_PHY, &
11685 F_RAIN_PHY
11687 LOGICAL, OPTIONAL, INTENT(IN) :: &
11688 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
11689 ! Optional
11690 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
11691 INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
11692 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
11693 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
11694 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
11696 INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
11697 !jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
11698 INTEGER, INTENT(IN ), OPTIONAL :: progn
11699 INTEGER, INTENT(IN ) :: calc_clean_atm_diag
11701 ! Ozone
11702 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11703 INTENT(INOUT) :: O33D
11704 INTEGER, INTENT(IN ) :: o3input
11706 real, parameter :: thresh=1.e-9
11707 real slope
11708 character(len=200) :: msg
11711 ! Top of atmosphere and surface longwave fluxes (W m-2)
11712 REAL, DIMENSION( ims:ime, jms:jme ), &
11713 OPTIONAL, INTENT(INOUT) :: &
11714 LWUPT,LWUPTC,LWUPTCLN,LWDNT,LWDNTC,LWDNTCLN,&
11715 LWUPB,LWUPBC,LWUPBCLN,LWDNB,LWDNBC,LWDNBCLN
11717 ! Layer longwave fluxes (including extra layer above model top)
11718 ! Vertical ordering is from bottom to top (W m-2)
11719 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
11720 OPTIONAL, INTENT(OUT) :: &
11721 LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
11723 ! LOCAL VARS
11725 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
11726 Tw1D
11728 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
11729 CLDFRA1D, &
11730 DZ1D, &
11731 P1D, &
11732 T1D, &
11733 QV1D, &
11734 QC1D, &
11735 QR1D, &
11736 QI1D, &
11737 RHO1D, &
11738 QS1D, &
11739 QG1D, &
11740 O31D, &
11741 qndrop1d
11742 !BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996)
11743 real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, &
11744 re_30C=1250.0/9.208, re_20C=1250.0/9.387
11747 ! Added local arrays for RRTMG
11748 integer :: ncol, &
11749 nlay, &
11750 icld, &
11751 cldovrlp, &
11752 idcor, &
11753 juldat, &
11754 inflglw, &
11755 iceflglw, &
11756 liqflglw
11757 ! Latitude
11758 real, dimension( ims:ime,jms:jme ), intent(in) :: xlat ! (latitude for cldovrlp=4 or 5)
11759 real :: lat
11761 ! Dimension with extra layer from model top to TOA
11762 real, dimension( 1, kts:nlayers+1 ) :: plev, &
11763 tlev
11764 real, dimension( 1, kts:nlayers ) :: play, &
11765 tlay, &
11766 h2ovmr, &
11767 o3vmr, &
11768 co2vmr, &
11769 o2vmr, &
11770 ch4vmr, &
11771 n2ovmr, &
11772 cfc11vmr, &
11773 cfc12vmr, &
11774 cfc22vmr, &
11775 ccl4vmr
11776 real, dimension( kts:nlayers ) :: o3mmr
11777 ! Add height of each layer for exponential-random cloud overlap
11778 ! This will be derived below from the dz in each layer
11779 real, dimension( 1, kts:nlayers ) :: hgt
11780 real :: dzsum
11781 ! For old cloud property specification for rrtm_lw
11782 real, dimension( kts:kte ) :: clwp, &
11783 ciwp, &
11784 cswp, &
11785 plwp, &
11786 piwp
11787 ! Surface emissivity (for 16 LW spectral bands)
11788 real, dimension( 1, nbndlw ) :: emis
11789 ! Dimension with extra layer from model top to TOA,
11790 ! though no clouds are allowed in extra layer
11791 real, dimension( 1, kts:nlayers ) :: clwpth, &
11792 ciwpth, &
11793 cswpth, &
11794 rel, &
11795 rei, &
11796 res, &
11797 cldfrac, &
11798 relqmcl, &
11799 reicmcl, &
11800 resnmcl
11801 real, dimension( nbndlw, 1, kts:nlayers ) :: taucld
11802 real, dimension( ngptlw, 1, kts:nlayers ) :: cldfmcl, &
11803 clwpmcl, &
11804 ciwpmcl, &
11805 cswpmcl, &
11806 taucmcl
11807 real, dimension( 1, kts:nlayers, nbndlw ) :: tauaer
11809 ! Output arrays contain extra layer from model top to TOA
11810 real, dimension( 1, kts:nlayers+1 ) :: uflx, &
11811 dflx, &
11812 uflxc, &
11813 dflxc, &
11814 uflxcln, &
11815 dflxcln
11817 real, dimension( 1, kts:nlayers ) :: hr, &
11818 hrc
11820 real, dimension ( 1 ) :: tsfc, &
11821 ps
11822 real :: ro, &
11823 dz
11824 real:: snow_mass_factor
11826 !..We can use message interface regardless of what options are running,
11827 !.. so let us ask for it here.
11828 CHARACTER(LEN=256) :: message
11829 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
11831 !ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc. from file
11832 ! then interpolate to date of run.
11833 REAL(8) :: co2, n2o, ch4, cfc11, cfc12
11835 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11836 ! cfc-22 (169 ppt)
11837 real :: cfc22
11838 data cfc22 / 0.169e-9 /
11839 ! ccl4 (93 ppt)
11840 real :: ccl4
11841 data ccl4 / 0.093e-9 /
11842 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
11843 real :: o2
11844 data o2 / 0.209488 /
11846 integer :: iplon, irng, permuteseed
11847 integer :: nb
11849 ! For old cloud property specification for rrtm_lw
11850 ! Cloud and precipitation absorption coefficients
11851 real :: abcw,abice,abrn,absn
11852 data abcw /0.144/
11853 data abice /0.0735/
11854 data abrn /0.330e-3/
11855 data absn /2.34e-3/
11857 ! Molecular weights and ratios for converting mmr to vmr units
11858 ! real :: amd ! Effective molecular weight of dry air (g/mol)
11859 ! real :: amw ! Molecular weight of water vapor (g/mol)
11860 ! real :: amo ! Molecular weight of ozone (g/mol)
11861 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
11862 ! Atomic weights for conversion from mass to volume mixing ratios
11863 ! data amd / 28.9660 /
11864 ! data amw / 18.0160 /
11865 ! data amo / 47.9998 /
11866 ! data amo2 / 31.9999 /
11868 real :: amdw ! Molecular weight of dry air / water vapor
11869 real :: amdo ! Molecular weight of dry air / ozone
11870 real :: amdo2 ! Molecular weight of dry air / oxygen
11871 data amdw / 1.607793 /
11872 data amdo / 0.603461 /
11873 data amdo2 / 0.905190 /
11875 !!
11876 real, dimension( 1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
11878 real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
11879 cliqwp, & ! in-cloud cloud liquid water path
11880 csnowp, & ! in-cloud snow water path
11881 reliq, & ! effective drop radius (microns)
11882 reice ! effective ice crystal size (microns)
11883 real, dimension(1, 1:kte-kts+1):: recloud1d, &
11884 reice1d, &
11885 resnow1d
11887 real :: gliqwp, gicewp, gsnowp, gravmks
11889 !
11890 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
11892 real, dimension (1) :: landfrac, landm, snowh, icefrac
11894 integer :: pcols, pver
11896 !
11897 INTEGER :: i,j,K, idx_rei
11898 REAL :: corr
11899 LOGICAL :: predicate
11901 ! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010
11902 INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table
11903 INTEGER :: L, LL, klev ! Loop indices
11904 REAL, DIMENSION( kts:nlayers+1 ) :: varint
11905 REAL :: wght,vark,vark1,tem1,tem2,tem3
11906 REAL :: PPROF(nproflevs), TPROF(nproflevs)
11907 ! Weighted mean pressure and temperature profiles from midlatitude
11908 ! summer (MLS),midlatitude winter (MLW), sub-Arctic
11909 ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP)
11910 ! standard atmospheres.
11911 DATA PPROF /1000.00,855.47,731.82,626.05,535.57,458.16, &
11912 391.94,335.29,286.83,245.38,209.91,179.57, &
11913 153.62,131.41,112.42,96.17,82.27,70.38, &
11914 60.21,51.51,44.06,37.69,32.25,27.59, &
11915 23.60,20.19,17.27,14.77,12.64,10.81, &
11916 9.25,7.91,6.77,5.79,4.95,4.24, &
11917 3.63,3.10,2.65,2.27,1.94,1.66, &
11918 1.42,1.22,1.04,0.89,0.76,0.65, &
11919 0.56,0.48,0.41,0.35,0.30,0.26, &
11920 0.22,0.19,0.16,0.14,0.12,0.10/
11921 DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, &
11922 245.62,238.41,231.57,225.91,221.72,217.79, &
11923 215.06,212.74,210.25,210.16,210.69,212.14, &
11924 213.74,215.37,216.82,217.94,219.03,220.18, &
11925 221.37,222.64,224.16,225.88,227.63,229.51, &
11926 231.50,233.73,236.18,238.78,241.60,244.44, &
11927 247.35,250.33,253.32,256.30,259.22,262.12, &
11928 264.80,266.50,267.59,268.44,268.69,267.76, &
11929 266.13,263.96,261.54,258.93,256.15,253.23, &
11930 249.89,246.67,243.48,240.25,236.66,233.86/
11931 !------------------------------------------------------------------
11932 #if ( WRF_CHEM == 1 )
11933 IF ( aer_ra_feedback == 1) then
11934 IF ( .NOT. &
11935 ( PRESENT(tauaerlw1) .AND. &
11936 PRESENT(tauaerlw2) .AND. &
11937 PRESENT(tauaerlw3) .AND. &
11938 PRESENT(tauaerlw4) .AND. &
11939 PRESENT(tauaerlw5) .AND. &
11940 PRESENT(tauaerlw6) .AND. &
11941 PRESENT(tauaerlw7) .AND. &
11942 PRESENT(tauaerlw8) .AND. &
11943 PRESENT(tauaerlw9) .AND. &
11944 PRESENT(tauaerlw10) .AND. &
11945 PRESENT(tauaerlw11) .AND. &
11946 PRESENT(tauaerlw12) .AND. &
11947 PRESENT(tauaerlw13) .AND. &
11948 PRESENT(tauaerlw14) .AND. &
11949 PRESENT(tauaerlw15) .AND. &
11950 PRESENT(tauaerlw16) ) ) THEN
11951 CALL wrf_error_fatal &
11952 ('Warning: missing fields required for aerosol radiation' )
11953 ENDIF
11954 ENDIF
11955 #endif
11958 !-----CALCULATE LONG WAVE RADIATION
11959 !
11960 ! All fields are ordered vertically from bottom to top
11961 ! Pressures are in mb
11962 !
11964 ! Read time-varying trace gases concentrations and interpolate them to run date.
11965 !
11966 IF ( GHG_INPUT .EQ. 1 ) THEN
11967 CALL read_CAMgases(yr,julian,.false.,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
11968 IF ( wrf_dm_on_monitor() ) THEN
11969 WRITE(message,*)'RRTMG LW CLWRF interpolated GHG values year:',yr,' julian day:',julian
11970 call wrf_debug( 1, message)
11971 WRITE(message,*)' co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12
11972 call wrf_debug( 1, message)
11973 ENDIF
11974 ELSE
11975 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11976 ! Annual function for co2 in WRF v4.2
11977 co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
11978 ! co2 = 379.e-6
11979 ch4 = 1774.e-9
11980 n2o = 319.e-9
11981 cfc11 = 0.251e-9
11982 cfc12 = 0.538e-9
11983 END IF
11985 ! latitude loop
11986 j_loop: do j = jts,jte
11988 ! longitude loop
11989 i_loop: do i = its,ite
11991 do k=kts,kte+1
11992 Pw1D(K) = p8w(I,K,J)/100.
11993 Tw1D(K) = t8w(I,K,J)
11994 enddo
11996 DO K=kts,kte
11997 QV1D(K)=0.
11998 QC1D(K)=0.
11999 QR1D(K)=0.
12000 QI1D(K)=0.
12001 QS1D(K)=0.
12002 CLDFRA1D(k)=0.
12003 ENDDO
12005 DO K=kts,kte
12006 QV1D(K)=QV3D(I,K,J)
12007 QV1D(K)=max(0.,QV1D(K))
12008 ENDDO
12010 IF (o3input.eq.2) THEN
12011 DO K=kts,kte
12012 O31D(K)=O33D(I,K,J)
12013 ENDDO
12014 ELSE
12015 DO K=kts,kte
12016 O31D(K)=0.0
12017 ENDDO
12018 ENDIF
12020 DO K=kts,kte
12021 TTEN1D(K)=0.
12022 T1D(K)=T3D(I,K,J)
12023 P1D(K)=P3D(I,K,J)/100.
12024 RHO1D(K)=RHO3D(I,K,J)
12025 DZ1D(K)=dz8w(I,K,J)
12026 ENDDO
12028 ! moist variables
12030 IF (ICLOUD .ne. 0) THEN
12031 IF ( PRESENT( CLDFRA3D ) ) THEN
12032 DO K=kts,kte
12033 CLDFRA1D(k)=CLDFRA3D(I,K,J)
12034 ENDDO
12035 ENDIF
12037 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
12038 IF ( F_QC) THEN
12039 DO K=kts,kte
12040 QC1D(K)=QC3D(I,K,J)
12041 QC1D(K)=max(0.,QC1D(K))
12042 ENDDO
12043 ENDIF
12044 ENDIF
12046 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
12047 IF ( F_QR) THEN
12048 DO K=kts,kte
12049 QR1D(K)=QR3D(I,K,J)
12050 QR1D(K)=max(0.,QR1D(K))
12051 ENDDO
12052 ENDIF
12053 ENDIF
12055 IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
12056 IF (F_QNDROP) THEN
12057 DO K=kts,kte
12058 qndrop1d(K)=qndrop3d(I,K,J)
12059 ENDDO
12060 ENDIF
12061 ENDIF
12063 ! This logic is tortured because cannot test F_QI unless
12064 ! it is present, and order of evaluation of expressions
12065 ! is not specified in Fortran
12067 IF ( PRESENT ( F_QI ) ) THEN
12068 predicate = F_QI
12069 ELSE
12070 predicate = .FALSE.
12071 ENDIF
12073 ! For MP option 3
12074 IF (.NOT. predicate .and. .not. warm_rain) THEN
12075 DO K=kts,kte
12076 IF (T1D(K) .lt. 273.15) THEN
12077 QI1D(K)=QC1D(K)
12078 QS1D(K)=QR1D(K)
12079 QC1D(K)=0.
12080 QR1D(K)=0.
12081 ENDIF
12082 ENDDO
12083 ENDIF
12085 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
12086 IF (F_QI) THEN
12087 DO K=kts,kte
12088 QI1D(K)=QI3D(I,K,J)
12089 QI1D(K)=max(0.,QI1D(K))
12090 ENDDO
12091 ENDIF
12092 ENDIF
12094 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
12095 IF (F_QS) THEN
12096 DO K=kts,kte
12097 QS1D(K)=QS3D(I,K,J)
12098 QS1D(K)=max(0.,QS1D(K))
12099 ENDDO
12100 ENDIF
12101 ENDIF
12103 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
12104 IF (F_QG) THEN
12105 DO K=kts,kte
12106 QG1D(K)=QG3D(I,K,J)
12107 QG1D(K)=max(0.,QG1D(K))
12108 ENDDO
12109 ENDIF
12110 ENDIF
12112 ! mji - For MP option 5
12113 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
12114 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
12115 DO K=kts,kte
12116 qi1d(k) = 0.1*qs3d(i,k,j)
12117 qs1d(k) = 0.9*qs3d(i,k,j)
12118 qc1d(k) = qc3d(i,k,j)
12119 qi1d(k) = max(0.,qi1d(k))
12120 qc1d(k) = max(0.,qc1d(k))
12121 ENDDO
12122 ENDIF
12123 ENDIF
12125 ENDIF
12127 ! For mp option=5 or 85 (new Ferrier- Aligo or fer_hires scheme), QI3D saves all
12128 #if (HWRF == 1)
12129 IF ( mp_physics == FER_MP_HIRES .OR. &
12130 mp_physics == FER_MP_HIRES_ADVECT .OR. &
12131 mp_physics == ETAMP_HWRF ) THEN
12132 #else
12133 IF ( mp_physics == FER_MP_HIRES .OR. &
12134 mp_physics == FER_MP_HIRES_ADVECT) THEN
12135 #endif
12136 DO K=kts,kte
12137 qi1d(k) = qi3d(i,k,j)
12138 qs1d(k) = 0.0
12139 qc1d(k) = qc3d(i,k,j)
12140 qi1d(k) = max(0.,qi1d(k))
12141 qc1d(k) = max(0.,qc1d(k))
12142 ENDDO
12143 ENDIF
12145 ! EMISS0=EMISS(I,J)
12146 ! GLW0=0.
12147 ! OLR0=0.
12148 ! TSFC=TSK(I,J)
12149 DO K=kts,kte
12150 QV1D(K)=AMAX1(QV1D(K),1.E-12)
12151 ENDDO
12153 ! Set up input for longwave
12154 ncol = 1
12155 ! Add extra layer from top of model to top of atmosphere
12156 ! nlay = (kte - kts + 1) + 1
12157 ! Edited for top of model adjustment (nlayers = kte + 1).
12158 ! Steven Cavallo, December 2010
12159 nlay = nlayers ! Keep these indices the same
12161 ! Select cloud overlap assumption (1 = random, 2 = maximum-random, 3 = maximum, 4 = exponential, 5 = exponential-random
12162 icld=cldovrlp ! J. Henderson AER assign namelist variable cldovrlp to existing icld
12164 ! Set julian date
12165 juldat = julian
12166 ! Select cloud liquid and ice optics parameterization options
12167 ! For passing in cloud optical properties directly:
12168 ! icld = 2
12169 ! inflglw = 0
12170 ! iceflglw = 0
12171 ! liqflglw = 0
12172 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
12173 inflglw = 2
12174 iceflglw = 3
12175 liqflglw = 1
12177 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
12178 IF (ICLOUD .ne. 0) THEN
12179 IF ( has_reqc .ne. 0) THEN
12180 inflglw = 3
12181 DO K=kts,kte
12182 recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
12183 if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
12184 & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
12185 recloud1D(ncol,K) = 10.5
12186 elseif(recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
12187 & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
12188 recloud1D(ncol,K) = 7.5
12189 endif
12190 ENDDO
12191 ELSE
12192 DO K=kts,kte
12193 recloud1D(ncol,K) = 5.0
12194 ENDDO
12195 ENDIF
12197 IF ( has_reqi .ne. 0) THEN
12198 inflglw = 4
12199 iceflglw = 4
12200 DO K=kts,kte
12201 reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6)
12202 if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
12203 idx_rei = int(t3d(i,k,j)-179.)
12204 idx_rei = min(max(idx_rei,1),75)
12205 corr = t3d(i,k,j) - int(t3d(i,k,j))
12206 reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + &
12207 & retab(idx_rei+1)*corr
12208 reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0)
12209 endif
12210 ENDDO
12211 ELSE
12212 DO K=kts,kte
12213 #if (EM_CORE==1)
12214 reice1D(ncol,K) = 10.0
12215 #else
12216 tem2 = 25.0 !- was 10.0
12217 tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3)
12218 if (tem3>thresh) then !- Only when IWC>1.e-9 gm^-3
12219 tem1=t1d(k)-273.15
12220 if (tem1 < -50.0) then
12221 tem2 = re_50C*tem3**0.109
12222 elseif (tem1 < -40.0) then
12223 tem2 = re_40C*tem3**0.08
12224 elseif (tem1 < -30.0) then
12225 tem2 = re_30C*tem3**0.055
12226 else
12227 tem2 = re_20C*tem3**0.031
12228 endif
12229 tem2 = max(25.,tem2)
12230 endif
12231 reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice<= 140 microns
12232 #endif
12233 ENDDO
12234 ENDIF
12236 IF ( has_reqs .ne. 0) THEN
12237 inflglw = 5
12238 iceflglw = 5
12239 DO K=kts,kte
12240 resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
12241 ENDDO
12242 ELSE
12243 DO K=kts,kte
12244 resnow1D(ncol,K) = 10.0
12245 ENDDO
12246 ENDIF
12248 ! special case for P3 microphysics
12249 ! put ice into snow category for optics, then set ice to zero
12250 IF (has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
12251 inflglw = 5
12252 iceflglw = 5
12253 DO K=kts,kte
12254 resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
12255 QS1D(K)=QI3D(I,K,J)
12256 QI1D(K)=0.
12257 reice1D(ncol,K)=10.
12258 END DO
12259 END IF
12261 ENDIF
12263 ! Layer indexing goes bottom to top here for all fields.
12264 ! Water vapor and ozone are converted from mmr to vmr.
12265 ! Pressures are in units of mb here.
12266 plev(ncol,1) = pw1d(1)
12267 tlev(ncol,1) = tw1d(1)
12268 tsfc(ncol) = tsk(i,j)
12269 do k = kts, kte
12270 play(ncol,k) = p1d(k)
12271 plev(ncol,k+1) = pw1d(k+1)
12272 pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
12273 tlay(ncol,k) = t1d(k)
12274 tlev(ncol,k+1) = tw1d(k+1)
12275 h2ovmr(ncol,k) = qv1d(k) * amdw
12276 co2vmr(ncol,k) = co2
12277 o2vmr(ncol,k) = o2
12278 ch4vmr(ncol,k) = ch4
12279 n2ovmr(ncol,k) = n2o
12280 cfc11vmr(ncol,k) = cfc11
12281 cfc12vmr(ncol,k) = cfc12
12282 cfc22vmr(ncol,k) = cfc22
12283 ccl4vmr(ncol,k) = ccl4
12284 enddo
12286 ! Derive height of each layer mid-point from layer thickness.
12287 ! Needed for exponential (icld=4) and exponential-random overlap (icld=5) options only.
12288 dzsum = 0.0
12289 do k = kts, kte
12290 dz = dz1d(k)
12291 hgt(ncol,k) = dzsum + 0.5*dz
12292 dzsum = dzsum + dz
12293 enddo
12295 ! This section is replaced with a new method to deal with model top
12296 if ( 1 == 0 ) then
12298 ! Define profile values for extra layer from model top to top of atmosphere.
12299 ! The top layer temperature for all gridpoints is set to the top layer-1
12300 ! temperature plus a constant (0 K) that represents an isothermal layer
12301 ! above ptop. Top layer interface temperatures are linearly interpolated
12302 ! from the layer temperatures.
12304 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
12305 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
12306 plev(ncol,kte+2) = 1.0e-5
12307 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
12308 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
12309 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
12310 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
12311 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
12312 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
12313 cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte)
12314 cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte)
12315 cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte)
12316 ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte)
12318 endif
12320 ! Set up values for extra layers to the top of the atmosphere.
12321 ! Temperature is calculated based on an average temperature profile given
12322 ! here in a table. The input table data is linearly interpolated to the
12323 ! column pressure. Mixing ratios are held constant except for ozone.
12324 ! Caution should be used if model top pressure is less than 5 hPa.
12325 ! Steven Cavallo, NCAR/MMM, December 2010
12326 ! Calculate the column pressure buffer levels above the
12327 ! model top
12328 do L=kte+1,nlayers,1
12329 plev(ncol,L+1) = plev(ncol,L) - deltap
12330 play(ncol,L) = 0.5*(plev(ncol,L) + plev(ncol,L+1))
12331 ! Fill in height array above model top to top of atmosphere using
12332 ! dz from model top layer for completeness, though this information is not
12333 ! likely to be used by the exponential-random cloud overlap method.
12334 hgt(ncol,L) = dzsum + 0.5*dz
12335 dzsum = dzsum + dz
12336 enddo
12337 ! Add zero as top level. This gets the temperature max at the
12338 ! stratopause, reducing the downward flux errors in the top
12339 ! levels. If zero happened to be the top level already,
12340 ! this will add another level with zero, but will not affect
12341 ! the radiative transfer calculation.
12342 plev(ncol,nlayers+1) = 0.00
12343 play(ncol,nlayers) = 0.5*(plev(ncol,nlayers) + plev(ncol,nlayers+1))
12345 ! Interpolate the table temperatures to column pressure levels
12346 do L=1,nlayers+1,1
12347 if ( PPROF(nproflevs) .lt. plev(ncol,L) ) then
12348 do LL=2,nproflevs,1
12349 if ( PPROF(LL) .lt. plev(ncol,L) ) then
12350 klev = LL - 1
12351 exit
12352 endif
12353 enddo
12355 else
12356 klev = nproflevs
12357 endif
12359 if (klev .ne. nproflevs ) then
12360 vark = TPROF(klev)
12361 vark1 = TPROF(klev+1)
12362 wght=(plev(ncol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev))
12363 else
12364 vark = TPROF(klev)
12365 vark1 = TPROF(klev)
12366 wght = 0.0
12367 endif
12368 varint(L) = wght*(vark1-vark)+vark
12370 enddo
12372 ! Match the interpolated table temperature profile to WRF column
12373 do L=kte+1,nlayers+1,1
12374 tlev(ncol,L) = varint(L) + (tlev(ncol,kte) - varint(kte))
12375 !if ( L .le. nlay ) then
12376 tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1))
12377 !endif
12378 enddo
12380 ! Now the chemical species (except for ozone)
12381 do L=kte+1,nlayers,1
12382 h2ovmr(ncol,L) = h2ovmr(ncol,kte)
12383 co2vmr(ncol,L) = co2vmr(ncol,kte)
12384 o2vmr(ncol,L) = o2vmr(ncol,kte)
12385 ch4vmr(ncol,L) = ch4vmr(ncol,kte)
12386 n2ovmr(ncol,L) = n2ovmr(ncol,kte)
12387 cfc11vmr(ncol,L) = cfc11vmr(ncol,kte)
12388 cfc12vmr(ncol,L) = cfc12vmr(ncol,kte)
12389 cfc22vmr(ncol,L) = cfc22vmr(ncol,kte)
12390 ccl4vmr(ncol,L) = ccl4vmr(ncol,kte)
12391 enddo
12392 ! End top of model buffer
12393 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
12394 ! Get ozone profile including amount in extra layer above model top.
12395 ! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers
12396 ! dimension for o3mmr
12397 call inirad (o3mmr,plev,kts,nlay-1)
12399 ! Steven Cavallo: Changed to nlayers from kte+1
12400 if(o3input.eq.2) then
12401 do k = kts, nlayers
12402 o3vmr(ncol,k) = o3mmr(k) * amdo
12403 if(k.le.kte)then
12404 o3vmr(ncol,k) = o31d(k)
12405 else
12406 ! apply shifted climatology profile above model top
12407 o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
12408 if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
12409 endif
12410 enddo
12411 else
12412 do k = kts, nlayers
12413 o3vmr(ncol,k) = o3mmr(k) * amdo
12414 if (k.le.kte) o31d(k) = o3vmr(ncol,k)
12415 enddo
12416 endif
12418 ! output o3 for o3input=0
12419 IF (o3input.ne.2) THEN
12420 DO K=kts,kte
12421 O33D(I,K,J)=O31D(K)
12422 ENDDO
12423 ENDIF
12425 ! Set surface emissivity in each RRTMG longwave band
12426 do nb = 1, nbndlw
12427 emis(ncol, nb) = emiss(i,j)
12428 enddo
12430 ! Define cloud optical properties for radiation (inflglw = 0)
12431 ! This is approach used with older RRTM_LW;
12432 ! Cloud and precipitation paths in g/m2
12433 ! qi=0 if no ice phase
12434 ! qs=0 if no ice phase
12435 if (inflglw .eq. 0) then
12436 do k = kts,kte
12437 ro = p1d(k) / (r * t1d(k))*100.
12438 dz = dz1d(k)
12439 clwp(k) = ro*qc1d(k)*dz*1000.
12440 ciwp(k) = ro*qi1d(k)*dz*1000.
12441 plwp(k) = (ro*qr1d(k))**0.75*dz*1000.
12442 piwp(k) = (ro*qs1d(k))**0.75*dz*1000.
12443 enddo
12445 ! Cloud fraction and cloud optical depth; old approach used with RRTM_LW
12446 do k = kts, kte
12447 cldfrac(ncol,k) = cldfra1d(k)
12448 do nb = 1, nbndlw
12449 taucld(nb,ncol,k) = abcw*clwp(k) + abice*ciwp(k) &
12450 +abrn*plwp(k) + absn*piwp(k)
12451 if (taucld(nb,ncol,k) .gt. 0.01) cldfrac(ncol,k) = 1.
12452 enddo
12453 enddo
12455 ! Zero out cloud physical property arrays; not used when passing optical properties
12456 ! into radiation
12457 do k = kts, kte
12458 clwpth(ncol,k) = 0.0
12459 ciwpth(ncol,k) = 0.0
12460 rel(ncol,k) = 10.0
12461 rei(ncol,k) = 10.0
12462 enddo
12463 endif
12465 ! Define cloud physical properties for radiation (inflglw = 1 or 2)
12466 ! Cloud fraction
12467 ! Set cloud arrays if passing cloud physical properties into radiation
12468 if (inflglw .gt. 0) then
12469 do k = kts, kte
12470 cldfrac(ncol,k) = cldfra1d(k)
12471 enddo
12473 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
12474 pcols = ncol
12475 pver = kte - kts + 1
12476 gravmks = g
12477 landfrac(ncol) = 2.-XLAND(I,J)
12478 landm(ncol) = landfrac(ncol)
12479 snowh(ncol) = 0.001*SNOW(I,J)
12480 icefrac(ncol) = XICE(I,J)
12482 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
12483 ! pdel is in mb here; convert back to Pa (*100.)
12484 ! Water paths are in units of g/m2
12485 ! snow added as ice cloud (JD 091022)
12486 do k = kts, kte
12487 gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
12488 gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
12489 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
12490 cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
12491 end do
12494 ! Mukul
12495 !..The ice water path is already sum of cloud ice and snow, but when we have explicit
12496 !.. ice effective radius, overwrite the ice path with only the cloud ice variable,
12497 !.. leaving out the snow for its own effect.
12498 if(iceflglw.ge.4)then
12499 do k = kts, kte
12500 gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
12501 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
12502 end do
12503 end if
12505 !..Here the snow path is adjusted if (radiation) effective radius of snow is
12506 !.. larger than what we currently have in the lookup tables. Since mass goes
12507 !.. rather close to diameter squared, adjust the mixing ratio of snow used
12508 !.. to compute its water path in combination with the max diameter. Not a
12509 !.. perfect fix, but certainly better than using all snow mass when diameter is
12510 !.. far larger than table currently contains and crystal sizes much larger than
12511 !.. about 140 microns have lesser impact than those much smaller sizes.
12513 if(iceflglw.eq.5)then
12514 do k = kts, kte
12515 snow_mass_factor = 0.99 ! Assume 1% of snow overlaps the cloud ice category
12516 gicewp = gicewp + (qs1d(k)*(1.0-snow_mass_factor) * pdel(ncol,k)*100.0 / gravmks * 1000.0)
12517 if (resnow1d(ncol,k) .gt. 130.)then
12518 snow_mass_factor = MIN(snow_mass_factor, &
12519 & (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)))
12520 resnow1d(ncol,k) = 130.0
12521 IF ( wrf_dm_on_monitor() ) THEN
12522 WRITE(message,*)'RRTMG: reducing snow mass (cloud path) to ', &
12523 nint(snow_mass_factor*100.), ' percent of full value'
12524 call wrf_debug(150, message)
12525 ENDIF
12526 endif
12527 gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
12528 csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
12529 end do
12530 end if
12533 !link the aerosol feedback to cloud -czhao
12534 if( PRESENT( progn ) ) then
12535 if (progn == 1) then
12536 !jdfcz if(prescribe==0) then
12538 pi = 4.*atan(1.0)
12539 third=1./3.
12540 rhoh2o=1.e3
12541 relconst=3/(4.*pi*rhoh2o)
12542 ! minimun liquid water path to calculate rel
12543 ! corresponds to optical depth of 1.e-3 for radius 4 microns.
12544 lwpmin=3.e-5
12545 do k = kts, kte
12546 reliq(ncol,k) = 10.
12547 if( PRESENT( F_QNDROP ) ) then
12548 if( F_QNDROP ) then
12549 if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
12550 qndrop1d(k).gt.1000. ) then
12551 reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
12552 ! apply scaling from Martin et al., JAS 51, 1830.
12553 reliq(ncol,k)=1.1*reliq(ncol,k)
12554 reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
12555 reliq(ncol,k)=max(reliq(ncol,k),4.)
12556 reliq(ncol,k)=min(reliq(ncol,k),20.)
12557 end if
12558 end if
12559 end if
12560 end do
12561 !jdfcz else ! prescribe
12562 ! following Kiehl
12563 ! call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12564 ! write(0,*) 'lw prescribe aerosol',maxval(qndrop3d)
12565 !jdfcz endif
12566 else ! progn
12567 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12568 endif
12569 else !present(progn)
12570 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12571 endif
12573 ! following Kristjansson and Mitchell
12574 call reicalc(ncol, pcols, pver, tlay, reice)
12577 !..If we already have effective radius of cloud and ice, then just overwrite what
12578 !.. was computed in the relcalc and reicalc subroutines above.
12580 if (inflglw .ge. 3) then
12581 do k = kts, kte
12582 reliq(ncol,k) = recloud1d(ncol,k)
12583 end do
12584 endif
12585 #if (EM_CORE==1)
12586 if (iceflglw .ge. 4) then
12587 #else
12588 if (iceflglw .ge. 3) then !BSF: was .ge. 4
12589 #endif
12591 do k = kts, kte
12592 reice(ncol,k) = reice1d(ncol,k)
12593 end do
12594 endif
12596 ! Limit upper bound of reice for Fu ice parameterization and convert
12597 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
12598 if (iceflglw .eq. 3) then
12599 do k = kts, kte
12600 reice(ncol,k) = reice(ncol,k) * 1.0315
12601 reice(ncol,k) = min(140.0,reice(ncol,k))
12602 end do
12603 endif
12604 !if CAMMGMP is used, use output from CAMMGMP
12605 if(is_CAMMGMP_used) then
12606 do k = kts, kte
12607 if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
12608 reice(ncol,k) = iradius(i,k,j)
12609 else
12610 reice(ncol,k) = 25.
12611 end if
12612 reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
12613 if ( qc1d(k) .gt. 1.e-20) then
12614 reliq(ncol,k) = lradius(i,k,j)
12615 else
12616 reliq(ncol,k) = 10.
12617 end if
12618 reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
12619 enddo
12620 endif
12623 ! Set cloud physical property arrays
12624 do k = kts, kte
12625 clwpth(ncol,k) = cliqwp(ncol,k)
12626 ciwpth(ncol,k) = cicewp(ncol,k)
12627 rel(ncol,k) = reliq(ncol,k)
12628 rei(ncol,k) = reice(ncol,k)
12629 enddo
12631 !Mukul
12632 if (inflglw .eq. 5) then
12633 do k = kts, kte
12634 cswpth(ncol,k) = csnowp(ncol,k)
12635 res(ncol,k) = resnow1d(ncol,k)
12636 end do
12637 else
12638 do k = kts, kte
12639 cswpth(ncol,k) = 0.
12640 res(ncol,k) = 10.
12641 end do
12642 endif
12644 ! Zero out cloud optical properties here; not used when passing physical properties
12645 ! to radiation and taucld is calculated in radiation
12646 do k = kts, kte
12647 do nb = 1, nbndlw
12648 taucld(nb,ncol,k) = 0.0
12649 enddo
12650 enddo
12651 endif
12653 ! No clouds are allowed in the extra layer from model top to TOA
12654 ! Steven Cavallo: Edited out for buffer adjustment below
12655 if ( 1 == 0 ) then
12658 clwpth(ncol,kte+1) = 0.
12659 ciwpth(ncol,kte+1) = 0.
12660 cswpth(ncol,kte+1) = 0.
12661 rel(ncol,kte+1) = 10.
12662 rei(ncol,kte+1) = 10.
12663 res(ncol,kte+1) = 10.
12664 cldfrac(ncol,kte+1) = 0.
12665 do nb = 1, nbndlw
12666 taucld(nb,ncol,kte+1) = 0.
12667 enddo
12669 endif
12671 ! Buffer adjustment. Steven Cavallo December 2010
12672 do k=kte+1,nlayers
12673 clwpth(ncol,k) = 0.
12674 ciwpth(ncol,k) = 0.
12675 cswpth(ncol,k) = 0.
12676 rel(ncol,k) = 10.
12677 rei(ncol,k) = 10.
12678 res(ncol,k) = 10.
12679 cldfrac(ncol,k) = 0.
12680 do nb = 1,nbndlw
12681 taucld(nb,ncol,k) = 0.
12682 enddo
12683 enddo
12685 iplon = 1
12686 irng = 0
12687 permuteseed = 150
12689 ! Sub-column generator for McICA
12690 lat=xlat(i,j) !retrieve scalar latitude for column calculation
12691 call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
12692 cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, &
12693 hgt, idcor, juldat, lat, &
12694 cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl)
12696 !--------------------------------------------------------------------------
12697 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
12698 !--------------------------------------------------------------------------
12699 ! Aerosol optical depth by layer for each RRTMG longwave band
12700 ! No aerosols in layer above model top (kte+1)
12701 ! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1
12702 ! do nb = 1, nbndlw
12703 ! do k = kts, kte+1
12704 ! tauaer(ncol,k,nb) = 0.
12705 ! enddo
12706 ! enddo
12708 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
12709 !
12710 do nb = 1, nbndlw
12711 do k = kts,nlayers
12712 tauaer(ncol,k,nb) = 0.
12713 end do
12714 end do
12716 #if ( WRF_CHEM == 1 )
12717 IF ( AER_RA_FEEDBACK == 1) then
12718 ! do nb = 1, nbndlw
12719 do k = kts,kte !wig
12720 if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then
12721 tauaer(ncol,k,1)=tauaerlw1(i,k,j)
12722 tauaer(ncol,k,2)=tauaerlw2(i,k,j)
12723 tauaer(ncol,k,3)=tauaerlw3(i,k,j)
12724 tauaer(ncol,k,4)=tauaerlw4(i,k,j)
12725 tauaer(ncol,k,5)=tauaerlw5(i,k,j)
12726 tauaer(ncol,k,6)=tauaerlw6(i,k,j)
12727 tauaer(ncol,k,7)=tauaerlw7(i,k,j)
12728 tauaer(ncol,k,8)=tauaerlw8(i,k,j)
12729 tauaer(ncol,k,9)=tauaerlw9(i,k,j)
12730 tauaer(ncol,k,10)=tauaerlw10(i,k,j)
12731 tauaer(ncol,k,11)=tauaerlw11(i,k,j)
12732 tauaer(ncol,k,12)=tauaerlw12(i,k,j)
12733 tauaer(ncol,k,13)=tauaerlw13(i,k,j)
12734 tauaer(ncol,k,14)=tauaerlw14(i,k,j)
12735 tauaer(ncol,k,15)=tauaerlw15(i,k,j)
12736 tauaer(ncol,k,16)=tauaerlw16(i,k,j)
12737 endif
12738 enddo ! k
12739 ! end do ! nb
12741 !wig beg
12742 do nb = 1, nbndlw
12743 slope = 0. !use slope as a sum holder
12744 do k = kts,kte
12745 slope = slope + tauaer(ncol,k,nb)
12746 end do
12747 if( slope < 0. ) then
12748 write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
12749 call wrf_error_fatal(msg)
12750 else if( slope > 5. ) then
12751 call wrf_message("-------------------------")
12752 write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
12753 call wrf_message(msg)
12755 call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16")
12756 do k=kts,kte
12757 write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j)
12758 call wrf_message(msg)
12759 end do
12760 call wrf_message("-------------------------")
12761 endif
12762 enddo ! nb
12763 endif ! aer_ra_feedback
12764 #endif
12766 ! Call RRTMG longwave radiation model
12767 call rrtmg_lw &
12768 (ncol ,nlay ,icld , &
12769 play ,plev ,tlay ,tlev ,tsfc , &
12770 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
12771 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
12772 inflglw ,iceflglw,liqflglw,cldfmcl , &
12773 taucmcl ,ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl , &
12774 tauaer , &
12775 uflx ,dflx ,hr ,uflxc ,dflxc, hrc, &
12776 uflxcln ,dflxcln, calc_clean_atm_diag )
12778 ! Output downard surface flux, and outgoing longwave flux and cloud forcing
12779 ! at the top of atmosphere (W/m2)
12780 glw(i,j) = dflx(1,1)
12781 ! olr(i,j) = uflx(1,kte+2)
12782 ! lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
12783 ! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead
12784 ! of top of model. Dec 2010.
12785 olr(i,j) = uflx(1,nlayers+1)
12786 lwcf(i,j) = uflxc(1,nlayers+1) - uflx(1,nlayers+1)
12788 if (present(lwupt)) then
12789 ! Output up and down toa fluxes for total and clear sky
12790 ! nlayers+1 represents value at 0 mb
12791 lwupt(i,j) = uflx(1,nlayers+1)
12792 lwuptc(i,j) = uflxc(1,nlayers+1)
12793 lwdnt(i,j) = dflx(1,nlayers+1)
12794 lwdntc(i,j) = dflxc(1,nlayers+1)
12795 ! Output up and down surface fluxes for total and clear sky
12796 lwupb(i,j) = uflx(1,1)
12797 lwupbc(i,j) = uflxc(1,1)
12798 lwdnb(i,j) = dflx(1,1)
12799 lwdnbc(i,j) = dflxc(1,1)
12800 if(calc_clean_atm_diag .gt. 0)then
12801 ! Output up and down toa fluxes for clean sky
12802 lwuptcln(i,j) = uflxcln(1,nlayers+1)
12803 lwdntcln(i,j) = dflxcln(1,nlayers+1)
12804 ! Output up and down surface fluxes for clean sky
12805 lwupbcln(i,j) = uflxcln(1,1)
12806 lwdnbcln(i,j) = dflxcln(1,1)
12807 end if
12808 endif
12810 ! Output up and down layer fluxes for total and clear sky.
12811 ! Vertical ordering is from bottom to top in units of W m-2.
12812 if ( present (lwupflx) ) then
12813 do k=kts,kte+2
12814 lwupflx(i,k,j) = uflx(1,k)
12815 lwupflxc(i,k,j) = uflxc(1,k)
12816 lwdnflx(i,k,j) = dflx(1,k)
12817 lwdnflxc(i,k,j) = dflxc(1,k)
12818 enddo
12819 endif
12821 ! Output heating rate tendency; convert heating rate from K/d to K/s
12822 ! Heating rate arrays are ordered vertically from bottom to top here.
12823 do k=kts,kte
12824 tten1d(k) = hr(ncol,k)/86400.
12825 rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j)
12826 tten1d(k) = hrc(ncol,k)/86400.
12827 rthratenlwc(i,k,j) = tten1d(k)/pi3d(i,k,j)
12828 enddo
12830 !
12831 end do i_loop
12832 end do j_loop
12834 !-------------------------------------------------------------------
12836 END SUBROUTINE RRTMG_LWRAD
12839 !-------------------------------------------------------------------------
12840 SUBROUTINE INIRAD (O3PROF,Plev, kts, kte)
12841 !-------------------------------------------------------------------------
12842 IMPLICIT NONE
12843 !-------------------------------------------------------------------------
12844 INTEGER, INTENT(IN ) :: kts,kte
12846 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12848 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12850 ! LOCAL VAR
12852 INTEGER :: k
12854 !
12855 ! COMPUTE OZONE MIXING RATIO DISTRIBUTION
12856 !
12857 DO K=kts,kte+1
12858 O3PROF(K)=0.
12859 ENDDO
12861 CALL O3DATA(O3PROF, Plev, kts, kte)
12863 END SUBROUTINE INIRAD
12865 !-------------------------------------------------------------------------
12866 SUBROUTINE O3DATA (O3PROF, Plev, kts, kte)
12867 !-------------------------------------------------------------------------
12868 IMPLICIT NONE
12869 !-------------------------------------------------------------------------
12870 !
12871 INTEGER, INTENT(IN ) :: kts, kte
12872 !
12873 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12875 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12877 ! LOCAL VAR
12878 INTEGER :: K, JJ
12880 REAL :: PRLEVH(kts:kte+2),PPWRKH(32), &
12881 O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), &
12882 O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31)
12884 REAL :: PB1, PB2, PT1, PT2
12886 DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, &
12887 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, &
12888 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, &
12889 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, &
12890 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, &
12891 9.856E-6,5.960E-6,5.960E-6/
12893 DATA PPSUM /955.890,850.532,754.599,667.742,589.841, &
12894 519.421,455.480,398.085,347.171,301.735,261.310,225.360, &
12895 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, &
12896 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, &
12897 9.277, 4.660, 2.421, 1.294, 0.647/
12898 !
12899 DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, &
12900 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, &
12901 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, &
12902 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, &
12903 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, &
12904 9.389E-6,6.135E-6,6.135E-6/
12906 DATA PPWIN /955.747,841.783,740.199,649.538,568.404, &
12907 495.815,431.069,373.464,322.354,277.190,237.635,203.433, &
12908 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, &
12909 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, &
12910 7.583, 3.620, 1.807, 0.938, 0.469/
12911 !
12913 DO K=1,31
12914 PPANN(K)=PPSUM(K)
12915 ENDDO
12916 !
12917 O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1))
12918 !
12919 DO K=2,31
12920 O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* &
12921 (PPSUM(K)-PPWIN(K-1))
12922 ENDDO
12923 !
12924 DO K=2,31
12925 O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K))
12926 ENDDO
12927 !
12928 DO K=1,31
12929 O3WRK(K)=O3ANN(K)
12930 PPWRK(K)=PPANN(K)
12931 ENDDO
12932 !
12933 ! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS
12934 !
12936 ! Plev is total P at model levels, from bottom to top
12937 ! Plev is in mb
12939 DO K=kts,kte+2
12940 PRLEVH(K)=Plev(K)
12941 ENDDO
12942 !
12943 PPWRKH(1)=1100.
12944 DO K=2,31
12945 PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2.
12946 ENDDO
12947 PPWRKH(32)=0.
12948 DO K=kts,kte+1
12949 DO 25 JJ=1,31
12950 IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN
12951 PB1=0.
12952 ELSE
12953 PB1=PRLEVH(K)-PPWRKH(JJ)
12954 ENDIF
12955 IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN
12956 PB2=0.
12957 ELSE
12958 PB2=PRLEVH(K)-PPWRKH(JJ+1)
12959 ENDIF
12960 IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN
12961 PT1=0.
12962 ELSE
12963 PT1=PRLEVH(K+1)-PPWRKH(JJ)
12964 ENDIF
12965 IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN
12966 PT2=0.
12967 ELSE
12968 PT2=PRLEVH(K+1)-PPWRKH(JJ+1)
12969 ENDIF
12970 O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ)
12971 25 CONTINUE
12972 O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1))
12974 ENDDO
12975 !
12976 END SUBROUTINE O3DATA
12978 !------------------------------------------------------------------
12980 !====================================================================
12981 SUBROUTINE rrtmg_lwinit( &
12982 p_top, allowed_to_read , &
12983 ids, ide, jds, jde, kds, kde, &
12984 ims, ime, jms, jme, kms, kme, &
12985 its, ite, jts, jte, kts, kte )
12986 !--------------------------------------------------------------------
12987 IMPLICIT NONE
12988 !--------------------------------------------------------------------
12990 LOGICAL , INTENT(IN) :: allowed_to_read
12991 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
12992 ims, ime, jms, jme, kms, kme, &
12993 its, ite, jts, jte, kts, kte
12994 REAL, INTENT(IN) :: p_top
12996 ! Steven Cavallo. Added for buffer layer adjustment. December 2010.
12997 NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels.
12998 ! nlayers will subsequently
12999 ! replace kte+1
13001 ! Read in absorption coefficients and other data
13002 IF ( allowed_to_read ) THEN
13003 CALL rrtmg_lwlookuptable
13004 ENDIF
13006 ! Perform g-point reduction and other initializations
13007 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
13008 call rrtmg_lw_ini(cp)
13010 END SUBROUTINE rrtmg_lwinit
13013 ! **************************************************************************
13014 SUBROUTINE rrtmg_lwlookuptable
13015 ! **************************************************************************
13017 IMPLICIT NONE
13019 ! Local
13020 INTEGER :: i
13021 LOGICAL :: opened
13022 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
13024 CHARACTER*80 errmess
13025 INTEGER rrtmg_unit
13027 IF ( wrf_dm_on_monitor() ) THEN
13028 DO i = 10,99
13029 INQUIRE ( i , OPENED = opened )
13030 IF ( .NOT. opened ) THEN
13031 rrtmg_unit = i
13032 GOTO 2010
13033 ENDIF
13034 ENDDO
13035 rrtmg_unit = -1
13036 2010 CONTINUE
13037 ENDIF
13038 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
13039 IF ( rrtmg_unit < 0 ) THEN
13040 CALL wrf_error_fatal ( 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// &
13041 'find unused fortran unit to read in lookup table.' )
13042 ENDIF
13044 IF ( wrf_dm_on_monitor() ) THEN
13045 OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA', &
13046 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
13047 ENDIF
13049 call lw_kgb01(rrtmg_unit)
13050 call lw_kgb02(rrtmg_unit)
13051 call lw_kgb03(rrtmg_unit)
13052 call lw_kgb04(rrtmg_unit)
13053 call lw_kgb05(rrtmg_unit)
13054 call lw_kgb06(rrtmg_unit)
13055 call lw_kgb07(rrtmg_unit)
13056 call lw_kgb08(rrtmg_unit)
13057 call lw_kgb09(rrtmg_unit)
13058 call lw_kgb10(rrtmg_unit)
13059 call lw_kgb11(rrtmg_unit)
13060 call lw_kgb12(rrtmg_unit)
13061 call lw_kgb13(rrtmg_unit)
13062 call lw_kgb14(rrtmg_unit)
13063 call lw_kgb15(rrtmg_unit)
13064 call lw_kgb16(rrtmg_unit)
13066 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
13068 RETURN
13069 9009 CONTINUE
13070 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_DATA on unit ',rrtmg_unit
13071 CALL wrf_error_fatal(errmess)
13073 END SUBROUTINE rrtmg_lwlookuptable
13075 ! **************************************************************************
13076 ! RRTMG Longwave Radiative Transfer Model
13077 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
13078 !
13079 ! Original version: E. J. Mlawer, et al.
13080 ! Revision for GCMs: Michael J. Iacono; October, 2002
13081 ! Revision for F90 formatting: Michael J. Iacono; June 2006
13082 !
13083 ! This file contains 16 READ statements that include the
13084 ! absorption coefficients and other data for each of the 16 longwave
13085 ! spectral bands used in RRTMG_LW. Here, the data are defined for 16
13086 ! g-points, or sub-intervals, per band. These data are combined and
13087 ! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce
13088 ! the total number of g-points from 256 to 140 for use in the GCM.
13089 ! **************************************************************************
13091 ! **************************************************************************
13092 subroutine lw_kgb01(rrtmg_unit)
13093 ! **************************************************************************
13095 use rrlw_kg01, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
13096 absa, absb, &
13097 selfrefo, forrefo
13099 implicit none
13100 save
13102 ! Input
13103 integer, intent(in) :: rrtmg_unit
13105 ! Local
13106 character*80 errmess
13107 logical, external :: wrf_dm_on_monitor
13109 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13110 ! and upper atmosphere.
13111 ! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
13113 ! The array KAO contains absorption coefs at the 16 chosen g-values
13114 ! for a range of pressure levels > ~100mb and temperatures. The first
13115 ! index in the array, JT, which runs from 1 to 5, corresponds to
13116 ! different temperatures. More specifically, JT = 3 means that the
13117 ! data are for the corresponding TREF for this pressure level,
13118 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13119 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13120 ! index, JP, runs from 1 to 13 and refers to the corresponding
13121 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13122 ! The third index, IG, goes from 1 to 16, and tells us which
13123 ! g-interval the absorption coefficients are for.
13125 ! The array KBO contains absorption coefs at the 16 chosen g-values
13126 ! for a range of pressure levels < ~100mb and temperatures. The first
13127 ! index in the array, JT, which runs from 1 to 5, corresponds to
13128 ! different temperatures. More specifically, JT = 3 means that the
13129 ! data are for the reference temperature TREF for this pressure
13130 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13131 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13132 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13133 ! reference pressure level (see taumol.f for the value of these
13134 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13135 ! and tells us which g-interval the absorption coefficients are for.
13137 ! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the
13138 ! nitrogen continuum for the upper and lower atmosphere.
13139 ! Minor gas mapping levels:
13140 ! Lower - n2: P = 142.5490 mbar, T = 215.70 K
13141 ! Upper - n2: P = 142.5490 mbar, T = 215.70 K
13143 ! The array FORREFO contains the coefficient of the water vapor
13144 ! foreign-continuum (including the energy term). The first
13145 ! index refers to reference temperature (296,260,224,260) and
13146 ! pressure (970,475,219,3 mbar) levels. The second index
13147 ! runs over the g-channel (1 to 16).
13149 ! The array SELFREFO contains the coefficient of the water vapor
13150 ! self-continuum (including the energy term). The first index
13151 ! refers to temperature in 7.2 degree increments. For instance,
13152 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13153 ! etc. The second index runs over the g-channel (1 to 16).
13155 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13157 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13158 fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
13159 DM_BCAST_MACRO(fracrefao)
13160 DM_BCAST_MACRO(fracrefbo)
13161 DM_BCAST_MACRO(kao)
13162 DM_BCAST_MACRO(kbo)
13163 DM_BCAST_MACRO(kao_mn2)
13164 DM_BCAST_MACRO(kbo_mn2)
13165 DM_BCAST_MACRO(selfrefo)
13166 DM_BCAST_MACRO(forrefo)
13168 RETURN
13169 9010 CONTINUE
13170 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13171 CALL wrf_error_fatal(errmess)
13173 end subroutine lw_kgb01
13175 ! **************************************************************************
13176 subroutine lw_kgb02(rrtmg_unit)
13177 ! **************************************************************************
13179 use rrlw_kg02, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13181 implicit none
13182 save
13184 ! Input
13185 integer, intent(in) :: rrtmg_unit
13187 ! Local
13188 character*80 errmess
13189 logical, external :: wrf_dm_on_monitor
13191 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13192 ! and upper atmosphere.
13193 ! Planck fraction mapping levels:
13194 ! Lower: P = 1053.630 mbar, T = 294.2 K
13195 ! Upper: P = 3.206e-2 mb, T = 197.92 K
13197 ! The array KAO contains absorption coefs at the 16 chosen g-values
13198 ! for a range of pressure levels > ~100mb and temperatures. The first
13199 ! index in the array, JT, which runs from 1 to 5, corresponds to
13200 ! different temperatures. More specifically, JT = 3 means that the
13201 ! data are for the corresponding TREF for this pressure level,
13202 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13203 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13204 ! index, JP, runs from 1 to 13 and refers to the corresponding
13205 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13206 ! The third index, IG, goes from 1 to 16, and tells us which
13207 ! g-interval the absorption coefficients are for.
13209 ! The array KBO contains absorption coefs at the 16 chosen g-values
13210 ! for a range of pressure levels < ~100mb and temperatures. The first
13211 ! index in the array, JT, which runs from 1 to 5, corresponds to
13212 ! different temperatures. More specifically, JT = 3 means that the
13213 ! data are for the reference temperature TREF for this pressure
13214 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13215 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13216 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13217 ! reference pressure level (see taumol.f for the value of these
13218 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13219 ! and tells us which g-interval the absorption coefficients are for.
13221 ! The array FORREFO contains the coefficient of the water vapor
13222 ! foreign-continuum (including the energy term). The first
13223 ! index refers to reference temperature (296,260,224,260) and
13224 ! pressure (970,475,219,3 mbar) levels. The second index
13225 ! runs over the g-channel (1 to 16).
13227 ! The array SELFREFO contains the coefficient of the water vapor
13228 ! self-continuum (including the energy term). The first index
13229 ! refers to temperature in 7.2 degree increments. For instance,
13230 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13231 ! etc. The second index runs over the g-channel (1 to 16).
13233 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13235 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13236 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13237 DM_BCAST_MACRO(fracrefao)
13238 DM_BCAST_MACRO(fracrefbo)
13239 DM_BCAST_MACRO(kao)
13240 DM_BCAST_MACRO(kbo)
13241 DM_BCAST_MACRO(selfrefo)
13242 DM_BCAST_MACRO(forrefo)
13244 RETURN
13245 9010 CONTINUE
13246 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13247 CALL wrf_error_fatal(errmess)
13249 end subroutine lw_kgb02
13251 ! **************************************************************************
13252 subroutine lw_kgb03(rrtmg_unit)
13253 ! **************************************************************************
13255 use rrlw_kg03, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
13256 kbo_mn2o, selfrefo, forrefo
13258 implicit none
13259 save
13261 ! Input
13262 integer, intent(in) :: rrtmg_unit
13264 ! Local
13265 character*80 errmess
13266 logical, external :: wrf_dm_on_monitor
13268 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13269 ! and upper atmosphere.
13270 ! Planck fraction mapping levels:
13271 ! Lower: P = 212.7250 mbar, T = 223.06 K
13272 ! Upper: P = 95.8 mbar, T = 215.7 k
13274 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13275 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13276 ! of water vapor to CO2. The first index in the array, JS, runs
13277 ! from 1 to 10, and corresponds to different gas column amount ratios,
13278 ! as expressed through the binary species parameter eta, defined as
13279 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13280 ! ratio of the reference MLS column amount value of gas 1
13281 ! to that of gas2.
13282 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13283 ! to different temperatures. More specifically, JT = 3 means that the
13284 ! data are for the reference temperature TREF for this pressure
13285 ! level, JT = 2 refers to the temperature
13286 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13287 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13288 ! to the reference pressure level (e.g. JP = 1 is for a
13289 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13290 ! and tells us which g-interval the absorption coefficients are for.
13292 ! The array KBO contains absorption coefs at the 16 chosen g-values
13293 ! for a range of pressure levels < ~100mb and temperatures. The first
13294 ! index in the array, JT, which runs from 1 to 5, corresponds to
13295 ! different temperatures. More specifically, JT = 3 means that the
13296 ! data are for the reference temperature TREF for this pressure
13297 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13298 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13299 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13300 ! reference pressure level (see taumol.f for the value of these
13301 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13302 ! and tells us which g-interval the absorption coefficients are for.
13303 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13304 ! to different temperatures. More specifically, JT = 3 means that the
13305 ! data are for the reference temperature TREF for this pressure
13306 ! level, JT = 2 refers to the temperature
13307 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13308 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13309 ! to the reference pressure level (e.g. JP = 1 is for a
13310 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13311 ! and tells us which g-interval the absorption coefficients are for.
13313 ! The array KAO_Mxx contains the absorption coefficient for
13314 ! a minor species at the 16 chosen g-values for a reference pressure
13315 ! level below 100~ mb. The first index in the array, JS, runs
13316 ! from 1 to 10, and corresponds to different gas column amount ratios,
13317 ! as expressed through the binary species parameter eta, defined as
13318 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13319 ! ratio of the reference MLS column amount value of gas 1
13320 ! to that of gas2. The second index refers to temperature
13321 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13322 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13323 ! runs over the g-channel (1 to 16).
13325 ! The array KBO_Mxx contains the absorption coefficient for
13326 ! a minor species at the 16 chosen g-values for a reference pressure
13327 ! level above 100~ mb. The first index in the array, JS, runs
13328 ! from 1 to 10, and corresponds to different gas column amounts ratios,
13329 ! as expressed through the binary species parameter eta, defined as
13330 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13331 ! ratio of the reference MLS column amount value of gas 1 to
13332 ! that of gas2. The second 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 third index
13335 ! runs over the g-channel (1 to 16).
13337 ! The array FORREFO contains the coefficient of the water vapor
13338 ! foreign-continuum (including the energy term). The first
13339 ! index refers to reference temperature (296,260,224,260) and
13340 ! pressure (970,475,219,3 mbar) levels. The second index
13341 ! runs over the g-channel (1 to 16).
13343 ! The array SELFREFO contains the coefficient of the water vapor
13344 ! self-continuum (including the energy term). The first index
13345 ! refers to temperature in 7.2 degree increments. For instance,
13346 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13347 ! etc. The second index runs over the g-channel (1 to 16).
13349 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13351 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13352 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
13353 DM_BCAST_MACRO(fracrefao)
13354 DM_BCAST_MACRO(fracrefbo)
13355 DM_BCAST_MACRO(kao)
13356 DM_BCAST_MACRO(kbo)
13357 DM_BCAST_MACRO(kao_mn2o)
13358 DM_BCAST_MACRO(kbo_mn2o)
13359 DM_BCAST_MACRO(selfrefo)
13360 DM_BCAST_MACRO(forrefo)
13362 RETURN
13363 9010 CONTINUE
13364 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13365 CALL wrf_error_fatal(errmess)
13367 end subroutine lw_kgb03
13369 ! **************************************************************************
13370 subroutine lw_kgb04(rrtmg_unit)
13371 ! **************************************************************************
13373 use rrlw_kg04, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13375 implicit none
13376 save
13378 ! Input
13379 integer, intent(in) :: rrtmg_unit
13381 ! Local
13382 character*80 errmess
13383 logical, external :: wrf_dm_on_monitor
13385 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13386 ! and upper atmosphere.
13387 ! Planck fraction mapping levels:
13388 ! Lower : P = 142.5940 mbar, T = 215.70 K
13389 ! Upper : P = 95.58350 mb, T = 215.70 K
13391 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13392 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13393 ! of water vapor to CO2. The first index in the array, JS, runs
13394 ! from 1 to 10, and corresponds to different gas column amount ratios,
13395 ! as expressed through the binary species parameter eta, defined as
13396 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13397 ! ratio of the reference MLS column amount value of gas 1
13398 ! to that of gas2.
13399 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13400 ! to different temperatures. More specifically, JT = 3 means that the
13401 ! data are for the reference temperature TREF for this pressure
13402 ! level, JT = 2 refers to the temperature
13403 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13404 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13405 ! to the reference pressure level (e.g. JP = 1 is for a
13406 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13407 ! and tells us which g-interval the absorption coefficients are for.
13409 ! The array KBO contains absorption coefs for each of the 16 g-intervals
13410 ! for a range of pressure levels < ~100mb, temperatures, and ratios
13411 ! of H2O to CO2. The first index in the array, JS, runs
13412 ! from 1 to 10, and corresponds to different gas column amount ratios,
13413 ! as expressed through the binary species parameter eta, defined as
13414 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13415 ! ratio of the reference MLS column amount value of gas 1
13416 ! to that of gas2. The second index, JT, which
13417 ! runs from 1 to 5, corresponds to different temperatures. More
13418 ! specifically, JT = 3 means that the data are for the corresponding
13419 ! reference temperature TREF for this pressure level, JT = 2 refers
13420 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
13421 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
13422 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
13423 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
13424 ! 16, and tells us which g-interval the absorption coefficients are for.
13426 ! The array FORREFO contains the coefficient of the water vapor
13427 ! foreign-continuum (including the energy term). The first
13428 ! index refers to reference temperature (296,260,224,260) and
13429 ! pressure (970,475,219,3 mbar) levels. The second index
13430 ! runs over the g-channel (1 to 16).
13432 ! The array SELFREFO contains the coefficient of the water vapor
13433 ! self-continuum (including the energy term). The first index
13434 ! refers to temperature in 7.2 degree increments. For instance,
13435 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13436 ! etc. The second index runs over the g-channel (1 to 16).
13438 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13440 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13441 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13442 DM_BCAST_MACRO(fracrefao)
13443 DM_BCAST_MACRO(fracrefbo)
13444 DM_BCAST_MACRO(kao)
13445 DM_BCAST_MACRO(kbo)
13446 DM_BCAST_MACRO(selfrefo)
13447 DM_BCAST_MACRO(forrefo)
13449 RETURN
13450 9010 CONTINUE
13451 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13452 CALL wrf_error_fatal(errmess)
13454 end subroutine lw_kgb04
13456 ! **************************************************************************
13457 subroutine lw_kgb05(rrtmg_unit)
13458 ! **************************************************************************
13460 use rrlw_kg05, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, &
13461 selfrefo, forrefo, ccl4o
13463 implicit none
13464 save
13466 ! Input
13467 integer, intent(in) :: rrtmg_unit
13469 ! Local
13470 character*80 errmess
13471 logical, external :: wrf_dm_on_monitor
13473 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13474 ! and upper atmosphere.
13475 ! Planck fraction mapping levels:
13476 ! Lower: P = 473.42 mb, T = 259.83
13477 ! Upper: P = 0.2369280 mbar, T = 253.60 K
13479 ! The arrays kao_mo3 and ccl4o contain the coefficients for
13480 ! ozone and ccl4 in the lower atmosphere.
13481 ! Minor gas mapping level:
13482 ! Lower - o3: P = 317.34 mbar, T = 240.77 k
13483 ! Lower - ccl4:
13485 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13486 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13487 ! of water vapor to CO2. The first index in the array, JS, runs
13488 ! from 1 to 10, and corresponds to different gas column amount ratios,
13489 ! as expressed through the binary species parameter eta, defined as
13490 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13491 ! ratio of the reference MLS column amount value of gas 1
13492 ! to that of gas2.
13493 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13494 ! to different temperatures. More specifically, JT = 3 means that the
13495 ! data are for the reference temperature TREF for this pressure
13496 ! level, JT = 2 refers to the temperature
13497 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13498 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13499 ! to the reference pressure level (e.g. JP = 1 is for a
13500 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13501 ! and tells us which g-interval the absorption coefficients are for.
13503 ! The array KBO contains absorption coefs for each of the 16 g-intervals
13504 ! for a range of pressure levels < ~100mb, temperatures, and ratios
13505 ! of H2O to CO2. The first index in the array, JS, runs
13506 ! from 1 to 10, and corresponds to different gas column amount ratios,
13507 ! as expressed through the binary species parameter eta, defined as
13508 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13509 ! ratio of the reference MLS column amount value of gas 1
13510 ! to that of gas2. The second index, JT, which
13511 ! runs from 1 to 5, corresponds to different temperatures. More
13512 ! specifically, JT = 3 means that the data are for the corresponding
13513 ! reference temperature TREF for this pressure level, JT = 2 refers
13514 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
13515 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
13516 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
13517 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
13518 ! 16, and tells us which g-interval the absorption coefficients are for.
13520 ! The array KAO_Mxx contains the absorption coefficient for
13521 ! a minor species at the 16 chosen g-values for a reference pressure
13522 ! level below 100~ mb. The first index in the array, JS, runs
13523 ! from 1 to 10, and corresponds to different gas column amount ratios,
13524 ! as expressed through the binary species parameter eta, defined as
13525 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13526 ! ratio of the reference MLS column amount value of gas 1
13527 ! to that of gas2. The second index refers to temperature
13528 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13529 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13530 ! runs over the g-channel (1 to 16).
13532 ! The array FORREFO contains the coefficient of the water vapor
13533 ! foreign-continuum (including the energy term). The first
13534 ! index refers to reference temperature (296,260,224,260) and
13535 ! pressure (970,475,219,3 mbar) levels. The second index
13536 ! runs over the g-channel (1 to 16).
13538 ! The array SELFREFO contains the coefficient of the water vapor
13539 ! self-continuum (including the energy term). The first index
13540 ! refers to temperature in 7.2 degree increments. For instance,
13541 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13542 ! etc. The second index runs over the g-channel (1 to 16).
13544 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13546 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13547 fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
13548 DM_BCAST_MACRO(fracrefao)
13549 DM_BCAST_MACRO(fracrefbo)
13550 DM_BCAST_MACRO(kao)
13551 DM_BCAST_MACRO(kbo)
13552 DM_BCAST_MACRO(kao_mo3)
13553 DM_BCAST_MACRO(ccl4o)
13554 DM_BCAST_MACRO(selfrefo)
13555 DM_BCAST_MACRO(forrefo)
13557 RETURN
13558 9010 CONTINUE
13559 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13560 CALL wrf_error_fatal(errmess)
13562 end subroutine lw_kgb05
13564 ! **************************************************************************
13565 subroutine lw_kgb06(rrtmg_unit)
13566 ! **************************************************************************
13568 use rrlw_kg06
13569 ! use rrlw_kg06, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, &
13570 ! cfc11adjo, cfc12o
13572 implicit none
13573 save
13575 ! Input
13576 integer, intent(in) :: rrtmg_unit
13578 ! Local
13579 character*80 errmess
13580 logical, external :: wrf_dm_on_monitor
13582 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13583 ! and upper atmosphere.
13584 ! Planck fraction mapping levels:
13585 ! Lower: : P = 473.4280 mb, T = 259.83 K
13587 ! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
13588 ! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
13589 ! atmosphere.
13590 ! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
13591 ! Minor gas mapping level:
13592 ! Lower - co2: P = 706.2720 mb, T = 294.2 k
13593 ! Upper - cfc11, cfc12
13595 ! The array KAO contains absorption coefs at the 16 chosen g-values
13596 ! for a range of pressure levels > ~100mb and temperatures. The first
13597 ! index in the array, JT, which runs from 1 to 5, corresponds to
13598 ! different temperatures. More specifically, JT = 3 means that the
13599 ! data are for the corresponding TREF for this pressure level,
13600 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13601 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13602 ! index, JP, runs from 1 to 13 and refers to the corresponding
13603 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13604 ! The third index, IG, goes from 1 to 16, and tells us which
13605 ! g-interval the absorption coefficients are for.
13607 ! The array KAO_Mxx contains the absorption coefficient for
13608 ! a minor species at the 16 chosen g-values for a reference pressure
13609 ! level below 100~ mb. The first index refers to temperature
13610 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13611 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13612 ! runs over the g-channel (1 to 16).
13614 ! The array FORREFO contains the coefficient of the water vapor
13615 ! foreign-continuum (including the energy term). The first
13616 ! index refers to reference temperature (296,260,224,260) and
13617 ! pressure (970,475,219,3 mbar) levels. The second index
13618 ! runs over the g-channel (1 to 16).
13620 ! The array SELFREFO contains the coefficient of the water vapor
13621 ! self-continuum (including the energy term). The first index
13622 ! refers to temperature in 7.2 degree increments. For instance,
13623 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13624 ! etc. The second index runs over the g-channel (1 to 16).
13626 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13628 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13629 fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
13630 DM_BCAST_MACRO(fracrefao)
13631 DM_BCAST_MACRO(kao)
13632 DM_BCAST_MACRO(kao_mco2)
13633 DM_BCAST_MACRO(cfc11adjo)
13634 DM_BCAST_MACRO(cfc12o)
13635 DM_BCAST_MACRO(selfrefo)
13636 DM_BCAST_MACRO(forrefo)
13638 RETURN
13639 9010 CONTINUE
13640 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13641 CALL wrf_error_fatal(errmess)
13643 end subroutine lw_kgb06
13645 ! **************************************************************************
13646 subroutine lw_kgb07(rrtmg_unit)
13647 ! **************************************************************************
13649 use rrlw_kg07, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, &
13650 kbo_mco2, selfrefo, forrefo
13652 implicit none
13653 save
13655 ! Input
13656 integer, intent(in) :: rrtmg_unit
13658 ! Local
13659 character*80 errmess
13660 logical, external :: wrf_dm_on_monitor
13662 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13663 ! and upper atmosphere.
13664 ! Planck fraction mapping levels:
13665 ! Lower : P = 706.27 mb, T = 278.94 K
13666 ! Upper : P = 95.58 mbar, T= 215.70 K
13668 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13669 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13670 ! of water vapor to CO2. The first index in the array, JS, runs
13671 ! from 1 to 10, and corresponds to different gas column amount ratios,
13672 ! as expressed through the binary species parameter eta, defined as
13673 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13674 ! ratio of the reference MLS column amount value of gas 1
13675 ! to that of gas2.
13676 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13677 ! to different temperatures. More specifically, JT = 3 means that the
13678 ! data are for the reference temperature TREF for this pressure
13679 ! level, JT = 2 refers to the temperature
13680 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13681 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13682 ! to the reference pressure level (e.g. JP = 1 is for a
13683 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13684 ! and tells us which g-interval the absorption coefficients are for.
13686 ! The array KBO contains absorption coefs at the 16 chosen g-values
13687 ! for a range of pressure levels < ~100mb and temperatures. The first
13688 ! index in the array, JT, which runs from 1 to 5, corresponds to
13689 ! different temperatures. More specifically, JT = 3 means that the
13690 ! data are for the reference temperature TREF for this pressure
13691 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13692 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13693 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13694 ! reference pressure level (see taumol.f for the value of these
13695 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13696 ! and tells us which g-interval the absorption coefficients are for.
13698 ! The array KAO_Mxx contains the absorption coefficient for
13699 ! a minor species at the 16 chosen g-values for a reference pressure
13700 ! level below 100~ mb. The first index in the array, JS, runs
13701 ! from 1 to 10, and corresponds to different gas column amount ratios,
13702 ! as expressed through the binary species parameter eta, defined as
13703 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13704 ! ratio of the reference MLS column amount value of gas 1
13705 ! to that of gas2. The second index refers to temperature
13706 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13707 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13708 ! runs over the g-channel (1 to 16).
13710 ! The array KBO_Mxx contains the absorption coefficient for
13711 ! a minor species at the 16 chosen g-values for a reference pressure
13712 ! level above 100~ mb. The first index refers to temperature
13713 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13714 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13715 ! runs over the g-channel (1 to 16).
13717 ! The array FORREFO contains the coefficient of the water vapor
13718 ! foreign-continuum (including the energy term). The first
13719 ! index refers to reference temperature (296_rb,260_rb,224,260) and
13720 ! pressure (970,475,219,3 mbar) levels. The second index
13721 ! runs over the g-channel (1 to 16).
13723 ! The array SELFREFO contains the coefficient of the water vapor
13724 ! self-continuum (including the energy term). The first index
13725 ! refers to temperature in 7.2 degree increments. For instance,
13726 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13727 ! etc. The second index runs over the g-channel (1 to 16).
13729 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13731 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13732 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
13733 DM_BCAST_MACRO(fracrefao)
13734 DM_BCAST_MACRO(fracrefbo)
13735 DM_BCAST_MACRO(kao)
13736 DM_BCAST_MACRO(kbo)
13737 DM_BCAST_MACRO(kao_mco2)
13738 DM_BCAST_MACRO(kbo_mco2)
13739 DM_BCAST_MACRO(selfrefo)
13740 DM_BCAST_MACRO(forrefo)
13742 RETURN
13743 9010 CONTINUE
13744 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13745 CALL wrf_error_fatal(errmess)
13747 end subroutine lw_kgb07
13749 ! **************************************************************************
13750 subroutine lw_kgb08(rrtmg_unit)
13751 ! **************************************************************************
13753 use rrlw_kg08, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
13754 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
13755 cfc12o, cfc22adjo
13757 implicit none
13758 save
13760 ! Input
13761 integer, intent(in) :: rrtmg_unit
13763 ! Local
13764 character*80 errmess
13765 logical, external :: wrf_dm_on_monitor
13767 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13768 ! and upper atmosphere.
13769 ! Planck fraction mapping levels:
13770 ! Lower: P=473.4280 mb, T = 259.83 K
13771 ! Upper: P=95.5835 mb, T= 215.7 K
13773 ! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for
13774 ! carbon dioxide and n2o in the lower and upper atmosphere.
13775 ! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere,
13776 ! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22.
13777 ! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1
13778 ! and 1290-1335 cm-1 bands.
13779 ! Minor gas mapping level:
13780 ! Lower - co2: P = 1053.63 mb, T = 294.2 k
13781 ! Lower - o3: P = 317.348 mb, T = 240.77 k
13782 ! Lower - n2o: P = 706.2720 mb, T= 278.94 k
13783 ! Lower - cfc12, cfc22
13784 ! Upper - co2: P = 35.1632 mb, T = 223.28 k
13785 ! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
13787 ! The array KAO contains absorption coefs at the 16 chosen g-values
13788 ! for a range of pressure levels > ~100mb and temperatures. The first
13789 ! index in the array, JT, which runs from 1 to 5, corresponds to
13790 ! different temperatures. More specifically, JT = 3 means that the
13791 ! data are for the corresponding TREF for this pressure level,
13792 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13793 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13794 ! index, JP, runs from 1 to 13 and refers to the corresponding
13795 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13796 ! The third index, IG, goes from 1 to 16, and tells us which
13797 ! g-interval the absorption coefficients are for.
13799 ! The array KBO contains absorption coefs at the 16 chosen g-values
13800 ! for a range of pressure levels < ~100mb and temperatures. The first
13801 ! index in the array, JT, which runs from 1 to 5, corresponds to
13802 ! different temperatures. More specifically, JT = 3 means that the
13803 ! data are for the reference temperature TREF for this pressure
13804 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13805 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13806 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13807 ! reference pressure level (see taumol.f for the value of these
13808 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13809 ! and tells us which g-interval the absorption coefficients are for.
13811 ! The array KAO_Mxx contains the absorption coefficient for
13812 ! a minor species at the 16 chosen g-values for a reference pressure
13813 ! level below 100~ mb. The first index refers to temperature
13814 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13815 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13816 ! runs over the g-channel (1 to 16).
13818 ! The array KBO_Mxx contains the absorption coefficient for
13819 ! a minor species at the 16 chosen g-values for a reference pressure
13820 ! level above 100~ mb. The first index refers to temperature
13821 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13822 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13823 ! runs over the g-channel (1 to 16).
13825 ! The array FORREFO contains the coefficient of the water vapor
13826 ! foreign-continuum (including the energy term). The first
13827 ! index refers to reference temperature (296,260,224,260) and
13828 ! pressure (970,475,219,3 mbar) levels. The second index
13829 ! runs over the g-channel (1 to 16).
13831 ! The array SELFREFO contains the coefficient of the water vapor
13832 ! self-continuum (including the energy term). The first index
13833 ! refers to temperature in 7.2 degree increments. For instance,
13834 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13835 ! etc. The second index runs over the g-channel (1 to 16).
13837 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13839 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13840 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, &
13841 kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
13842 DM_BCAST_MACRO(fracrefao)
13843 DM_BCAST_MACRO(fracrefbo)
13844 DM_BCAST_MACRO(kao)
13845 DM_BCAST_MACRO(kbo)
13846 DM_BCAST_MACRO(kao_mco2)
13847 DM_BCAST_MACRO(kbo_mco2)
13848 DM_BCAST_MACRO(kao_mn2o)
13849 DM_BCAST_MACRO(kbo_mn2o)
13850 DM_BCAST_MACRO(kao_mo3)
13851 DM_BCAST_MACRO(cfc12o)
13852 DM_BCAST_MACRO(cfc22adjo)
13853 DM_BCAST_MACRO(selfrefo)
13854 DM_BCAST_MACRO(forrefo)
13856 RETURN
13857 9010 CONTINUE
13858 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13859 CALL wrf_error_fatal(errmess)
13861 end subroutine lw_kgb08
13863 ! **************************************************************************
13864 subroutine lw_kgb09(rrtmg_unit)
13865 ! **************************************************************************
13867 use rrlw_kg09, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
13868 kbo_mn2o, selfrefo, forrefo
13870 implicit none
13871 save
13873 ! Input
13874 integer, intent(in) :: rrtmg_unit
13876 ! Local
13877 character*80 errmess
13878 logical, external :: wrf_dm_on_monitor
13880 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13881 ! and upper atmosphere.
13882 ! Planck fraction mapping levels:
13883 ! Lower: P=212.7250 mb, T = 223.06 K
13884 ! Upper: P=3.20e-2 mb, T = 197.92 k
13886 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13887 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13888 ! of water vapor to CO2. The first index in the array, JS, runs
13889 ! from 1 to 10, and corresponds to different gas column amount ratios,
13890 ! as expressed through the binary species parameter eta, defined as
13891 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13892 ! ratio of the reference MLS column amount value of gas 1
13893 ! to that of gas2.
13894 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13895 ! to different temperatures. More specifically, JT = 3 means that the
13896 ! data are for the reference temperature TREF for this pressure
13897 ! level, JT = 2 refers to the temperature
13898 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13899 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13900 ! to the reference pressure level (e.g. JP = 1 is for a
13901 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13902 ! and tells us which g-interval the absorption coefficients are for.
13904 ! The array KBO contains absorption coefs at the 16 chosen g-values
13905 ! for a range of pressure levels < ~100mb and temperatures. The first
13906 ! index in the array, JT, which runs from 1 to 5, corresponds to
13907 ! different temperatures. More specifically, JT = 3 means that the
13908 ! data are for the reference temperature TREF for this pressure
13909 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13910 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13911 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13912 ! reference pressure level (see taumol.f for the value of these
13913 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13914 ! and tells us which g-interval the absorption coefficients are for.
13916 ! The array KAO_Mxx contains the absorption coefficient for
13917 ! a minor species at the 16 chosen g-values for a reference pressure
13918 ! level below 100~ mb. The first index in the array, JS, runs
13919 ! from 1 to 10, and corresponds to different gas column amount ratios,
13920 ! as expressed through the binary species parameter eta, defined as
13921 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13922 ! ratio of the reference MLS column amount value of gas 1
13923 ! to that of gas2. The second index refers to temperature
13924 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13925 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13926 ! runs over the g-channel (1 to 16).
13928 ! The array KBO_Mxx contains the absorption coefficient for
13929 ! a minor species at the 16 chosen g-values for a reference pressure
13930 ! level above 100~ mb. The first index refers to temperature
13931 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13932 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13933 ! runs over the g-channel (1 to 16).
13935 ! The array FORREFO contains the coefficient of the water vapor
13936 ! foreign-continuum (including the energy term). The first
13937 ! index refers to reference temperature (296,260,224,260) and
13938 ! pressure (970,475,219,3 mbar) levels. The second index
13939 ! runs over the g-channel (1 to 16).
13941 ! The array SELFREFO contains the coefficient of the water vapor
13942 ! self-continuum (including the energy term). The first index
13943 ! refers to temperature in 7.2 degree increments. For instance,
13944 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13945 ! etc. The second index runs over the g-channel (1 to 16).
13947 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13949 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13950 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
13951 DM_BCAST_MACRO(fracrefao)
13952 DM_BCAST_MACRO(fracrefbo)
13953 DM_BCAST_MACRO(kao)
13954 DM_BCAST_MACRO(kbo)
13955 DM_BCAST_MACRO(kao_mn2o)
13956 DM_BCAST_MACRO(kbo_mn2o)
13957 DM_BCAST_MACRO(selfrefo)
13958 DM_BCAST_MACRO(forrefo)
13960 RETURN
13961 9010 CONTINUE
13962 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13963 CALL wrf_error_fatal(errmess)
13965 end subroutine lw_kgb09
13967 ! **************************************************************************
13968 subroutine lw_kgb10(rrtmg_unit)
13969 ! **************************************************************************
13971 use rrlw_kg10, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13973 implicit none
13974 save
13976 ! Input
13977 integer, intent(in) :: rrtmg_unit
13979 ! Local
13980 character*80 errmess
13981 logical, external :: wrf_dm_on_monitor
13983 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13984 ! and upper atmosphere.
13985 ! Planck fraction mapping levels:
13986 ! Lower: P = 212.7250 mb, T = 223.06 K
13987 ! Upper: P = 95.58350 mb, T = 215.70 K
13989 ! The array KAO contains absorption coefs at the 16 chosen g-values
13990 ! for a range of pressure levels > ~100mb and temperatures. The first
13991 ! index in the array, JT, which runs from 1 to 5, corresponds to
13992 ! different temperatures. More specifically, JT = 3 means that the
13993 ! data are for the corresponding TREF for this pressure level,
13994 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13995 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13996 ! index, JP, runs from 1 to 13 and refers to the corresponding
13997 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13998 ! The third index, IG, goes from 1 to 16, and tells us which
13999 ! g-interval the absorption coefficients are for.
14001 ! The array KBO contains absorption coefs at the 16 chosen g-values
14002 ! for a range of pressure levels < ~100mb and temperatures. The first
14003 ! index in the array, JT, which runs from 1 to 5, corresponds to
14004 ! different temperatures. More specifically, JT = 3 means that the
14005 ! data are for the reference temperature TREF for this pressure
14006 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
14007 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
14008 ! The second index, JP, runs from 13 to 59 and refers to the JPth
14009 ! reference pressure level (see taumol.f for the value of these
14010 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
14011 ! and tells us which g-interval the absorption coefficients are for.
14013 ! The array FORREFO contains the coefficient of the water vapor
14014 ! foreign-continuum (including the energy term). The first
14015 ! index refers to reference temperature (296,260,224,260) and
14016 ! pressure (970,475,219,3 mbar) levels. The second index
14017 ! runs over the g-channel (1 to 16).
14019 ! The array SELFREFO contains the coefficient of the water vapor
14020 ! self-continuum (including the energy term). The first index
14021 ! refers to temperature in 7.2 degree increments. For instance,
14022 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14023 ! etc. The second index runs over the g-channel (1 to 16).
14025 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14027 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14028 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
14029 DM_BCAST_MACRO(fracrefao)
14030 DM_BCAST_MACRO(fracrefbo)
14031 DM_BCAST_MACRO(kao)
14032 DM_BCAST_MACRO(kbo)
14033 DM_BCAST_MACRO(selfrefo)
14034 DM_BCAST_MACRO(forrefo)
14036 RETURN
14037 9010 CONTINUE
14038 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14039 CALL wrf_error_fatal(errmess)
14041 end subroutine lw_kgb10
14043 ! **************************************************************************
14044 subroutine lw_kgb11(rrtmg_unit)
14045 ! **************************************************************************
14047 use rrlw_kg11, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, &
14048 kbo_mo2, selfrefo, forrefo
14050 implicit none
14051 save
14053 ! Input
14054 integer, intent(in) :: rrtmg_unit
14056 ! Local
14057 character*80 errmess
14058 logical, external :: wrf_dm_on_monitor
14060 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14061 ! and upper atmosphere.
14062 ! Planck fraction mapping levels:
14063 ! Lower: P=1053.63 mb, T= 294.2 K
14064 ! Upper: P=0.353 mb, T = 262.11 K
14066 ! The array KAO contains absorption coefs at the 16 chosen g-values
14067 ! for a range of pressure levels > ~100mb and temperatures. The first
14068 ! index in the array, JT, which runs from 1 to 5, corresponds to
14069 ! different temperatures. More specifically, JT = 3 means that the
14070 ! data are for the corresponding TREF for this pressure level,
14071 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
14072 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
14073 ! index, JP, runs from 1 to 13 and refers to the corresponding
14074 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
14075 ! The third index, IG, goes from 1 to 16, and tells us which
14076 ! g-interval the absorption coefficients are for.
14078 ! The array KBO contains absorption coefs at the 16 chosen g-values
14079 ! for a range of pressure levels < ~100mb and temperatures. The first
14080 ! index in the array, JT, which runs from 1 to 5, corresponds to
14081 ! different temperatures. More specifically, JT = 3 means that the
14082 ! data are for the reference temperature TREF for this pressure
14083 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
14084 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
14085 ! The second index, JP, runs from 13 to 59 and refers to the JPth
14086 ! reference pressure level (see taumol.f for the value of these
14087 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
14088 ! and tells us which g-interval the absorption coefficients are for.
14090 ! The array KAO_Mxx contains the absorption coefficient for
14091 ! a minor species at the 16 chosen g-values for a reference pressure
14092 ! level below 100~ mb. The first index refers to temperature
14093 ! in 7.2 degree increments. For instance, JT = 1 refers to a
14094 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
14095 ! runs over the g-channel (1 to 16).
14097 ! The array KBO_Mxx contains the absorption coefficient for
14098 ! a minor species at the 16 chosen g-values for a reference pressure
14099 ! level above 100~ mb. The first index refers to temperature
14100 ! in 7.2 degree increments. For instance, JT = 1 refers to a
14101 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
14102 ! runs over the g-channel (1 to 16).
14104 ! The array FORREFO contains the coefficient of the water vapor
14105 ! foreign-continuum (including the energy term). The first
14106 ! index refers to reference temperature (296,260,224,260) and
14107 ! pressure (970,475,219,3 mbar) levels. The second index
14108 ! runs over the g-channel (1 to 16).
14110 ! The array SELFREFO contains the coefficient of the water vapor
14111 ! self-continuum (including the energy term). The first index
14112 ! refers to temperature in 7.2 degree increments. For instance,
14113 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14114 ! etc. The second index runs over the g-channel (1 to 16).
14116 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14118 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14119 fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
14120 DM_BCAST_MACRO(fracrefao)
14121 DM_BCAST_MACRO(fracrefbo)
14122 DM_BCAST_MACRO(kao)
14123 DM_BCAST_MACRO(kbo)
14124 DM_BCAST_MACRO(kao_mo2)
14125 DM_BCAST_MACRO(kbo_mo2)
14126 DM_BCAST_MACRO(selfrefo)
14127 DM_BCAST_MACRO(forrefo)
14129 RETURN
14130 9010 CONTINUE
14131 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14132 CALL wrf_error_fatal(errmess)
14134 end subroutine lw_kgb11
14136 ! **************************************************************************
14137 subroutine lw_kgb12(rrtmg_unit)
14138 ! **************************************************************************
14140 use rrlw_kg12, only : fracrefao, kao, selfrefo, forrefo
14142 implicit none
14143 save
14145 ! Input
14146 integer, intent(in) :: rrtmg_unit
14148 ! Local
14149 character*80 errmess
14150 logical, external :: wrf_dm_on_monitor
14152 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14153 ! and upper atmosphere.
14154 ! Planck fraction mapping levels:
14155 ! Lower: P = 174.1640 mbar, T= 215.78 K
14157 ! The array KAO contains absorption coefs for each of the 16 g-intervals
14158 ! for a range of pressure levels > ~100mb, temperatures, and ratios
14159 ! of water vapor to CO2. The first index in the array, JS, runs
14160 ! from 1 to 10, and corresponds to different gas column amount ratios,
14161 ! as expressed through the binary species parameter eta, defined as
14162 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14163 ! ratio of the reference MLS column amount value of gas 1
14164 ! to that of gas2.
14165 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
14166 ! to different temperatures. More specifically, JT = 3 means that the
14167 ! data are for the reference temperature TREF for this pressure
14168 ! level, JT = 2 refers to the temperature
14169 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
14170 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
14171 ! to the reference pressure level (e.g. JP = 1 is for a
14172 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
14173 ! and tells us which g-interval the absorption coefficients are for.
14175 ! The array FORREFO contains the coefficient of the water vapor
14176 ! foreign-continuum (including the energy term). The first
14177 ! index refers to reference temperature (296,260,224,260) and
14178 ! pressure (970,475,219,3 mbar) levels. The second index
14179 ! runs over the g-channel (1 to 16).
14181 ! The array SELFREFO contains the coefficient of the water vapor
14182 ! self-continuum (including the energy term). The first index
14183 ! refers to temperature in 7.2 degree increments. For instance,
14184 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14185 ! etc. The second index runs over the g-channel (1 to 16).
14187 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14189 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14190 fracrefao, kao, selfrefo, forrefo
14191 DM_BCAST_MACRO(fracrefao)
14192 DM_BCAST_MACRO(kao)
14193 DM_BCAST_MACRO(selfrefo)
14194 DM_BCAST_MACRO(forrefo)
14196 RETURN
14197 9010 CONTINUE
14198 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14199 CALL wrf_error_fatal(errmess)
14201 end subroutine lw_kgb12
14203 ! **************************************************************************
14204 subroutine lw_kgb13(rrtmg_unit)
14205 ! **************************************************************************
14207 use rrlw_kg13, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
14208 kbo_mo3, selfrefo, forrefo
14210 implicit none
14211 save
14213 ! Input
14214 integer, intent(in) :: rrtmg_unit
14216 ! Local
14217 character*80 errmess
14218 logical, external :: wrf_dm_on_monitor
14220 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14221 ! and upper atmosphere.
14222 ! Planck fraction mapping levels:
14223 ! Lower: P=473.4280 mb, T = 259.83 K
14224 ! Upper: P=4.758820 mb, T = 250.85 K
14226 ! The array KAO contains absorption coefs for each of the 16 g-intervals
14227 ! for a range of pressure levels > ~100mb, temperatures, and ratios
14228 ! of water vapor to CO2. The first index in the array, JS, runs
14229 ! from 1 to 10, and corresponds to different gas column amount ratios,
14230 ! as expressed through the binary species parameter eta, defined as
14231 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14232 ! ratio of the reference MLS column amount value of gas 1
14233 ! to that of gas2.
14234 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
14235 ! to different temperatures. More specifically, JT = 3 means that the
14236 ! data are for the reference temperature TREF for this pressure
14237 ! level, JT = 2 refers to the temperature
14238 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
14239 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
14240 ! to the reference pressure level (e.g. JP = 1 is for a
14241 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
14242 ! and tells us which g-interval the absorption coefficients are for.
14244 ! The array KAO_Mxx contains the absorption coefficient for
14245 ! a minor species at the 16 chosen g-values for a reference pressure
14246 ! level below 100~ mb. The first index in the array, JS, runs
14247 ! from 1 to 10, and corresponds to different gas column amount ratios,
14248 ! as expressed through the binary species parameter eta, defined as
14249 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14250 ! ratio of the reference MLS column amount value of gas 1
14251 ! to that of gas2. The second index refers to temperature
14252 ! in 7.2 degree increments. For instance, JT = 1 refers to a
14253 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
14254 ! runs over the g-channel (1 to 16).
14256 ! The array KBO_Mxx contains the absorption coefficient for
14257 ! a minor species at the 16 chosen g-values for a reference pressure
14258 ! level above 100~ mb. The first index refers to temperature
14259 ! in 7.2 degree increments. For instance, JT = 1 refers to a
14260 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
14261 ! runs over the g-channel (1 to 16).
14263 ! The array FORREFO contains the coefficient of the water vapor
14264 ! foreign-continuum (including the energy term). The first
14265 ! index refers to reference temperature (296,260,224,260) and
14266 ! pressure (970,475,219,3 mbar) levels. The second index
14267 ! runs over the g-channel (1 to 16).
14269 ! The array SELFREFO contains the coefficient of the water vapor
14270 ! self-continuum (including the energy term). The first index
14271 ! refers to temperature in 7.2 degree increments. For instance,
14272 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14273 ! etc. The second index runs over the g-channel (1 to 16).
14275 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14277 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14278 fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
14279 DM_BCAST_MACRO(fracrefao)
14280 DM_BCAST_MACRO(fracrefbo)
14281 DM_BCAST_MACRO(kao)
14282 DM_BCAST_MACRO(kao_mco2)
14283 DM_BCAST_MACRO(kao_mco)
14284 DM_BCAST_MACRO(kbo_mo3)
14285 DM_BCAST_MACRO(selfrefo)
14286 DM_BCAST_MACRO(forrefo)
14288 RETURN
14289 9010 CONTINUE
14290 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14291 CALL wrf_error_fatal(errmess)
14293 end subroutine lw_kgb13
14295 ! **************************************************************************
14296 subroutine lw_kgb14(rrtmg_unit)
14297 ! **************************************************************************
14299 use rrlw_kg14, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
14301 implicit none
14302 save
14304 ! Input
14305 integer, intent(in) :: rrtmg_unit
14307 ! Local
14308 character*80 errmess
14309 logical, external :: wrf_dm_on_monitor
14311 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14312 ! and upper atmosphere.
14313 ! Planck fraction mapping levels:
14314 ! Lower: P = 142.5940 mb, T = 215.70 K
14315 ! Upper: P = 4.758820 mb, T = 250.85 K
14317 ! The array KAO contains absorption coefs for each of the 16 g-intervals
14318 ! for a range of pressure levels > ~100mb, temperatures, and ratios
14319 ! of water vapor to CO2. The first index in the array, JS, runs
14320 ! from 1 to 10, and corresponds to different gas column amount ratios,
14321 ! as expressed through the binary species parameter eta, defined as
14322 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14323 ! ratio of the reference MLS column amount value of gas 1
14324 ! to that of gas2.
14325 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
14326 ! to different temperatures. More specifically, JT = 3 means that the
14327 ! data are for the reference temperature TREF for this pressure
14328 ! level, JT = 2 refers to the temperature
14329 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
14330 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
14331 ! to the reference pressure level (e.g. JP = 1 is for a
14332 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
14333 ! and tells us which g-interval the absorption coefficients are for.
14335 ! The array KBO contains absorption coefs at the 16 chosen g-values
14336 ! for a range of pressure levels < ~100mb and temperatures. The first
14337 ! index in the array, JT, which runs from 1 to 5, corresponds to
14338 ! different temperatures. More specifically, JT = 3 means that the
14339 ! data are for the reference temperature TREF for this pressure
14340 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
14341 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
14342 ! The second index, JP, runs from 13 to 59 and refers to the JPth
14343 ! reference pressure level (see taumol.f for the value of these
14344 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
14345 ! and tells us which g-interval the absorption coefficients are for.
14347 ! The array FORREFO contains the coefficient of the water vapor
14348 ! foreign-continuum (including the energy term). The first
14349 ! index refers to reference temperature (296,260,224,260) and
14350 ! pressure (970,475,219,3 mbar) levels. The second index
14351 ! runs over the g-channel (1 to 16).
14353 ! The array SELFREFO contains the coefficient of the water vapor
14354 ! self-continuum (including the energy term). The first index
14355 ! refers to temperature in 7.2 degree increments. For instance,
14356 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14357 ! etc. The second index runs over the g-channel (1 to 16).
14359 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14361 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14362 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
14363 DM_BCAST_MACRO(fracrefao)
14364 DM_BCAST_MACRO(fracrefbo)
14365 DM_BCAST_MACRO(kao)
14366 DM_BCAST_MACRO(kbo)
14367 DM_BCAST_MACRO(selfrefo)
14368 DM_BCAST_MACRO(forrefo)
14370 RETURN
14371 9010 CONTINUE
14372 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14373 CALL wrf_error_fatal(errmess)
14375 end subroutine lw_kgb14
14377 ! **************************************************************************
14378 subroutine lw_kgb15(rrtmg_unit)
14379 ! **************************************************************************
14381 use rrlw_kg15, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
14383 implicit none
14384 save
14386 ! Input
14387 integer, intent(in) :: rrtmg_unit
14389 ! Local
14390 character*80 errmess
14391 logical, external :: wrf_dm_on_monitor
14393 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14394 ! and upper atmosphere.
14395 ! Planck fraction mapping levels:
14396 ! Lower: P = 1053. mb, T = 294.2 K
14398 ! The array KAO contains absorption coefs for each of the 16 g-intervals
14399 ! for a range of pressure levels > ~100mb, temperatures, and ratios
14400 ! of water vapor to CO2. The first index in the array, JS, runs
14401 ! from 1 to 10, and corresponds to different gas column amount ratios,
14402 ! as expressed through the binary species parameter eta, defined as
14403 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14404 ! ratio of the reference MLS column amount value of gas 1
14405 ! to that of gas2.
14406 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
14407 ! to different temperatures. More specifically, JT = 3 means that the
14408 ! data are for the reference temperature TREF for this pressure
14409 ! level, JT = 2 refers to the temperature
14410 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
14411 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
14412 ! to the reference pressure level (e.g. JP = 1 is for a
14413 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
14414 ! and tells us which g-interval the absorption coefficients are for.
14416 ! The array KA_Mxx contains the absorption coefficient for
14417 ! a minor species at the 16 chosen g-values for a reference pressure
14418 ! level below 100~ mb. The first index in the array, JS, runs
14419 ! from 1 to 10, and corresponds to different gas column amount ratios,
14420 ! as expressed through the binary species parameter eta, defined as
14421 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14422 ! ratio of the reference MLS column amount value of gas 1
14423 ! to that of gas2. The second index refers to temperature
14424 ! in 7.2 degree increments. For instance, JT = 1 refers to a
14425 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
14426 ! runs over the g-channel (1 to 16).
14428 ! The array FORREFO contains the coefficient of the water vapor
14429 ! foreign-continuum (including the energy term). The first
14430 ! index refers to reference temperature (296,260,224,260) and
14431 ! pressure (970,475,219,3 mbar) levels. The second index
14432 ! runs over the g-channel (1 to 16).
14434 ! The array SELFREFO contains the coefficient of the water vapor
14435 ! self-continuum (including the energy term). The first index
14436 ! refers to temperature in 7.2 degree increments. For instance,
14437 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14438 ! etc. The second index runs over the g-channel (1 to 16).
14440 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14442 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14443 fracrefao, kao, kao_mn2, selfrefo, forrefo
14444 DM_BCAST_MACRO(fracrefao)
14445 DM_BCAST_MACRO(kao)
14446 DM_BCAST_MACRO(kao_mn2)
14447 DM_BCAST_MACRO(selfrefo)
14448 DM_BCAST_MACRO(forrefo)
14450 RETURN
14451 9010 CONTINUE
14452 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14453 CALL wrf_error_fatal(errmess)
14455 end subroutine lw_kgb15
14457 ! **************************************************************************
14458 subroutine lw_kgb16(rrtmg_unit)
14459 ! **************************************************************************
14461 use rrlw_kg16, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
14463 implicit none
14464 save
14466 ! Input
14467 integer, intent(in) :: rrtmg_unit
14469 ! Local
14470 character*80 errmess
14471 logical, external :: wrf_dm_on_monitor
14473 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
14474 ! and upper atmosphere.
14475 ! Planck fraction mapping levels:
14476 ! Lower: P = 387.6100 mbar, T = 250.17 K
14477 ! Upper: P=95.58350 mb, T = 215.70 K
14479 ! The array KAO contains absorption coefs for each of the 16 g-intervals
14480 ! for a range of pressure levels > ~100mb, temperatures, and ratios
14481 ! of water vapor to CO2. The first index in the array, JS, runs
14482 ! from 1 to 10, and corresponds to different gas column amount ratios,
14483 ! as expressed through the binary species parameter eta, defined as
14484 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
14485 ! ratio of the reference MLS column amount value of gas 1
14486 ! to that of gas2.
14487 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
14488 ! to different temperatures. More specifically, JT = 3 means that the
14489 ! data are for the reference temperature TREF for this pressure
14490 ! level, JT = 2 refers to the temperature
14491 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
14492 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
14493 ! to the reference pressure level (e.g. JP = 1 is for a
14494 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
14495 ! and tells us which g-interval the absorption coefficients are for.
14497 ! The array KBO contains absorption coefs at the 16 chosen g-values
14498 ! for a range of pressure levels < ~100mb and temperatures. The first
14499 ! index in the array, JT, which runs from 1 to 5, corresponds to
14500 ! different temperatures. More specifically, JT = 3 means that the
14501 ! data are for the reference temperature TREF for this pressure
14502 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
14503 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
14504 ! The second index, JP, runs from 13 to 59 and refers to the JPth
14505 ! reference pressure level (see taumol.f for the value of these
14506 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
14507 ! and tells us which g-interval the absorption coefficients are for.
14509 ! The array FORREFO contains the coefficient of the water vapor
14510 ! foreign-continuum (including the energy term). The first
14511 ! index refers to reference temperature (296,260,224,260) and
14512 ! pressure (970,475,219,3 mbar) levels. The second index
14513 ! runs over the g-channel (1 to 16).
14515 ! The array SELFREFO contains the coefficient of the water vapor
14516 ! self-continuum (including the energy term). The first index
14517 ! refers to temperature in 7.2 degree increments. For instance,
14518 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
14519 ! etc. The second index runs over the g-channel (1 to 16).
14521 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
14523 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
14524 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
14525 DM_BCAST_MACRO(fracrefao)
14526 DM_BCAST_MACRO(fracrefbo)
14527 DM_BCAST_MACRO(kao)
14528 DM_BCAST_MACRO(kbo)
14529 DM_BCAST_MACRO(selfrefo)
14530 DM_BCAST_MACRO(forrefo)
14532 RETURN
14533 9010 CONTINUE
14534 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
14535 CALL wrf_error_fatal(errmess)
14537 end subroutine lw_kgb16
14539 !===============================================================================
14540 subroutine relcalc(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
14541 !-----------------------------------------------------------------------
14542 !
14543 ! Purpose:
14544 ! Compute cloud water size
14545 !
14546 ! Method:
14547 ! analytic formula following the formulation originally developed by J. T. Kiehl
14548 !
14549 ! Author: Phil Rasch
14550 !
14551 !-----------------------------------------------------------------------
14552 implicit none
14553 !------------------------------Arguments--------------------------------
14554 !
14555 ! Input arguments
14556 !
14557 integer, intent(in) :: ncol
14558 integer, intent(in) :: pcols, pver
14559 real, intent(in) :: landfrac(pcols) ! Land fraction
14560 real, intent(in) :: icefrac(pcols) ! Ice fraction
14561 real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
14562 real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
14563 real, intent(in) :: t(pcols,pver) ! Temperature
14565 !
14566 ! Output arguments
14567 !
14568 real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
14569 !
14570 !---------------------------Local workspace-----------------------------
14571 !
14572 integer i,k ! Lon, lev indices
14573 real tmelt ! freezing temperature of fresh water (K)
14574 real rliqland ! liquid drop size if over land
14575 real rliqocean ! liquid drop size if over ocean
14576 real rliqice ! liquid drop size if over sea ice
14577 !
14578 !-----------------------------------------------------------------------
14579 !
14580 tmelt = 273.16
14581 rliqocean = 14.0
14582 rliqice = 14.0
14583 rliqland = 8.0
14584 do k=1,pver
14585 do i=1,ncol
14586 ! jrm Reworked effective radius algorithm
14587 ! Start with temperature-dependent value appropriate for continental air
14588 ! Note: findmcnew has a pressure dependence here
14589 rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(i,k))*0.05))
14590 ! Modify for snow depth over land
14591 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,snowh(i)*10.))
14592 ! Ramp between polluted value over land to clean value over ocean.
14593 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,1.0-landm(i)))
14594 ! Ramp between the resultant value and a sea ice value in the presence of ice.
14595 rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0,max(0.0,icefrac(i)))
14596 ! end jrm
14597 end do
14598 end do
14599 end subroutine relcalc
14600 !===============================================================================
14601 subroutine reicalc(ncol, pcols, pver, t, re)
14602 !
14604 integer, intent(in) :: ncol, pcols, pver
14605 real, intent(out) :: re(pcols,pver)
14606 real, intent(in) :: t(pcols,pver)
14607 real corr
14608 integer i
14609 integer k
14610 integer index
14611 !
14612 ! Tabulated values of re(T) in the temperature interval
14613 ! 180 K -- 274 K; hexagonal columns assumed:
14614 !
14615 !
14616 do k=1,pver
14617 do i=1,ncol
14618 index = int(t(i,k)-179.)
14619 index = min(max(index,1),94)
14620 corr = t(i,k) - int(t(i,k))
14621 re(i,k) = retab(index)*(1.-corr) &
14622 +retab(index+1)*corr
14623 ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
14624 end do
14625 end do
14626 !
14627 return
14628 end subroutine reicalc
14629 !------------------------------------------------------------------
14631 END MODULE module_ra_rrtmg_lw