| blob | 048c3b0c5a237b41b6de93c182394b13b8197a2c |
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_im = 4
22 integer, parameter :: kind_in = kind(1) ! native integer
24 !
25 ! real kinds
26 ! ----------
27 !
28 ! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
29 ! integer, parameter :: kind_rm = selected_real_kind(6) ! 4 byte real
30 ! integer, parameter :: kind_rn = kind(1.0) ! native real
32 #if 0
33 ! Modified for WRF:
34 #if (RWORDSIZE == 8)
35 integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
36 #endif
37 #if (RWORDSIZE == 4)
38 integer, parameter :: kind_rb = selected_real_kind(6) ! 4 byte real
39 #endif
40 #else
41 integer, parameter :: kind_rb = kind(1.0) ! native real
42 #endif
44 end module parkind
46 module parrrtm
48 use parkind ,only : im => kind_im
50 ! implicit none
51 save
53 !------------------------------------------------------------------
54 ! rrtmg_lw main parameters
55 !
56 ! Initial version: JJMorcrette, ECMWF, Jul 1998
57 ! Revised: MJIacono, AER, Jun 2006
58 ! Revised: MJIacono, AER, Aug 2007
59 ! Revised: MJIacono, AER, Aug 2008
60 !------------------------------------------------------------------
62 ! name type purpose
63 ! ----- : ---- : ----------------------------------------------
64 ! mxlay : integer: maximum number of layers
65 ! mg : integer: number of original g-intervals per spectral band
66 ! nbndlw : integer: number of spectral bands
67 ! maxxsec: integer: maximum number of cross-section molecules
68 ! (e.g. cfcs)
69 ! maxinpx: integer:
70 ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw
71 ! ngNN : integer: number of reduced g-intervals per spectral band
72 ! ngsNN : integer: cumulative number of g-intervals per band
73 !------------------------------------------------------------------
75 integer(kind=im), parameter :: mxlay = 203
76 integer(kind=im), parameter :: mg = 16
77 integer(kind=im), parameter :: nbndlw = 16
78 integer(kind=im), parameter :: maxxsec= 4
79 integer(kind=im), parameter :: mxmol = 38
80 integer(kind=im), parameter :: maxinpx= 38
81 integer(kind=im), parameter :: nmol = 7
82 ! Use for 140 g-point model
83 integer(kind=im), parameter :: ngptlw = 140
84 ! Use for 256 g-point model
85 ! integer(kind=im), parameter :: ngptlw = 256
87 ! Use for 140 g-point model
88 integer(kind=im), parameter :: ng1 = 10
89 integer(kind=im), parameter :: ng2 = 12
90 integer(kind=im), parameter :: ng3 = 16
91 integer(kind=im), parameter :: ng4 = 14
92 integer(kind=im), parameter :: ng5 = 16
93 integer(kind=im), parameter :: ng6 = 8
94 integer(kind=im), parameter :: ng7 = 12
95 integer(kind=im), parameter :: ng8 = 8
96 integer(kind=im), parameter :: ng9 = 12
97 integer(kind=im), parameter :: ng10 = 6
98 integer(kind=im), parameter :: ng11 = 8
99 integer(kind=im), parameter :: ng12 = 8
100 integer(kind=im), parameter :: ng13 = 4
101 integer(kind=im), parameter :: ng14 = 2
102 integer(kind=im), parameter :: ng15 = 2
103 integer(kind=im), parameter :: ng16 = 2
105 integer(kind=im), parameter :: ngs1 = 10
106 integer(kind=im), parameter :: ngs2 = 22
107 integer(kind=im), parameter :: ngs3 = 38
108 integer(kind=im), parameter :: ngs4 = 52
109 integer(kind=im), parameter :: ngs5 = 68
110 integer(kind=im), parameter :: ngs6 = 76
111 integer(kind=im), parameter :: ngs7 = 88
112 integer(kind=im), parameter :: ngs8 = 96
113 integer(kind=im), parameter :: ngs9 = 108
114 integer(kind=im), parameter :: ngs10 = 114
115 integer(kind=im), parameter :: ngs11 = 122
116 integer(kind=im), parameter :: ngs12 = 130
117 integer(kind=im), parameter :: ngs13 = 134
118 integer(kind=im), parameter :: ngs14 = 136
119 integer(kind=im), parameter :: ngs15 = 138
121 ! Use for 256 g-point model
122 ! integer(kind=im), parameter :: ng1 = 16
123 ! integer(kind=im), parameter :: ng2 = 16
124 ! integer(kind=im), parameter :: ng3 = 16
125 ! integer(kind=im), parameter :: ng4 = 16
126 ! integer(kind=im), parameter :: ng5 = 16
127 ! integer(kind=im), parameter :: ng6 = 16
128 ! integer(kind=im), parameter :: ng7 = 16
129 ! integer(kind=im), parameter :: ng8 = 16
130 ! integer(kind=im), parameter :: ng9 = 16
131 ! integer(kind=im), parameter :: ng10 = 16
132 ! integer(kind=im), parameter :: ng11 = 16
133 ! integer(kind=im), parameter :: ng12 = 16
134 ! integer(kind=im), parameter :: ng13 = 16
135 ! integer(kind=im), parameter :: ng14 = 16
136 ! integer(kind=im), parameter :: ng15 = 16
137 ! integer(kind=im), parameter :: ng16 = 16
139 ! integer(kind=im), parameter :: ngs1 = 16
140 ! integer(kind=im), parameter :: ngs2 = 32
141 ! integer(kind=im), parameter :: ngs3 = 48
142 ! integer(kind=im), parameter :: ngs4 = 64
143 ! integer(kind=im), parameter :: ngs5 = 80
144 ! integer(kind=im), parameter :: ngs6 = 96
145 ! integer(kind=im), parameter :: ngs7 = 112
146 ! integer(kind=im), parameter :: ngs8 = 128
147 ! integer(kind=im), parameter :: ngs9 = 144
148 ! integer(kind=im), parameter :: ngs10 = 160
149 ! integer(kind=im), parameter :: ngs11 = 176
150 ! integer(kind=im), parameter :: ngs12 = 192
151 ! integer(kind=im), parameter :: ngs13 = 208
152 ! integer(kind=im), parameter :: ngs14 = 224
153 ! integer(kind=im), parameter :: ngs15 = 240
154 ! integer(kind=im), parameter :: ngs16 = 256
156 end module parrrtm
158 module rrlw_cld
160 use parkind, only : rb => kind_rb
162 ! implicit none
163 save
165 !------------------------------------------------------------------
166 ! rrtmg_lw cloud property coefficients
168 ! Revised: MJIacono, AER, jun2006
169 ! Revised: MJIacono, AER, aug2008
170 !------------------------------------------------------------------
172 ! name type purpose
173 ! ----- : ---- : ----------------------------------------------
174 ! abscld1: real :
175 ! absice0: real :
176 ! absice1: real :
177 ! absice2: real :
178 ! absice3: real :
179 ! absliq0: real :
180 ! absliq1: real :
181 !------------------------------------------------------------------
183 real(kind=rb) :: abscld1
184 real(kind=rb) , dimension(2) :: absice0
185 real(kind=rb) , dimension(2,5) :: absice1
186 real(kind=rb) , dimension(43,16) :: absice2
187 real(kind=rb) , dimension(46,16) :: absice3
188 real(kind=rb) :: absliq0
189 real(kind=rb) , dimension(58,16) :: absliq1
191 end module rrlw_cld
193 module rrlw_con
195 use parkind, only : rb => kind_rb
197 ! implicit none
198 save
200 !------------------------------------------------------------------
201 ! rrtmg_lw constants
203 ! Initial version: MJIacono, AER, jun2006
204 ! Revised: MJIacono, AER, aug2008
205 !------------------------------------------------------------------
207 ! name type purpose
208 ! ----- : ---- : ----------------------------------------------
209 ! fluxfac: real : radiance to flux conversion factor
210 ! heatfac: real : flux to heating rate conversion factor
211 !oneminus: real : 1.-1.e-6
212 ! pi : real : pi
213 ! grav : real : acceleration of gravity
214 ! planck : real : planck constant
215 ! boltz : real : boltzmann constant
216 ! clight : real : speed of light
217 ! avogad : real : avogadro constant
218 ! alosmt : real : loschmidt constant
219 ! gascon : real : molar gas constant
220 ! radcn1 : real : first radiation constant
221 ! radcn2 : real : second radiation constant
222 ! sbcnst : real : stefan-boltzmann constant
223 ! secdy : real : seconds per day
224 !------------------------------------------------------------------
226 real(kind=rb) :: fluxfac, heatfac
227 real(kind=rb) :: oneminus, pi, grav
228 real(kind=rb) :: planck, boltz, clight
229 real(kind=rb) :: avogad, alosmt, gascon
230 real(kind=rb) :: radcn1, radcn2
231 real(kind=rb) :: sbcnst, secdy
233 end module rrlw_con
235 module rrlw_kg01
237 use parkind ,only : im => kind_im, rb => kind_rb
239 ! implicit none
240 save
242 !-----------------------------------------------------------------
243 ! rrtmg_lw ORIGINAL abs. coefficients for interval 1
244 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
245 !
246 ! Initial version: JJMorcrette, ECMWF, jul1998
247 ! Revised: MJIacono, AER, jun2006
248 ! Revised: MJIacono, AER, aug2008
249 !-----------------------------------------------------------------
250 !
251 ! name type purpose
252 ! ---- : ---- : ---------------------------------------------
253 !fracrefao: real
254 !fracrefbo: real
255 ! kao : real
256 ! kbo : real
257 ! kao_mn2 : real
258 ! kbo_mn2 : real
259 ! selfrefo: real
260 ! forrefo : real
261 !-----------------------------------------------------------------
263 integer(kind=im), parameter :: no1 = 16
265 real(kind=rb) :: fracrefao(no1) , fracrefbo(no1)
266 real(kind=rb) :: kao(5,13,no1)
267 real(kind=rb) :: kbo(5,13:59,no1)
268 real(kind=rb) :: kao_mn2(19,no1) , kbo_mn2(19,no1)
269 real(kind=rb) :: selfrefo(10,no1), forrefo(4,no1)
271 !-----------------------------------------------------------------
272 ! rrtmg_lw COMBINED abs. coefficients for interval 1
273 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
274 !
275 ! Initial version: JJMorcrette, ECMWF, jul1998
276 ! Revised: MJIacono, AER, jun2006
277 ! Revised: MJIacono, AER, aug2008
278 !-----------------------------------------------------------------
279 !
280 ! name type purpose
281 ! ---- : ---- : ---------------------------------------------
282 !fracrefa : real
283 !fracrefb : real
284 ! ka : real
285 ! kb : real
286 ! absa : real
287 ! absb : real
288 ! ka_mn2 : real
289 ! kb_mn2 : real
290 ! selfref : real
291 ! forref : real
292 !-----------------------------------------------------------------
294 integer(kind=im), parameter :: ng1 = 10
296 real(kind=rb) :: fracrefa(ng1) , fracrefb(ng1)
297 real(kind=rb) :: ka(5,13,ng1) , absa(65,ng1)
298 real(kind=rb) :: kb(5,13:59,ng1), absb(235,ng1)
299 real(kind=rb) :: ka_mn2(19,ng1) , kb_mn2(19,ng1)
300 real(kind=rb) :: selfref(10,ng1), forref(4,ng1)
302 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
304 end module rrlw_kg01
306 module rrlw_kg02
308 use parkind ,only : im => kind_im, rb => kind_rb
310 ! implicit none
311 save
313 !-----------------------------------------------------------------
314 ! rrtmg_lw ORIGINAL abs. coefficients for interval 2
315 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
316 !
317 ! Initial version: JJMorcrette, ECMWF, jul1998
318 ! Revised: MJIacono, AER, jun2006
319 ! Revised: MJIacono, AER, aug2008
320 !-----------------------------------------------------------------
321 !
322 ! name type purpose
323 ! ---- : ---- : ---------------------------------------------
324 !fracrefao: real
325 !fracrefbo: real
326 ! kao : real
327 ! kbo : real
328 ! selfrefo: real
329 ! forrefo : real
330 !-----------------------------------------------------------------
332 integer(kind=im), parameter :: no2 = 16
334 real(kind=rb) :: fracrefao(no2) , fracrefbo(no2)
335 real(kind=rb) :: kao(5,13,no2)
336 real(kind=rb) :: kbo(5,13:59,no2)
337 real(kind=rb) :: selfrefo(10,no2) , forrefo(4,no2)
339 !-----------------------------------------------------------------
340 ! rrtmg_lw COMBINED abs. coefficients for interval 2
341 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
342 !
343 ! Initial version: JJMorcrette, ECMWF, jul1998
344 ! Revised: MJIacono, AER, jun2006
345 ! Revised: MJIacono, AER, aug2008
346 !-----------------------------------------------------------------
347 !
348 ! name type purpose
349 ! ---- : ---- : ---------------------------------------------
350 !fracrefa : real
351 !fracrefb : real
352 ! ka : real
353 ! kb : real
354 ! absa : real
355 ! absb : real
356 ! selfref : real
357 ! forref : real
358 !
359 ! refparam: real
360 !-----------------------------------------------------------------
362 integer(kind=im), parameter :: ng2 = 12
364 real(kind=rb) :: fracrefa(ng2) , fracrefb(ng2)
365 real(kind=rb) :: ka(5,13,ng2) , absa(65,ng2)
366 real(kind=rb) :: kb(5,13:59,ng2), absb(235,ng2)
367 real(kind=rb) :: selfref(10,ng2), forref(4,ng2)
369 real(kind=rb) :: refparam(13)
371 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
373 end module rrlw_kg02
375 module rrlw_kg03
377 use parkind ,only : im => kind_im, rb => kind_rb
379 ! implicit none
380 save
382 !-----------------------------------------------------------------
383 ! rrtmg_lw ORIGINAL abs. coefficients for interval 3
384 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
385 !
386 ! Initial version: JJMorcrette, ECMWF, jul1998
387 ! Revised: MJIacono, AER, jun2006
388 ! Revised: MJIacono, AER, aug2008
389 !-----------------------------------------------------------------
390 !
391 ! name type purpose
392 ! ---- : ---- : ---------------------------------------------
393 !fracrefao: real
394 !fracrefbo: real
395 ! kao : real
396 ! kbo : real
397 ! kao_mn2o: real
398 ! kbo_mn2o: real
399 ! selfrefo: real
400 ! forrefo : real
401 !-----------------------------------------------------------------
403 integer(kind=im), parameter :: no3 = 16
405 real(kind=rb) :: fracrefao(no3,9) ,fracrefbo(no3,5)
406 real(kind=rb) :: kao(9,5,13,no3)
407 real(kind=rb) :: kbo(5,5,13:59,no3)
408 real(kind=rb) :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3)
409 real(kind=rb) :: selfrefo(10,no3)
410 real(kind=rb) :: forrefo(4,no3)
412 !-----------------------------------------------------------------
413 ! rrtmg_lw COMBINED abs. coefficients for interval 3
414 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
415 !
416 ! Initial version: JJMorcrette, ECMWF, jul1998
417 ! Revised: MJIacono, AER, jun2006
418 ! Revised: MJIacono, AER, aug2008
419 !-----------------------------------------------------------------
420 !
421 ! name type purpose
422 ! ---- : ---- : ---------------------------------------------
423 !fracrefa : real
424 !fracrefb : real
425 ! ka : real
426 ! kb : real
427 ! ka_mn2o : real
428 ! kb_mn2o : real
429 ! selfref : real
430 ! forref : real
431 !
432 ! absa : real
433 ! absb : real
434 !-----------------------------------------------------------------
436 integer(kind=im), parameter :: ng3 = 16
438 real(kind=rb) :: fracrefa(ng3,9) ,fracrefb(ng3,5)
439 real(kind=rb) :: ka(9,5,13,ng3) ,absa(585,ng3)
440 real(kind=rb) :: kb(5,5,13:59,ng3),absb(1175,ng3)
441 real(kind=rb) :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3)
442 real(kind=rb) :: selfref(10,ng3)
443 real(kind=rb) :: forref(4,ng3)
445 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
447 end module rrlw_kg03
449 module rrlw_kg04
451 use parkind ,only : im => kind_im, rb => kind_rb
453 ! implicit none
454 save
456 !-----------------------------------------------------------------
457 ! rrtmg_lw ORIGINAL abs. coefficients for interval 4
458 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
459 !
460 ! Initial version: JJMorcrette, ECMWF, jul1998
461 ! Revised: MJIacono, AER, jun2006
462 ! Revised: MJIacono, AER, aug2008
463 !-----------------------------------------------------------------
464 !
465 ! name type purpose
466 ! ---- : ---- : ---------------------------------------------
467 !fracrefao: real
468 !fracrefbo: real
469 ! kao : real
470 ! kbo : real
471 ! selfrefo: real
472 ! forrefo : real
473 !-----------------------------------------------------------------
475 integer(kind=im), parameter :: no4 = 16
477 real(kind=rb) :: fracrefao(no4,9) ,fracrefbo(no4,5)
478 real(kind=rb) :: kao(9,5,13,no4)
479 real(kind=rb) :: kbo(5,5,13:59,no4)
480 real(kind=rb) :: selfrefo(10,no4) ,forrefo(4,no4)
482 !-----------------------------------------------------------------
483 ! rrtmg_lw COMBINED abs. coefficients for interval 4
484 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
485 !
486 ! Initial version: JJMorcrette, ECMWF, jul1998
487 ! Revised: MJIacono, AER, jun2006
488 ! Revised: MJIacono, AER, aug2008
489 !-----------------------------------------------------------------
490 !
491 ! name type purpose
492 ! ---- : ---- : ---------------------------------------------
493 ! absa : real
494 ! absb : real
495 !fracrefa : real
496 !fracrefb : real
497 ! ka : real
498 ! kb : real
499 ! selfref : real
500 ! forref : real
501 !-----------------------------------------------------------------
503 integer(kind=im), parameter :: ng4 = 14
505 real(kind=rb) :: fracrefa(ng4,9) ,fracrefb(ng4,5)
506 real(kind=rb) :: ka(9,5,13,ng4) ,absa(585,ng4)
507 real(kind=rb) :: kb(5,5,13:59,ng4),absb(1175,ng4)
508 real(kind=rb) :: selfref(10,ng4) ,forref(4,ng4)
510 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
512 end module rrlw_kg04
514 module rrlw_kg05
516 use parkind ,only : im => kind_im, rb => kind_rb
518 ! implicit none
519 save
521 !-----------------------------------------------------------------
522 ! rrtmg_lw ORIGINAL abs. coefficients for interval 5
523 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
524 !
525 ! Initial version: JJMorcrette, ECMWF, jul1998
526 ! Revised: MJIacono, AER, jun2006
527 ! Revised: MJIacono, AER, aug2008
528 !-----------------------------------------------------------------
529 !
530 ! name type purpose
531 ! ---- : ---- : ---------------------------------------------
532 !fracrefao: real
533 !fracrefbo: real
534 ! kao : real
535 ! kbo : real
536 ! kao_mo3 : real
537 ! selfrefo: real
538 ! forrefo : real
539 ! ccl4o : real
540 !-----------------------------------------------------------------
542 integer(kind=im), parameter :: no5 = 16
544 real(kind=rb) :: fracrefao(no5,9) ,fracrefbo(no5,5)
545 real(kind=rb) :: kao(9,5,13,no5)
546 real(kind=rb) :: kbo(5,5,13:59,no5)
547 real(kind=rb) :: kao_mo3(9,19,no5)
548 real(kind=rb) :: selfrefo(10,no5)
549 real(kind=rb) :: forrefo(4,no5)
550 real(kind=rb) :: ccl4o(no5)
552 !-----------------------------------------------------------------
553 ! rrtmg_lw COMBINED abs. coefficients for interval 5
554 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
555 !
556 ! Initial version: JJMorcrette, ECMWF, jul1998
557 ! Revised: MJIacono, AER, jun2006
558 ! Revised: MJIacono, AER, aug2008
559 !-----------------------------------------------------------------
560 !
561 ! name type purpose
562 ! ---- : ---- : ---------------------------------------------
563 !fracrefa : real
564 !fracrefb : real
565 ! ka : real
566 ! kb : real
567 ! ka_mo3 : real
568 ! selfref : real
569 ! forref : real
570 ! ccl4 : real
571 !
572 ! absa : real
573 ! absb : real
574 !-----------------------------------------------------------------
576 integer(kind=im), parameter :: ng5 = 16
578 real(kind=rb) :: fracrefa(ng5,9) ,fracrefb(ng5,5)
579 real(kind=rb) :: ka(9,5,13,ng5) ,absa(585,ng5)
580 real(kind=rb) :: kb(5,5,13:59,ng5),absb(1175,ng5)
581 real(kind=rb) :: ka_mo3(9,19,ng5)
582 real(kind=rb) :: selfref(10,ng5)
583 real(kind=rb) :: forref(4,ng5)
584 real(kind=rb) :: ccl4(ng5)
586 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
588 end module rrlw_kg05
590 module rrlw_kg06
592 use parkind ,only : im => kind_im, rb => kind_rb
594 ! implicit none
595 save
597 !-----------------------------------------------------------------
598 ! rrtmg_lw ORIGINAL abs. coefficients for interval 6
599 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
600 !
601 ! Initial version: JJMorcrette, ECMWF, jul1998
602 ! Revised: MJIacono, AER, jun2006
603 ! Revised: MJIacono, AER, aug2008
604 !-----------------------------------------------------------------
605 !
606 ! name type purpose
607 ! ---- : ---- : ---------------------------------------------
608 !fracrefao: real
609 ! kao : real
610 ! kao_mco2: real
611 ! selfrefo: real
612 ! forrefo : real
613 !cfc11adjo: real
614 ! cfc12o : real
615 !-----------------------------------------------------------------
617 integer(kind=im), parameter :: no6 = 16
619 real(kind=rb) , dimension(no6) :: fracrefao
620 real(kind=rb) :: kao(5,13,no6)
621 real(kind=rb) :: kao_mco2(19,no6)
622 real(kind=rb) :: selfrefo(10,no6)
623 real(kind=rb) :: forrefo(4,no6)
625 real(kind=rb) , dimension(no6) :: cfc11adjo
626 real(kind=rb) , dimension(no6) :: cfc12o
628 !-----------------------------------------------------------------
629 ! rrtmg_lw COMBINED abs. coefficients for interval 6
630 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
631 !
632 ! Initial version: JJMorcrette, ECMWF, jul1998
633 ! Revised: MJIacono, AER, jun2006
634 ! Revised: MJIacono, AER, aug2008
635 !-----------------------------------------------------------------
636 !
637 ! name type purpose
638 ! ---- : ---- : ---------------------------------------------
639 !fracrefa : real
640 ! ka : real
641 ! ka_mco2 : real
642 ! selfref : real
643 ! forref : real
644 !cfc11adj : real
645 ! cfc12 : real
646 !
647 ! absa : real
648 !-----------------------------------------------------------------
650 integer(kind=im), parameter :: ng6 = 8
652 real(kind=rb) , dimension(ng6) :: fracrefa
653 real(kind=rb) :: ka(5,13,ng6),absa(65,ng6)
654 real(kind=rb) :: ka_mco2(19,ng6)
655 real(kind=rb) :: selfref(10,ng6)
656 real(kind=rb) :: forref(4,ng6)
658 real(kind=rb) , dimension(ng6) :: cfc11adj
659 real(kind=rb) , dimension(ng6) :: cfc12
661 equivalence (ka(1,1,1),absa(1,1))
663 end module rrlw_kg06
665 module rrlw_kg07
667 use parkind ,only : im => kind_im, rb => kind_rb
669 ! implicit none
670 save
672 !-----------------------------------------------------------------
673 ! rrtmg_lw ORIGINAL abs. coefficients for interval 7
674 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
675 !
676 ! Initial version: JJMorcrette, ECMWF, jul1998
677 ! Revised: MJIacono, AER, jun2006
678 ! Revised: MJIacono, AER, aug2008
679 !-----------------------------------------------------------------
680 !
681 ! name type purpose
682 ! ---- : ---- : ---------------------------------------------
683 !fracrefao: real
684 !fracrefbo: real
685 ! kao : real
686 ! kbo : real
687 ! kao_mco2: real
688 ! kbo_mco2: real
689 ! selfrefo: real
690 ! forrefo : real
691 !-----------------------------------------------------------------
693 integer(kind=im), parameter :: no7 = 16
695 real(kind=rb) , dimension(no7) :: fracrefbo
696 real(kind=rb) :: fracrefao(no7,9)
697 real(kind=rb) :: kao(9,5,13,no7)
698 real(kind=rb) :: kbo(5,13:59,no7)
699 real(kind=rb) :: kao_mco2(9,19,no7)
700 real(kind=rb) :: kbo_mco2(19,no7)
701 real(kind=rb) :: selfrefo(10,no7)
702 real(kind=rb) :: forrefo(4,no7)
704 !-----------------------------------------------------------------
705 ! rrtmg_lw COMBINED abs. coefficients for interval 7
706 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
707 !
708 ! Initial version: JJMorcrette, ECMWF, jul1998
709 ! Revised: MJIacono, AER, jun2006
710 ! Revised: MJIacono, AER, aug2008
711 !-----------------------------------------------------------------
712 !
713 ! name type purpose
714 ! ---- : ---- : ---------------------------------------------
715 !fracrefa : real
716 !fracrefb : real
717 ! ka : real
718 ! kb : real
719 ! ka_mco2 : real
720 ! kb_mco2 : real
721 ! selfref : real
722 ! forref : real
723 !
724 ! absa : real
725 !-----------------------------------------------------------------
727 integer(kind=im), parameter :: ng7 = 12
729 real(kind=rb) , dimension(ng7) :: fracrefb
730 real(kind=rb) :: fracrefa(ng7,9)
731 real(kind=rb) :: ka(9,5,13,ng7) ,absa(585,ng7)
732 real(kind=rb) :: kb(5,13:59,ng7),absb(235,ng7)
733 real(kind=rb) :: ka_mco2(9,19,ng7)
734 real(kind=rb) :: kb_mco2(19,ng7)
735 real(kind=rb) :: selfref(10,ng7)
736 real(kind=rb) :: forref(4,ng7)
738 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
740 end module rrlw_kg07
742 module rrlw_kg08
744 use parkind ,only : im => kind_im, rb => kind_rb
746 ! implicit none
747 save
749 !-----------------------------------------------------------------
750 ! rrtmg_lw ORIGINAL abs. coefficients for interval 8
751 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
752 !
753 ! Initial version: JJMorcrette, ECMWF, jul1998
754 ! Revised: MJIacono, AER, jun2006
755 ! Revised: MJIacono, AER, aug2008
756 !-----------------------------------------------------------------
757 !
758 ! name type purpose
759 ! ---- : ---- : ---------------------------------------------
760 !fracrefao: real
761 !fracrefbo: real
762 ! kao : real
763 ! kbo : real
764 ! kao_mco2: real
765 ! kbo_mco2: real
766 ! kao_mn2o: real
767 ! kbo_mn2o: real
768 ! kao_mo3 : real
769 ! selfrefo: real
770 ! forrefo : real
771 ! cfc12o : real
772 !cfc22adjo: real
773 !-----------------------------------------------------------------
775 integer(kind=im), parameter :: no8 = 16
777 real(kind=rb) , dimension(no8) :: fracrefao
778 real(kind=rb) , dimension(no8) :: fracrefbo
779 real(kind=rb) , dimension(no8) :: cfc12o
780 real(kind=rb) , dimension(no8) :: cfc22adjo
782 real(kind=rb) :: kao(5,13,no8)
783 real(kind=rb) :: kao_mco2(19,no8)
784 real(kind=rb) :: kao_mn2o(19,no8)
785 real(kind=rb) :: kao_mo3(19,no8)
786 real(kind=rb) :: kbo(5,13:59,no8)
787 real(kind=rb) :: kbo_mco2(19,no8)
788 real(kind=rb) :: kbo_mn2o(19,no8)
789 real(kind=rb) :: selfrefo(10,no8)
790 real(kind=rb) :: forrefo(4,no8)
792 !-----------------------------------------------------------------
793 ! rrtmg_lw COMBINED abs. coefficients for interval 8
794 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
795 !
796 ! Initial version: JJMorcrette, ECMWF, jul1998
797 ! Revised: MJIacono, AER, jun2006
798 ! Revised: MJIacono, AER, aug2008
799 !-----------------------------------------------------------------
800 !
801 ! name type purpose
802 ! ---- : ---- : ---------------------------------------------
803 !fracrefa : real
804 !fracrefb : real
805 ! ka : real
806 ! kb : real
807 ! ka_mco2 : real
808 ! kb_mco2 : real
809 ! ka_mn2o : real
810 ! kb_mn2o : real
811 ! ka_mo3 : real
812 ! selfref : real
813 ! forref : real
814 ! cfc12 : real
815 ! cfc22adj: real
816 !
817 ! absa : real
818 ! absb : real
819 !-----------------------------------------------------------------
821 integer(kind=im), parameter :: ng8 = 8
823 real(kind=rb) , dimension(ng8) :: fracrefa
824 real(kind=rb) , dimension(ng8) :: fracrefb
825 real(kind=rb) , dimension(ng8) :: cfc12
826 real(kind=rb) , dimension(ng8) :: cfc22adj
828 real(kind=rb) :: ka(5,13,ng8) ,absa(65,ng8)
829 real(kind=rb) :: kb(5,13:59,ng8) ,absb(235,ng8)
830 real(kind=rb) :: ka_mco2(19,ng8)
831 real(kind=rb) :: ka_mn2o(19,ng8)
832 real(kind=rb) :: ka_mo3(19,ng8)
833 real(kind=rb) :: kb_mco2(19,ng8)
834 real(kind=rb) :: kb_mn2o(19,ng8)
835 real(kind=rb) :: selfref(10,ng8)
836 real(kind=rb) :: forref(4,ng8)
838 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
840 end module rrlw_kg08
842 module rrlw_kg09
844 use parkind ,only : im => kind_im, rb => kind_rb
846 ! implicit none
847 save
849 !-----------------------------------------------------------------
850 ! rrtmg_lw ORIGINAL abs. coefficients for interval 9
851 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
852 !
853 ! Initial version: JJMorcrette, ECMWF, jul1998
854 ! Revised: MJIacono, AER, jun2006
855 ! Revised: MJIacono, AER, aug2008
856 !-----------------------------------------------------------------
857 !
858 ! name type purpose
859 ! ---- : ---- : ---------------------------------------------
860 !fracrefao: real
861 !fracrefbo: real
862 ! kao : real
863 ! kbo : real
864 ! kao_mn2o: real
865 ! kbo_mn2o: real
866 ! selfrefo: real
867 ! forrefo : real
868 !-----------------------------------------------------------------
870 integer(kind=im), parameter :: no9 = 16
872 real(kind=rb) , dimension(no9) :: fracrefbo
874 real(kind=rb) :: fracrefao(no9,9)
875 real(kind=rb) :: kao(9,5,13,no9)
876 real(kind=rb) :: kbo(5,13:59,no9)
877 real(kind=rb) :: kao_mn2o(9,19,no9)
878 real(kind=rb) :: kbo_mn2o(19,no9)
879 real(kind=rb) :: selfrefo(10,no9)
880 real(kind=rb) :: forrefo(4,no9)
882 !-----------------------------------------------------------------
883 ! rrtmg_lw COMBINED abs. coefficients for interval 9
884 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
885 !
886 ! Initial version: JJMorcrette, ECMWF, jul1998
887 ! Revised: MJIacono, AER, jun2006
888 ! Revised: MJIacono, AER, aug2008
889 !-----------------------------------------------------------------
890 !
891 ! name type purpose
892 ! ---- : ---- : ---------------------------------------------
893 !fracrefa : real
894 !fracrefb : real
895 ! ka : real
896 ! kb : real
897 ! ka_mn2o : real
898 ! kb_mn2o : real
899 ! selfref : real
900 ! forref : real
901 !
902 ! absa : real
903 ! absb : real
904 !-----------------------------------------------------------------
906 integer(kind=im), parameter :: ng9 = 12
908 real(kind=rb) , dimension(ng9) :: fracrefb
909 real(kind=rb) :: fracrefa(ng9,9)
910 real(kind=rb) :: ka(9,5,13,ng9) ,absa(585,ng9)
911 real(kind=rb) :: kb(5,13:59,ng9) ,absb(235,ng9)
912 real(kind=rb) :: ka_mn2o(9,19,ng9)
913 real(kind=rb) :: kb_mn2o(19,ng9)
914 real(kind=rb) :: selfref(10,ng9)
915 real(kind=rb) :: forref(4,ng9)
917 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
919 end module rrlw_kg09
921 module rrlw_kg10
923 use parkind ,only : im => kind_im, rb => kind_rb
925 ! implicit none
926 save
928 !-----------------------------------------------------------------
929 ! rrtmg_lw ORIGINAL abs. coefficients for interval 10
930 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
931 !
932 ! Initial version: JJMorcrette, ECMWF, jul1998
933 ! Revised: MJIacono, AER, jun2006
934 ! Revised: MJIacono, AER, aug2008
935 !-----------------------------------------------------------------
936 !
937 ! name type purpose
938 ! ---- : ---- : ---------------------------------------------
939 !fracrefao: real
940 !fracrefbo: real
941 ! kao : real
942 ! kbo : real
943 ! selfrefo: real
944 ! forrefo : real
945 !-----------------------------------------------------------------
947 integer(kind=im), parameter :: no10 = 16
949 real(kind=rb) , dimension(no10) :: fracrefao
950 real(kind=rb) , dimension(no10) :: fracrefbo
952 real(kind=rb) :: kao(5,13,no10)
953 real(kind=rb) :: kbo(5,13:59,no10)
954 real(kind=rb) :: selfrefo(10,no10)
955 real(kind=rb) :: forrefo(4,no10)
957 !-----------------------------------------------------------------
958 ! rrtmg_lw COMBINED abs. coefficients for interval 10
959 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
960 !
961 ! Initial version: JJMorcrette, ECMWF, jul1998
962 ! Revised: MJIacono, AER, jun2006
963 ! Revised: MJIacono, AER, aug2008
964 !-----------------------------------------------------------------
965 !
966 ! name type purpose
967 ! ---- : ---- : ---------------------------------------------
968 !fracrefao: real
969 !fracrefbo: real
970 ! kao : real
971 ! kbo : real
972 ! selfref : real
973 ! forref : real
974 !
975 ! absa : real
976 ! absb : real
977 !-----------------------------------------------------------------
979 integer(kind=im), parameter :: ng10 = 6
981 real(kind=rb) , dimension(ng10) :: fracrefa
982 real(kind=rb) , dimension(ng10) :: fracrefb
984 real(kind=rb) :: ka(5,13,ng10) , absa(65,ng10)
985 real(kind=rb) :: kb(5,13:59,ng10), absb(235,ng10)
986 real(kind=rb) :: selfref(10,ng10)
987 real(kind=rb) :: forref(4,ng10)
989 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
991 end module rrlw_kg10
993 module rrlw_kg11
995 use parkind ,only : im => kind_im, rb => kind_rb
997 ! implicit none
998 save
1000 !-----------------------------------------------------------------
1001 ! rrtmg_lw ORIGINAL abs. coefficients for interval 11
1002 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
1003 !
1004 ! Initial version: JJMorcrette, ECMWF, jul1998
1005 ! Revised: MJIacono, AER, jun2006
1006 ! Revised: MJIacono, AER, aug2008
1007 !-----------------------------------------------------------------
1008 !
1009 ! name type purpose
1010 ! ---- : ---- : ---------------------------------------------
1011 !fracrefao: real
1012 !fracrefbo: real
1013 ! kao : real
1014 ! kbo : real
1015 ! kao_mo2 : real
1016 ! kbo_mo2 : real
1017 ! selfrefo: real
1018 ! forrefo : real
1019 !-----------------------------------------------------------------
1021 integer(kind=im), parameter :: no11 = 16
1023 real(kind=rb) , dimension(no11) :: fracrefao
1024 real(kind=rb) , dimension(no11) :: fracrefbo
1026 real(kind=rb) :: kao(5,13,no11)
1027 real(kind=rb) :: kbo(5,13:59,no11)
1028 real(kind=rb) :: kao_mo2(19,no11)
1029 real(kind=rb) :: kbo_mo2(19,no11)
1030 real(kind=rb) :: selfrefo(10,no11)
1031 real(kind=rb) :: forrefo(4,no11)
1033 !-----------------------------------------------------------------
1034 ! rrtmg_lw COMBINED abs. coefficients for interval 11
1035 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
1036 !
1037 ! Initial version: JJMorcrette, ECMWF, jul1998
1038 ! Revised: MJIacono, AER, jun2006
1039 ! Revised: MJIacono, AER, aug2008
1040 !-----------------------------------------------------------------
1041 !
1042 ! name type purpose
1043 ! ---- : ---- : ---------------------------------------------
1044 !fracrefa : real
1045 !fracrefb : real
1046 ! ka : real
1047 ! kb : real
1048 ! ka_mo2 : real
1049 ! kb_mo2 : real
1050 ! selfref : real
1051 ! forref : real
1052 !
1053 ! absa : real
1054 ! absb : real
1055 !-----------------------------------------------------------------
1057 integer(kind=im), parameter :: ng11 = 8
1059 real(kind=rb) , dimension(ng11) :: fracrefa
1060 real(kind=rb) , dimension(ng11) :: fracrefb
1062 real(kind=rb) :: ka(5,13,ng11) , absa(65,ng11)
1063 real(kind=rb) :: kb(5,13:59,ng11), absb(235,ng11)
1064 real(kind=rb) :: ka_mo2(19,ng11)
1065 real(kind=rb) :: kb_mo2(19,ng11)
1066 real(kind=rb) :: selfref(10,ng11)
1067 real(kind=rb) :: forref(4,ng11)
1069 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1071 end module rrlw_kg11
1073 module rrlw_kg12
1075 use parkind ,only : im => kind_im, rb => kind_rb
1077 ! implicit none
1078 save
1080 !-----------------------------------------------------------------
1081 ! rrtmg_lw ORIGINAL abs. coefficients for interval 12
1082 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1083 !
1084 ! Initial version: JJMorcrette, ECMWF, jul1998
1085 ! Revised: MJIacono, AER, jun2006
1086 ! Revised: MJIacono, AER, aug2008
1087 !-----------------------------------------------------------------
1088 !
1089 ! name type purpose
1090 ! ---- : ---- : ---------------------------------------------
1091 !fracrefao: real
1092 ! kao : real
1093 ! selfrefo: real
1094 ! forrefo : real
1095 !-----------------------------------------------------------------
1097 integer(kind=im), parameter :: no12 = 16
1099 real(kind=rb) :: fracrefao(no12,9)
1100 real(kind=rb) :: kao(9,5,13,no12)
1101 real(kind=rb) :: selfrefo(10,no12)
1102 real(kind=rb) :: forrefo(4,no12)
1104 !-----------------------------------------------------------------
1105 ! rrtmg_lw COMBINED abs. coefficients for interval 12
1106 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
1107 !
1108 ! Initial version: JJMorcrette, ECMWF, jul1998
1109 ! Revised: MJIacono, AER, jun2006
1110 ! Revised: MJIacono, AER, aug2008
1111 !-----------------------------------------------------------------
1112 !
1113 ! name type purpose
1114 ! ---- : ---- : ---------------------------------------------
1115 !fracrefa : real
1116 ! ka : real
1117 ! selfref : real
1118 ! forref : real
1119 !
1120 ! absa : real
1121 !-----------------------------------------------------------------
1123 integer(kind=im), parameter :: ng12 = 8
1125 real(kind=rb) :: fracrefa(ng12,9)
1126 real(kind=rb) :: ka(9,5,13,ng12) ,absa(585,ng12)
1127 real(kind=rb) :: selfref(10,ng12)
1128 real(kind=rb) :: forref(4,ng12)
1130 equivalence (ka(1,1,1,1),absa(1,1))
1132 end module rrlw_kg12
1134 module rrlw_kg13
1136 use parkind ,only : im => kind_im, rb => kind_rb
1138 ! implicit none
1139 save
1141 !-----------------------------------------------------------------
1142 ! rrtmg_lw ORIGINAL abs. coefficients for interval 13
1143 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1144 !
1145 ! Initial version: JJMorcrette, ECMWF, jul1998
1146 ! Revised: MJIacono, AER, jun2006
1147 ! Revised: MJIacono, AER, aug2008
1148 !-----------------------------------------------------------------
1149 !
1150 ! name type purpose
1151 ! ---- : ---- : ---------------------------------------------
1152 !fracrefao: real
1153 ! kao : real
1154 ! kao_mco2: real
1155 ! kao_mco : real
1156 ! kbo_mo3 : real
1157 ! selfrefo: real
1158 ! forrefo : real
1159 !-----------------------------------------------------------------
1161 integer(kind=im), parameter :: no13 = 16
1163 real(kind=rb) , dimension(no13) :: fracrefbo
1165 real(kind=rb) :: fracrefao(no13,9)
1166 real(kind=rb) :: kao(9,5,13,no13)
1167 real(kind=rb) :: kao_mco2(9,19,no13)
1168 real(kind=rb) :: kao_mco(9,19,no13)
1169 real(kind=rb) :: kbo_mo3(19,no13)
1170 real(kind=rb) :: selfrefo(10,no13)
1171 real(kind=rb) :: forrefo(4,no13)
1173 !-----------------------------------------------------------------
1174 ! rrtmg_lw COMBINED abs. coefficients for interval 13
1175 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1176 !
1177 ! Initial version: JJMorcrette, ECMWF, jul1998
1178 ! Revised: MJIacono, AER, jun2006
1179 ! Revised: MJIacono, AER, aug2008
1180 !-----------------------------------------------------------------
1181 !
1182 ! name type purpose
1183 ! ---- : ---- : ---------------------------------------------
1184 !fracrefa : real
1185 ! ka : real
1186 ! ka_mco2 : real
1187 ! ka_mco : real
1188 ! kb_mo3 : real
1189 ! selfref : real
1190 ! forref : real
1191 !
1192 ! absa : real
1193 !-----------------------------------------------------------------
1195 integer(kind=im), parameter :: ng13 = 4
1197 real(kind=rb) , dimension(ng13) :: fracrefb
1199 real(kind=rb) :: fracrefa(ng13,9)
1200 real(kind=rb) :: ka(9,5,13,ng13) ,absa(585,ng13)
1201 real(kind=rb) :: ka_mco2(9,19,ng13)
1202 real(kind=rb) :: ka_mco(9,19,ng13)
1203 real(kind=rb) :: kb_mo3(19,ng13)
1204 real(kind=rb) :: selfref(10,ng13)
1205 real(kind=rb) :: forref(4,ng13)
1207 equivalence (ka(1,1,1,1),absa(1,1))
1209 end module rrlw_kg13
1211 module rrlw_kg14
1213 use parkind ,only : im => kind_im, rb => kind_rb
1215 ! implicit none
1216 save
1218 !-----------------------------------------------------------------
1219 ! rrtmg_lw ORIGINAL abs. coefficients for interval 14
1220 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1221 !
1222 ! Initial version: JJMorcrette, ECMWF, jul1998
1223 ! Revised: MJIacono, AER, jun2006
1224 ! Revised: MJIacono, AER, aug2008
1225 !-----------------------------------------------------------------
1226 !
1227 ! name type purpose
1228 ! ---- : ---- : ---------------------------------------------
1229 !fracrefao: real
1230 !fracrefbo: real
1231 ! kao : real
1232 ! kbo : real
1233 ! selfrefo: real
1234 ! forrefo : real
1235 !-----------------------------------------------------------------
1237 integer(kind=im), parameter :: no14 = 16
1239 real(kind=rb) , dimension(no14) :: fracrefao
1240 real(kind=rb) , dimension(no14) :: fracrefbo
1242 real(kind=rb) :: kao(5,13,no14)
1243 real(kind=rb) :: kbo(5,13:59,no14)
1244 real(kind=rb) :: selfrefo(10,no14)
1245 real(kind=rb) :: forrefo(4,no14)
1247 !-----------------------------------------------------------------
1248 ! rrtmg_lw COMBINED abs. coefficients for interval 14
1249 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
1250 !
1251 ! Initial version: JJMorcrette, ECMWF, jul1998
1252 ! Revised: MJIacono, AER, jun2006
1253 ! Revised: MJIacono, AER, aug2008
1254 !-----------------------------------------------------------------
1255 !
1256 ! name type purpose
1257 ! ---- : ---- : ---------------------------------------------
1258 !fracrefa : real
1259 !fracrefb : real
1260 ! ka : real
1261 ! kb : real
1262 ! selfref : real
1263 ! forref : real
1264 !
1265 ! absa : real
1266 ! absb : real
1267 !-----------------------------------------------------------------
1269 integer(kind=im), parameter :: ng14 = 2
1271 real(kind=rb) , dimension(ng14) :: fracrefa
1272 real(kind=rb) , dimension(ng14) :: fracrefb
1274 real(kind=rb) :: ka(5,13,ng14) ,absa(65,ng14)
1275 real(kind=rb) :: kb(5,13:59,ng14),absb(235,ng14)
1276 real(kind=rb) :: selfref(10,ng14)
1277 real(kind=rb) :: forref(4,ng14)
1279 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1281 end module rrlw_kg14
1283 module rrlw_kg15
1285 use parkind ,only : im => kind_im, rb => kind_rb
1287 ! implicit none
1288 save
1290 !-----------------------------------------------------------------
1291 ! rrtmg_lw ORIGINAL abs. coefficients for interval 15
1292 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1293 !
1294 ! Initial version: JJMorcrette, ECMWF, jul1998
1295 ! Revised: MJIacono, AER, jun2006
1296 ! Revised: MJIacono, AER, aug2008
1297 !-----------------------------------------------------------------
1298 !
1299 ! name type purpose
1300 ! ---- : ---- : ---------------------------------------------
1301 !fracrefao: real
1302 ! kao : real
1303 ! kao_mn2 : real
1304 ! selfrefo: real
1305 ! forrefo : real
1306 !-----------------------------------------------------------------
1308 integer(kind=im), parameter :: no15 = 16
1310 real(kind=rb) :: fracrefao(no15,9)
1311 real(kind=rb) :: kao(9,5,13,no15)
1312 real(kind=rb) :: kao_mn2(9,19,no15)
1313 real(kind=rb) :: selfrefo(10,no15)
1314 real(kind=rb) :: forrefo(4,no15)
1317 !-----------------------------------------------------------------
1318 ! rrtmg_lw COMBINED abs. coefficients for interval 15
1319 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
1320 !
1321 ! Initial version: JJMorcrette, ECMWF, jul1998
1322 ! Revised: MJIacono, AER, jun2006
1323 ! Revised: MJIacono, AER, aug2008
1324 !-----------------------------------------------------------------
1325 !
1326 ! name type purpose
1327 ! ---- : ---- : ---------------------------------------------
1328 !fracrefa : real
1329 ! ka : real
1330 ! ka_mn2 : real
1331 ! selfref : real
1332 ! forref : real
1333 !
1334 ! absa : real
1335 !-----------------------------------------------------------------
1337 integer(kind=im), parameter :: ng15 = 2
1339 real(kind=rb) :: fracrefa(ng15,9)
1340 real(kind=rb) :: ka(9,5,13,ng15) ,absa(585,ng15)
1341 real(kind=rb) :: ka_mn2(9,19,ng15)
1342 real(kind=rb) :: selfref(10,ng15)
1343 real(kind=rb) :: forref(4,ng15)
1345 equivalence (ka(1,1,1,1),absa(1,1))
1347 end module rrlw_kg15
1349 module rrlw_kg16
1351 use parkind ,only : im => kind_im, rb => kind_rb
1353 ! implicit none
1354 save
1356 !-----------------------------------------------------------------
1357 ! rrtmg_lw ORIGINAL abs. coefficients for interval 16
1358 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1359 !
1360 ! Initial version: JJMorcrette, ECMWF, jul1998
1361 ! Revised: MJIacono, AER, jun2006
1362 ! Revised: MJIacono, AER, aug2008
1363 !-----------------------------------------------------------------
1364 !
1365 ! name type purpose
1366 ! ---- : ---- : ---------------------------------------------
1367 !fracrefao: real
1368 ! kao : real
1369 ! kbo : real
1370 ! selfrefo: real
1371 ! forrefo : real
1372 !-----------------------------------------------------------------
1374 integer(kind=im), parameter :: no16 = 16
1376 real(kind=rb) , dimension(no16) :: fracrefbo
1378 real(kind=rb) :: fracrefao(no16,9)
1379 real(kind=rb) :: kao(9,5,13,no16)
1380 real(kind=rb) :: kbo(5,13:59,no16)
1381 real(kind=rb) :: selfrefo(10,no16)
1382 real(kind=rb) :: forrefo(4,no16)
1384 !-----------------------------------------------------------------
1385 ! rrtmg_lw COMBINED abs. coefficients for interval 16
1386 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1387 !
1388 ! Initial version: JJMorcrette, ECMWF, jul1998
1389 ! Revised: MJIacono, AER, jun2006
1390 ! Revised: MJIacono, AER, aug2008
1391 !-----------------------------------------------------------------
1392 !
1393 ! name type purpose
1394 ! ---- : ---- : ---------------------------------------------
1395 !fracrefa : real
1396 ! ka : real
1397 ! kb : real
1398 ! selfref : real
1399 ! forref : real
1400 !
1401 ! absa : real
1402 ! absb : real
1403 !-----------------------------------------------------------------
1405 integer(kind=im), parameter :: ng16 = 2
1407 real(kind=rb) , dimension(ng16) :: fracrefb
1409 real(kind=rb) :: fracrefa(ng16,9)
1410 real(kind=rb) :: ka(9,5,13,ng16) ,absa(585,ng16)
1411 real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
1412 real(kind=rb) :: selfref(10,ng16)
1413 real(kind=rb) :: forref(4,ng16)
1415 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1417 end module rrlw_kg16
1420 module rrlw_ref
1422 use parkind, only : im => kind_im, rb => kind_rb
1424 ! implicit none
1425 save
1427 !------------------------------------------------------------------
1428 ! rrtmg_lw reference atmosphere
1429 ! Based on standard mid-latitude summer profile
1430 !
1431 ! Initial version: JJMorcrette, ECMWF, jul1998
1432 ! Revised: MJIacono, AER, jun2006
1433 ! Revised: MJIacono, AER, aug2008
1434 !------------------------------------------------------------------
1436 ! name type purpose
1437 ! ----- : ---- : ----------------------------------------------
1438 ! pref : real : Reference pressure levels
1439 ! preflog: real : Reference pressure levels, ln(pref)
1440 ! tref : real : Reference temperature levels for MLS profile
1441 ! chi_mls: real :
1442 !------------------------------------------------------------------
1444 real(kind=rb) , dimension(59) :: pref
1445 real(kind=rb) , dimension(59) :: preflog
1446 real(kind=rb) , dimension(59) :: tref
1447 real(kind=rb) :: chi_mls(7,59)
1449 end module rrlw_ref
1451 module rrlw_tbl
1453 use parkind, only : im => kind_im, rb => kind_rb
1455 ! implicit none
1456 save
1458 !------------------------------------------------------------------
1459 ! rrtmg_lw exponential lookup table arrays
1461 ! Initial version: JJMorcrette, ECMWF, jul1998
1462 ! Revised: MJIacono, AER, Jun 2006
1463 ! Revised: MJIacono, AER, Aug 2007
1464 ! Revised: MJIacono, AER, Aug 2008
1465 !------------------------------------------------------------------
1467 ! name type purpose
1468 ! ----- : ---- : ----------------------------------------------
1469 ! ntbl : integer: Lookup table dimension
1470 ! tblint : real : Lookup table conversion factor
1471 ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative
1472 ! transfer)
1473 ! exp_tbl: real : Transmittance lookup table
1474 ! tfn_tbl: real : Tau transition function; i.e. the transition of
1475 ! the Planck function from that for the mean layer
1476 ! temperature to that for the layer boundary
1477 ! temperature as a function of optical depth.
1478 ! The "linear in tau" method is used to make
1479 ! the table.
1480 ! pade : real : Pade constant
1481 ! bpade : real : Inverse of Pade constant
1482 !------------------------------------------------------------------
1484 integer(kind=im), parameter :: ntbl = 10000
1486 real(kind=rb), parameter :: tblint = 10000.0_rb
1488 real(kind=rb) , dimension(0:ntbl) :: tau_tbl
1489 real(kind=rb) , dimension(0:ntbl) :: exp_tbl
1490 real(kind=rb) , dimension(0:ntbl) :: tfn_tbl
1492 real(kind=rb), parameter :: pade = 0.278_rb
1493 real(kind=rb) :: bpade
1495 end module rrlw_tbl
1497 module rrlw_vsn
1499 ! implicit none
1500 save
1502 !------------------------------------------------------------------
1503 ! rrtmg_lw version information
1505 ! Initial version: JJMorcrette, ECMWF, jul1998
1506 ! Revised: MJIacono, AER, jun2006
1507 ! Revised: MJIacono, AER, aug2008
1508 !------------------------------------------------------------------
1510 ! name type purpose
1511 ! ----- : ---- : ----------------------------------------------
1512 !hnamrtm :character:
1513 !hnamini :character:
1514 !hnamcld :character:
1515 !hnamclc :character:
1516 !hnamrtr :character:
1517 !hnamrtx :character:
1518 !hnamrtc :character:
1519 !hnamset :character:
1520 !hnamtau :character:
1521 !hnamatm :character:
1522 !hnamutl :character:
1523 !hnamext :character:
1524 !hnamkg :character:
1525 !
1526 ! hvrrtm :character:
1527 ! hvrini :character:
1528 ! hvrcld :character:
1529 ! hvrclc :character:
1530 ! hvrrtr :character:
1531 ! hvrrtx :character:
1532 ! hvrrtc :character:
1533 ! hvrset :character:
1534 ! hvrtau :character:
1535 ! hvratm :character:
1536 ! hvrutl :character:
1537 ! hvrext :character:
1538 ! hvrkg :character:
1539 !------------------------------------------------------------------
1541 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, &
1542 hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
1543 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, &
1544 hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
1546 character*18 hvrkg
1547 character*20 hnamkg
1549 end module rrlw_vsn
1551 module rrlw_wvn
1553 use parkind, only : im => kind_im, rb => kind_rb
1554 use parrrtm, only : nbndlw, mg, ngptlw, maxinpx
1556 ! implicit none
1557 save
1559 !------------------------------------------------------------------
1560 ! rrtmg_lw spectral information
1562 ! Initial version: JJMorcrette, ECMWF, jul1998
1563 ! Revised: MJIacono, AER, jun2006
1564 ! Revised: MJIacono, AER, aug2008
1565 !------------------------------------------------------------------
1567 ! name type purpose
1568 ! ----- : ---- : ----------------------------------------------
1569 ! ng : integer: Number of original g-intervals in each spectral band
1570 ! nspa : integer: For the lower atmosphere, the number of reference
1571 ! atmospheres that are stored for each spectral band
1572 ! per pressure level and temperature. Each of these
1573 ! atmospheres has different relative amounts of the
1574 ! key species for the band (i.e. different binary
1575 ! species parameters).
1576 ! nspb : integer: Same as nspa for the upper atmosphere
1577 !wavenum1: real : Spectral band lower boundary in wavenumbers
1578 !wavenum2: real : Spectral band upper boundary in wavenumbers
1579 ! delwave: real : Spectral band width in wavenumbers
1580 ! totplnk: real : Integrated Planck value for each band; (band 16
1581 ! includes total from 2600 cm-1 to infinity)
1582 ! Used for calculation across total spectrum
1583 !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1)
1584 ! Used for calculation in band 16 only if
1585 ! individual band output requested
1586 !
1587 ! ngc : integer: The number of new g-intervals in each band
1588 ! ngs : integer: The cumulative sum of new g-intervals for each band
1589 ! ngm : integer: The index of each new g-interval relative to the
1590 ! original 16 g-intervals in each band
1591 ! ngn : integer: The number of original g-intervals that are
1592 ! combined to make each new g-intervals in each band
1593 ! ngb : integer: The band index for each new g-interval
1594 ! wt : real : RRTM weights for the original 16 g-intervals
1595 ! rwgt : real : Weights for combining original 16 g-intervals
1596 ! (256 total) into reduced set of g-intervals
1597 ! (140 total)
1598 ! nxmol : integer: Number of cross-section molecules
1599 ! ixindx : integer: Flag for active cross-sections in calculation
1600 !------------------------------------------------------------------
1602 integer(kind=im) :: ng(nbndlw)
1603 integer(kind=im) :: nspa(nbndlw)
1604 integer(kind=im) :: nspb(nbndlw)
1606 real(kind=rb) :: wavenum1(nbndlw)
1607 real(kind=rb) :: wavenum2(nbndlw)
1608 real(kind=rb) :: delwave(nbndlw)
1610 real(kind=rb) :: totplnk(181,nbndlw)
1611 real(kind=rb) :: totplk16(181)
1613 integer(kind=im) :: ngc(nbndlw)
1614 integer(kind=im) :: ngs(nbndlw)
1615 integer(kind=im) :: ngn(ngptlw)
1616 integer(kind=im) :: ngb(ngptlw)
1617 integer(kind=im) :: ngm(nbndlw*mg)
1619 real(kind=rb) :: wt(mg)
1620 real(kind=rb) :: rwgt(nbndlw*mg)
1622 integer(kind=im) :: nxmol
1623 integer(kind=im) :: ixindx(maxinpx)
1625 end module rrlw_wvn
1627 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
1628 ! author: $Author: trn $
1629 ! revision: $Revision: 1.3 $
1630 ! created: $Date: 2009/04/16 19:54:22 $
1631 !
1633 ! Fortran-95 implementation of the Mersenne Twister 19937, following
1634 ! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10),
1635 ! adapted cosmetically by making the names more general.
1636 ! Users must declare one or more variables of type randomNumberSequence in the calling
1637 ! procedure which are then initialized using a required seed. If the
1638 ! variable is not initialized the random numbers will all be 0.
1639 ! For example:
1640 ! program testRandoms
1641 ! use RandomNumbers
1642 ! type(randomNumberSequence) :: randomNumbers
1643 ! integer :: i
1644 !
1645 ! randomNumbers = new_RandomNumberSequence(seed = 100)
1646 ! do i = 1, 10
1647 ! print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
1648 ! end do
1649 ! end program testRandoms
1650 !
1651 ! Fortran-95 implementation by
1652 ! Robert Pincus
1653 ! NOAA-CIRES Climate Diagnostics Center
1654 ! Boulder, CO 80305
1655 ! email: Robert.Pincus@colorado.edu
1656 !
1657 ! This documentation in the original C program reads:
1658 ! -------------------------------------------------------------
1659 ! A C-program for MT19937, with initialization improved 2002/2/10.
1660 ! Coded by Takuji Nishimura and Makoto Matsumoto.
1661 ! This is a faster version by taking Shawn Cokus's optimization,
1662 ! Matthe Bellew's simplification, Isaku Wada's real version.
1663 !
1664 ! Before using, initialize the state by using init_genrand(seed)
1665 ! or init_by_array(init_key, key_length).
1666 !
1667 ! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
1668 ! All rights reserved.
1669 !
1670 ! Redistribution and use in source and binary forms, with or without
1671 ! modification, are permitted provided that the following conditions
1672 ! are met:
1673 !
1674 ! 1. Redistributions of source code must retain the above copyright
1675 ! notice, this list of conditions and the following disclaimer.
1676 !
1677 ! 2. Redistributions in binary form must reproduce the above copyright
1678 ! notice, this list of conditions and the following disclaimer in the
1679 ! documentation and/or other materials provided with the distribution.
1680 !
1681 ! 3. The names of its contributors may not be used to endorse or promote
1682 ! products derived from this software without specific prior written
1683 ! permission.
1684 !
1685 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1686 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1687 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1688 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
1689 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
1690 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
1691 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
1692 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
1693 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1694 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
1695 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1696 !
1697 !
1698 ! Any feedback is very welcome.
1699 ! http://www.math.keio.ac.jp/matumoto/emt.html
1700 ! email: matumoto@math.keio.ac.jp
1701 ! -------------------------------------------------------------
1703 module MersenneTwister
1704 ! -------------------------------------------------------------
1706 use parkind, only : im => kind_im, rb => kind_rb
1708 implicit none
1709 private
1711 ! Algorithm parameters
1712 ! -------
1713 ! Period parameters
1714 integer(kind=im), parameter :: blockSize = 624, &
1715 M = 397, &
1716 MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL)
1717 UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL)
1718 LMASK = 2147483647 ! least significant r bits (0x7fffffffUL)
1719 ! Tempering parameters
1720 integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
1721 TMASKC= -272236544 ! (0xefc60000UL)
1722 ! -------
1724 ! The type containing the state variable
1725 type randomNumberSequence
1726 integer(kind=im) :: currentElement ! = blockSize
1727 integer(kind=im), dimension(0:blockSize -1) :: state ! = 0
1728 end type randomNumberSequence
1730 interface new_RandomNumberSequence
1731 module procedure initialize_scalar, initialize_vector
1732 end interface new_RandomNumberSequence
1734 public :: randomNumberSequence
1735 public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
1736 getRandomInt, getRandomPositiveInt, getRandomReal
1737 ! -------------------------------------------------------------
1738 contains
1739 ! -------------------------------------------------------------
1740 ! Private functions
1741 ! ---------------------------
1742 function mixbits(u, v)
1743 integer(kind=im), intent( in) :: u, v
1744 integer(kind=im) :: mixbits
1746 mixbits = ior(iand(u, UMASK), iand(v, LMASK))
1747 end function mixbits
1748 ! ---------------------------
1749 function twist(u, v)
1750 integer(kind=im), intent( in) :: u, v
1751 integer(kind=im) :: twist
1753 ! Local variable
1754 integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /)
1756 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1757 twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1758 end function twist
1759 ! ---------------------------
1760 subroutine nextState(twister)
1761 type(randomNumberSequence), intent(inout) :: twister
1763 ! Local variables
1764 integer(kind=im) :: k
1766 do k = 0, blockSize - M - 1
1767 twister%state(k) = ieor(twister%state(k + M), &
1768 twist(twister%state(k), twister%state(k + 1_im)))
1769 end do
1770 do k = blockSize - M, blockSize - 2
1771 twister%state(k) = ieor(twister%state(k + M - blockSize), &
1772 twist(twister%state(k), twister%state(k + 1_im)))
1773 end do
1774 twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), &
1775 twist(twister%state(blockSize - 1_im), twister%state(0_im)))
1776 twister%currentElement = 0_im
1778 end subroutine nextState
1779 ! ---------------------------
1780 elemental function temper(y)
1781 integer(kind=im), intent(in) :: y
1782 integer(kind=im) :: temper
1784 integer(kind=im) :: x
1786 ! Tempering
1787 x = ieor(y, ishft(y, -11))
1788 x = ieor(x, iand(ishft(x, 7), TMASKB))
1789 x = ieor(x, iand(ishft(x, 15), TMASKC))
1790 temper = ieor(x, ishft(x, -18))
1791 end function temper
1792 ! -------------------------------------------------------------
1793 ! Public (but hidden) functions
1794 ! --------------------
1795 function initialize_scalar(seed) result(twister)
1796 integer(kind=im), intent(in ) :: seed
1797 type(randomNumberSequence) :: twister
1799 integer(kind=im) :: i
1800 ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions,
1801 ! MSBs of the seed affect only MSBs of the array state[].
1802 ! 2002/01/09 modified by Makoto Matsumoto
1804 twister%state(0) = iand(seed, -1_im)
1805 do i = 1, blockSize - 1 ! ubound(twister%state)
1806 twister%state(i) = 1812433253_im * ieor(twister%state(i-1), &
1807 ishft(twister%state(i-1), -30_im)) + i
1808 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1809 end do
1810 twister%currentElement = blockSize
1811 end function initialize_scalar
1812 ! -------------------------------------------------------------
1813 function initialize_vector(seed) result(twister)
1814 integer(kind=im), dimension(0:), intent(in) :: seed
1815 type(randomNumberSequence) :: twister
1817 integer(kind=im) :: i, j, k, nFirstLoop, nWraps
1819 nWraps = 0
1820 twister = initialize_scalar(19650218_im)
1822 nFirstLoop = max(blockSize, size(seed))
1823 do k = 1, nFirstLoop
1824 i = mod(k + nWraps, blockSize)
1825 j = mod(k - 1, size(seed))
1826 if(i == 0) then
1827 twister%state(i) = twister%state(blockSize - 1)
1828 twister%state(1) = ieor(twister%state(1), &
1829 ieor(twister%state(1-1), &
1830 ishft(twister%state(1-1), -30_im)) * 1664525_im) + &
1831 seed(j) + j ! Non-linear
1832 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1833 nWraps = nWraps + 1
1834 else
1835 twister%state(i) = ieor(twister%state(i), &
1836 ieor(twister%state(i-1), &
1837 ishft(twister%state(i-1), -30_im)) * 1664525_im) + &
1838 seed(j) + j ! Non-linear
1839 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1840 end if
1841 end do
1843 !
1844 ! Walk through the state array, beginning where we left off in the block above
1845 !
1846 do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
1847 twister%state(i) = ieor(twister%state(i), &
1848 ieor(twister%state(i-1), &
1849 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1850 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1851 end do
1853 twister%state(0) = twister%state(blockSize - 1)
1855 do i = 1, mod(nFirstLoop, blockSize) + nWraps
1856 twister%state(i) = ieor(twister%state(i), &
1857 ieor(twister%state(i-1), &
1858 ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
1859 twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1860 end do
1862 twister%state(0) = UMASK
1863 twister%currentElement = blockSize
1865 end function initialize_vector
1866 ! -------------------------------------------------------------
1867 ! Public functions
1868 ! --------------------
1869 function getRandomInt(twister)
1870 type(randomNumberSequence), intent(inout) :: twister
1871 integer(kind=im) :: getRandomInt
1872 ! Generate a random integer on the interval [0,0xffffffff]
1873 ! Equivalent to genrand_int32 in the C code.
1874 ! Fortran doesn't have a type that's unsigned like C does,
1875 ! so this is integers in the range -2**31 - 2**31
1876 ! All functions for getting random numbers call this one,
1877 ! then manipulate the result
1879 if(twister%currentElement >= blockSize) call nextState(twister)
1881 getRandomInt = temper(twister%state(twister%currentElement))
1882 twister%currentElement = twister%currentElement + 1
1884 end function getRandomInt
1885 ! --------------------
1886 function getRandomPositiveInt(twister)
1887 type(randomNumberSequence), intent(inout) :: twister
1888 integer(kind=im) :: getRandomPositiveInt
1889 ! Generate a random integer on the interval [0,0x7fffffff]
1890 ! or [0,2**31]
1891 ! Equivalent to genrand_int31 in the C code.
1893 ! Local integers
1894 integer(kind=im) :: localInt
1896 localInt = getRandomInt(twister)
1897 getRandomPositiveInt = ishft(localInt, -1)
1899 end function getRandomPositiveInt
1900 ! --------------------
1901 !! mji - modified Jan 2007, double converted to rrtmg real kind type
1902 function getRandomReal(twister)
1903 type(randomNumberSequence), intent(inout) :: twister
1904 ! double precision :: getRandomReal
1905 real(kind=rb) :: getRandomReal
1906 ! Generate a random number on [0,1]
1907 ! Equivalent to genrand_real1 in the C code
1908 ! The result is stored as double precision but has 32 bit resolution
1910 integer(kind=im) :: localInt
1912 localInt = getRandomInt(twister)
1913 if(localInt < 0) then
1914 ! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
1915 getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb)
1916 else
1917 ! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0)
1918 getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb)
1919 end if
1921 end function getRandomReal
1922 ! --------------------
1923 subroutine finalize_RandomNumberSequence(twister)
1924 type(randomNumberSequence), intent(inout) :: twister
1926 twister%currentElement = blockSize
1927 twister%state(:) = 0_im
1928 end subroutine finalize_RandomNumberSequence
1930 ! --------------------
1932 end module MersenneTwister
1935 module mcica_random_numbers
1937 ! Generic module to wrap random number generators.
1938 ! The module defines a type that identifies the particular stream of random
1939 ! numbers, and has procedures for initializing it and getting real numbers
1940 ! in the range 0 to 1.
1941 ! This version uses the Mersenne Twister to generate random numbers on [0, 1].
1942 !
1943 use MersenneTwister, only: randomNumberSequence, & ! The random number engine.
1944 new_RandomNumberSequence, getRandomReal
1945 !! mji
1946 !! use time_manager_mod, only: time_type, get_date
1948 use parkind, only : im => kind_im, rb => kind_rb
1950 implicit none
1951 private
1953 type randomNumberStream
1954 type(randomNumberSequence) :: theNumbers
1955 end type randomNumberStream
1957 interface getRandomNumbers
1958 module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
1959 end interface getRandomNumbers
1961 interface initializeRandomNumberStream
1962 module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
1963 end interface initializeRandomNumberStream
1965 public :: randomNumberStream, &
1966 initializeRandomNumberStream, getRandomNumbers
1967 !! mji
1968 !! initializeRandomNumberStream, getRandomNumbers, &
1969 !! constructSeed
1970 contains
1971 ! ---------------------------------------------------------
1972 ! Initialization
1973 ! ---------------------------------------------------------
1974 function initializeRandomNumberStream_S(seed) result(new)
1975 integer(kind=im), intent( in) :: seed
1976 type(randomNumberStream) :: new
1978 new%theNumbers = new_RandomNumberSequence(seed)
1980 end function initializeRandomNumberStream_S
1981 ! ---------------------------------------------------------
1982 function initializeRandomNumberStream_V(seed) result(new)
1983 integer(kind=im), dimension(:), intent( in) :: seed
1984 type(randomNumberStream) :: new
1986 new%theNumbers = new_RandomNumberSequence(seed)
1988 end function initializeRandomNumberStream_V
1989 ! ---------------------------------------------------------
1990 ! Procedures for drawing random numbers
1991 ! ---------------------------------------------------------
1992 subroutine getRandomNumber_Scalar(stream, number)
1993 type(randomNumberStream), intent(inout) :: stream
1994 real(kind=rb), intent( out) :: number
1996 number = getRandomReal(stream%theNumbers)
1997 end subroutine getRandomNumber_Scalar
1998 ! ---------------------------------------------------------
1999 subroutine getRandomNumber_1D(stream, numbers)
2000 type(randomNumberStream), intent(inout) :: stream
2001 real(kind=rb), dimension(:), intent( out) :: numbers
2003 ! Local variables
2004 integer(kind=im) :: i
2006 do i = 1, size(numbers)
2007 numbers(i) = getRandomReal(stream%theNumbers)
2008 end do
2009 end subroutine getRandomNumber_1D
2010 ! ---------------------------------------------------------
2011 subroutine getRandomNumber_2D(stream, numbers)
2012 type(randomNumberStream), intent(inout) :: stream
2013 real(kind=rb), dimension(:, :), intent( out) :: numbers
2015 ! Local variables
2016 integer(kind=im) :: i
2018 do i = 1, size(numbers, 2)
2019 call getRandomNumber_1D(stream, numbers(:, i))
2020 end do
2021 end subroutine getRandomNumber_2D
2022 ! mji
2023 ! ! ---------------------------------------------------------
2024 ! ! Constructing a unique seed from grid cell index and model date/time
2025 ! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute
2026 ! ! ---------------------------------------------------------
2027 ! function constructSeed(i, j, time) result(seed)
2028 ! integer(kind=im), intent( in) :: i, j
2029 ! type(time_type), intent( in) :: time
2030 ! integer(kind=im), dimension(8) :: seed
2031 !
2032 ! ! Local variables
2033 ! integer(kind=im) :: year, month, day, hour, minute, second
2034 !
2035 !
2036 ! call get_date(time, year, month, day, hour, minute, second)
2037 ! seed = (/ i, j, year, month, day, hour, minute, second /)
2038 ! end function constructSeed
2040 end module mcica_random_numbers
2042 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2043 ! author: $Author: trn $
2044 ! revision: $Revision: 1.3 $
2045 ! created: $Date: 2009/04/16 19:54:22 $
2046 !
2047 module mcica_subcol_gen_lw
2049 ! --------------------------------------------------------------------------
2050 ! | |
2051 ! | Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER). |
2052 ! | This software may be used, copied, or redistributed as long as it is |
2053 ! | not sold and this copyright notice is reproduced on each copy made. |
2054 ! | This model is provided as is without any express or implied warranties. |
2055 ! | (http://www.rtweb.aer.com/) |
2056 ! | |
2057 ! --------------------------------------------------------------------------
2059 ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
2060 ! Two options are possible:
2061 ! 1) Input cloud physical properties: cloud fraction, ice and liquid water
2062 ! paths, ice fraction, and particle sizes. Output will be stochastic
2063 ! arrays of these variables. (inflag = 1)
2064 ! 2) Input cloud optical properties directly: cloud optical depth, single
2065 ! scattering albedo and asymmetry parameter. Output will be stochastic
2066 ! arrays of these variables. (inflag = 0; longwave scattering is not
2067 ! yet available, ssac and asmc are for future expansion)
2069 ! --------- Modules ----------
2071 use parkind, only : im => kind_im, rb => kind_rb
2072 use parrrtm, only : nbndlw, ngptlw
2073 use rrlw_con, only: grav
2074 use rrlw_wvn, only: ngb
2075 use rrlw_vsn
2077 implicit none
2079 ! public interfaces/functions/subroutines
2080 public :: mcica_subcol_lw, generate_stochastic_clouds
2082 contains
2084 !------------------------------------------------------------------
2085 ! Public subroutines
2086 !------------------------------------------------------------------
2088 subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
2089 cldfrac, ciwp, clwp, rei, rel, tauc, cldfmcl, &
2090 ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
2092 ! ----- Input -----
2093 ! Control
2094 integer(kind=im), intent(in) :: iplon ! column/longitude index
2095 integer(kind=im), intent(in) :: ncol ! number of columns
2096 integer(kind=im), intent(in) :: nlay ! number of model layers
2097 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2098 integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times,
2099 ! permute the seed between each call.
2100 ! between calls for LW and SW, recommended
2101 ! permuteseed differes by 'ngpt'
2102 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2103 ! 0 = kissvec
2104 ! 1 = Mersenne Twister
2106 ! Atmosphere
2107 real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb)
2108 ! Dimensions: (ncol,nlay)
2110 ! Atmosphere/clouds - cldprop
2111 real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction
2112 ! Dimensions: (ncol,nlay)
2113 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2114 ! Dimensions: (nbndlw,ncol,nlay)
2115 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2116 ! Dimensions: (nbndlw,ncol,nlay)
2117 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2118 ! Dimensions: (nbndlw,ncol,nlay)
2119 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2120 ! Dimensions: (ncol,nlay)
2121 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2122 ! Dimensions: (ncol,nlay)
2123 real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size
2124 ! Dimensions: (ncol,nlay)
2125 real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size
2126 ! Dimensions: (ncol,nlay)
2128 ! ----- Output -----
2129 ! Atmosphere/clouds - cldprmc [mcica]
2130 real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
2131 ! Dimensions: (ngptlw,ncol,nlay)
2132 real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
2133 ! Dimensions: (ngptlw,ncol,nlay)
2134 real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
2135 ! Dimensions: (ngptlw,ncol,nlay)
2136 real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns)
2137 ! Dimensions: (ncol,nlay)
2138 real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns)
2139 ! Dimensions: (ncol,nlay)
2140 real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
2141 ! Dimensions: (ngptlw,ncol,nlay)
2142 ! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica]
2143 ! Dimensions: (ngptlw,ncol,nlay)
2144 ! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica]
2145 ! Dimensions: (ngptlw,ncol,nlay)
2147 ! ----- Local -----
2149 ! Stochastic cloud generator variables [mcica]
2150 integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals)
2151 integer(kind=im) :: ilev ! loop index
2153 real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa)
2154 ! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa)
2155 ! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity)
2156 ! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity)
2159 ! Return if clear sky; or stop if icld out of range
2160 if (icld.eq.0) return
2161 if (icld.lt.0.or.icld.gt.3) then
2162 stop 'MCICA_SUBCOL: INVALID ICLD'
2163 endif
2165 ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns
2168 ! Pass particle sizes to new arrays, no subcolumns for these properties yet
2169 ! Convert pressures from mb to Pa
2171 reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
2172 relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
2173 pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
2175 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components
2177 ! cwp = (q * pdel * 1000.) / gravit)
2178 ! = (kg/kg * kg m-1 s-2 *1000.) / m s-2
2179 ! = (g m-2)
2180 !
2181 ! q = (cwp * gravit) / (pdel *1000.)
2182 ! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
2183 ! = kg/kg
2185 ! do ilev = 1, nlay
2186 ! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2187 ! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
2188 ! enddo
2190 ! Generate the stochastic subcolumns of cloud optical properties for the longwave;
2191 call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, tauc, &
2192 cldfmcl, clwpmcl, ciwpmcl, taucmcl, permuteseed)
2194 end subroutine mcica_subcol_lw
2197 !-------------------------------------------------------------------------------------------------
2198 subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, tauc, &
2199 cld_stoch, clwp_stoch, ciwp_stoch, tauc_stoch, changeSeed)
2200 !-------------------------------------------------------------------------------------------------
2202 !----------------------------------------------------------------------------------------------------------------
2203 ! ---------------------
2204 ! Contact: Cecile Hannay (hannay@ucar.edu)
2205 !
2206 ! Original code: Based on Raisanen et al., QJRMS, 2004.
2207 !
2208 ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
2209 ! random number generator, which can be changed to the optional kissvec random number generator
2210 ! with flag 'irng'. Some extra functionality has been commented or removed.
2211 ! Michael J. Iacono, AER, Inc., February 2007
2212 !
2213 ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
2214 ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
2215 ! and uniform cloud liquid and cloud ice concentration.
2216 ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
2217 ! and obeys an overlap assumption in the vertical.
2218 !
2219 ! Overlap assumption:
2220 ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
2221 ! The default option is maximum-random (option 3)
2222 ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
2223 ! This is set with the variable "overlap"
2224 !mji - Exponential overlap option (overlap=4) has been deactivated in this version
2225 ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
2226 !
2227 ! Seed:
2228 ! If the stochastic cloud generator is called several times during the same timestep,
2229 ! one should change the seed between the call to insure that the subcolumns are different.
2230 ! This is done by changing the argument 'changeSeed'
2231 ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
2232 ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
2233 !
2234 ! PDF assumption:
2235 ! We can use arbitrary complicated PDFS.
2236 ! In the present version, we produce homogeneuous clouds (the simplest case).
2237 ! Future developments include using the PDF scheme of Ben Johnson.
2238 !
2239 ! History file:
2240 ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
2241 ! nsubcol = number of subcolumns
2242 ! overlap = overlap type (1-3)
2243 ! Zo = length scale
2244 ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
2245 ! CLDLIQ_S = mean of the subcolumn cloud water
2246 ! CLDICE_S = mean of the subcolumn cloud ice
2247 !
2248 ! Note:
2249 ! Here: we force that the cloud condensate to be consistent with the cloud fraction
2250 ! i.e we only have cloud condensate when the cell is cloudy.
2251 ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
2252 ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
2253 ! without cloud condensate or the opposite).
2254 !---------------------------------------------------------------------------------------------------------------
2256 use mcica_random_numbers
2257 ! The Mersenne Twister random number engine
2258 use MersenneTwister, only: randomNumberSequence, &
2259 new_RandomNumberSequence, getRandomReal
2261 type(randomNumberSequence) :: randomNumbers
2263 ! -- Arguments
2265 integer(kind=im), intent(in) :: ncol ! number of columns
2266 integer(kind=im), intent(in) :: nlay ! number of layers
2267 integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag
2268 integer(kind=im), intent(inout) :: irng ! flag for random number generator
2269 ! 0 = kissvec
2270 ! 1 = Mersenne Twister
2271 integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
2272 integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed
2274 ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
2275 real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa)
2276 ! Dimensions: (ncol,nlay)
2277 real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction
2278 ! Dimensions: (ncol,nlay)
2279 real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path
2280 ! Dimensions: (ncol,nlay)
2281 real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path
2282 ! Dimensions: (ncol,nlay)
2283 real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth
2284 ! Dimensions: (nbndlw,ncol,nlay)
2285 ! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
2286 ! Dimensions: (nbndlw,ncol,nlay)
2287 ! inactive - for future expansion
2288 ! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
2289 ! Dimensions: (nbndlw,ncol,nlay)
2290 ! inactive - for future expansion
2292 real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
2293 ! Dimensions: (ngptlw,ncol,nlay)
2294 real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
2295 ! Dimensions: (ngptlw,ncol,nlay)
2296 real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
2297 ! Dimensions: (ngptlw,ncol,nlay)
2298 real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
2299 ! Dimensions: (ngptlw,ncol,nlay)
2300 ! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
2301 ! Dimensions: (ngptlw,ncol,nlay)
2302 ! inactive - for future expansion
2303 ! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter
2304 ! Dimensions: (ngptlw,ncol,nlay)
2305 ! inactive - for future expansion
2307 ! -- Local variables
2308 real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction
2310 ! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
2311 ! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction
2312 ! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water
2313 ! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice
2314 ! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth
2315 ! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo
2316 ! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter
2318 ! Set overlap
2319 integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum/random,
2320 ! 3 = maximum overlap,
2321 ! real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m)
2322 ! real(kind=rb) :: zm(ncol,nlay) ! Height of midpoints (above surface)
2323 ! real(kind=rb), dimension(nlay) :: alpha=0.0_rb ! overlap parameter
2325 ! Constants (min value for cloud fraction and cloud water and ice)
2326 real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
2327 ! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used)
2329 ! Variables related to random number and seed
2330 real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers
2331 integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
2332 real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec)
2333 integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister)
2334 real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister)
2336 ! Flag to identify cloud fraction in subcolumns
2337 logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy
2339 ! Indices
2340 integer(kind=im) :: ilev, isubcol, i, n ! indices
2342 !------------------------------------------------------------------------------------------
2344 ! Check that irng is in bounds; if not, set to default
2345 if (irng .ne. 0) irng = 1
2347 ! Pass input cloud overlap setting to local variable
2348 overlap = icld
2350 ! Ensure that cloud fractions are in bounds
2351 do ilev = 1, nlay
2352 do i = 1, ncol
2353 cldf(i,ilev) = cld(i,ilev)
2354 if (cldf(i,ilev) < cldmin) then
2355 cldf(i,ilev) = 0._rb
2356 endif
2357 enddo
2358 enddo
2360 ! ----- Create seed --------
2362 ! Advance randum number generator by changeseed values
2363 if (irng.eq.0) then
2364 ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
2365 ! Must use pmid from bottom four layers.
2366 do i=1,ncol
2367 if (pmid(i,1).lt.pmid(i,2)) then
2368 stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
2369 endif
2370 seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im
2371 seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im
2372 seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im
2373 seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im
2374 enddo
2375 do i=1,changeSeed
2376 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2377 enddo
2378 elseif (irng.eq.1) then
2379 randomNumbers = new_RandomNumberSequence(seed = changeSeed)
2380 endif
2383 ! ------ Apply overlap assumption --------
2385 ! generate the random numbers
2387 select case (overlap)
2389 case(1)
2390 ! Random overlap
2391 ! i) pick a random value at every level
2393 if (irng.eq.0) then
2394 do isubcol = 1,nsubcol
2395 do ilev = 1,nlay
2396 call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level
2397 CDF(isubcol,:,ilev) = rand_num
2398 enddo
2399 enddo
2400 elseif (irng.eq.1) then
2401 do isubcol = 1, nsubcol
2402 do i = 1, ncol
2403 do ilev = 1, nlay
2404 rand_num_mt = getRandomReal(randomNumbers)
2405 CDF(isubcol,i,ilev) = rand_num_mt
2406 enddo
2407 enddo
2408 enddo
2409 endif
2411 case(2)
2412 ! Maximum-Random overlap
2413 ! i) pick a random number for top layer.
2414 ! ii) walk down the column:
2415 ! - if the layer above is cloudy, we use the same random number than in the layer above
2416 ! - if the layer above is clear, we use a new random number
2418 if (irng.eq.0) then
2419 do isubcol = 1,nsubcol
2420 do ilev = 1,nlay
2421 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2422 CDF(isubcol,:,ilev) = rand_num
2423 enddo
2424 enddo
2425 elseif (irng.eq.1) then
2426 do isubcol = 1, nsubcol
2427 do i = 1, ncol
2428 do ilev = 1, nlay
2429 rand_num_mt = getRandomReal(randomNumbers)
2430 CDF(isubcol,i,ilev) = rand_num_mt
2431 enddo
2432 enddo
2433 enddo
2434 endif
2436 do ilev = 2,nlay
2437 do i = 1, ncol
2438 do isubcol = 1, nsubcol
2439 if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
2440 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1)
2441 else
2442 CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1))
2443 endif
2444 enddo
2445 enddo
2446 enddo
2448 case(3)
2449 ! Maximum overlap
2450 ! i) pick the same random numebr at every level
2452 if (irng.eq.0) then
2453 do isubcol = 1,nsubcol
2454 call kissvec(seed1, seed2, seed3, seed4, rand_num)
2455 do ilev = 1,nlay
2456 CDF(isubcol,:,ilev) = rand_num
2457 enddo
2458 enddo
2459 elseif (irng.eq.1) then
2460 do isubcol = 1, nsubcol
2461 do i = 1, ncol
2462 rand_num_mt = getRandomReal(randomNumbers)
2463 do ilev = 1, nlay
2464 CDF(isubcol,i,ilev) = rand_num_mt
2465 enddo
2466 enddo
2467 enddo
2468 endif
2470 ! case(4) - inactive
2471 ! ! Exponential overlap: weighting between maximum and random overlap increases with the distance.
2472 ! ! The random numbers for exponential overlap verify:
2473 ! ! j=1 RAN(j)=RND1
2474 ! ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
2475 ! ! RAN(j) = RND2
2476 ! ! alpha is obtained from the equation
2477 ! ! alpha = exp(- (Zi-Zj-1)/Zo) where Zo is a characteristic length scale
2480 ! ! compute alpha
2481 ! zm = state%zm
2482 ! alpha(:, 1) = 0.
2483 ! do ilev = 2,nlay
2484 ! alpha(:, ilev) = exp( -( zm (:, ilev-1) - zm (:, ilev)) / Zo)
2485 ! end do
2487 ! ! generate 2 streams of random numbers
2488 ! do isubcol = 1,nsubcol
2489 ! do ilev = 1,nlay
2490 ! call kissvec(seed1, seed2, seed3, seed4, rand_num)
2491 ! CDF(isubcol, :, ilev) = rand_num
2492 ! call kissvec(seed1, seed2, seed3, seed4, rand_num)
2493 ! CDF2(isubcol, :, ilev) = rand_num
2494 ! end do
2495 ! end do
2497 ! ! generate random numbers
2498 ! do ilev = 2,nlay
2499 ! where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
2500 ! CDF(:,:,ilev) = CDF(:,:,ilev-1)
2501 ! end where
2502 ! end do
2504 end select
2507 ! -- generate subcolumns for homogeneous clouds -----
2508 do ilev = 1,nlay
2509 iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
2510 enddo
2512 ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
2513 ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
2514 ! where there is a cloud, define the subcolumn cloud properties,
2515 ! otherwise set these to zero
2517 do ilev = 1,nlay
2518 do i = 1, ncol
2519 do isubcol = 1, nsubcol
2520 if (iscloudy(isubcol,i,ilev) ) then
2521 cld_stoch(isubcol,i,ilev) = 1._rb
2522 clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
2523 ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
2524 n = ngb(isubcol)
2525 tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
2526 ! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
2527 ! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
2528 else
2529 cld_stoch(isubcol,i,ilev) = 0._rb
2530 clwp_stoch(isubcol,i,ilev) = 0._rb
2531 ciwp_stoch(isubcol,i,ilev) = 0._rb
2532 tauc_stoch(isubcol,i,ilev) = 0._rb
2533 ! ssac_stoch(isubcol,i,ilev) = 1._rb
2534 ! asmc_stoch(isubcol,i,ilev) = 1._rb
2535 endif
2536 enddo
2537 enddo
2538 enddo
2540 ! -- compute the means of the subcolumns ---
2541 ! mean_cld_stoch(:,:) = 0._rb
2542 ! mean_clwp_stoch(:,:) = 0._rb
2543 ! mean_ciwp_stoch(:,:) = 0._rb
2544 ! mean_tauc_stoch(:,:) = 0._rb
2545 ! mean_ssac_stoch(:,:) = 0._rb
2546 ! mean_asmc_stoch(:,:) = 0._rb
2547 ! do i = 1, nsubcol
2548 ! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:)
2549 ! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:)
2550 ! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:)
2551 ! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:)
2552 ! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:)
2553 ! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:)
2554 ! end do
2555 ! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
2556 ! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
2557 ! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
2558 ! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
2559 ! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
2560 ! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
2562 end subroutine generate_stochastic_clouds
2565 !------------------------------------------------------------------
2566 ! Private subroutines
2567 !------------------------------------------------------------------
2569 !--------------------------------------------------------------------------------------------------
2570 subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
2571 !--------------------------------------------------------------------------------------------------
2573 ! public domain code
2574 ! made available from http://www.fortran.com/
2575 ! downloaded by pjr on 03/16/04 for NCAR CAM
2576 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
2578 ! The KISS (Keep It Simple Stupid) random number generator. Combines:
2579 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
2580 ! (2) A 3-shift shift-register generator, period 2^32-1,
2581 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
2582 ! Overall period>2^123;
2583 !
2584 real(kind=rb), dimension(:), intent(inout) :: ran_arr
2585 integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
2586 integer(kind=im) :: i,sz,kiss
2587 integer(kind=im) :: m, k, n
2589 ! inline function
2590 m(k, n) = ieor (k, ishft (k, n) )
2592 sz = size(ran_arr)
2593 do i = 1, sz
2594 seed1(i) = 69069_im * seed1(i) + 1327217885_im
2595 seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
2596 seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
2597 seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
2598 kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
2599 ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
2600 end do
2602 end subroutine kissvec
2604 end module mcica_subcol_gen_lw
2606 ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_cldprmc.f90,v $
2607 ! author: $Author: mike $
2608 ! revision: $Revision: 1.8 $
2609 ! created: $Date: 2009/05/22 21:04:30 $
2610 !
2611 module rrtmg_lw_cldprmc
2613 ! --------------------------------------------------------------------------
2614 ! | |
2615 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
2616 ! | This software may be used, copied, or redistributed as long as it is |
2617 ! | not sold and this copyright notice is reproduced on each copy made. |
2618 ! | This model is provided as is without any express or implied warranties. |
2619 ! | (http://www.rtweb.aer.com/) |
2620 ! | |
2621 ! --------------------------------------------------------------------------
2623 ! --------- Modules ----------
2625 use parkind, only : im => kind_im, rb => kind_rb
2626 use parrrtm, only : ngptlw, nbndlw
2627 use rrlw_cld, only: abscld1, absliq0, absliq1, &
2628 absice0, absice1, absice2, absice3
2629 use rrlw_wvn, only: ngb
2630 use rrlw_vsn, only: hvrclc, hnamclc
2632 implicit none
2634 contains
2636 ! ------------------------------------------------------------------------------
2637 subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
2638 ciwpmc, clwpmc, reicmc, relqmc, ncbands, taucmc)
2639 ! ------------------------------------------------------------------------------
2641 ! Purpose: Compute the cloud optical depth(s) for each cloudy layer.
2643 ! ------- Input -------
2645 integer(kind=im), intent(in) :: nlayers ! total number of layers
2646 integer(kind=im), intent(in) :: inflag ! see definitions
2647 integer(kind=im), intent(in) :: iceflag ! see definitions
2648 integer(kind=im), intent(in) :: liqflag ! see definitions
2650 real(kind=rb), intent(in) :: cldfmc(:,:) ! cloud fraction [mcica]
2651 ! Dimensions: (ngptlw,nlayers)
2652 real(kind=rb), intent(in) :: ciwpmc(:,:) ! cloud ice water path [mcica]
2653 ! Dimensions: (ngptlw,nlayers)
2654 real(kind=rb), intent(in) :: clwpmc(:,:) ! cloud liquid water path [mcica]
2655 ! Dimensions: (ngptlw,nlayers)
2656 real(kind=rb), intent(in) :: relqmc(:) ! liquid particle effective radius (microns)
2657 ! Dimensions: (nlayers)
2658 real(kind=rb), intent(in) :: reicmc(:) ! ice particle effective radius (microns)
2659 ! Dimensions: (nlayers)
2660 ! specific definition of reicmc depends on setting of iceflag:
2661 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
2662 ! r_ec must be >= 10.0 microns
2663 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
2664 ! r_ec range is limited to 13.0 to 130.0 microns
2665 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
2666 ! r_k range is limited to 5.0 to 131.0 microns
2667 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
2668 ! dge range is limited to 5.0 to 140.0 microns
2669 ! [dge = 1.0315 * r_ec]
2671 ! ------- Output -------
2673 integer(kind=im), intent(out) :: ncbands ! number of cloud spectral bands
2674 real(kind=rb), intent(inout) :: taucmc(:,:) ! cloud optical depth [mcica]
2675 ! Dimensions: (ngptlw,nlayers)
2677 ! ------- Local -------
2679 integer(kind=im) :: lay ! Layer index
2680 integer(kind=im) :: ib ! spectral band index
2681 integer(kind=im) :: ig ! g-point interval index
2682 integer(kind=im) :: index
2683 integer(kind=im) :: icb(nbndlw)
2685 real(kind=rb) :: abscoice(ngptlw) ! ice absorption coefficients
2686 real(kind=rb) :: abscoliq(ngptlw) ! liquid absorption coefficients
2687 real(kind=rb) :: cwp ! cloud water path
2688 real(kind=rb) :: radice ! cloud ice effective size (microns)
2689 real(kind=rb) :: factor !
2690 real(kind=rb) :: fint !
2691 real(kind=rb) :: radliq ! cloud liquid droplet radius (microns)
2692 real(kind=rb), parameter :: eps = 1.e-6_rb ! epsilon
2693 real(kind=rb), parameter :: cldmin = 1.e-20_rb ! minimum value for cloud quantities
2695 ! ------- Definitions -------
2697 ! Explanation of the method for each value of INFLAG. Values of
2698 ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds.
2699 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
2700 ! requires further user input to specify the method to be used to
2701 ! compute the aborption due to each.
2702 ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray)
2703 ! optical depth are input.
2704 ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud
2705 ! water path (g/m2) are input. The (gray) cloud optical
2706 ! depth is computed as in CCM2.
2707 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
2708 ! water path (g/m2), and cloud ice fraction are input.
2709 ! ICEFLAG = 0: The ice effective radius (microns) is input and the
2710 ! optical depths due to ice clouds are computed as in CCM3.
2711 ! ICEFLAG = 1: The ice effective radius (microns) is input and the
2712 ! optical depths due to ice clouds are computed as in
2713 ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The
2714 ! spectral regions in this work have been matched with
2715 ! the spectral bands in RRTM to as great an extent
2716 ! as possible:
2717 ! E&C 1 IB = 5 RRTM bands 9-16
2718 ! E&C 2 IB = 4 RRTM bands 6-8
2719 ! E&C 3 IB = 3 RRTM bands 3-5
2720 ! E&C 4 IB = 2 RRTM band 2
2721 ! E&C 5 IB = 1 RRTM band 1
2722 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
2723 ! optical properties due to ice clouds are computed from
2724 ! the optical properties stored in the RT code,
2725 ! STREAMER v3.0 (Reference: Key. J., Streamer
2726 ! User's Guide, Cooperative Institute for
2727 ! Meteorological Satellite Studies, 2001, 96 pp.).
2728 ! Valid range of values for re are between 5.0 and
2729 ! 131.0 micron.
2730 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
2731 ! and the optical properties, are calculated as in
2732 ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
2733 ! tables which were appropriately averaged for the
2734 ! bands in RRTM_LW. Linear interpolation is used to
2735 ! get the coefficients from the stored tables.
2736 ! Valid range of values for dge are between 5.0 and
2737 ! 140.0 micron.
2738 ! LIQFLAG = 0: The optical depths due to water clouds are computed as
2739 ! in CCM3.
2740 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
2741 ! and the optical depths due to water clouds are computed
2742 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
2743 ! The values for absorption coefficients appropriate for
2744 ! the spectral bands in RRTM have been obtained for a
2745 ! range of effective radii by an averaging procedure
2746 ! based on the work of J. Pinto (private communication).
2747 ! Linear interpolation is used to get the absorption
2748 ! coefficients for the input effective radius.
2750 data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/
2752 hvrclc = '$Revision: 1.8 $'
2754 ncbands = 1
2756 ! This initialization is done in rrtmg_lw_subcol.F90.
2757 ! do lay = 1, nlayers
2758 ! do ig = 1, ngptlw
2759 ! taucmc(ig,lay) = 0.0_rb
2760 ! enddo
2761 ! enddo
2763 ! Main layer loop
2764 do lay = 1, nlayers
2766 do ig = 1, ngptlw
2767 cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2768 if (cldfmc(ig,lay) .ge. cldmin .and. &
2769 (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
2771 ! Ice clouds and water clouds combined.
2772 if (inflag .eq. 0) then
2773 ! Cloud optical depth already defined in taucmc, return to main program
2774 return
2776 elseif(inflag .eq. 1) then
2777 stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
2778 ! cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2779 ! taucmc(ig,lay) = abscld1 * cwp
2781 ! Separate treatement of ice clouds and water clouds.
2782 elseif(inflag .eq. 2) then
2783 radice = reicmc(lay)
2785 ! Calculation of absorption coefficients due to ice clouds.
2786 if (ciwpmc(ig,lay) .eq. 0.0_rb) then
2787 abscoice(ig) = 0.0_rb
2789 elseif (iceflag .eq. 0) then
2790 if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL'
2791 abscoice(ig) = absice0(1) + absice0(2)/radice
2793 elseif (iceflag .eq. 1) then
2794 if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
2795 'ICE RADIUS OUT OF BOUNDS'
2796 ncbands = 5
2797 ib = icb(ngb(ig))
2798 abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
2800 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
2802 elseif (iceflag .eq. 2) then
2803 if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
2804 ncbands = 16
2805 factor = (radice - 2._rb)/3._rb
2806 index = int(factor)
2807 if (index .eq. 43) index = 42
2808 fint = factor - float(index)
2809 ib = ngb(ig)
2810 abscoice(ig) = &
2811 absice2(index,ib) + fint * &
2812 (absice2(index+1,ib) - (absice2(index,ib)))
2814 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
2816 elseif (iceflag .eq. 3) then
2817 if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
2818 ncbands = 16
2819 factor = (radice - 2._rb)/3._rb
2820 index = int(factor)
2821 if (index .eq. 46) index = 45
2822 fint = factor - float(index)
2823 ib = ngb(ig)
2824 abscoice(ig) = &
2825 absice3(index,ib) + fint * &
2826 (absice3(index+1,ib) - (absice3(index,ib)))
2828 endif
2830 ! Calculation of absorption coefficients due to water clouds.
2831 if (clwpmc(ig,lay) .eq. 0.0_rb) then
2832 abscoliq(ig) = 0.0_rb
2834 elseif (liqflag .eq. 0) then
2835 abscoliq(ig) = absliq0
2837 elseif (liqflag .eq. 1) then
2838 radliq = relqmc(lay)
2839 if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop &
2840 'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
2841 index = int(radliq - 1.5_rb)
2842 if (index .eq. 0) index = 1
2843 if (index .eq. 58) index = 57
2844 fint = radliq - 1.5_rb - float(index)
2845 ib = ngb(ig)
2846 abscoliq(ig) = &
2847 absliq1(index,ib) + fint * &
2848 (absliq1(index+1,ib) - (absliq1(index,ib)))
2849 endif
2851 taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + &
2852 clwpmc(ig,lay) * abscoliq(ig)
2854 endif
2855 endif
2856 enddo
2857 enddo
2859 end subroutine cldprmc
2861 end module rrtmg_lw_cldprmc
2863 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
2864 ! author: $Author: trn $
2865 ! revision: $Revision: 1.3 $
2866 ! created: $Date: 2009/04/16 19:54:22 $
2867 !
2868 module rrtmg_lw_rtrnmc
2870 ! --------------------------------------------------------------------------
2871 ! | |
2872 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
2873 ! | This software may be used, copied, or redistributed as long as it is |
2874 ! | not sold and this copyright notice is reproduced on each copy made. |
2875 ! | This model is provided as is without any express or implied warranties. |
2876 ! | (http://www.rtweb.aer.com/) |
2877 ! | |
2878 ! --------------------------------------------------------------------------
2880 ! --------- Modules ----------
2882 use parkind, only : im => kind_im, rb => kind_rb
2883 use parrrtm, only : mg, nbndlw, ngptlw
2884 use rrlw_con, only: fluxfac, heatfac
2885 use rrlw_wvn, only: delwave, ngb, ngs
2886 use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
2887 use rrlw_vsn, only: hvrrtc, hnamrtc
2889 implicit none
2891 real(kind=rb) :: wtdiff, rec_6
2892 real(kind=rb) :: a0(nbndlw),a1(nbndlw),a2(nbndlw)! diffusivity angle adjustment coefficients
2894 ! This secant and weight corresponds to the standard diffusivity
2895 ! angle. This initial value is redefined below for some bands.
2896 data wtdiff /0.5_rb/
2897 data rec_6 /0.166667_rb/
2899 ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
2900 ! and 1.80) as a function of total column water vapor. The function
2901 ! has been defined to minimize flux and cooling rate errors in these bands
2902 ! over a wide range of precipitable water values.
2903 data a0 / 1.66_rb, 1.55_rb, 1.58_rb, 1.66_rb, &
2904 1.54_rb, 1.454_rb, 1.89_rb, 1.33_rb, &
2905 1.668_rb, 1.66_rb, 1.66_rb, 1.66_rb, &
2906 1.66_rb, 1.66_rb, 1.66_rb, 1.66_rb /
2907 data a1 / 0.00_rb, 0.25_rb, 0.22_rb, 0.00_rb, &
2908 0.13_rb, 0.446_rb, -0.10_rb, 0.40_rb, &
2909 -0.006_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
2910 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
2911 data a2 / 0.00_rb, -12.0_rb, -11.7_rb, 0.00_rb, &
2912 -0.72_rb,-0.243_rb, 0.19_rb,-0.062_rb, &
2913 0.414_rb, 0.00_rb, 0.00_rb, 0.00_rb, &
2914 0.00_rb, 0.00_rb, 0.00_rb, 0.00_rb /
2916 contains
2918 !-----------------------------------------------------------------------------
2919 subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
2920 cldfmc, taucmc, planklay, planklev, plankbnd, &
2921 pwvcm, fracs, taut, &
2922 totuflux, totdflux, fnet, htr, &
2923 totuclfl, totdclfl, fnetc, htrc )
2924 !-----------------------------------------------------------------------------
2925 !
2926 ! Original version: E. J. Mlawer, et al. RRTM_V3.0
2927 ! Revision for GCMs: Michael J. Iacono; October, 2002
2928 ! Revision for F90: Michael J. Iacono; June, 2006
2929 !
2930 ! This program calculates the upward fluxes, downward fluxes, and
2931 ! heating rates for an arbitrary clear or cloudy atmosphere. The input
2932 ! to this program is the atmospheric profile, all Planck function
2933 ! information, and the cloud fraction by layer. A variable diffusivity
2934 ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9
2935 ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
2936 ! the column water vapor, and other bands use a value of 1.66. The Gaussian
2937 ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that
2938 ! use of the emissivity angle for the flux integration can cause errors of
2939 ! 1 to 4 W/m2 within cloudy layers.
2940 ! Clouds are treated with the McICA stochastic approach and maximum-random
2941 ! cloud overlap.
2942 !***************************************************************************
2944 ! ------- Declarations -------
2946 ! ----- Input -----
2947 integer(kind=im), intent(in) :: nlayers ! total number of layers
2948 integer(kind=im), intent(in) :: istart ! beginning band of calculation
2949 integer(kind=im), intent(in) :: iend ! ending band of calculation
2950 integer(kind=im), intent(in) :: iout ! output option flag
2952 ! Atmosphere
2953 real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb)
2954 ! Dimensions: (0:nlayers)
2955 real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm)
2956 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
2957 ! Dimensions: (nbndlw)
2958 real(kind=rb), intent(in) :: planklay(:,:) !
2959 ! Dimensions: (nlayers,nbndlw)
2960 real(kind=rb), intent(in) :: planklev(0:,:) !
2961 ! Dimensions: (0:nlayers,nbndlw)
2962 real(kind=rb), intent(in) :: plankbnd(:) !
2963 ! Dimensions: (nbndlw)
2964 real(kind=rb), intent(in) :: fracs(:,:) !
2965 ! Dimensions: (nlayers,ngptw)
2966 real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths
2967 ! Dimensions: (nlayers,ngptlw)
2969 ! Clouds
2970 integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands
2971 real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica]
2972 ! Dimensions: (ngptlw,nlayers)
2973 real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica]
2974 ! Dimensions: (ngptlw,nlayers)
2976 ! ----- Output -----
2977 real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2)
2978 ! Dimensions: (0:nlayers)
2979 real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2)
2980 ! Dimensions: (0:nlayers)
2981 real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2)
2982 ! Dimensions: (0:nlayers)
2983 real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day)
2984 ! Dimensions: (0:nlayers)
2985 real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2)
2986 ! Dimensions: (0:nlayers)
2987 real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2)
2988 ! Dimensions: (0:nlayers)
2989 real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2)
2990 ! Dimensions: (0:nlayers)
2991 real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day)
2992 ! Dimensions: (0:nlayers)
2994 ! ----- Local -----
2995 ! Declarations for radiative transfer
2996 real(kind=rb) :: abscld(nlayers,ngptlw)
2997 real(kind=rb) :: atot(nlayers)
2998 real(kind=rb) :: atrans(nlayers)
2999 real(kind=rb) :: bbugas(nlayers)
3000 real(kind=rb) :: bbutot(nlayers)
3001 real(kind=rb) :: clrurad(0:nlayers)
3002 real(kind=rb) :: clrdrad(0:nlayers)
3003 real(kind=rb) :: efclfrac(nlayers,ngptlw)
3004 real(kind=rb) :: uflux(0:nlayers)
3005 real(kind=rb) :: dflux(0:nlayers)
3006 real(kind=rb) :: urad(0:nlayers)
3007 real(kind=rb) :: drad(0:nlayers)
3008 real(kind=rb) :: uclfl(0:nlayers)
3009 real(kind=rb) :: dclfl(0:nlayers)
3010 real(kind=rb) :: odcld(nlayers,ngptlw)
3013 real(kind=rb) :: secdiff(nbndlw) ! secant of diffusivity angle
3014 real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
3015 real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
3016 real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
3017 real(kind=rb) :: rad0, reflect, radlu, radclru
3019 integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer
3020 integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices
3021 integer(kind=im) :: igc ! g-point interval counter
3022 integer(kind=im) :: iclddn ! flag for cloud in down path
3023 integer(kind=im) :: ittot, itgas, itr ! lookup table indices
3025 ! ------- Definitions -------
3026 ! input
3027 ! nlayers ! number of model layers
3028 ! ngptlw ! total number of g-point subintervals
3029 ! nbndlw ! number of longwave spectral bands
3030 ! ncbands ! number of spectral bands for clouds
3031 ! secdiff ! diffusivity angle
3032 ! wtdiff ! weight for radiance to flux conversion
3033 ! pavel ! layer pressures (mb)
3034 ! pz ! level (interface) pressures (mb)
3035 ! tavel ! layer temperatures (k)
3036 ! tz ! level (interface) temperatures(mb)
3037 ! tbound ! surface temperature (k)
3038 ! cldfrac ! layer cloud fraction
3039 ! taucloud ! layer cloud optical depth
3040 ! itr ! integer look-up table index
3041 ! icldlyr ! flag for cloudy layers
3042 ! iclddn ! flag for cloud in column at any layer
3043 ! semiss ! surface emissivities for each band
3044 ! reflect ! surface reflectance
3045 ! bpade ! 1/(pade constant)
3046 ! tau_tbl ! clear sky optical depth look-up table
3047 ! exp_tbl ! exponential look-up table for transmittance
3048 ! tfn_tbl ! tau transition function look-up table
3050 ! local
3051 ! atrans ! gaseous absorptivity
3052 ! abscld ! cloud absorptivity
3053 ! atot ! combined gaseous and cloud absorptivity
3054 ! odclr ! clear sky (gaseous) optical depth
3055 ! odcld ! cloud optical depth
3056 ! odtot ! optical depth of gas and cloud
3057 ! tfacgas ! gas-only pade factor, used for planck fn
3058 ! tfactot ! gas and cloud pade factor, used for planck fn
3059 ! bbdgas ! gas-only planck function for downward rt
3060 ! bbugas ! gas-only planck function for upward rt
3061 ! bbdtot ! gas and cloud planck function for downward rt
3062 ! bbutot ! gas and cloud planck function for upward calc.
3063 ! gassrc ! source radiance due to gas only
3064 ! efclfrac ! effective cloud fraction
3065 ! radlu ! spectrally summed upward radiance
3066 ! radclru ! spectrally summed clear sky upward radiance
3067 ! urad ! upward radiance by layer
3068 ! clrurad ! clear sky upward radiance by layer
3069 ! radld ! spectrally summed downward radiance
3070 ! radclrd ! spectrally summed clear sky downward radiance
3071 ! drad ! downward radiance by layer
3072 ! clrdrad ! clear sky downward radiance by layer
3074 ! output
3075 ! totuflux ! upward longwave flux (w/m2)
3076 ! totdflux ! downward longwave flux (w/m2)
3077 ! fnet ! net longwave flux (w/m2)
3078 ! htr ! longwave heating rate (k/day)
3079 ! totuclfl ! clear sky upward longwave flux (w/m2)
3080 ! totdclfl ! clear sky downward longwave flux (w/m2)
3081 ! fnetc ! clear sky net longwave flux (w/m2)
3082 ! htrc ! clear sky longwave heating rate (k/day)
3085 hvrrtc = '$Revision: 1.3 $'
3087 do ibnd = 1,nbndlw
3088 if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
3089 secdiff(ibnd) = 1.66_rb
3090 else
3091 secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm)
3092 if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb
3093 if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb
3094 endif
3095 enddo
3097 urad(0) = 0.0_rb
3098 drad(0) = 0.0_rb
3099 totuflux(0) = 0.0_rb
3100 totdflux(0) = 0.0_rb
3101 clrurad(0) = 0.0_rb
3102 clrdrad(0) = 0.0_rb
3103 totuclfl(0) = 0.0_rb
3104 totdclfl(0) = 0.0_rb
3106 do lay = 1, nlayers
3107 urad(lay) = 0.0_rb
3108 drad(lay) = 0.0_rb
3109 totuflux(lay) = 0.0_rb
3110 totdflux(lay) = 0.0_rb
3111 clrurad(lay) = 0.0_rb
3112 clrdrad(lay) = 0.0_rb
3113 totuclfl(lay) = 0.0_rb
3114 totdclfl(lay) = 0.0_rb
3115 icldlyr(lay) = 0
3117 ! Change to band loop?
3118 do ig = 1, ngptlw
3119 if (cldfmc(ig,lay) .eq. 1._rb) then
3120 ib = ngb(ig)
3121 odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay)
3122 transcld = exp(-odcld(lay,ig))
3123 abscld(lay,ig) = 1._rb - transcld
3124 efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay)
3125 icldlyr(lay) = 1
3126 else
3127 odcld(lay,ig) = 0.0_rb
3128 abscld(lay,ig) = 0.0_rb
3129 efclfrac(lay,ig) = 0.0_rb
3130 endif
3131 enddo
3133 enddo
3135 igc = 1
3136 ! Loop over frequency bands.
3137 do iband = istart, iend
3139 ! Reinitialize g-point counter for each band if output for each band is requested.
3140 if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1
3142 ! Loop over g-channels.
3143 1000 continue
3145 ! Radiative transfer starts here.
3146 radld = 0._rb
3147 radclrd = 0._rb
3148 iclddn = 0
3150 ! Downward radiative transfer loop.
3152 do lev = nlayers, 1, -1
3153 plfrac = fracs(lev,igc)
3154 blay = planklay(lev,iband)
3155 dplankup = planklev(lev,iband) - blay
3156 dplankdn = planklev(lev-1,iband) - blay
3157 odepth = secdiff(iband) * taut(lev,igc)
3158 if (odepth .lt. 0.0_rb) odepth = 0.0_rb
3159 ! Cloudy layer
3160 if (icldlyr(lev).eq.1) then
3161 iclddn = 1
3162 odtot = odepth + odcld(lev,igc)
3163 if (odtot .lt. 0.06_rb) then
3164 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3165 odepth_rec = rec_6*odepth
3166 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3168 atot(lev) = odtot - 0.5_rb*odtot*odtot
3169 odtot_rec = rec_6*odtot
3170 bbdtot = plfrac * (blay+dplankdn*odtot_rec)
3171 bbd = plfrac*(blay+dplankdn*odepth_rec)
3172 radld = radld - radld * (atrans(lev) + &
3173 efclfrac(lev,igc) * (1. - atrans(lev))) + &
3174 gassrc + cldfmc(igc,lev) * &
3175 (bbdtot * atot(lev) - gassrc)
3176 drad(lev-1) = drad(lev-1) + radld
3178 bbugas(lev) = plfrac * (blay+dplankup*odepth_rec)
3179 bbutot(lev) = plfrac * (blay+dplankup*odtot_rec)
3181 elseif (odepth .le. 0.06_rb) then
3182 atrans(lev) = odepth - 0.5_rb*odepth*odepth
3183 odepth_rec = rec_6*odepth
3184 gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3186 odtot = odepth + odcld(lev,igc)
3187 tblind = odtot/(bpade+odtot)
3188 ittot = tblint*tblind + 0.5_rb
3189 tfactot = tfn_tbl(ittot)
3190 bbdtot = plfrac * (blay + tfactot*dplankdn)
3191 bbd = plfrac*(blay+dplankdn*odepth_rec)
3192 atot(lev) = 1. - exp_tbl(ittot)
3194 radld = radld - radld * (atrans(lev) + &
3195 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3196 gassrc + cldfmc(igc,lev) * &
3197 (bbdtot * atot(lev) - gassrc)
3198 drad(lev-1) = drad(lev-1) + radld
3200 bbugas(lev) = plfrac * (blay + dplankup*odepth_rec)
3201 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3203 else
3205 tblind = odepth/(bpade+odepth)
3206 itgas = tblint*tblind+0.5_rb
3207 odepth = tau_tbl(itgas)
3208 atrans(lev) = 1._rb - exp_tbl(itgas)
3209 tfacgas = tfn_tbl(itgas)
3210 gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
3212 odtot = odepth + odcld(lev,igc)
3213 tblind = odtot/(bpade+odtot)
3214 ittot = tblint*tblind + 0.5_rb
3215 tfactot = tfn_tbl(ittot)
3216 bbdtot = plfrac * (blay + tfactot*dplankdn)
3217 bbd = plfrac*(blay+tfacgas*dplankdn)
3218 atot(lev) = 1._rb - exp_tbl(ittot)
3220 radld = radld - radld * (atrans(lev) + &
3221 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3222 gassrc + cldfmc(igc,lev) * &
3223 (bbdtot * atot(lev) - gassrc)
3224 drad(lev-1) = drad(lev-1) + radld
3225 bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
3226 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
3227 endif
3228 ! Clear layer
3229 else
3230 if (odepth .le. 0.06_rb) then
3231 atrans(lev) = odepth-0.5_rb*odepth*odepth
3232 odepth = rec_6*odepth
3233 bbd = plfrac*(blay+dplankdn*odepth)
3234 bbugas(lev) = plfrac*(blay+dplankup*odepth)
3235 else
3236 tblind = odepth/(bpade+odepth)
3237 itr = tblint*tblind+0.5_rb
3238 transc = exp_tbl(itr)
3239 atrans(lev) = 1._rb-transc
3240 tausfac = tfn_tbl(itr)
3241 bbd = plfrac*(blay+tausfac*dplankdn)
3242 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
3243 endif
3244 radld = radld + (bbd-radld)*atrans(lev)
3245 drad(lev-1) = drad(lev-1) + radld
3246 endif
3247 ! Set clear sky stream to total sky stream as long as layers
3248 ! remain clear. Streams diverge when a cloud is reached (iclddn=1),
3249 ! and clear sky stream must be computed separately from that point.
3250 if (iclddn.eq.1) then
3251 radclrd = radclrd + (bbd-radclrd) * atrans(lev)
3252 clrdrad(lev-1) = clrdrad(lev-1) + radclrd
3253 else
3254 radclrd = radld
3255 clrdrad(lev-1) = drad(lev-1)
3256 endif
3257 enddo
3259 ! Spectral emissivity & reflectance
3260 ! Include the contribution of spectrally varying longwave emissivity
3261 ! and reflection from the surface to the upward radiative transfer.
3262 ! Note: Spectral and Lambertian reflection are identical for the
3263 ! diffusivity angle flux integration used here.
3265 rad0 = fracs(1,igc) * plankbnd(iband)
3266 ! Add in specular reflection of surface downward radiance.
3267 reflect = 1._rb - semiss(iband)
3268 radlu = rad0 + reflect * radld
3269 radclru = rad0 + reflect * radclrd
3272 ! Upward radiative transfer loop.
3273 urad(0) = urad(0) + radlu
3274 clrurad(0) = clrurad(0) + radclru
3276 do lev = 1, nlayers
3277 ! Cloudy layer
3278 if (icldlyr(lev) .eq. 1) then
3279 gassrc = bbugas(lev) * atrans(lev)
3280 radlu = radlu - radlu * (atrans(lev) + &
3281 efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
3282 gassrc + cldfmc(igc,lev) * &
3283 (bbutot(lev) * atot(lev) - gassrc)
3284 urad(lev) = urad(lev) + radlu
3285 ! Clear layer
3286 else
3287 radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
3288 urad(lev) = urad(lev) + radlu
3289 endif
3290 ! Set clear sky stream to total sky stream as long as all layers
3291 ! are clear (iclddn=0). Streams must be calculated separately at
3292 ! all layers when a cloud is present (ICLDDN=1), because surface
3293 ! reflectance is different for each stream.
3294 if (iclddn.eq.1) then
3295 radclru = radclru + (bbugas(lev)-radclru)*atrans(lev)
3296 clrurad(lev) = clrurad(lev) + radclru
3297 else
3298 radclru = radlu
3299 clrurad(lev) = urad(lev)
3300 endif
3301 enddo
3303 ! Increment g-point counter
3304 igc = igc + 1
3305 ! Return to continue radiative transfer for all g-channels in present band
3306 if (igc .le. ngs(iband)) go to 1000
3308 ! Process longwave output from band for total and clear streams.
3309 ! Calculate upward, downward, and net flux.
3310 do lev = nlayers, 0, -1
3311 uflux(lev) = urad(lev)*wtdiff
3312 dflux(lev) = drad(lev)*wtdiff
3313 urad(lev) = 0.0_rb
3314 drad(lev) = 0.0_rb
3315 totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband)
3316 totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband)
3317 uclfl(lev) = clrurad(lev)*wtdiff
3318 dclfl(lev) = clrdrad(lev)*wtdiff
3319 clrurad(lev) = 0.0_rb
3320 clrdrad(lev) = 0.0_rb
3321 totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband)
3322 totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband)
3323 enddo
3325 ! End spectral band loop
3326 enddo
3328 ! Calculate fluxes at surface
3329 totuflux(0) = totuflux(0) * fluxfac
3330 totdflux(0) = totdflux(0) * fluxfac
3331 fnet(0) = totuflux(0) - totdflux(0)
3332 totuclfl(0) = totuclfl(0) * fluxfac
3333 totdclfl(0) = totdclfl(0) * fluxfac
3334 fnetc(0) = totuclfl(0) - totdclfl(0)
3336 ! Calculate fluxes at model levels
3337 do lev = 1, nlayers
3338 totuflux(lev) = totuflux(lev) * fluxfac
3339 totdflux(lev) = totdflux(lev) * fluxfac
3340 fnet(lev) = totuflux(lev) - totdflux(lev)
3341 totuclfl(lev) = totuclfl(lev) * fluxfac
3342 totdclfl(lev) = totdclfl(lev) * fluxfac
3343 fnetc(lev) = totuclfl(lev) - totdclfl(lev)
3344 l = lev - 1
3346 ! Calculate heating rates at model layers
3347 htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev))
3348 htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev))
3349 enddo
3351 ! Set heating rate to zero in top layer
3352 htr(nlayers) = 0.0_rb
3353 htrc(nlayers) = 0.0_rb
3355 end subroutine rtrnmc
3357 end module rrtmg_lw_rtrnmc
3359 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
3360 ! author: $Author: trn $
3361 ! revision: $Revision: 1.3 $
3362 ! created: $Date: 2009/04/16 19:54:22 $
3363 !
3364 module rrtmg_lw_setcoef
3366 ! --------------------------------------------------------------------------
3367 ! | |
3368 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
3369 ! | This software may be used, copied, or redistributed as long as it is |
3370 ! | not sold and this copyright notice is reproduced on each copy made. |
3371 ! | This model is provided as is without any express or implied warranties. |
3372 ! | (http://www.rtweb.aer.com/) |
3373 ! | |
3374 ! --------------------------------------------------------------------------
3376 ! ------- Modules -------
3378 use parkind, only : im => kind_im, rb => kind_rb
3379 use parrrtm, only : nbndlw, mg, maxxsec, mxmol
3380 use rrlw_wvn, only: totplnk, totplk16
3381 use rrlw_ref
3382 use rrlw_vsn, only: hvrset, hnamset
3384 implicit none
3386 contains
3388 !----------------------------------------------------------------------------
3389 subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
3390 coldry, wkl, wbroad, &
3391 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
3392 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
3393 colbrd, fac00, fac01, fac10, fac11, &
3394 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
3395 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
3396 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
3397 selffac, selffrac, indself, forfac, forfrac, indfor, &
3398 minorfrac, scaleminor, scaleminorn2, indminor)
3399 !----------------------------------------------------------------------------
3400 !
3401 ! Purpose: For a given atmosphere, calculate the indices and
3402 ! fractions related to the pressure and temperature interpolations.
3403 ! Also calculate the values of the integrated Planck functions
3404 ! for each band at the level and layer temperatures.
3406 ! ------- Declarations -------
3408 ! ----- Input -----
3409 integer(kind=im), intent(in) :: nlayers ! total number of layers
3410 integer(kind=im), intent(in) :: istart ! beginning band of calculation
3412 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
3413 ! Dimensions: (nlayers)
3414 real(kind=rb), intent(in) :: tavel(:) ! layer temperatures (K)
3415 ! Dimensions: (nlayers)
3416 real(kind=rb), intent(in) :: tz(0:) ! level (interface) temperatures (K)
3417 ! Dimensions: (0:nlayers)
3418 real(kind=rb), intent(in) :: tbound ! surface temperature (K)
3419 real(kind=rb), intent(in) :: coldry(:) ! dry air column density (mol/cm2)
3420 ! Dimensions: (nlayers)
3421 real(kind=rb), intent(in) :: wbroad(:) ! broadening gas column density (mol/cm2)
3422 ! Dimensions: (nlayers)
3423 real(kind=rb), intent(in) :: wkl(:,:) ! molecular amounts (mol/cm-2)
3424 ! Dimensions: (mxmol,nlayers)
3425 real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity
3426 ! Dimensions: (nbndlw)
3428 ! ----- Output -----
3429 integer(kind=im), intent(out) :: laytrop ! tropopause layer index
3430 integer(kind=im), intent(out) :: jp(:) !
3431 ! Dimensions: (nlayers)
3432 integer(kind=im), intent(out) :: jt(:) !
3433 ! Dimensions: (nlayers)
3434 integer(kind=im), intent(out) :: jt1(:) !
3435 ! Dimensions: (nlayers)
3436 real(kind=rb), intent(out) :: planklay(:,:) !
3437 ! Dimensions: (nlayers,nbndlw)
3438 real(kind=rb), intent(out) :: planklev(0:,:) !
3439 ! Dimensions: (0:nlayers,nbndlw)
3440 real(kind=rb), intent(out) :: plankbnd(:) !
3441 ! Dimensions: (nbndlw)
3443 real(kind=rb), intent(out) :: colh2o(:) ! column amount (h2o)
3444 ! Dimensions: (nlayers)
3445 real(kind=rb), intent(out) :: colco2(:) ! column amount (co2)
3446 ! Dimensions: (nlayers)
3447 real(kind=rb), intent(out) :: colo3(:) ! column amount (o3)
3448 ! Dimensions: (nlayers)
3449 real(kind=rb), intent(out) :: coln2o(:) ! column amount (n2o)
3450 ! Dimensions: (nlayers)
3451 real(kind=rb), intent(out) :: colco(:) ! column amount (co)
3452 ! Dimensions: (nlayers)
3453 real(kind=rb), intent(out) :: colch4(:) ! column amount (ch4)
3454 ! Dimensions: (nlayers)
3455 real(kind=rb), intent(out) :: colo2(:) ! column amount (o2)
3456 ! Dimensions: (nlayers)
3457 real(kind=rb), intent(out) :: colbrd(:) ! column amount (broadening gases)
3458 ! Dimensions: (nlayers)
3460 integer(kind=im), intent(out) :: indself(:)
3461 ! Dimensions: (nlayers)
3462 integer(kind=im), intent(out) :: indfor(:)
3463 ! Dimensions: (nlayers)
3464 real(kind=rb), intent(out) :: selffac(:)
3465 ! Dimensions: (nlayers)
3466 real(kind=rb), intent(out) :: selffrac(:)
3467 ! Dimensions: (nlayers)
3468 real(kind=rb), intent(out) :: forfac(:)
3469 ! Dimensions: (nlayers)
3470 real(kind=rb), intent(out) :: forfrac(:)
3471 ! Dimensions: (nlayers)
3473 integer(kind=im), intent(out) :: indminor(:)
3474 ! Dimensions: (nlayers)
3475 real(kind=rb), intent(out) :: minorfrac(:)
3476 ! Dimensions: (nlayers)
3477 real(kind=rb), intent(out) :: scaleminor(:)
3478 ! Dimensions: (nlayers)
3479 real(kind=rb), intent(out) :: scaleminorn2(:)
3480 ! Dimensions: (nlayers)
3482 real(kind=rb), intent(out) :: & !
3483 fac00(:), fac01(:), & ! Dimensions: (nlayers)
3484 fac10(:), fac11(:)
3486 real(kind=rb), intent(out) :: & !
3487 rat_h2oco2(:),rat_h2oco2_1(:), &
3488 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
3489 rat_h2on2o(:),rat_h2on2o_1(:), &
3490 rat_h2och4(:),rat_h2och4_1(:), &
3491 rat_n2oco2(:),rat_n2oco2_1(:), &
3492 rat_o3co2(:),rat_o3co2_1(:)
3495 ! ----- Local -----
3496 integer(kind=im) :: indbound, indlev0
3497 integer(kind=im) :: lay, indlay, indlev, iband
3498 integer(kind=im) :: jp1
3499 real(kind=rb) :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
3500 real(kind=rb) :: dbdtlev, dbdtlay
3501 real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp
3504 hvrset = '$Revision: 1.3 $'
3506 stpfac = 296._rb/1013._rb
3508 indbound = tbound - 159._rb
3509 if (indbound .lt. 1) then
3510 indbound = 1
3511 elseif (indbound .gt. 180) then
3512 indbound = 180
3513 endif
3514 tbndfrac = tbound - 159._rb - float(indbound)
3515 indlev0 = tz(0) - 159._rb
3516 if (indlev0 .lt. 1) then
3517 indlev0 = 1
3518 elseif (indlev0 .gt. 180) then
3519 indlev0 = 180
3520 endif
3521 t0frac = tz(0) - 159._rb - float(indlev0)
3522 laytrop = 0
3524 ! Begin layer loop
3525 ! Calculate the integrated Planck functions for each band at the
3526 ! surface, level, and layer temperatures.
3527 do lay = 1, nlayers
3528 indlay = tavel(lay) - 159._rb
3529 if (indlay .lt. 1) then
3530 indlay = 1
3531 elseif (indlay .gt. 180) then
3532 indlay = 180
3533 endif
3534 tlayfrac = tavel(lay) - 159._rb - float(indlay)
3535 indlev = tz(lay) - 159._rb
3536 if (indlev .lt. 1) then
3537 indlev = 1
3538 elseif (indlev .gt. 180) then
3539 indlev = 180
3540 endif
3541 tlevfrac = tz(lay) - 159._rb - float(indlev)
3543 ! Begin spectral band loop
3544 do iband = 1, 15
3545 if (lay.eq.1) then
3546 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3547 plankbnd(iband) = semiss(iband) * &
3548 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3549 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3550 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3551 endif
3552 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3553 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3554 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3555 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3556 enddo
3558 ! For band 16, if radiative transfer will be performed on just
3559 ! this band, use integrated Planck values up to 3250 cm-1.
3560 ! If radiative transfer will be performed across all 16 bands,
3561 ! then include in the integrated Planck values for this band
3562 ! contributions from 2600 cm-1 to infinity.
3563 iband = 16
3564 if (istart .eq. 16) then
3565 if (lay.eq.1) then
3566 dbdtlev = totplk16(indbound+1) - totplk16(indbound)
3567 plankbnd(iband) = semiss(iband) * &
3568 (totplk16(indbound) + tbndfrac * dbdtlev)
3569 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3570 planklev(0,iband) = totplk16(indlev0) + &
3571 t0frac * dbdtlev
3572 endif
3573 dbdtlev = totplk16(indlev+1) - totplk16(indlev)
3574 dbdtlay = totplk16(indlay+1) - totplk16(indlay)
3575 planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay
3576 planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev
3577 else
3578 if (lay.eq.1) then
3579 dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
3580 plankbnd(iband) = semiss(iband) * &
3581 (totplnk(indbound,iband) + tbndfrac * dbdtlev)
3582 dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3583 planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
3584 endif
3585 dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
3586 dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
3587 planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
3588 planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
3589 endif
3591 ! Find the two reference pressures on either side of the
3592 ! layer pressure. Store them in JP and JP1. Store in FP the
3593 ! fraction of the difference (in ln(pressure)) between these
3594 ! two values that the layer pressure lies.
3595 plog = log(pavel(lay))
3596 ! plog = dlog(pavel(lay))
3597 jp(lay) = int(36._rb - 5*(plog+0.04_rb))
3598 if (jp(lay) .lt. 1) then
3599 jp(lay) = 1
3600 elseif (jp(lay) .gt. 58) then
3601 jp(lay) = 58
3602 endif
3603 jp1 = jp(lay) + 1
3604 fp = 5._rb *(preflog(jp(lay)) - plog)
3606 ! Determine, for each reference pressure (JP and JP1), which
3607 ! reference temperature (these are different for each
3608 ! reference pressure) is nearest the layer temperature but does
3609 ! not exceed it. Store these indices in JT and JT1, resp.
3610 ! Store in FT (resp. FT1) the fraction of the way between JT
3611 ! (JT1) and the next highest reference temperature that the
3612 ! layer temperature falls.
3613 jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
3614 if (jt(lay) .lt. 1) then
3615 jt(lay) = 1
3616 elseif (jt(lay) .gt. 4) then
3617 jt(lay) = 4
3618 endif
3619 ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - float(jt(lay)-3)
3620 jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
3621 if (jt1(lay) .lt. 1) then
3622 jt1(lay) = 1
3623 elseif (jt1(lay) .gt. 4) then
3624 jt1(lay) = 4
3625 endif
3626 ft1 = ((tavel(lay)-tref(jp1))/15._rb) - float(jt1(lay)-3)
3627 water = wkl(1,lay)/coldry(lay)
3628 scalefac = pavel(lay) * stpfac / tavel(lay)
3630 ! If the pressure is less than ~100mb, perform a different
3631 ! set of species interpolations.
3632 if (plog .le. 4.56_rb) go to 5300
3633 laytrop = laytrop + 1
3635 forfac(lay) = scalefac / (1.+water)
3636 factor = (332.0_rb-tavel(lay))/36.0_rb
3637 indfor(lay) = min(2, max(1, int(factor)))
3638 forfrac(lay) = factor - float(indfor(lay))
3640 ! Set up factors needed to separately include the water vapor
3641 ! self-continuum in the calculation of absorption coefficient.
3642 selffac(lay) = water * forfac(lay)
3643 factor = (tavel(lay)-188.0_rb)/7.2_rb
3644 indself(lay) = min(9, max(1, int(factor)-7))
3645 selffrac(lay) = factor - float(indself(lay) + 7)
3647 ! Set up factors needed to separately include the minor gases
3648 ! in the calculation of absorption coefficient
3649 scaleminor(lay) = pavel(lay)/tavel(lay)
3650 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3651 *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3652 factor = (tavel(lay)-180.8_rb)/7.2_rb
3653 indminor(lay) = min(18, max(1, int(factor)))
3654 minorfrac(lay) = factor - float(indminor(lay))
3656 ! Setup reference ratio to be used in calculation of binary
3657 ! species parameter in lower atmosphere.
3658 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3659 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3661 rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay))
3662 rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1)
3664 rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay))
3665 rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1)
3667 rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay))
3668 rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1)
3670 rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay))
3671 rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3673 ! Calculate needed column amounts.
3674 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3675 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3676 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3677 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3678 colco(lay) = 1.e-20_rb * wkl(5,lay)
3679 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3680 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3681 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3682 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3683 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3684 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3685 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3686 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3687 go to 5400
3689 ! Above laytrop.
3690 5300 continue
3692 forfac(lay) = scalefac / (1.+water)
3693 factor = (tavel(lay)-188.0_rb)/36.0_rb
3694 indfor(lay) = 3
3695 forfrac(lay) = factor - 1.0_rb
3697 ! Set up factors needed to separately include the water vapor
3698 ! self-continuum in the calculation of absorption coefficient.
3699 selffac(lay) = water * forfac(lay)
3701 ! Set up factors needed to separately include the minor gases
3702 ! in the calculation of absorption coefficient
3703 scaleminor(lay) = pavel(lay)/tavel(lay)
3704 scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
3705 * (wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3706 factor = (tavel(lay)-180.8_rb)/7.2_rb
3707 indminor(lay) = min(18, max(1, int(factor)))
3708 minorfrac(lay) = factor - float(indminor(lay))
3710 ! Setup reference ratio to be used in calculation of binary
3711 ! species parameter in upper atmosphere.
3712 rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3713 rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3715 rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay))
3716 rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3718 ! Calculate needed column amounts.
3719 colh2o(lay) = 1.e-20_rb * wkl(1,lay)
3720 colco2(lay) = 1.e-20_rb * wkl(2,lay)
3721 colo3(lay) = 1.e-20_rb * wkl(3,lay)
3722 coln2o(lay) = 1.e-20_rb * wkl(4,lay)
3723 colco(lay) = 1.e-20_rb * wkl(5,lay)
3724 colch4(lay) = 1.e-20_rb * wkl(6,lay)
3725 colo2(lay) = 1.e-20_rb * wkl(7,lay)
3726 if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
3727 if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
3728 if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
3729 if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
3730 if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
3731 colbrd(lay) = 1.e-20_rb * wbroad(lay)
3732 5400 continue
3734 ! We have now isolated the layer ln pressure and temperature,
3735 ! between two reference pressures and two reference temperatures
3736 ! (for each reference pressure). We multiply the pressure
3737 ! fraction FP with the appropriate temperature fractions to get
3738 ! the factors that will be needed for the interpolation that yields
3739 ! the optical depths (performed in routines TAUGBn for band n).`
3741 compfp = 1. - fp
3742 fac10(lay) = compfp * ft
3743 fac00(lay) = compfp * (1._rb - ft)
3744 fac11(lay) = fp * ft1
3745 fac01(lay) = fp * (1._rb - ft1)
3747 ! Rescale selffac and forfac for use in taumol
3748 selffac(lay) = colh2o(lay)*selffac(lay)
3749 forfac(lay) = colh2o(lay)*forfac(lay)
3751 ! End layer loop
3752 enddo
3754 end subroutine setcoef
3756 !***************************************************************************
3757 subroutine lwatmref
3758 !***************************************************************************
3760 save
3762 ! These pressures are chosen such that the ln of the first pressure
3763 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
3764 ! each subsequent ln(pressure) differs from the previous one by 0.2.
3766 pref(:) = (/ &
3767 1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
3768 3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
3769 1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
3770 5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
3771 1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
3772 7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
3773 2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
3774 9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
3775 3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
3776 1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
3777 4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
3778 1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/)
3780 preflog(:) = (/ &
3781 6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
3782 5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
3783 4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
3784 3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
3785 2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
3786 1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
3787 9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
3788 -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
3789 -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
3790 -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
3791 -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
3792 -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/)
3794 ! These are the temperatures associated with the respective
3795 ! pressures for the mls standard atmosphere.
3797 tref(:) = (/ &
3798 2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
3799 2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
3800 2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
3801 2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
3802 2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
3803 2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
3804 2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
3805 2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
3806 2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
3807 2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
3808 2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
3809 1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/)
3811 chi_mls(1,1:12) = (/ &
3812 1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, &
3813 7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, &
3814 4.3082e-06_rb, 3.3319e-06_rb/)
3815 chi_mls(1,13:59) = (/ &
3816 3.2039e-06_rb, 3.1619e-06_rb, 3.2524e-06_rb, 3.4226e-06_rb, 3.6288e-06_rb, &
3817 3.9148e-06_rb, 4.1488e-06_rb, 4.3081e-06_rb, 4.4420e-06_rb, 4.5778e-06_rb, &
3818 4.7087e-06_rb, 4.7943e-06_rb, 4.8697e-06_rb, 4.9260e-06_rb, 4.9669e-06_rb, &
3819 4.9963e-06_rb, 5.0527e-06_rb, 5.1266e-06_rb, 5.2503e-06_rb, 5.3571e-06_rb, &
3820 5.4509e-06_rb, 5.4830e-06_rb, 5.5000e-06_rb, 5.5000e-06_rb, 5.4536e-06_rb, &
3821 5.4047e-06_rb, 5.3558e-06_rb, 5.2533e-06_rb, 5.1436e-06_rb, 5.0340e-06_rb, &
3822 4.8766e-06_rb, 4.6979e-06_rb, 4.5191e-06_rb, 4.3360e-06_rb, 4.1442e-06_rb, &
3823 3.9523e-06_rb, 3.7605e-06_rb, 3.5722e-06_rb, 3.3855e-06_rb, 3.1988e-06_rb, &
3824 3.0121e-06_rb, 2.8262e-06_rb, 2.6407e-06_rb, 2.4552e-06_rb, 2.2696e-06_rb, &
3825 4.3360e-06_rb, 4.1442e-06_rb/)
3826 chi_mls(2,1:12) = (/ &
3827 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3828 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3829 3.5500e-04_rb, 3.5500e-04_rb/)
3830 chi_mls(2,13:59) = (/ &
3831 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3832 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3833 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3834 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3835 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3836 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3837 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3838 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
3839 3.5500e-04_rb, 3.5471e-04_rb, 3.5427e-04_rb, 3.5384e-04_rb, 3.5340e-04_rb, &
3840 3.5500e-04_rb, 3.5500e-04_rb/)
3841 chi_mls(3,1:12) = (/ &
3842 3.0170e-08_rb, 3.4725e-08_rb, 4.2477e-08_rb, 5.2759e-08_rb, 6.6944e-08_rb, &
3843 8.7130e-08_rb, 1.1391e-07_rb, 1.5677e-07_rb, 2.1788e-07_rb, 3.2443e-07_rb, &
3844 4.6594e-07_rb, 5.6806e-07_rb/)
3845 chi_mls(3,13:59) = (/ &
3846 6.9607e-07_rb, 1.1186e-06_rb, 1.7618e-06_rb, 2.3269e-06_rb, 2.9577e-06_rb, &
3847 3.6593e-06_rb, 4.5950e-06_rb, 5.3189e-06_rb, 5.9618e-06_rb, 6.5113e-06_rb, &
3848 7.0635e-06_rb, 7.6917e-06_rb, 8.2577e-06_rb, 8.7082e-06_rb, 8.8325e-06_rb, &
3849 8.7149e-06_rb, 8.0943e-06_rb, 7.3307e-06_rb, 6.3101e-06_rb, 5.3672e-06_rb, &
3850 4.4829e-06_rb, 3.8391e-06_rb, 3.2827e-06_rb, 2.8235e-06_rb, 2.4906e-06_rb, &
3851 2.1645e-06_rb, 1.8385e-06_rb, 1.6618e-06_rb, 1.5052e-06_rb, 1.3485e-06_rb, &
3852 1.1972e-06_rb, 1.0482e-06_rb, 8.9926e-07_rb, 7.6343e-07_rb, 6.5381e-07_rb, &
3853 5.4419e-07_rb, 4.3456e-07_rb, 3.6421e-07_rb, 3.1194e-07_rb, 2.5967e-07_rb, &
3854 2.0740e-07_rb, 1.9146e-07_rb, 1.9364e-07_rb, 1.9582e-07_rb, 1.9800e-07_rb, &
3855 7.6343e-07_rb, 6.5381e-07_rb/)
3856 chi_mls(4,1:12) = (/ &
3857 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, &
3858 3.1965e-07_rb, 3.1532e-07_rb, 3.0383e-07_rb, 2.9422e-07_rb, 2.8495e-07_rb, &
3859 2.7671e-07_rb, 2.6471e-07_rb/)
3860 chi_mls(4,13:59) = (/ &
3861 2.4285e-07_rb, 2.0955e-07_rb, 1.7195e-07_rb, 1.3749e-07_rb, 1.1332e-07_rb, &
3862 1.0035e-07_rb, 9.1281e-08_rb, 8.5463e-08_rb, 8.0363e-08_rb, 7.3372e-08_rb, &
3863 6.5975e-08_rb, 5.6039e-08_rb, 4.7090e-08_rb, 3.9977e-08_rb, 3.2979e-08_rb, &
3864 2.6064e-08_rb, 2.1066e-08_rb, 1.6592e-08_rb, 1.3017e-08_rb, 1.0090e-08_rb, &
3865 7.6249e-09_rb, 6.1159e-09_rb, 4.6672e-09_rb, 3.2857e-09_rb, 2.8484e-09_rb, &
3866 2.4620e-09_rb, 2.0756e-09_rb, 1.8551e-09_rb, 1.6568e-09_rb, 1.4584e-09_rb, &
3867 1.3195e-09_rb, 1.2072e-09_rb, 1.0948e-09_rb, 9.9780e-10_rb, 9.3126e-10_rb, &
3868 8.6472e-10_rb, 7.9818e-10_rb, 7.5138e-10_rb, 7.1367e-10_rb, 6.7596e-10_rb, &
3869 6.3825e-10_rb, 6.0981e-10_rb, 5.8600e-10_rb, 5.6218e-10_rb, 5.3837e-10_rb, &
3870 9.9780e-10_rb, 9.3126e-10_rb/)
3871 chi_mls(5,1:12) = (/ &
3872 1.5000e-07_rb, 1.4306e-07_rb, 1.3474e-07_rb, 1.3061e-07_rb, 1.2793e-07_rb, &
3873 1.2038e-07_rb, 1.0798e-07_rb, 9.4238e-08_rb, 7.9488e-08_rb, 6.1386e-08_rb, &
3874 4.5563e-08_rb, 3.3475e-08_rb/)
3875 chi_mls(5,13:59) = (/ &
3876 2.5118e-08_rb, 1.8671e-08_rb, 1.4349e-08_rb, 1.2501e-08_rb, 1.2407e-08_rb, &
3877 1.3472e-08_rb, 1.4900e-08_rb, 1.6079e-08_rb, 1.7156e-08_rb, 1.8616e-08_rb, &
3878 2.0106e-08_rb, 2.1654e-08_rb, 2.3096e-08_rb, 2.4340e-08_rb, 2.5643e-08_rb, &
3879 2.6990e-08_rb, 2.8456e-08_rb, 2.9854e-08_rb, 3.0943e-08_rb, 3.2023e-08_rb, &
3880 3.3101e-08_rb, 3.4260e-08_rb, 3.5360e-08_rb, 3.6397e-08_rb, 3.7310e-08_rb, &
3881 3.8217e-08_rb, 3.9123e-08_rb, 4.1303e-08_rb, 4.3652e-08_rb, 4.6002e-08_rb, &
3882 5.0289e-08_rb, 5.5446e-08_rb, 6.0603e-08_rb, 6.8946e-08_rb, 8.3652e-08_rb, &
3883 9.8357e-08_rb, 1.1306e-07_rb, 1.4766e-07_rb, 1.9142e-07_rb, 2.3518e-07_rb, &
3884 2.7894e-07_rb, 3.5001e-07_rb, 4.3469e-07_rb, 5.1938e-07_rb, 6.0407e-07_rb, &
3885 6.8946e-08_rb, 8.3652e-08_rb/)
3886 chi_mls(6,1:12) = (/ &
3887 1.7000e-06_rb, 1.7000e-06_rb, 1.6999e-06_rb, 1.6904e-06_rb, 1.6671e-06_rb, &
3888 1.6351e-06_rb, 1.6098e-06_rb, 1.5590e-06_rb, 1.5120e-06_rb, 1.4741e-06_rb, &
3889 1.4385e-06_rb, 1.4002e-06_rb/)
3890 chi_mls(6,13:59) = (/ &
3891 1.3573e-06_rb, 1.3130e-06_rb, 1.2512e-06_rb, 1.1668e-06_rb, 1.0553e-06_rb, &
3892 9.3281e-07_rb, 8.1217e-07_rb, 7.5239e-07_rb, 7.0728e-07_rb, 6.6722e-07_rb, &
3893 6.2733e-07_rb, 5.8604e-07_rb, 5.4769e-07_rb, 5.1480e-07_rb, 4.8206e-07_rb, &
3894 4.4943e-07_rb, 4.1702e-07_rb, 3.8460e-07_rb, 3.5200e-07_rb, 3.1926e-07_rb, &
3895 2.8646e-07_rb, 2.5498e-07_rb, 2.2474e-07_rb, 1.9588e-07_rb, 1.8295e-07_rb, &
3896 1.7089e-07_rb, 1.5882e-07_rb, 1.5536e-07_rb, 1.5304e-07_rb, 1.5072e-07_rb, &
3897 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3898 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3899 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
3900 1.5000e-07_rb, 1.5000e-07_rb/)
3901 chi_mls(7,1:12) = (/ &
3902 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3903 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3904 0.2090_rb, 0.2090_rb/)
3905 chi_mls(7,13:59) = (/ &
3906 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3907 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3908 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3909 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3910 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3911 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3912 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3913 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3914 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, &
3915 0.2090_rb, 0.2090_rb/)
3917 end subroutine lwatmref
3919 !***************************************************************************
3920 subroutine lwavplank
3921 !***************************************************************************
3923 save
3925 totplnk(1:50, 1) = (/ &
3926 0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, &
3927 0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, &
3928 0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, &
3929 0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, &
3930 0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, &
3931 0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, &
3932 0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, &
3933 0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, &
3934 0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, &
3935 0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/)
3936 totplnk(51:100, 1) = (/ &
3937 0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, &
3938 0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, &
3939 0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, &
3940 0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, &
3941 0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, &
3942 0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, &
3943 0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, &
3944 0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, &
3945 0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, &
3946 0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/)
3947 totplnk(101:150, 1) = (/ &
3948 0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, &
3949 0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, &
3950 0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, &
3951 0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, &
3952 0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, &
3953 0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, &
3954 0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, &
3955 0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, &
3956 0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, &
3957 0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/)
3958 totplnk(151:181, 1) = (/ &
3959 0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, &
3960 0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, &
3961 0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, &
3962 0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, &
3963 0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, &
3964 0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, &
3965 0.65247e-05_rb/)
3966 totplnk(1:50, 2) = (/ &
3967 0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, &
3968 0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, &
3969 0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, &
3970 0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, &
3971 0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, &
3972 0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, &
3973 0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, &
3974 0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, &
3975 0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, &
3976 0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/)
3977 totplnk(51:100, 2) = (/ &
3978 0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, &
3979 0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, &
3980 0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, &
3981 0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, &
3982 0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, &
3983 0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, &
3984 0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, &
3985 0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, &
3986 0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, &
3987 0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/)
3988 totplnk(101:150, 2) = (/ &
3989 0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, &
3990 0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, &
3991 0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, &
3992 0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, &
3993 0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, &
3994 0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, &
3995 0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, &
3996 0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, &
3997 0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, &
3998 0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/)
3999 totplnk(151:181, 2) = (/ &
4000 0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, &
4001 0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, &
4002 0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, &
4003 0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, &
4004 0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, &
4005 0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, &
4006 0.17998e-04_rb/)
4007 totplnk(1:50, 3) = (/ &
4008 1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, &
4009 1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, &
4010 1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, &
4011 2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, &
4012 2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, &
4013 2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, &
4014 3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, &
4015 3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, &
4016 3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, &
4017 4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/)
4018 totplnk(51:100, 3) = (/ &
4019 4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, &
4020 4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, &
4021 5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, &
4022 5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, &
4023 6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, &
4024 6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, &
4025 7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, &
4026 8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, &
4027 8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, &
4028 9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/)
4029 totplnk(101:150, 3) = (/ &
4030 9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, &
4031 1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, &
4032 1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, &
4033 1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, &
4034 1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, &
4035 1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, &
4036 1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, &
4037 1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, &
4038 1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, &
4039 1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/)
4040 totplnk(151:181, 3) = (/ &
4041 1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, &
4042 1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, &
4043 1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, &
4044 1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, &
4045 1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, &
4046 2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, &
4047 2.15414e-05_rb/)
4048 totplnk(1:50, 4) = (/ &
4049 8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, &
4050 1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, &
4051 1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, &
4052 1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, &
4053 1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, &
4054 2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, &
4055 2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, &
4056 2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, &
4057 2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, &
4058 3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/)
4059 totplnk(51:100, 4) = (/ &
4060 3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, &
4061 4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, &
4062 4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, &
4063 5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, &
4064 5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, &
4065 6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, &
4066 6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, &
4067 7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, &
4068 7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, &
4069 8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/)
4070 totplnk(101:150, 4) = (/ &
4071 9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, &
4072 9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, &
4073 1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, &
4074 1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, &
4075 1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, &
4076 1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, &
4077 1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, &
4078 1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, &
4079 1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, &
4080 1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/)
4081 totplnk(151:181, 4) = (/ &
4082 1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, &
4083 1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, &
4084 1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, &
4085 1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, &
4086 2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, &
4087 2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, &
4088 2.23158e-05_rb/)
4089 totplnk(1:50, 5) = (/ &
4090 5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, &
4091 7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, &
4092 8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, &
4093 1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, &
4094 1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, &
4095 1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, &
4096 1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, &
4097 1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, &
4098 2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, &
4099 2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/)
4100 totplnk(51:100, 5) = (/ &
4101 2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, &
4102 3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, &
4103 3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, &
4104 4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, &
4105 4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, &
4106 5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, &
4107 5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, &
4108 6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, &
4109 6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, &
4110 7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/)
4111 totplnk(101:150, 5) = (/ &
4112 7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, &
4113 8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, &
4114 9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, &
4115 9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, &
4116 1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, &
4117 1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, &
4118 1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, &
4119 1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, &
4120 1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, &
4121 1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/)
4122 totplnk(151:181, 5) = (/ &
4123 1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, &
4124 1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, &
4125 1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, &
4126 1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, &
4127 1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, &
4128 2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, &
4129 2.17931e-05_rb/)
4130 totplnk(1:50, 6) = (/ &
4131 2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, &
4132 3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, &
4133 4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, &
4134 5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, &
4135 6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, &
4136 8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, &
4137 9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, &
4138 1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, &
4139 1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, &
4140 1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/)
4141 totplnk(51:100, 6) = (/ &
4142 1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, &
4143 2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, &
4144 2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, &
4145 2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, &
4146 3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, &
4147 3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, &
4148 3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, &
4149 4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, &
4150 4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, &
4151 5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/)
4152 totplnk(101:150, 6) = (/ &
4153 6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, &
4154 6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, &
4155 7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, &
4156 7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, &
4157 8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, &
4158 9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, &
4159 1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, &
4160 1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, &
4161 1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, &
4162 1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/)
4163 totplnk(151:181, 6) = (/ &
4164 1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, &
4165 1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, &
4166 1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, &
4167 1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, &
4168 1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, &
4169 1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, &
4170 1.96471e-05_rb/)
4171 totplnk(1:50, 7) = (/ &
4172 1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, &
4173 1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, &
4174 2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, &
4175 2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, &
4176 3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, &
4177 4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, &
4178 5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, &
4179 6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, &
4180 7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, &
4181 9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/)
4182 totplnk(51:100, 7) = (/ &
4183 1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, &
4184 1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, &
4185 1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, &
4186 1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, &
4187 2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, &
4188 2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, &
4189 2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, &
4190 3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, &
4191 3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, &
4192 3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/)
4193 totplnk(101:150, 7) = (/ &
4194 4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, &
4195 4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, &
4196 5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, &
4197 5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, &
4198 6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, &
4199 7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, &
4200 7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, &
4201 8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, &
4202 9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, &
4203 1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/)
4204 totplnk(151:181, 7) = (/ &
4205 1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, &
4206 1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, &
4207 1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, &
4208 1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, &
4209 1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, &
4210 1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, &
4211 1.68640e-05_rb/)
4212 totplnk(1:50, 8) = (/ &
4213 6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, &
4214 9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, &
4215 1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, &
4216 1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, &
4217 2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, &
4218 2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, &
4219 3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, &
4220 4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, &
4221 5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, &
4222 6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/)
4223 totplnk(51:100, 8) = (/ &
4224 7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, &
4225 8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, &
4226 1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, &
4227 1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, &
4228 1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, &
4229 1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, &
4230 1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, &
4231 2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, &
4232 2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, &
4233 2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/)
4234 totplnk(101:150, 8) = (/ &
4235 3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, &
4236 3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, &
4237 4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, &
4238 4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, &
4239 5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, &
4240 5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, &
4241 6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, &
4242 6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, &
4243 7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, &
4244 8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/)
4245 totplnk(151:181, 8) = (/ &
4246 9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, &
4247 9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, &
4248 1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, &
4249 1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, &
4250 1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, &
4251 1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, &
4252 1.45267e-05_rb/)
4253 totplnk(1:50, 9) = (/ &
4254 2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, &
4255 3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, &
4256 5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, &
4257 6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, &
4258 9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, &
4259 1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, &
4260 1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, &
4261 2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, &
4262 2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, &
4263 3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/)
4264 totplnk(51:100, 9) = (/ &
4265 3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, &
4266 4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, &
4267 5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, &
4268 7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, &
4269 8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, &
4270 9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, &
4271 1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, &
4272 1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, &
4273 1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, &
4274 1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/)
4275 totplnk(101:150, 9) = (/ &
4276 2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, &
4277 2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, &
4278 2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, &
4279 3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, &
4280 3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, &
4281 3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, &
4282 4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, &
4283 4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, &
4284 5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, &
4285 5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/)
4286 totplnk(151:181, 9) = (/ &
4287 6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, &
4288 7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, &
4289 7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, &
4290 8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, &
4291 9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, &
4292 1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, &
4293 1.10781e-05_rb/)
4294 totplnk(1:50,10) = (/ &
4295 8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, &
4296 1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, &
4297 1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, &
4298 2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, &
4299 3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, &
4300 5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, &
4301 6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, &
4302 8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, &
4303 1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, &
4304 1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/)
4305 totplnk(51:100,10) = (/ &
4306 1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, &
4307 2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, &
4308 2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, &
4309 3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, &
4310 4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, &
4311 5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, &
4312 6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, &
4313 7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, &
4314 9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, &
4315 1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/)
4316 totplnk(101:150,10) = (/ &
4317 1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, &
4318 1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, &
4319 1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, &
4320 1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, &
4321 2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, &
4322 2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, &
4323 2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, &
4324 3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, &
4325 3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, &
4326 4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/)
4327 totplnk(151:181,10) = (/ &
4328 4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, &
4329 5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, &
4330 5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, &
4331 6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, &
4332 6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, &
4333 7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, &
4334 8.14138e-06_rb/)
4335 totplnk(1:50,11) = (/ &
4336 2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, &
4337 3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, &
4338 5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, &
4339 8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, &
4340 1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, &
4341 1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, &
4342 2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, &
4343 3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, &
4344 4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, &
4345 5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/)
4346 totplnk(51:100,11) = (/ &
4347 7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, &
4348 9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, &
4349 1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, &
4350 1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, &
4351 1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, &
4352 2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, &
4353 3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, &
4354 3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, &
4355 4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, &
4356 5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/)
4357 totplnk(101:150,11) = (/ &
4358 6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, &
4359 7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, &
4360 8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, &
4361 1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, &
4362 1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, &
4363 1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, &
4364 1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, &
4365 1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, &
4366 2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, &
4367 2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/)
4368 totplnk(151:181,11) = (/ &
4369 2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, &
4370 3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, &
4371 3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, &
4372 3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, &
4373 4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, &
4374 4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, &
4375 5.19332e-06_rb/)
4376 totplnk(1:50,12) = (/ &
4377 2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, &
4378 4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, &
4379 7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, &
4380 1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, &
4381 1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, &
4382 2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, &
4383 4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, &
4384 5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, &
4385 8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, &
4386 1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/)
4387 totplnk(51:100,12) = (/ &
4388 1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, &
4389 2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, &
4390 2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, &
4391 3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, &
4392 4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, &
4393 6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, &
4394 8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, &
4395 1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, &
4396 1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, &
4397 1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/)
4398 totplnk(101:150,12) = (/ &
4399 1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, &
4400 2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, &
4401 2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, &
4402 3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, &
4403 4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, &
4404 5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, &
4405 5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, &
4406 6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, &
4407 8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, &
4408 9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/)
4409 totplnk(151:181,12) = (/ &
4410 1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, &
4411 1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, &
4412 1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, &
4413 1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, &
4414 1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, &
4415 2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, &
4416 2.41619e-06_rb/)
4417 totplnk(1:50,13) = (/ &
4418 4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, &
4419 8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, &
4420 1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, &
4421 2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, &
4422 3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, &
4423 6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, &
4424 9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, &
4425 1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, &
4426 2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, &
4427 3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/)
4428 totplnk(51:100,13) = (/ &
4429 4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, &
4430 6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, &
4431 8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, &
4432 1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, &
4433 1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, &
4434 2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, &
4435 2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, &
4436 3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, &
4437 4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, &
4438 6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/)
4439 totplnk(101:150,13) = (/ &
4440 7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, &
4441 9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, &
4442 1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, &
4443 1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, &
4444 1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, &
4445 2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, &
4446 2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, &
4447 3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, &
4448 3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, &
4449 4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/)
4450 totplnk(151:181,13) = (/ &
4451 5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, &
4452 6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, &
4453 7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, &
4454 8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, &
4455 9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, &
4456 1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, &
4457 1.28049e-06_rb/)
4458 totplnk(1:50,14) = (/ &
4459 1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, &
4460 2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, &
4461 4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, &
4462 8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, &
4463 1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, &
4464 2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, &
4465 3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, &
4466 5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, &
4467 8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, &
4468 1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/)
4469 totplnk(51:100,14) = (/ &
4470 1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, &
4471 2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, &
4472 4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, &
4473 5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, &
4474 7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, &
4475 1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, &
4476 1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, &
4477 1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, &
4478 2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, &
4479 3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/)
4480 totplnk(101:150,14) = (/ &
4481 4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, &
4482 5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, &
4483 6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, &
4484 8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, &
4485 1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, &
4486 1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, &
4487 1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, &
4488 1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, &
4489 2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, &
4490 2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/)
4491 totplnk(151:181,14) = (/ &
4492 3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, &
4493 3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, &
4494 4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, &
4495 5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, &
4496 6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, &
4497 7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, &
4498 8.27050e-07_rb/)
4499 totplnk(1:50,15) = (/ &
4500 3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, &
4501 7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, &
4502 1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, &
4503 2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, &
4504 4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, &
4505 7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, &
4506 1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, &
4507 2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, &
4508 3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, &
4509 5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/)
4510 totplnk(51:100,15) = (/ &
4511 7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, &
4512 1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, &
4513 1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, &
4514 2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, &
4515 3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, &
4516 4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, &
4517 6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, &
4518 8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, &
4519 1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, &
4520 1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/)
4521 totplnk(101:150,15) = (/ &
4522 1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, &
4523 2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, &
4524 3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, &
4525 4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, &
4526 5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, &
4527 6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, &
4528 8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, &
4529 1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, &
4530 1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, &
4531 1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/)
4532 totplnk(151:181,15) = (/ &
4533 1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, &
4534 2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, &
4535 2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, &
4536 3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, &
4537 3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, &
4538 4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, &
4539 4.96535e-07_rb/)
4540 totplnk(1:50,16) = (/ &
4541 0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, &
4542 0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, &
4543 0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, &
4544 0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, &
4545 0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, &
4546 0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, &
4547 0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, &
4548 0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, &
4549 0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, &
4550 0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/)
4551 totplnk(51:100,16) = (/ &
4552 0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, &
4553 0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, &
4554 0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, &
4555 0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, &
4556 0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, &
4557 0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, &
4558 0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, &
4559 0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, &
4560 0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, &
4561 0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/)
4562 totplnk(101:150,16) = (/ &
4563 0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, &
4564 0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, &
4565 0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, &
4566 0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, &
4567 0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, &
4568 0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, &
4569 0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, &
4570 0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, &
4571 0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, &
4572 0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/)
4573 totplnk(151:181,16) = (/ &
4574 0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, &
4575 0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, &
4576 0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, &
4577 0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, &
4578 0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, &
4579 0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, &
4580 0.16823e-06_rb/)
4581 totplk16(1:50) = (/ &
4582 0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, &
4583 0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, &
4584 0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, &
4585 0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, &
4586 0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, &
4587 0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, &
4588 0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, &
4589 0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, &
4590 0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, &
4591 0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/)
4592 totplk16(51:100) = (/ &
4593 0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, &
4594 0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, &
4595 0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, &
4596 0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, &
4597 0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, &
4598 0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, &
4599 0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, &
4600 0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, &
4601 0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, &
4602 0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/)
4603 totplk16(101:150) = (/ &
4604 0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, &
4605 0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, &
4606 0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, &
4607 0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, &
4608 0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, &
4609 0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, &
4610 0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, &
4611 0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, &
4612 0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, &
4613 0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/)
4614 totplk16(151:181) = (/ &
4615 0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, &
4616 0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, &
4617 0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, &
4618 0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, &
4619 0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, &
4620 0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, &
4621 0.14841e-06_rb/)
4623 end subroutine lwavplank
4625 end module rrtmg_lw_setcoef
4627 ! path: $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_taumol.f90,v $
4628 ! author: $Author: mike $
4629 ! revision: $Revision: 1.7 $
4630 ! created: $Date: 2009/10/20 15:08:37 $
4631 !
4632 module rrtmg_lw_taumol
4634 ! --------------------------------------------------------------------------
4635 ! | |
4636 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
4637 ! | This software may be used, copied, or redistributed as long as it is |
4638 ! | not sold and this copyright notice is reproduced on each copy made. |
4639 ! | This model is provided as is without any express or implied warranties. |
4640 ! | (http://www.rtweb.aer.com/) |
4641 ! | |
4642 ! --------------------------------------------------------------------------
4644 ! ------- Modules -------
4646 use parkind, only : im => kind_im, rb => kind_rb
4647 use parrrtm, only : mg, nbndlw, maxxsec, ngptlw
4648 use rrlw_con, only: oneminus
4649 use rrlw_wvn, only: nspa, nspb
4650 use rrlw_vsn, only: hvrtau, hnamtau
4652 implicit none
4654 contains
4656 !----------------------------------------------------------------------------
4657 subroutine taumol(nlayers, pavel, wx, coldry, &
4658 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
4659 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
4660 colbrd, fac00, fac01, fac10, fac11, &
4661 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
4662 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
4663 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
4664 selffac, selffrac, indself, forfac, forfrac, indfor, &
4665 minorfrac, scaleminor, scaleminorn2, indminor, &
4666 fracs, taug)
4667 !----------------------------------------------------------------------------
4669 ! *******************************************************************************
4670 ! * *
4671 ! * Optical depths developed for the *
4672 ! * *
4673 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
4674 ! * *
4675 ! * *
4676 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
4677 ! * 131 HARTWELL AVENUE *
4678 ! * LEXINGTON, MA 02421 *
4679 ! * *
4680 ! * *
4681 ! * ELI J. MLAWER *
4682 ! * JENNIFER DELAMERE *
4683 ! * STEVEN J. TAUBMAN *
4684 ! * SHEPARD A. CLOUGH *
4685 ! * *
4686 ! * *
4687 ! * *
4688 ! * *
4689 ! * email: mlawer@aer.com *
4690 ! * email: jdelamer@aer.com *
4691 ! * *
4692 ! * The authors wish to acknowledge the contributions of the *
4693 ! * following people: Karen Cady-Pereira, Patrick D. Brown, *
4694 ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
4695 ! * *
4696 ! *******************************************************************************
4697 ! * *
4698 ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. *
4699 ! * *
4700 ! *******************************************************************************
4701 ! * TAUMOL *
4702 ! * *
4703 ! * This file contains the subroutines TAUGBn (where n goes from *
4704 ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions *
4705 ! * per g-value and layer for band n. *
4706 ! * *
4707 ! * Output: optical depths (unitless) *
4708 ! * fractions needed to compute Planck functions at every layer *
4709 ! * and g-value *
4710 ! * *
4711 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
4712 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) *
4713 ! * *
4714 ! * Input *
4715 ! * *
4716 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
4717 ! * COMMON /PRECISE/ ONEMINUS *
4718 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
4719 ! * & PZ(0:MXLAY),TZ(0:MXLAY) *
4720 ! * COMMON /PROFDATA/ LAYTROP, *
4721 ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), *
4722 ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), *
4723 ! * & COLO2(MXLAY)
4724 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), *
4725 ! * & FAC10(MXLAY),FAC11(MXLAY) *
4726 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
4727 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
4728 ! * *
4729 ! * Description: *
4730 ! * NG(IBAND) - number of g-values in band IBAND *
4731 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
4732 ! * atmospheres that are stored for band IBAND per *
4733 ! * pressure level and temperature. Each of these *
4734 ! * atmospheres has different relative amounts of the *
4735 ! * key species for the band (i.e. different binary *
4736 ! * species parameters). *
4737 ! * NSPB(IBAND) - same for upper atmosphere *
4738 ! * ONEMINUS - since problems are caused in some cases by interpolation *
4739 ! * parameters equal to or greater than 1, for these cases *
4740 ! * these parameters are set to this value, slightly < 1. *
4741 ! * PAVEL - layer pressures (mb) *
4742 ! * TAVEL - layer temperatures (degrees K) *
4743 ! * PZ - level pressures (mb) *
4744 ! * TZ - level temperatures (degrees K) *
4745 ! * LAYTROP - layer at which switch is made from one combination of *
4746 ! * key species to another *
4747 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
4748 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
4749 ! * respectively (molecules/cm**2) *
4750 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
4751 ! * compute the interpolation factors that multiply the *
4752 ! * appropriate reference k-values. A value of 0 (1) for *
4753 ! * i,j indicates that the corresponding factor multiplies *
4754 ! * reference k-value for the lower (higher) of the two *
4755 ! * appropriate temperatures, and altitudes, respectively. *
4756 ! * JP - the index of the lower (in altitude) of the two appropriate *
4757 ! * reference pressure levels needed for interpolation *
4758 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
4759 ! * temperatures needed for interpolation (for pressure *
4760 ! * levels JP and JP+1, respectively) *
4761 ! * SELFFAC - scale factor needed for water vapor self-continuum, equals *
4762 ! * (water vapor density)/(atmospheric density at 296K and *
4763 ! * 1013 mb) *
4764 ! * SELFFRAC - factor needed for temperature interpolation of reference *
4765 ! * water vapor self-continuum data *
4766 ! * INDSELF - index of the lower of the two appropriate reference *
4767 ! * temperatures needed for the self-continuum interpolation *
4768 ! * FORFAC - scale factor needed for water vapor foreign-continuum. *
4769 ! * FORFRAC - factor needed for temperature interpolation of reference *
4770 ! * water vapor foreign-continuum data *
4771 ! * INDFOR - index of the lower of the two appropriate reference *
4772 ! * temperatures needed for the foreign-continuum interpolation *
4773 ! * *
4774 ! * Data input *
4775 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
4776 ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' *
4777 ! * (note: n is the band number,'MGAS' is the species name of the minor *
4778 ! * gas) *
4779 ! * *
4780 ! * Description: *
4781 ! * KA - k-values for low reference atmospheres (key-species only) *
4782 ! * (units: cm**2/molecule) *
4783 ! * KB - k-values for high reference atmospheres (key-species only) *
4784 ! * (units: cm**2/molecule) *
4785 ! * KA_M'MGAS' - k-values for low reference atmosphere minor species *
4786 ! * (units: cm**2/molecule) *
4787 ! * KB_M'MGAS' - k-values for high reference atmosphere minor species *
4788 ! * (units: cm**2/molecule) *
4789 ! * SELFREF - k-values for water vapor self-continuum for reference *
4790 ! * atmospheres (used below LAYTROP) *
4791 ! * (units: cm**2/molecule) *
4792 ! * FORREF - k-values for water vapor foreign-continuum for reference *
4793 ! * atmospheres (used below/above LAYTROP) *
4794 ! * (units: cm**2/molecule) *
4795 ! * *
4796 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
4797 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
4798 ! * *
4799 !*******************************************************************************
4801 ! ------- Declarations -------
4803 ! ----- Input -----
4804 integer(kind=im), intent(in) :: nlayers ! total number of layers
4805 real(kind=rb), intent(in) :: pavel(:) ! layer pressures (mb)
4806 ! Dimensions: (nlayers)
4807 real(kind=rb), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2)
4808 ! Dimensions: (maxxsec,nlayers)
4809 real(kind=rb), intent(in) :: coldry(:) ! column amount (dry air)
4810 ! Dimensions: (nlayers)
4812 integer(kind=im), intent(in) :: laytrop ! tropopause layer index
4813 integer(kind=im), intent(in) :: jp(:) !
4814 ! Dimensions: (nlayers)
4815 integer(kind=im), intent(in) :: jt(:) !
4816 ! Dimensions: (nlayers)
4817 integer(kind=im), intent(in) :: jt1(:) !
4818 ! Dimensions: (nlayers)
4819 real(kind=rb), intent(in) :: planklay(:,:) !
4820 ! Dimensions: (nlayers,nbndlw)
4821 real(kind=rb), intent(in) :: planklev(0:,:) !
4822 ! Dimensions: (nlayers,nbndlw)
4823 real(kind=rb), intent(in) :: plankbnd(:) !
4824 ! Dimensions: (nbndlw)
4826 real(kind=rb), intent(in) :: colh2o(:) ! column amount (h2o)
4827 ! Dimensions: (nlayers)
4828 real(kind=rb), intent(in) :: colco2(:) ! column amount (co2)
4829 ! Dimensions: (nlayers)
4830 real(kind=rb), intent(in) :: colo3(:) ! column amount (o3)
4831 ! Dimensions: (nlayers)
4832 real(kind=rb), intent(in) :: coln2o(:) ! column amount (n2o)
4833 ! Dimensions: (nlayers)
4834 real(kind=rb), intent(in) :: colco(:) ! column amount (co)
4835 ! Dimensions: (nlayers)
4836 real(kind=rb), intent(in) :: colch4(:) ! column amount (ch4)
4837 ! Dimensions: (nlayers)
4838 real(kind=rb), intent(in) :: colo2(:) ! column amount (o2)
4839 ! Dimensions: (nlayers)
4840 real(kind=rb), intent(in) :: colbrd(:) ! column amount (broadening gases)
4841 ! Dimensions: (nlayers)
4843 integer(kind=im), intent(in) :: indself(:)
4844 ! Dimensions: (nlayers)
4845 integer(kind=im), intent(in) :: indfor(:)
4846 ! Dimensions: (nlayers)
4847 real(kind=rb), intent(in) :: selffac(:)
4848 ! Dimensions: (nlayers)
4849 real(kind=rb), intent(in) :: selffrac(:)
4850 ! Dimensions: (nlayers)
4851 real(kind=rb), intent(in) :: forfac(:)
4852 ! Dimensions: (nlayers)
4853 real(kind=rb), intent(in) :: forfrac(:)
4854 ! Dimensions: (nlayers)
4856 integer(kind=im), intent(in) :: indminor(:)
4857 ! Dimensions: (nlayers)
4858 real(kind=rb), intent(in) :: minorfrac(:)
4859 ! Dimensions: (nlayers)
4860 real(kind=rb), intent(in) :: scaleminor(:)
4861 ! Dimensions: (nlayers)
4862 real(kind=rb), intent(in) :: scaleminorn2(:)
4863 ! Dimensions: (nlayers)
4865 real(kind=rb), intent(in) :: & !
4866 fac00(:), fac01(:), & ! Dimensions: (nlayers)
4867 fac10(:), fac11(:)
4868 real(kind=rb), intent(in) :: & !
4869 rat_h2oco2(:),rat_h2oco2_1(:), &
4870 rat_h2oo3(:),rat_h2oo3_1(:), & ! Dimensions: (nlayers)
4871 rat_h2on2o(:),rat_h2on2o_1(:), &
4872 rat_h2och4(:),rat_h2och4_1(:), &
4873 rat_n2oco2(:),rat_n2oco2_1(:), &
4874 rat_o3co2(:),rat_o3co2_1(:)
4876 ! ----- Output -----
4877 real(kind=rb), intent(out) :: fracs(:,:) ! planck fractions
4878 ! Dimensions: (nlayers,ngptlw)
4879 real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth
4880 ! Dimensions: (nlayers,ngptlw)
4882 hvrtau = '$Revision: 1.7 $'
4884 ! Calculate gaseous optical depth and planck fractions for each spectral band.
4886 call taugb1
4887 call taugb2
4888 call taugb3
4889 call taugb4
4890 call taugb5
4891 call taugb6
4892 call taugb7
4893 call taugb8
4894 call taugb9
4895 call taugb10
4896 call taugb11
4897 call taugb12
4898 call taugb13
4899 call taugb14
4900 call taugb15
4901 call taugb16
4903 contains
4905 !----------------------------------------------------------------------------
4906 subroutine taugb1
4907 !----------------------------------------------------------------------------
4909 ! ------- Modifications -------
4910 ! Written by Eli J. Mlawer, Atmospheric & Environmental Research.
4911 ! Revised by Michael J. Iacono, Atmospheric & Environmental Research.
4912 !
4913 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
4914 ! (high key - h2o; high minor - n2)
4915 !
4916 ! note: previous versions of rrtm band 1:
4917 ! 10-250 cm-1 (low - h2o; high - h2o)
4918 !----------------------------------------------------------------------------
4920 ! ------- Modules -------
4922 use parrrtm, only : ng1
4923 use rrlw_kg01, only : fracrefa, fracrefb, absa, ka, absb, kb, &
4924 ka_mn2, kb_mn2, selfref, forref
4926 ! ------- Declarations -------
4928 ! Local
4929 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
4930 real(kind=rb) :: pp, corradj, scalen2, tauself, taufor, taun2
4933 ! Minor gas mapping levels:
4934 ! lower - n2, p = 142.5490 mbar, t = 215.70 k
4935 ! upper - n2, p = 142.5490 mbar, t = 215.70 k
4937 ! Compute the optical depth by interpolating in ln(pressure) and
4938 ! temperature. Below laytrop, the water vapor self-continuum and
4939 ! foreign continuum is interpolated (in temperature) separately.
4941 ! Lower atmosphere loop
4942 do lay = 1, laytrop
4944 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1
4945 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1
4946 inds = indself(lay)
4947 indf = indfor(lay)
4948 indm = indminor(lay)
4949 pp = pavel(lay)
4950 corradj = 1.
4951 if (pp .lt. 250._rb) then
4952 corradj = 1._rb - 0.15_rb * (250._rb-pp) / 154.4_rb
4953 endif
4955 scalen2 = colbrd(lay) * scaleminorn2(lay)
4956 do ig = 1, ng1
4957 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
4958 (selfref(inds+1,ig) - selfref(inds,ig)))
4959 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
4960 (forref(indf+1,ig) - forref(indf,ig)))
4961 taun2 = scalen2*(ka_mn2(indm,ig) + &
4962 minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig)))
4963 taug(lay,ig) = corradj * (colh2o(lay) * &
4964 (fac00(lay) * absa(ind0,ig) + &
4965 fac10(lay) * absa(ind0+1,ig) + &
4966 fac01(lay) * absa(ind1,ig) + &
4967 fac11(lay) * absa(ind1+1,ig)) &
4968 + tauself + taufor + taun2)
4969 fracs(lay,ig) = fracrefa(ig)
4970 enddo
4971 enddo
4973 ! Upper atmosphere loop
4974 do lay = laytrop+1, nlayers
4976 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1
4977 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1
4978 indf = indfor(lay)
4979 indm = indminor(lay)
4980 pp = pavel(lay)
4981 corradj = 1._rb - 0.15_rb * (pp / 95.6_rb)
4983 scalen2 = colbrd(lay) * scaleminorn2(lay)
4984 do ig = 1, ng1
4985 taufor = forfac(lay) * (forref(indf,ig) + &
4986 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
4987 taun2 = scalen2*(kb_mn2(indm,ig) + &
4988 minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig)))
4989 taug(lay,ig) = corradj * (colh2o(lay) * &
4990 (fac00(lay) * absb(ind0,ig) + &
4991 fac10(lay) * absb(ind0+1,ig) + &
4992 fac01(lay) * absb(ind1,ig) + &
4993 fac11(lay) * absb(ind1+1,ig)) &
4994 + taufor + taun2)
4995 fracs(lay,ig) = fracrefb(ig)
4996 enddo
4997 enddo
4999 end subroutine taugb1
5001 !----------------------------------------------------------------------------
5002 subroutine taugb2
5003 !----------------------------------------------------------------------------
5004 !
5005 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
5006 !
5007 ! note: previous version of rrtm band 2:
5008 ! 250 - 500 cm-1 (low - h2o; high - h2o)
5009 !----------------------------------------------------------------------------
5011 ! ------- Modules -------
5013 use parrrtm, only : ng2, ngs1
5014 use rrlw_kg02, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5015 selfref, forref
5017 ! ------- Declarations -------
5019 ! Local
5020 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5021 real(kind=rb) :: pp, corradj, tauself, taufor
5024 ! Compute the optical depth by interpolating in ln(pressure) and
5025 ! temperature. Below laytrop, the water vapor self-continuum and
5026 ! foreign continuum is interpolated (in temperature) separately.
5028 ! Lower atmosphere loop
5029 do lay = 1, laytrop
5031 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
5032 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
5033 inds = indself(lay)
5034 indf = indfor(lay)
5035 pp = pavel(lay)
5036 corradj = 1._rb - .05_rb * (pp - 100._rb) / 900._rb
5037 do ig = 1, ng2
5038 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5039 (selfref(inds+1,ig) - selfref(inds,ig)))
5040 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5041 (forref(indf+1,ig) - forref(indf,ig)))
5042 taug(lay,ngs1+ig) = corradj * (colh2o(lay) * &
5043 (fac00(lay) * absa(ind0,ig) + &
5044 fac10(lay) * absa(ind0+1,ig) + &
5045 fac01(lay) * absa(ind1,ig) + &
5046 fac11(lay) * absa(ind1+1,ig)) &
5047 + tauself + taufor)
5048 fracs(lay,ngs1+ig) = fracrefa(ig)
5049 enddo
5050 enddo
5052 ! Upper atmosphere loop
5053 do lay = laytrop+1, nlayers
5055 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
5056 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
5057 indf = indfor(lay)
5058 do ig = 1, ng2
5059 taufor = forfac(lay) * (forref(indf,ig) + &
5060 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5061 taug(lay,ngs1+ig) = colh2o(lay) * &
5062 (fac00(lay) * absb(ind0,ig) + &
5063 fac10(lay) * absb(ind0+1,ig) + &
5064 fac01(lay) * absb(ind1,ig) + &
5065 fac11(lay) * absb(ind1+1,ig)) &
5066 + taufor
5067 fracs(lay,ngs1+ig) = fracrefb(ig)
5068 enddo
5069 enddo
5071 end subroutine taugb2
5073 !----------------------------------------------------------------------------
5074 subroutine taugb3
5075 !----------------------------------------------------------------------------
5076 !
5077 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
5078 ! (high key - h2o,co2; high minor - n2o)
5079 !----------------------------------------------------------------------------
5081 ! ------- Modules -------
5083 use parrrtm, only : ng3, ngs2
5084 use rrlw_ref, only : chi_mls
5085 use rrlw_kg03, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5086 ka_mn2o, kb_mn2o, selfref, forref
5088 ! ------- Declarations -------
5090 ! Local
5091 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5092 integer(kind=im) :: js, js1, jmn2o, jpl
5093 real(kind=rb) :: speccomb, specparm, specmult, fs
5094 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5095 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, &
5096 fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
5097 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5098 real(kind=rb) :: p, p4, fk0, fk1, fk2
5099 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5100 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5101 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
5102 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
5103 real(kind=rb) :: tau_major, tau_major1
5106 ! Minor gas mapping levels:
5107 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
5108 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
5110 ! P = 212.725 mb
5111 refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
5113 ! P = 95.58 mb
5114 refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
5116 ! P = 706.270mb
5117 refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
5119 ! P = 95.58 mb
5120 refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
5122 ! Compute the optical depth by interpolating in ln(pressure) and
5123 ! temperature, and appropriate species. Below laytrop, the water vapor
5124 ! self-continuum and foreign continuum is interpolated (in temperature)
5125 ! separately.
5127 ! Lower atmosphere loop
5128 do lay = 1, laytrop
5130 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5131 specparm = colh2o(lay)/speccomb
5132 if (specparm .ge. oneminus) specparm = oneminus
5133 specmult = 8._rb*(specparm)
5134 js = 1 + int(specmult)
5135 fs = mod(specmult,1.0_rb)
5137 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5138 specparm1 = colh2o(lay)/speccomb1
5139 if (specparm1 .ge. oneminus) specparm1 = oneminus
5140 specmult1 = 8._rb*(specparm1)
5141 js1 = 1 + int(specmult1)
5142 fs1 = mod(specmult1,1.0_rb)
5144 speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay)
5145 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5146 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5147 specmult_mn2o = 8._rb*specparm_mn2o
5148 jmn2o = 1 + int(specmult_mn2o)
5149 fmn2o = mod(specmult_mn2o,1.0_rb)
5150 fmn2omf = minorfrac(lay)*fmn2o
5151 ! In atmospheres where the amount of N2O is too great to be considered
5152 ! a minor species, adjust the column amount of N2O by an empirical factor
5153 ! to obtain the proper contribution.
5154 chi_n2o = coln2o(lay)/coldry(lay)
5155 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
5156 if (ratn2o .gt. 1.5_rb) then
5157 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5158 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5159 else
5160 adjcoln2o = coln2o(lay)
5161 endif
5163 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5164 specparm_planck = colh2o(lay)/speccomb_planck
5165 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5166 specmult_planck = 8._rb*specparm_planck
5167 jpl= 1 + int(specmult_planck)
5168 fpl = mod(specmult_planck,1.0_rb)
5170 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js
5171 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1
5172 inds = indself(lay)
5173 indf = indfor(lay)
5174 indm = indminor(lay)
5176 if (specparm .lt. 0.125_rb) then
5177 p = fs - 1
5178 p4 = p**4
5179 fk0 = p4
5180 fk1 = 1 - p - 2.0_rb*p4
5181 fk2 = p + p4
5182 fac000 = fk0*fac00(lay)
5183 fac100 = fk1*fac00(lay)
5184 fac200 = fk2*fac00(lay)
5185 fac010 = fk0*fac10(lay)
5186 fac110 = fk1*fac10(lay)
5187 fac210 = fk2*fac10(lay)
5188 else if (specparm .gt. 0.875_rb) then
5189 p = -fs
5190 p4 = p**4
5191 fk0 = p4
5192 fk1 = 1 - p - 2.0_rb*p4
5193 fk2 = p + p4
5194 fac000 = fk0*fac00(lay)
5195 fac100 = fk1*fac00(lay)
5196 fac200 = fk2*fac00(lay)
5197 fac010 = fk0*fac10(lay)
5198 fac110 = fk1*fac10(lay)
5199 fac210 = fk2*fac10(lay)
5200 else
5201 fac000 = (1._rb - fs) * fac00(lay)
5202 fac010 = (1._rb - fs) * fac10(lay)
5203 fac100 = fs * fac00(lay)
5204 fac110 = fs * fac10(lay)
5205 endif
5206 if (specparm1 .lt. 0.125_rb) then
5207 p = fs1 - 1
5208 p4 = p**4
5209 fk0 = p4
5210 fk1 = 1 - p - 2.0_rb*p4
5211 fk2 = p + p4
5212 fac001 = fk0*fac01(lay)
5213 fac101 = fk1*fac01(lay)
5214 fac201 = fk2*fac01(lay)
5215 fac011 = fk0*fac11(lay)
5216 fac111 = fk1*fac11(lay)
5217 fac211 = fk2*fac11(lay)
5218 else if (specparm1 .gt. 0.875_rb) then
5219 p = -fs1
5220 p4 = p**4
5221 fk0 = p4
5222 fk1 = 1 - p - 2.0_rb*p4
5223 fk2 = p + p4
5224 fac001 = fk0*fac01(lay)
5225 fac101 = fk1*fac01(lay)
5226 fac201 = fk2*fac01(lay)
5227 fac011 = fk0*fac11(lay)
5228 fac111 = fk1*fac11(lay)
5229 fac211 = fk2*fac11(lay)
5230 else
5231 fac001 = (1._rb - fs1) * fac01(lay)
5232 fac011 = (1._rb - fs1) * fac11(lay)
5233 fac101 = fs1 * fac01(lay)
5234 fac111 = fs1 * fac11(lay)
5235 endif
5237 do ig = 1, ng3
5238 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5239 (selfref(inds+1,ig) - selfref(inds,ig)))
5240 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5241 (forref(indf+1,ig) - forref(indf,ig)))
5242 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
5243 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
5244 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5245 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
5246 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5248 if (specparm .lt. 0.125_rb) then
5249 tau_major = speccomb * &
5250 (fac000 * absa(ind0,ig) + &
5251 fac100 * absa(ind0+1,ig) + &
5252 fac200 * absa(ind0+2,ig) + &
5253 fac010 * absa(ind0+9,ig) + &
5254 fac110 * absa(ind0+10,ig) + &
5255 fac210 * absa(ind0+11,ig))
5256 else if (specparm .gt. 0.875_rb) then
5257 tau_major = speccomb * &
5258 (fac200 * absa(ind0-1,ig) + &
5259 fac100 * absa(ind0,ig) + &
5260 fac000 * absa(ind0+1,ig) + &
5261 fac210 * absa(ind0+8,ig) + &
5262 fac110 * absa(ind0+9,ig) + &
5263 fac010 * absa(ind0+10,ig))
5264 else
5265 tau_major = speccomb * &
5266 (fac000 * absa(ind0,ig) + &
5267 fac100 * absa(ind0+1,ig) + &
5268 fac010 * absa(ind0+9,ig) + &
5269 fac110 * absa(ind0+10,ig))
5270 endif
5272 if (specparm1 .lt. 0.125_rb) then
5273 tau_major1 = speccomb1 * &
5274 (fac001 * absa(ind1,ig) + &
5275 fac101 * absa(ind1+1,ig) + &
5276 fac201 * absa(ind1+2,ig) + &
5277 fac011 * absa(ind1+9,ig) + &
5278 fac111 * absa(ind1+10,ig) + &
5279 fac211 * absa(ind1+11,ig))
5280 else if (specparm1 .gt. 0.875_rb) then
5281 tau_major1 = speccomb1 * &
5282 (fac201 * absa(ind1-1,ig) + &
5283 fac101 * absa(ind1,ig) + &
5284 fac001 * absa(ind1+1,ig) + &
5285 fac211 * absa(ind1+8,ig) + &
5286 fac111 * absa(ind1+9,ig) + &
5287 fac011 * absa(ind1+10,ig))
5288 else
5289 tau_major1 = speccomb1 * &
5290 (fac001 * absa(ind1,ig) + &
5291 fac101 * absa(ind1+1,ig) + &
5292 fac011 * absa(ind1+9,ig) + &
5293 fac111 * absa(ind1+10,ig))
5294 endif
5296 taug(lay,ngs2+ig) = tau_major + tau_major1 &
5297 + tauself + taufor &
5298 + adjcoln2o*absn2o
5299 fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
5300 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5301 enddo
5302 enddo
5304 ! Upper atmosphere loop
5305 do lay = laytrop+1, nlayers
5307 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5308 specparm = colh2o(lay)/speccomb
5309 if (specparm .ge. oneminus) specparm = oneminus
5310 specmult = 4._rb*(specparm)
5311 js = 1 + int(specmult)
5312 fs = mod(specmult,1.0_rb)
5314 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5315 specparm1 = colh2o(lay)/speccomb1
5316 if (specparm1 .ge. oneminus) specparm1 = oneminus
5317 specmult1 = 4._rb*(specparm1)
5318 js1 = 1 + int(specmult1)
5319 fs1 = mod(specmult1,1.0_rb)
5321 fac000 = (1._rb - fs) * fac00(lay)
5322 fac010 = (1._rb - fs) * fac10(lay)
5323 fac100 = fs * fac00(lay)
5324 fac110 = fs * fac10(lay)
5325 fac001 = (1._rb - fs1) * fac01(lay)
5326 fac011 = (1._rb - fs1) * fac11(lay)
5327 fac101 = fs1 * fac01(lay)
5328 fac111 = fs1 * fac11(lay)
5330 speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay)
5331 specparm_mn2o = colh2o(lay)/speccomb_mn2o
5332 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
5333 specmult_mn2o = 4._rb*specparm_mn2o
5334 jmn2o = 1 + int(specmult_mn2o)
5335 fmn2o = mod(specmult_mn2o,1.0_rb)
5336 fmn2omf = minorfrac(lay)*fmn2o
5337 ! In atmospheres where the amount of N2O is too great to be considered
5338 ! a minor species, adjust the column amount of N2O by an empirical factor
5339 ! to obtain the proper contribution.
5340 chi_n2o = coln2o(lay)/coldry(lay)
5341 ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1)
5342 if (ratn2o .gt. 1.5_rb) then
5343 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5344 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5345 else
5346 adjcoln2o = coln2o(lay)
5347 endif
5349 speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay)
5350 specparm_planck = colh2o(lay)/speccomb_planck
5351 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5352 specmult_planck = 4._rb*specparm_planck
5353 jpl= 1 + int(specmult_planck)
5354 fpl = mod(specmult_planck,1.0_rb)
5356 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
5357 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1
5358 indf = indfor(lay)
5359 indm = indminor(lay)
5361 do ig = 1, ng3
5362 taufor = forfac(lay) * (forref(indf,ig) + &
5363 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig)))
5364 n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * &
5365 (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig))
5366 n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * &
5367 (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig))
5368 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
5369 taug(lay,ngs2+ig) = speccomb * &
5370 (fac000 * absb(ind0,ig) + &
5371 fac100 * absb(ind0+1,ig) + &
5372 fac010 * absb(ind0+5,ig) + &
5373 fac110 * absb(ind0+6,ig)) &
5374 + speccomb1 * &
5375 (fac001 * absb(ind1,ig) + &
5376 fac101 * absb(ind1+1,ig) + &
5377 fac011 * absb(ind1+5,ig) + &
5378 fac111 * absb(ind1+6,ig)) &
5379 + taufor &
5380 + adjcoln2o*absn2o
5381 fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * &
5382 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5383 enddo
5384 enddo
5386 end subroutine taugb3
5388 !----------------------------------------------------------------------------
5389 subroutine taugb4
5390 !----------------------------------------------------------------------------
5391 !
5392 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
5393 !----------------------------------------------------------------------------
5395 ! ------- Modules -------
5397 use parrrtm, only : ng4, ngs3
5398 use rrlw_ref, only : chi_mls
5399 use rrlw_kg04, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5400 selfref, forref
5402 ! ------- Declarations -------
5404 ! Local
5405 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5406 integer(kind=im) :: js, js1, jpl
5407 real(kind=rb) :: speccomb, specparm, specmult, fs
5408 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5409 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5410 real(kind=rb) :: p, p4, fk0, fk1, fk2
5411 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5412 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5413 real(kind=rb) :: tauself, taufor
5414 real(kind=rb) :: refrat_planck_a, refrat_planck_b
5415 real(kind=rb) :: tau_major, tau_major1
5418 ! P = 142.5940 mb
5419 refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
5421 ! P = 95.58350 mb
5422 refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
5424 ! Compute the optical depth by interpolating in ln(pressure) and
5425 ! temperature, and appropriate species. Below laytrop, the water
5426 ! vapor self-continuum and foreign continuum is interpolated (in temperature)
5427 ! separately.
5429 ! Lower atmosphere loop
5430 do lay = 1, laytrop
5432 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5433 specparm = colh2o(lay)/speccomb
5434 if (specparm .ge. oneminus) specparm = oneminus
5435 specmult = 8._rb*(specparm)
5436 js = 1 + int(specmult)
5437 fs = mod(specmult,1.0_rb)
5439 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5440 specparm1 = colh2o(lay)/speccomb1
5441 if (specparm1 .ge. oneminus) specparm1 = oneminus
5442 specmult1 = 8._rb*(specparm1)
5443 js1 = 1 + int(specmult1)
5444 fs1 = mod(specmult1,1.0_rb)
5446 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5447 specparm_planck = colh2o(lay)/speccomb_planck
5448 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5449 specmult_planck = 8._rb*specparm_planck
5450 jpl= 1 + int(specmult_planck)
5451 fpl = mod(specmult_planck,1.0_rb)
5453 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js
5454 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1
5455 inds = indself(lay)
5456 indf = indfor(lay)
5458 if (specparm .lt. 0.125_rb) then
5459 p = fs - 1
5460 p4 = p**4
5461 fk0 = p4
5462 fk1 = 1 - p - 2.0_rb*p4
5463 fk2 = p + p4
5464 fac000 = fk0*fac00(lay)
5465 fac100 = fk1*fac00(lay)
5466 fac200 = fk2*fac00(lay)
5467 fac010 = fk0*fac10(lay)
5468 fac110 = fk1*fac10(lay)
5469 fac210 = fk2*fac10(lay)
5470 else if (specparm .gt. 0.875_rb) then
5471 p = -fs
5472 p4 = p**4
5473 fk0 = p4
5474 fk1 = 1 - p - 2.0_rb*p4
5475 fk2 = p + p4
5476 fac000 = fk0*fac00(lay)
5477 fac100 = fk1*fac00(lay)
5478 fac200 = fk2*fac00(lay)
5479 fac010 = fk0*fac10(lay)
5480 fac110 = fk1*fac10(lay)
5481 fac210 = fk2*fac10(lay)
5482 else
5483 fac000 = (1._rb - fs) * fac00(lay)
5484 fac010 = (1._rb - fs) * fac10(lay)
5485 fac100 = fs * fac00(lay)
5486 fac110 = fs * fac10(lay)
5487 endif
5489 if (specparm1 .lt. 0.125_rb) then
5490 p = fs1 - 1
5491 p4 = p**4
5492 fk0 = p4
5493 fk1 = 1 - p - 2.0_rb*p4
5494 fk2 = p + p4
5495 fac001 = fk0*fac01(lay)
5496 fac101 = fk1*fac01(lay)
5497 fac201 = fk2*fac01(lay)
5498 fac011 = fk0*fac11(lay)
5499 fac111 = fk1*fac11(lay)
5500 fac211 = fk2*fac11(lay)
5501 else if (specparm1 .gt. 0.875_rb) then
5502 p = -fs1
5503 p4 = p**4
5504 fk0 = p4
5505 fk1 = 1 - p - 2.0_rb*p4
5506 fk2 = p + p4
5507 fac001 = fk0*fac01(lay)
5508 fac101 = fk1*fac01(lay)
5509 fac201 = fk2*fac01(lay)
5510 fac011 = fk0*fac11(lay)
5511 fac111 = fk1*fac11(lay)
5512 fac211 = fk2*fac11(lay)
5513 else
5514 fac001 = (1._rb - fs1) * fac01(lay)
5515 fac011 = (1._rb - fs1) * fac11(lay)
5516 fac101 = fs1 * fac01(lay)
5517 fac111 = fs1 * fac11(lay)
5518 endif
5520 do ig = 1, ng4
5521 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
5522 (selfref(inds+1,ig) - selfref(inds,ig)))
5523 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5524 (forref(indf+1,ig) - forref(indf,ig)))
5526 if (specparm .lt. 0.125_rb) then
5527 tau_major = speccomb * &
5528 (fac000 * absa(ind0,ig) + &
5529 fac100 * absa(ind0+1,ig) + &
5530 fac200 * absa(ind0+2,ig) + &
5531 fac010 * absa(ind0+9,ig) + &
5532 fac110 * absa(ind0+10,ig) + &
5533 fac210 * absa(ind0+11,ig))
5534 else if (specparm .gt. 0.875_rb) then
5535 tau_major = speccomb * &
5536 (fac200 * absa(ind0-1,ig) + &
5537 fac100 * absa(ind0,ig) + &
5538 fac000 * absa(ind0+1,ig) + &
5539 fac210 * absa(ind0+8,ig) + &
5540 fac110 * absa(ind0+9,ig) + &
5541 fac010 * absa(ind0+10,ig))
5542 else
5543 tau_major = speccomb * &
5544 (fac000 * absa(ind0,ig) + &
5545 fac100 * absa(ind0+1,ig) + &
5546 fac010 * absa(ind0+9,ig) + &
5547 fac110 * absa(ind0+10,ig))
5548 endif
5550 if (specparm1 .lt. 0.125_rb) then
5551 tau_major1 = speccomb1 * &
5552 (fac001 * absa(ind1,ig) + &
5553 fac101 * absa(ind1+1,ig) + &
5554 fac201 * absa(ind1+2,ig) + &
5555 fac011 * absa(ind1+9,ig) + &
5556 fac111 * absa(ind1+10,ig) + &
5557 fac211 * absa(ind1+11,ig))
5558 else if (specparm1 .gt. 0.875_rb) then
5559 tau_major1 = speccomb1 * &
5560 (fac201 * absa(ind1-1,ig) + &
5561 fac101 * absa(ind1,ig) + &
5562 fac001 * absa(ind1+1,ig) + &
5563 fac211 * absa(ind1+8,ig) + &
5564 fac111 * absa(ind1+9,ig) + &
5565 fac011 * absa(ind1+10,ig))
5566 else
5567 tau_major1 = speccomb1 * &
5568 (fac001 * absa(ind1,ig) + &
5569 fac101 * absa(ind1+1,ig) + &
5570 fac011 * absa(ind1+9,ig) + &
5571 fac111 * absa(ind1+10,ig))
5572 endif
5574 taug(lay,ngs3+ig) = tau_major + tau_major1 &
5575 + tauself + taufor
5576 fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
5577 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5578 enddo
5579 enddo
5581 ! Upper atmosphere loop
5582 do lay = laytrop+1, nlayers
5584 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
5585 specparm = colo3(lay)/speccomb
5586 if (specparm .ge. oneminus) specparm = oneminus
5587 specmult = 4._rb*(specparm)
5588 js = 1 + int(specmult)
5589 fs = mod(specmult,1.0_rb)
5591 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
5592 specparm1 = colo3(lay)/speccomb1
5593 if (specparm1 .ge. oneminus) specparm1 = oneminus
5594 specmult1 = 4._rb*(specparm1)
5595 js1 = 1 + int(specmult1)
5596 fs1 = mod(specmult1,1.0_rb)
5598 fac000 = (1._rb - fs) * fac00(lay)
5599 fac010 = (1._rb - fs) * fac10(lay)
5600 fac100 = fs * fac00(lay)
5601 fac110 = fs * fac10(lay)
5602 fac001 = (1._rb - fs1) * fac01(lay)
5603 fac011 = (1._rb - fs1) * fac11(lay)
5604 fac101 = fs1 * fac01(lay)
5605 fac111 = fs1 * fac11(lay)
5607 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5608 specparm_planck = colo3(lay)/speccomb_planck
5609 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5610 specmult_planck = 4._rb*specparm_planck
5611 jpl= 1 + int(specmult_planck)
5612 fpl = mod(specmult_planck,1.0_rb)
5614 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js
5615 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1
5617 do ig = 1, ng4
5618 taug(lay,ngs3+ig) = speccomb * &
5619 (fac000 * absb(ind0,ig) + &
5620 fac100 * absb(ind0+1,ig) + &
5621 fac010 * absb(ind0+5,ig) + &
5622 fac110 * absb(ind0+6,ig)) &
5623 + speccomb1 * &
5624 (fac001 * absb(ind1,ig) + &
5625 fac101 * absb(ind1+1,ig) + &
5626 fac011 * absb(ind1+5,ig) + &
5627 fac111 * absb(ind1+6,ig))
5628 fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * &
5629 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5630 enddo
5632 ! Empirical modification to code to improve stratospheric cooling rates
5633 ! for co2. Revised to apply weighting for g-point reduction in this band.
5635 taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92
5636 taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88
5637 taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07
5638 taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1
5639 taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99
5640 taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88
5641 taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943
5643 enddo
5645 end subroutine taugb4
5647 !----------------------------------------------------------------------------
5648 subroutine taugb5
5649 !----------------------------------------------------------------------------
5650 !
5651 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
5652 ! (high key - o3,co2)
5653 !----------------------------------------------------------------------------
5655 ! ------- Modules -------
5657 use parrrtm, only : ng5, ngs4
5658 use rrlw_ref, only : chi_mls
5659 use rrlw_kg05, only : fracrefa, fracrefb, absa, ka, absb, kb, &
5660 ka_mo3, selfref, forref, ccl4
5662 ! ------- Declarations -------
5664 ! Local
5665 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5666 integer(kind=im) :: js, js1, jmo3, jpl
5667 real(kind=rb) :: speccomb, specparm, specmult, fs
5668 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
5669 real(kind=rb) :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
5670 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
5671 real(kind=rb) :: p, p4, fk0, fk1, fk2
5672 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
5673 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
5674 real(kind=rb) :: tauself, taufor, o3m1, o3m2, abso3
5675 real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a
5676 real(kind=rb) :: tau_major, tau_major1
5679 ! Minor gas mapping level :
5680 ! lower - o3, p = 317.34 mbar, t = 240.77 k
5681 ! lower - ccl4
5683 ! Calculate reference ratio to be used in calculation of Planck
5684 ! fraction in lower/upper atmosphere.
5686 ! P = 473.420 mb
5687 refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
5689 ! P = 0.2369 mb
5690 refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
5692 ! P = 317.3480
5693 refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
5695 ! Compute the optical depth by interpolating in ln(pressure) and
5696 ! temperature, and appropriate species. Below laytrop, the
5697 ! water vapor self-continuum and foreign continuum is
5698 ! interpolated (in temperature) separately.
5700 ! Lower atmosphere loop
5701 do lay = 1, laytrop
5703 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
5704 specparm = colh2o(lay)/speccomb
5705 if (specparm .ge. oneminus) specparm = oneminus
5706 specmult = 8._rb*(specparm)
5707 js = 1 + int(specmult)
5708 fs = mod(specmult,1.0_rb)
5710 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5711 specparm1 = colh2o(lay)/speccomb1
5712 if (specparm1 .ge. oneminus) specparm1 = oneminus
5713 specmult1 = 8._rb*(specparm1)
5714 js1 = 1 + int(specmult1)
5715 fs1 = mod(specmult1,1.0_rb)
5717 speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay)
5718 specparm_mo3 = colh2o(lay)/speccomb_mo3
5719 if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus
5720 specmult_mo3 = 8._rb*specparm_mo3
5721 jmo3 = 1 + int(specmult_mo3)
5722 fmo3 = mod(specmult_mo3,1.0_rb)
5724 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5725 specparm_planck = colh2o(lay)/speccomb_planck
5726 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5727 specmult_planck = 8._rb*specparm_planck
5728 jpl= 1 + int(specmult_planck)
5729 fpl = mod(specmult_planck,1.0_rb)
5731 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js
5732 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1
5733 inds = indself(lay)
5734 indf = indfor(lay)
5735 indm = indminor(lay)
5737 if (specparm .lt. 0.125_rb) then
5738 p = fs - 1
5739 p4 = p**4
5740 fk0 = p4
5741 fk1 = 1 - p - 2.0_rb*p4
5742 fk2 = p + p4
5743 fac000 = fk0*fac00(lay)
5744 fac100 = fk1*fac00(lay)
5745 fac200 = fk2*fac00(lay)
5746 fac010 = fk0*fac10(lay)
5747 fac110 = fk1*fac10(lay)
5748 fac210 = fk2*fac10(lay)
5749 else if (specparm .gt. 0.875_rb) then
5750 p = -fs
5751 p4 = p**4
5752 fk0 = p4
5753 fk1 = 1 - p - 2.0_rb*p4
5754 fk2 = p + p4
5755 fac000 = fk0*fac00(lay)
5756 fac100 = fk1*fac00(lay)
5757 fac200 = fk2*fac00(lay)
5758 fac010 = fk0*fac10(lay)
5759 fac110 = fk1*fac10(lay)
5760 fac210 = fk2*fac10(lay)
5761 else
5762 fac000 = (1._rb - fs) * fac00(lay)
5763 fac010 = (1._rb - fs) * fac10(lay)
5764 fac100 = fs * fac00(lay)
5765 fac110 = fs * fac10(lay)
5766 endif
5768 if (specparm1 .lt. 0.125_rb) then
5769 p = fs1 - 1
5770 p4 = p**4
5771 fk0 = p4
5772 fk1 = 1 - p - 2.0_rb*p4
5773 fk2 = p + p4
5774 fac001 = fk0*fac01(lay)
5775 fac101 = fk1*fac01(lay)
5776 fac201 = fk2*fac01(lay)
5777 fac011 = fk0*fac11(lay)
5778 fac111 = fk1*fac11(lay)
5779 fac211 = fk2*fac11(lay)
5780 else if (specparm1 .gt. 0.875_rb) then
5781 p = -fs1
5782 p4 = p**4
5783 fk0 = p4
5784 fk1 = 1 - p - 2.0_rb*p4
5785 fk2 = p + p4
5786 fac001 = fk0*fac01(lay)
5787 fac101 = fk1*fac01(lay)
5788 fac201 = fk2*fac01(lay)
5789 fac011 = fk0*fac11(lay)
5790 fac111 = fk1*fac11(lay)
5791 fac211 = fk2*fac11(lay)
5792 else
5793 fac001 = (1._rb - fs1) * fac01(lay)
5794 fac011 = (1._rb - fs1) * fac11(lay)
5795 fac101 = fs1 * fac01(lay)
5796 fac111 = fs1 * fac11(lay)
5797 endif
5799 do ig = 1, ng5
5800 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5801 (selfref(inds+1,ig) - selfref(inds,ig)))
5802 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5803 (forref(indf+1,ig) - forref(indf,ig)))
5804 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
5805 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
5806 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
5807 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
5808 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
5810 if (specparm .lt. 0.125_rb) then
5811 tau_major = speccomb * &
5812 (fac000 * absa(ind0,ig) + &
5813 fac100 * absa(ind0+1,ig) + &
5814 fac200 * absa(ind0+2,ig) + &
5815 fac010 * absa(ind0+9,ig) + &
5816 fac110 * absa(ind0+10,ig) + &
5817 fac210 * absa(ind0+11,ig))
5818 else if (specparm .gt. 0.875_rb) then
5819 tau_major = speccomb * &
5820 (fac200 * absa(ind0-1,ig) + &
5821 fac100 * absa(ind0,ig) + &
5822 fac000 * absa(ind0+1,ig) + &
5823 fac210 * absa(ind0+8,ig) + &
5824 fac110 * absa(ind0+9,ig) + &
5825 fac010 * absa(ind0+10,ig))
5826 else
5827 tau_major = speccomb * &
5828 (fac000 * absa(ind0,ig) + &
5829 fac100 * absa(ind0+1,ig) + &
5830 fac010 * absa(ind0+9,ig) + &
5831 fac110 * absa(ind0+10,ig))
5832 endif
5834 if (specparm1 .lt. 0.125_rb) then
5835 tau_major1 = speccomb1 * &
5836 (fac001 * absa(ind1,ig) + &
5837 fac101 * absa(ind1+1,ig) + &
5838 fac201 * absa(ind1+2,ig) + &
5839 fac011 * absa(ind1+9,ig) + &
5840 fac111 * absa(ind1+10,ig) + &
5841 fac211 * absa(ind1+11,ig))
5842 else if (specparm1 .gt. 0.875_rb) then
5843 tau_major1 = speccomb1 * &
5844 (fac201 * absa(ind1-1,ig) + &
5845 fac101 * absa(ind1,ig) + &
5846 fac001 * absa(ind1+1,ig) + &
5847 fac211 * absa(ind1+8,ig) + &
5848 fac111 * absa(ind1+9,ig) + &
5849 fac011 * absa(ind1+10,ig))
5850 else
5851 tau_major1 = speccomb1 * &
5852 (fac001 * absa(ind1,ig) + &
5853 fac101 * absa(ind1+1,ig) + &
5854 fac011 * absa(ind1+9,ig) + &
5855 fac111 * absa(ind1+10,ig))
5856 endif
5858 taug(lay,ngs4+ig) = tau_major + tau_major1 &
5859 + tauself + taufor &
5860 + abso3*colo3(lay) &
5861 + wx(1,lay) * ccl4(ig)
5862 fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
5863 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5864 enddo
5865 enddo
5867 ! Upper atmosphere loop
5868 do lay = laytrop+1, nlayers
5870 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
5871 specparm = colo3(lay)/speccomb
5872 if (specparm .ge. oneminus) specparm = oneminus
5873 specmult = 4._rb*(specparm)
5874 js = 1 + int(specmult)
5875 fs = mod(specmult,1.0_rb)
5877 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
5878 specparm1 = colo3(lay)/speccomb1
5879 if (specparm1 .ge. oneminus) specparm1 = oneminus
5880 specmult1 = 4._rb*(specparm1)
5881 js1 = 1 + int(specmult1)
5882 fs1 = mod(specmult1,1.0_rb)
5884 fac000 = (1._rb - fs) * fac00(lay)
5885 fac010 = (1._rb - fs) * fac10(lay)
5886 fac100 = fs * fac00(lay)
5887 fac110 = fs * fac10(lay)
5888 fac001 = (1._rb - fs1) * fac01(lay)
5889 fac011 = (1._rb - fs1) * fac11(lay)
5890 fac101 = fs1 * fac01(lay)
5891 fac111 = fs1 * fac11(lay)
5893 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5894 specparm_planck = colo3(lay)/speccomb_planck
5895 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5896 specmult_planck = 4._rb*specparm_planck
5897 jpl= 1 + int(specmult_planck)
5898 fpl = mod(specmult_planck,1.0_rb)
5900 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js
5901 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1
5903 do ig = 1, ng5
5904 taug(lay,ngs4+ig) = speccomb * &
5905 (fac000 * absb(ind0,ig) + &
5906 fac100 * absb(ind0+1,ig) + &
5907 fac010 * absb(ind0+5,ig) + &
5908 fac110 * absb(ind0+6,ig)) &
5909 + speccomb1 * &
5910 (fac001 * absb(ind1,ig) + &
5911 fac101 * absb(ind1+1,ig) + &
5912 fac011 * absb(ind1+5,ig) + &
5913 fac111 * absb(ind1+6,ig)) &
5914 + wx(1,lay) * ccl4(ig)
5915 fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * &
5916 (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5917 enddo
5918 enddo
5920 end subroutine taugb5
5922 !----------------------------------------------------------------------------
5923 subroutine taugb6
5924 !----------------------------------------------------------------------------
5925 !
5926 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
5927 ! (high key - nothing; high minor - cfc11, cfc12)
5928 !----------------------------------------------------------------------------
5930 ! ------- Modules -------
5932 use parrrtm, only : ng6, ngs5
5933 use rrlw_ref, only : chi_mls
5934 use rrlw_kg06, only : fracrefa, absa, ka, ka_mco2, &
5935 selfref, forref, cfc11adj, cfc12
5937 ! ------- Declarations -------
5939 ! Local
5940 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5941 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
5942 real(kind=rb) :: tauself, taufor, absco2
5945 ! Minor gas mapping level:
5946 ! lower - co2, p = 706.2720 mb, t = 294.2 k
5947 ! upper - cfc11, cfc12
5949 ! Compute the optical depth by interpolating in ln(pressure) and
5950 ! temperature. The water vapor self-continuum and foreign continuum
5951 ! is interpolated (in temperature) separately.
5953 ! Lower atmosphere loop
5954 do lay = 1, laytrop
5956 ! In atmospheres where the amount of CO2 is too great to be considered
5957 ! a minor species, adjust the column amount of CO2 by an empirical factor
5958 ! to obtain the proper contribution.
5959 chi_co2 = colco2(lay)/(coldry(lay))
5960 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
5961 if (ratco2 .gt. 3.0_rb) then
5962 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb
5963 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
5964 else
5965 adjcolco2 = colco2(lay)
5966 endif
5968 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1
5969 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1
5970 inds = indself(lay)
5971 indf = indfor(lay)
5972 indm = indminor(lay)
5974 do ig = 1, ng6
5975 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
5976 (selfref(inds+1,ig) - selfref(inds,ig)))
5977 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
5978 (forref(indf+1,ig) - forref(indf,ig)))
5979 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
5980 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
5981 taug(lay,ngs5+ig) = colh2o(lay) * &
5982 (fac00(lay) * absa(ind0,ig) + &
5983 fac10(lay) * absa(ind0+1,ig) + &
5984 fac01(lay) * absa(ind1,ig) + &
5985 fac11(lay) * absa(ind1+1,ig)) &
5986 + tauself + taufor &
5987 + adjcolco2 * absco2 &
5988 + wx(2,lay) * cfc11adj(ig) &
5989 + wx(3,lay) * cfc12(ig)
5990 fracs(lay,ngs5+ig) = fracrefa(ig)
5991 enddo
5992 enddo
5994 ! Upper atmosphere loop
5995 ! Nothing important goes on above laytrop in this band.
5996 do lay = laytrop+1, nlayers
5998 do ig = 1, ng6
5999 taug(lay,ngs5+ig) = 0.0_rb &
6000 + wx(2,lay) * cfc11adj(ig) &
6001 + wx(3,lay) * cfc12(ig)
6002 fracs(lay,ngs5+ig) = fracrefa(ig)
6003 enddo
6004 enddo
6006 end subroutine taugb6
6008 !----------------------------------------------------------------------------
6009 subroutine taugb7
6010 !----------------------------------------------------------------------------
6011 !
6012 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
6013 ! (high key - o3; high minor - co2)
6014 !----------------------------------------------------------------------------
6016 ! ------- Modules -------
6018 use parrrtm, only : ng7, ngs6
6019 use rrlw_ref, only : chi_mls
6020 use rrlw_kg07, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6021 ka_mco2, kb_mco2, selfref, forref
6023 ! ------- Declarations -------
6025 ! Local
6026 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6027 integer(kind=im) :: js, js1, jmco2, jpl
6028 real(kind=rb) :: speccomb, specparm, specmult, fs
6029 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6030 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
6031 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6032 real(kind=rb) :: p, p4, fk0, fk1, fk2
6033 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6034 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6035 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
6036 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6037 real(kind=rb) :: refrat_planck_a, refrat_m_a
6038 real(kind=rb) :: tau_major, tau_major1
6041 ! Minor gas mapping level :
6042 ! lower - co2, p = 706.2620 mbar, t= 278.94 k
6043 ! upper - co2, p = 12.9350 mbar, t = 234.01 k
6045 ! Calculate reference ratio to be used in calculation of Planck
6046 ! fraction in lower atmosphere.
6048 ! P = 706.2620 mb
6049 refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
6051 ! P = 706.2720 mb
6052 refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
6054 ! Compute the optical depth by interpolating in ln(pressure),
6055 ! temperature, and appropriate species. Below laytrop, the water
6056 ! vapor self-continuum and foreign continuum is interpolated
6057 ! (in temperature) separately.
6059 ! Lower atmosphere loop
6060 do lay = 1, laytrop
6062 speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay)
6063 specparm = colh2o(lay)/speccomb
6064 if (specparm .ge. oneminus) specparm = oneminus
6065 specmult = 8._rb*(specparm)
6066 js = 1 + int(specmult)
6067 fs = mod(specmult,1.0_rb)
6069 speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay)
6070 specparm1 = colh2o(lay)/speccomb1
6071 if (specparm1 .ge. oneminus) specparm1 = oneminus
6072 specmult1 = 8._rb*(specparm1)
6073 js1 = 1 + int(specmult1)
6074 fs1 = mod(specmult1,1.0_rb)
6076 speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay)
6077 specparm_mco2 = colh2o(lay)/speccomb_mco2
6078 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
6079 specmult_mco2 = 8._rb*specparm_mco2
6081 jmco2 = 1 + int(specmult_mco2)
6082 fmco2 = mod(specmult_mco2,1.0_rb)
6084 ! In atmospheres where the amount of CO2 is too great to be considered
6085 ! a minor species, adjust the column amount of CO2 by an empirical factor
6086 ! to obtain the proper contribution.
6087 chi_co2 = colco2(lay)/(coldry(lay))
6088 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6089 if (ratco2 .gt. 3.0_rb) then
6090 adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb
6091 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6092 else
6093 adjcolco2 = colco2(lay)
6094 endif
6096 speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay)
6097 specparm_planck = colh2o(lay)/speccomb_planck
6098 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6099 specmult_planck = 8._rb*specparm_planck
6100 jpl= 1 + int(specmult_planck)
6101 fpl = mod(specmult_planck,1.0_rb)
6103 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js
6104 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1
6105 inds = indself(lay)
6106 indf = indfor(lay)
6107 indm = indminor(lay)
6109 if (specparm .lt. 0.125_rb) then
6110 p = fs - 1
6111 p4 = p**4
6112 fk0 = p4
6113 fk1 = 1 - p - 2.0_rb*p4
6114 fk2 = p + p4
6115 fac000 = fk0*fac00(lay)
6116 fac100 = fk1*fac00(lay)
6117 fac200 = fk2*fac00(lay)
6118 fac010 = fk0*fac10(lay)
6119 fac110 = fk1*fac10(lay)
6120 fac210 = fk2*fac10(lay)
6121 else if (specparm .gt. 0.875_rb) then
6122 p = -fs
6123 p4 = p**4
6124 fk0 = p4
6125 fk1 = 1 - p - 2.0_rb*p4
6126 fk2 = p + p4
6127 fac000 = fk0*fac00(lay)
6128 fac100 = fk1*fac00(lay)
6129 fac200 = fk2*fac00(lay)
6130 fac010 = fk0*fac10(lay)
6131 fac110 = fk1*fac10(lay)
6132 fac210 = fk2*fac10(lay)
6133 else
6134 fac000 = (1._rb - fs) * fac00(lay)
6135 fac010 = (1._rb - fs) * fac10(lay)
6136 fac100 = fs * fac00(lay)
6137 fac110 = fs * fac10(lay)
6138 endif
6139 if (specparm .lt. 0.125_rb) then
6140 p = fs1 - 1
6141 p4 = p**4
6142 fk0 = p4
6143 fk1 = 1 - p - 2.0_rb*p4
6144 fk2 = p + p4
6145 fac001 = fk0*fac01(lay)
6146 fac101 = fk1*fac01(lay)
6147 fac201 = fk2*fac01(lay)
6148 fac011 = fk0*fac11(lay)
6149 fac111 = fk1*fac11(lay)
6150 fac211 = fk2*fac11(lay)
6151 else if (specparm1 .gt. 0.875_rb) then
6152 p = -fs1
6153 p4 = p**4
6154 fk0 = p4
6155 fk1 = 1 - p - 2.0_rb*p4
6156 fk2 = p + p4
6157 fac001 = fk0*fac01(lay)
6158 fac101 = fk1*fac01(lay)
6159 fac201 = fk2*fac01(lay)
6160 fac011 = fk0*fac11(lay)
6161 fac111 = fk1*fac11(lay)
6162 fac211 = fk2*fac11(lay)
6163 else
6164 fac001 = (1._rb - fs1) * fac01(lay)
6165 fac011 = (1._rb - fs1) * fac11(lay)
6166 fac101 = fs1 * fac01(lay)
6167 fac111 = fs1 * fac11(lay)
6168 endif
6170 do ig = 1, ng7
6171 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6172 (selfref(inds+1,ig) - selfref(inds,ig)))
6173 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6174 (forref(indf+1,ig) - forref(indf,ig)))
6175 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
6176 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6177 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
6178 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6179 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6181 if (specparm .lt. 0.125_rb) then
6182 tau_major = speccomb * &
6183 (fac000 * absa(ind0,ig) + &
6184 fac100 * absa(ind0+1,ig) + &
6185 fac200 * absa(ind0+2,ig) + &
6186 fac010 * absa(ind0+9,ig) + &
6187 fac110 * absa(ind0+10,ig) + &
6188 fac210 * absa(ind0+11,ig))
6189 else if (specparm .gt. 0.875_rb) then
6190 tau_major = speccomb * &
6191 (fac200 * absa(ind0-1,ig) + &
6192 fac100 * absa(ind0,ig) + &
6193 fac000 * absa(ind0+1,ig) + &
6194 fac210 * absa(ind0+8,ig) + &
6195 fac110 * absa(ind0+9,ig) + &
6196 fac010 * absa(ind0+10,ig))
6197 else
6198 tau_major = speccomb * &
6199 (fac000 * absa(ind0,ig) + &
6200 fac100 * absa(ind0+1,ig) + &
6201 fac010 * absa(ind0+9,ig) + &
6202 fac110 * absa(ind0+10,ig))
6203 endif
6205 if (specparm1 .lt. 0.125_rb) then
6206 tau_major1 = speccomb1 * &
6207 (fac001 * absa(ind1,ig) + &
6208 fac101 * absa(ind1+1,ig) + &
6209 fac201 * absa(ind1+2,ig) + &
6210 fac011 * absa(ind1+9,ig) + &
6211 fac111 * absa(ind1+10,ig) + &
6212 fac211 * absa(ind1+11,ig))
6213 else if (specparm1 .gt. 0.875_rb) then
6214 tau_major1 = speccomb1 * &
6215 (fac201 * absa(ind1-1,ig) + &
6216 fac101 * absa(ind1,ig) + &
6217 fac001 * absa(ind1+1,ig) + &
6218 fac211 * absa(ind1+8,ig) + &
6219 fac111 * absa(ind1+9,ig) + &
6220 fac011 * absa(ind1+10,ig))
6221 else
6222 tau_major1 = speccomb1 * &
6223 (fac001 * absa(ind1,ig) + &
6224 fac101 * absa(ind1+1,ig) + &
6225 fac011 * absa(ind1+9,ig) + &
6226 fac111 * absa(ind1+10,ig))
6227 endif
6229 taug(lay,ngs6+ig) = tau_major + tau_major1 &
6230 + tauself + taufor &
6231 + adjcolco2*absco2
6232 fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
6233 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6234 enddo
6235 enddo
6237 ! Upper atmosphere loop
6238 do lay = laytrop+1, nlayers
6240 ! In atmospheres where the amount of CO2 is too great to be considered
6241 ! a minor species, adjust the column amount of CO2 by an empirical factor
6242 ! to obtain the proper contribution.
6243 chi_co2 = colco2(lay)/(coldry(lay))
6244 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6245 if (ratco2 .gt. 3.0_rb) then
6246 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb
6247 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6248 else
6249 adjcolco2 = colco2(lay)
6250 endif
6252 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1
6253 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1
6254 indm = indminor(lay)
6256 do ig = 1, ng7
6257 absco2 = kb_mco2(indm,ig) + minorfrac(lay) * &
6258 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))
6259 taug(lay,ngs6+ig) = colo3(lay) * &
6260 (fac00(lay) * absb(ind0,ig) + &
6261 fac10(lay) * absb(ind0+1,ig) + &
6262 fac01(lay) * absb(ind1,ig) + &
6263 fac11(lay) * absb(ind1+1,ig)) &
6264 + adjcolco2 * absco2
6265 fracs(lay,ngs6+ig) = fracrefb(ig)
6266 enddo
6268 ! Empirical modification to code to improve stratospheric cooling rates
6269 ! for o3. Revised to apply weighting for g-point reduction in this band.
6271 taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_rb
6272 taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_rb
6273 taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_rb
6274 taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_rb
6275 taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_rb
6276 taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_rb
6278 enddo
6280 end subroutine taugb7
6282 !----------------------------------------------------------------------------
6283 subroutine taugb8
6284 !----------------------------------------------------------------------------
6285 !
6286 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
6287 ! (high key - o3; high minor - co2, n2o)
6288 !----------------------------------------------------------------------------
6290 ! ------- Modules -------
6292 use parrrtm, only : ng8, ngs7
6293 use rrlw_ref, only : chi_mls
6294 use rrlw_kg08, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6295 ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o, &
6296 selfref, forref, cfc12, cfc22adj
6298 ! ------- Declarations -------
6300 ! Local
6301 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6302 real(kind=rb) :: tauself, taufor, absco2, abso3, absn2o
6303 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
6306 ! Minor gas mapping level:
6307 ! lower - co2, p = 1053.63 mb, t = 294.2 k
6308 ! lower - o3, p = 317.348 mb, t = 240.77 k
6309 ! lower - n2o, p = 706.2720 mb, t= 278.94 k
6310 ! lower - cfc12,cfc11
6311 ! upper - co2, p = 35.1632 mb, t = 223.28 k
6312 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k
6314 ! Compute the optical depth by interpolating in ln(pressure) and
6315 ! temperature, and appropriate species. Below laytrop, the water vapor
6316 ! self-continuum and foreign continuum is interpolated (in temperature)
6317 ! separately.
6319 ! Lower atmosphere loop
6320 do lay = 1, laytrop
6322 ! In atmospheres where the amount of CO2 is too great to be considered
6323 ! a minor species, adjust the column amount of CO2 by an empirical factor
6324 ! to obtain the proper contribution.
6325 chi_co2 = colco2(lay)/(coldry(lay))
6326 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6327 if (ratco2 .gt. 3.0_rb) then
6328 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6329 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6330 else
6331 adjcolco2 = colco2(lay)
6332 endif
6334 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
6335 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
6336 inds = indself(lay)
6337 indf = indfor(lay)
6338 indm = indminor(lay)
6340 do ig = 1, ng8
6341 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6342 (selfref(inds+1,ig) - selfref(inds,ig)))
6343 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6344 (forref(indf+1,ig) - forref(indf,ig)))
6345 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * &
6346 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6347 abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * &
6348 (ka_mo3(indm+1,ig) - ka_mo3(indm,ig)))
6349 absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * &
6350 (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig)))
6351 taug(lay,ngs7+ig) = colh2o(lay) * &
6352 (fac00(lay) * absa(ind0,ig) + &
6353 fac10(lay) * absa(ind0+1,ig) + &
6354 fac01(lay) * absa(ind1,ig) + &
6355 fac11(lay) * absa(ind1+1,ig)) &
6356 + tauself + taufor &
6357 + adjcolco2*absco2 &
6358 + colo3(lay) * abso3 &
6359 + coln2o(lay) * absn2o &
6360 + wx(3,lay) * cfc12(ig) &
6361 + wx(4,lay) * cfc22adj(ig)
6362 fracs(lay,ngs7+ig) = fracrefa(ig)
6363 enddo
6364 enddo
6366 ! Upper atmosphere loop
6367 do lay = laytrop+1, nlayers
6369 ! In atmospheres where the amount of CO2 is too great to be considered
6370 ! a minor species, adjust the column amount of CO2 by an empirical factor
6371 ! to obtain the proper contribution.
6372 chi_co2 = colco2(lay)/coldry(lay)
6373 ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6374 if (ratco2 .gt. 3.0_rb) then
6375 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6376 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb
6377 else
6378 adjcolco2 = colco2(lay)
6379 endif
6381 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1
6382 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1
6383 indm = indminor(lay)
6385 do ig = 1, ng8
6386 absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * &
6387 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)))
6388 absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * &
6389 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)))
6390 taug(lay,ngs7+ig) = colo3(lay) * &
6391 (fac00(lay) * absb(ind0,ig) + &
6392 fac10(lay) * absb(ind0+1,ig) + &
6393 fac01(lay) * absb(ind1,ig) + &
6394 fac11(lay) * absb(ind1+1,ig)) &
6395 + adjcolco2*absco2 &
6396 + coln2o(lay)*absn2o &
6397 + wx(3,lay) * cfc12(ig) &
6398 + wx(4,lay) * cfc22adj(ig)
6399 fracs(lay,ngs7+ig) = fracrefb(ig)
6400 enddo
6401 enddo
6403 end subroutine taugb8
6405 !----------------------------------------------------------------------------
6406 subroutine taugb9
6407 !----------------------------------------------------------------------------
6408 !
6409 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
6410 ! (high key - ch4; high minor - n2o)
6411 !----------------------------------------------------------------------------
6413 ! ------- Modules -------
6415 use parrrtm, only : ng9, ngs8
6416 use rrlw_ref, only : chi_mls
6417 use rrlw_kg09, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6418 ka_mn2o, kb_mn2o, selfref, forref
6420 ! ------- Declarations -------
6422 ! Local
6423 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6424 integer(kind=im) :: js, js1, jmn2o, jpl
6425 real(kind=rb) :: speccomb, specparm, specmult, fs
6426 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6427 real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
6428 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6429 real(kind=rb) :: p, p4, fk0, fk1, fk2
6430 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6431 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6432 real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
6433 real(kind=rb) :: chi_n2o, ratn2o, adjfac, adjcoln2o
6434 real(kind=rb) :: refrat_planck_a, refrat_m_a
6435 real(kind=rb) :: tau_major, tau_major1
6438 ! Minor gas mapping level :
6439 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
6440 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
6442 ! Calculate reference ratio to be used in calculation of Planck
6443 ! fraction in lower/upper atmosphere.
6445 ! P = 212 mb
6446 refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
6448 ! P = 706.272 mb
6449 refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
6451 ! Compute the optical depth by interpolating in ln(pressure),
6452 ! temperature, and appropriate species. Below laytrop, the water
6453 ! vapor self-continuum and foreign continuum is interpolated
6454 ! (in temperature) separately.
6456 ! Lower atmosphere loop
6457 do lay = 1, laytrop
6459 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
6460 specparm = colh2o(lay)/speccomb
6461 if (specparm .ge. oneminus) specparm = oneminus
6462 specmult = 8._rb*(specparm)
6463 js = 1 + int(specmult)
6464 fs = mod(specmult,1.0_rb)
6466 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
6467 specparm1 = colh2o(lay)/speccomb1
6468 if (specparm1 .ge. oneminus) specparm1 = oneminus
6469 specmult1 = 8._rb*(specparm1)
6470 js1 = 1 + int(specmult1)
6471 fs1 = mod(specmult1,1.0_rb)
6473 speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay)
6474 specparm_mn2o = colh2o(lay)/speccomb_mn2o
6475 if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
6476 specmult_mn2o = 8._rb*specparm_mn2o
6477 jmn2o = 1 + int(specmult_mn2o)
6478 fmn2o = mod(specmult_mn2o,1.0_rb)
6480 ! In atmospheres where the amount of N2O is too great to be considered
6481 ! a minor species, adjust the column amount of N2O by an empirical factor
6482 ! to obtain the proper contribution.
6483 chi_n2o = coln2o(lay)/(coldry(lay))
6484 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6485 if (ratn2o .gt. 1.5_rb) then
6486 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6487 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6488 else
6489 adjcoln2o = coln2o(lay)
6490 endif
6492 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
6493 specparm_planck = colh2o(lay)/speccomb_planck
6494 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6495 specmult_planck = 8._rb*specparm_planck
6496 jpl= 1 + int(specmult_planck)
6497 fpl = mod(specmult_planck,1.0_rb)
6499 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js
6500 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1
6501 inds = indself(lay)
6502 indf = indfor(lay)
6503 indm = indminor(lay)
6505 if (specparm .lt. 0.125_rb) then
6506 p = fs - 1
6507 p4 = p**4
6508 fk0 = p4
6509 fk1 = 1 - p - 2.0_rb*p4
6510 fk2 = p + p4
6511 fac000 = fk0*fac00(lay)
6512 fac100 = fk1*fac00(lay)
6513 fac200 = fk2*fac00(lay)
6514 fac010 = fk0*fac10(lay)
6515 fac110 = fk1*fac10(lay)
6516 fac210 = fk2*fac10(lay)
6517 else if (specparm .gt. 0.875_rb) then
6518 p = -fs
6519 p4 = p**4
6520 fk0 = p4
6521 fk1 = 1 - p - 2.0_rb*p4
6522 fk2 = p + p4
6523 fac000 = fk0*fac00(lay)
6524 fac100 = fk1*fac00(lay)
6525 fac200 = fk2*fac00(lay)
6526 fac010 = fk0*fac10(lay)
6527 fac110 = fk1*fac10(lay)
6528 fac210 = fk2*fac10(lay)
6529 else
6530 fac000 = (1._rb - fs) * fac00(lay)
6531 fac010 = (1._rb - fs) * fac10(lay)
6532 fac100 = fs * fac00(lay)
6533 fac110 = fs * fac10(lay)
6534 endif
6536 if (specparm1 .lt. 0.125_rb) then
6537 p = fs1 - 1
6538 p4 = p**4
6539 fk0 = p4
6540 fk1 = 1 - p - 2.0_rb*p4
6541 fk2 = p + p4
6542 fac001 = fk0*fac01(lay)
6543 fac101 = fk1*fac01(lay)
6544 fac201 = fk2*fac01(lay)
6545 fac011 = fk0*fac11(lay)
6546 fac111 = fk1*fac11(lay)
6547 fac211 = fk2*fac11(lay)
6548 else if (specparm1 .gt. 0.875_rb) then
6549 p = -fs1
6550 p4 = p**4
6551 fk0 = p4
6552 fk1 = 1 - p - 2.0_rb*p4
6553 fk2 = p + p4
6554 fac001 = fk0*fac01(lay)
6555 fac101 = fk1*fac01(lay)
6556 fac201 = fk2*fac01(lay)
6557 fac011 = fk0*fac11(lay)
6558 fac111 = fk1*fac11(lay)
6559 fac211 = fk2*fac11(lay)
6560 else
6561 fac001 = (1._rb - fs1) * fac01(lay)
6562 fac011 = (1._rb - fs1) * fac11(lay)
6563 fac101 = fs1 * fac01(lay)
6564 fac111 = fs1 * fac11(lay)
6565 endif
6567 do ig = 1, ng9
6568 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6569 (selfref(inds+1,ig) - selfref(inds,ig)))
6570 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6571 (forref(indf+1,ig) - forref(indf,ig)))
6572 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
6573 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6574 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
6575 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6576 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6578 if (specparm .lt. 0.125_rb) then
6579 tau_major = speccomb * &
6580 (fac000 * absa(ind0,ig) + &
6581 fac100 * absa(ind0+1,ig) + &
6582 fac200 * absa(ind0+2,ig) + &
6583 fac010 * absa(ind0+9,ig) + &
6584 fac110 * absa(ind0+10,ig) + &
6585 fac210 * absa(ind0+11,ig))
6586 else if (specparm .gt. 0.875_rb) then
6587 tau_major = speccomb * &
6588 (fac200 * absa(ind0-1,ig) + &
6589 fac100 * absa(ind0,ig) + &
6590 fac000 * absa(ind0+1,ig) + &
6591 fac210 * absa(ind0+8,ig) + &
6592 fac110 * absa(ind0+9,ig) + &
6593 fac010 * absa(ind0+10,ig))
6594 else
6595 tau_major = speccomb * &
6596 (fac000 * absa(ind0,ig) + &
6597 fac100 * absa(ind0+1,ig) + &
6598 fac010 * absa(ind0+9,ig) + &
6599 fac110 * absa(ind0+10,ig))
6600 endif
6602 if (specparm1 .lt. 0.125_rb) then
6603 tau_major1 = speccomb1 * &
6604 (fac001 * absa(ind1,ig) + &
6605 fac101 * absa(ind1+1,ig) + &
6606 fac201 * absa(ind1+2,ig) + &
6607 fac011 * absa(ind1+9,ig) + &
6608 fac111 * absa(ind1+10,ig) + &
6609 fac211 * absa(ind1+11,ig))
6610 else if (specparm1 .gt. 0.875_rb) then
6611 tau_major1 = speccomb1 * &
6612 (fac201 * absa(ind1-1,ig) + &
6613 fac101 * absa(ind1,ig) + &
6614 fac001 * absa(ind1+1,ig) + &
6615 fac211 * absa(ind1+8,ig) + &
6616 fac111 * absa(ind1+9,ig) + &
6617 fac011 * absa(ind1+10,ig))
6618 else
6619 tau_major1 = speccomb1 * &
6620 (fac001 * absa(ind1,ig) + &
6621 fac101 * absa(ind1+1,ig) + &
6622 fac011 * absa(ind1+9,ig) + &
6623 fac111 * absa(ind1+10,ig))
6624 endif
6626 taug(lay,ngs8+ig) = tau_major + tau_major1 &
6627 + tauself + taufor &
6628 + adjcoln2o*absn2o
6629 fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
6630 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6631 enddo
6632 enddo
6634 ! Upper atmosphere loop
6635 do lay = laytrop+1, nlayers
6637 ! In atmospheres where the amount of N2O is too great to be considered
6638 ! a minor species, adjust the column amount of N2O by an empirical factor
6639 ! to obtain the proper contribution.
6640 chi_n2o = coln2o(lay)/(coldry(lay))
6641 ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6642 if (ratn2o .gt. 1.5_rb) then
6643 adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6644 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6645 else
6646 adjcoln2o = coln2o(lay)
6647 endif
6649 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1
6650 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1
6651 indm = indminor(lay)
6653 do ig = 1, ng9
6654 absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * &
6655 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))
6656 taug(lay,ngs8+ig) = colch4(lay) * &
6657 (fac00(lay) * absb(ind0,ig) + &
6658 fac10(lay) * absb(ind0+1,ig) + &
6659 fac01(lay) * absb(ind1,ig) + &
6660 fac11(lay) * absb(ind1+1,ig)) &
6661 + adjcoln2o*absn2o
6662 fracs(lay,ngs8+ig) = fracrefb(ig)
6663 enddo
6664 enddo
6666 end subroutine taugb9
6668 !----------------------------------------------------------------------------
6669 subroutine taugb10
6670 !----------------------------------------------------------------------------
6671 !
6672 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
6673 !----------------------------------------------------------------------------
6675 ! ------- Modules -------
6677 use parrrtm, only : ng10, ngs9
6678 use rrlw_kg10, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6679 selfref, forref
6681 ! ------- Declarations -------
6683 ! Local
6684 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6685 real(kind=rb) :: tauself, taufor
6688 ! Compute the optical depth by interpolating in ln(pressure) and
6689 ! temperature. Below laytrop, the water vapor self-continuum and
6690 ! foreign continuum is interpolated (in temperature) separately.
6692 ! Lower atmosphere loop
6693 do lay = 1, laytrop
6694 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1
6695 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1
6696 inds = indself(lay)
6697 indf = indfor(lay)
6699 do ig = 1, ng10
6700 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6701 (selfref(inds+1,ig) - selfref(inds,ig)))
6702 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6703 (forref(indf+1,ig) - forref(indf,ig)))
6704 taug(lay,ngs9+ig) = colh2o(lay) * &
6705 (fac00(lay) * absa(ind0,ig) + &
6706 fac10(lay) * absa(ind0+1,ig) + &
6707 fac01(lay) * absa(ind1,ig) + &
6708 fac11(lay) * absa(ind1+1,ig)) &
6709 + tauself + taufor
6710 fracs(lay,ngs9+ig) = fracrefa(ig)
6711 enddo
6712 enddo
6714 ! Upper atmosphere loop
6715 do lay = laytrop+1, nlayers
6716 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1
6717 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1
6718 indf = indfor(lay)
6720 do ig = 1, ng10
6721 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6722 (forref(indf+1,ig) - forref(indf,ig)))
6723 taug(lay,ngs9+ig) = colh2o(lay) * &
6724 (fac00(lay) * absb(ind0,ig) + &
6725 fac10(lay) * absb(ind0+1,ig) + &
6726 fac01(lay) * absb(ind1,ig) + &
6727 fac11(lay) * absb(ind1+1,ig)) &
6728 + taufor
6729 fracs(lay,ngs9+ig) = fracrefb(ig)
6730 enddo
6731 enddo
6733 end subroutine taugb10
6735 !----------------------------------------------------------------------------
6736 subroutine taugb11
6737 !----------------------------------------------------------------------------
6738 !
6739 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
6740 ! (high key - h2o; high minor - o2)
6741 !----------------------------------------------------------------------------
6743 ! ------- Modules -------
6745 use parrrtm, only : ng11, ngs10
6746 use rrlw_kg11, only : fracrefa, fracrefb, absa, ka, absb, kb, &
6747 ka_mo2, kb_mo2, selfref, forref
6749 ! ------- Declarations -------
6751 ! Local
6752 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6753 real(kind=rb) :: scaleo2, tauself, taufor, tauo2
6756 ! Minor gas mapping level :
6757 ! lower - o2, p = 706.2720 mbar, t = 278.94 k
6758 ! upper - o2, p = 4.758820 mbarm t = 250.85 k
6760 ! Compute the optical depth by interpolating in ln(pressure) and
6761 ! temperature. Below laytrop, the water vapor self-continuum and
6762 ! foreign continuum is interpolated (in temperature) separately.
6764 ! Lower atmosphere loop
6765 do lay = 1, laytrop
6766 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1
6767 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1
6768 inds = indself(lay)
6769 indf = indfor(lay)
6770 indm = indminor(lay)
6771 scaleo2 = colo2(lay)*scaleminor(lay)
6772 do ig = 1, ng11
6773 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
6774 (selfref(inds+1,ig) - selfref(inds,ig)))
6775 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6776 (forref(indf+1,ig) - forref(indf,ig)))
6777 tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * &
6778 (ka_mo2(indm+1,ig) - ka_mo2(indm,ig)))
6779 taug(lay,ngs10+ig) = colh2o(lay) * &
6780 (fac00(lay) * absa(ind0,ig) + &
6781 fac10(lay) * absa(ind0+1,ig) + &
6782 fac01(lay) * absa(ind1,ig) + &
6783 fac11(lay) * absa(ind1+1,ig)) &
6784 + tauself + taufor &
6785 + tauo2
6786 fracs(lay,ngs10+ig) = fracrefa(ig)
6787 enddo
6788 enddo
6790 ! Upper atmosphere loop
6791 do lay = laytrop+1, nlayers
6792 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1
6793 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1
6794 indf = indfor(lay)
6795 indm = indminor(lay)
6796 scaleo2 = colo2(lay)*scaleminor(lay)
6797 do ig = 1, ng11
6798 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6799 (forref(indf+1,ig) - forref(indf,ig)))
6800 tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * &
6801 (kb_mo2(indm+1,ig) - kb_mo2(indm,ig)))
6802 taug(lay,ngs10+ig) = colh2o(lay) * &
6803 (fac00(lay) * absb(ind0,ig) + &
6804 fac10(lay) * absb(ind0+1,ig) + &
6805 fac01(lay) * absb(ind1,ig) + &
6806 fac11(lay) * absb(ind1+1,ig)) &
6807 + taufor &
6808 + tauo2
6809 fracs(lay,ngs10+ig) = fracrefb(ig)
6810 enddo
6811 enddo
6813 end subroutine taugb11
6815 !----------------------------------------------------------------------------
6816 subroutine taugb12
6817 !----------------------------------------------------------------------------
6818 !
6819 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
6820 !----------------------------------------------------------------------------
6822 ! ------- Modules -------
6824 use parrrtm, only : ng12, ngs11
6825 use rrlw_ref, only : chi_mls
6826 use rrlw_kg12, only : fracrefa, absa, ka, &
6827 selfref, forref
6829 ! ------- Declarations -------
6831 ! Local
6832 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6833 integer(kind=im) :: js, js1, jpl
6834 real(kind=rb) :: speccomb, specparm, specmult, fs
6835 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
6836 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
6837 real(kind=rb) :: p, p4, fk0, fk1, fk2
6838 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
6839 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
6840 real(kind=rb) :: tauself, taufor
6841 real(kind=rb) :: refrat_planck_a
6842 real(kind=rb) :: tau_major, tau_major1
6845 ! Calculate reference ratio to be used in calculation of Planck
6846 ! fraction in lower/upper atmosphere.
6848 ! P = 174.164 mb
6849 refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
6851 ! Compute the optical depth by interpolating in ln(pressure),
6852 ! temperature, and appropriate species. Below laytrop, the water
6853 ! vapor self-continuum adn foreign continuum is interpolated
6854 ! (in temperature) separately.
6856 ! Lower atmosphere loop
6857 do lay = 1, laytrop
6859 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
6860 specparm = colh2o(lay)/speccomb
6861 if (specparm .ge. oneminus) specparm = oneminus
6862 specmult = 8._rb*(specparm)
6863 js = 1 + int(specmult)
6864 fs = mod(specmult,1.0_rb)
6866 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
6867 specparm1 = colh2o(lay)/speccomb1
6868 if (specparm1 .ge. oneminus) specparm1 = oneminus
6869 specmult1 = 8._rb*(specparm1)
6870 js1 = 1 + int(specmult1)
6871 fs1 = mod(specmult1,1.0_rb)
6873 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
6874 specparm_planck = colh2o(lay)/speccomb_planck
6875 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6876 specmult_planck = 8._rb*specparm_planck
6877 jpl= 1 + int(specmult_planck)
6878 fpl = mod(specmult_planck,1.0_rb)
6880 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js
6881 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1
6882 inds = indself(lay)
6883 indf = indfor(lay)
6885 if (specparm .lt. 0.125_rb) then
6886 p = fs - 1
6887 p4 = p**4
6888 fk0 = p4
6889 fk1 = 1 - p - 2.0_rb*p4
6890 fk2 = p + p4
6891 fac000 = fk0*fac00(lay)
6892 fac100 = fk1*fac00(lay)
6893 fac200 = fk2*fac00(lay)
6894 fac010 = fk0*fac10(lay)
6895 fac110 = fk1*fac10(lay)
6896 fac210 = fk2*fac10(lay)
6897 else if (specparm .gt. 0.875_rb) then
6898 p = -fs
6899 p4 = p**4
6900 fk0 = p4
6901 fk1 = 1 - p - 2.0_rb*p4
6902 fk2 = p + p4
6903 fac000 = fk0*fac00(lay)
6904 fac100 = fk1*fac00(lay)
6905 fac200 = fk2*fac00(lay)
6906 fac010 = fk0*fac10(lay)
6907 fac110 = fk1*fac10(lay)
6908 fac210 = fk2*fac10(lay)
6909 else
6910 fac000 = (1._rb - fs) * fac00(lay)
6911 fac010 = (1._rb - fs) * fac10(lay)
6912 fac100 = fs * fac00(lay)
6913 fac110 = fs * fac10(lay)
6914 endif
6916 if (specparm1 .lt. 0.125_rb) then
6917 p = fs1 - 1
6918 p4 = p**4
6919 fk0 = p4
6920 fk1 = 1 - p - 2.0_rb*p4
6921 fk2 = p + p4
6922 fac001 = fk0*fac01(lay)
6923 fac101 = fk1*fac01(lay)
6924 fac201 = fk2*fac01(lay)
6925 fac011 = fk0*fac11(lay)
6926 fac111 = fk1*fac11(lay)
6927 fac211 = fk2*fac11(lay)
6928 else if (specparm1 .gt. 0.875_rb) then
6929 p = -fs1
6930 p4 = p**4
6931 fk0 = p4
6932 fk1 = 1 - p - 2.0_rb*p4
6933 fk2 = p + p4
6934 fac001 = fk0*fac01(lay)
6935 fac101 = fk1*fac01(lay)
6936 fac201 = fk2*fac01(lay)
6937 fac011 = fk0*fac11(lay)
6938 fac111 = fk1*fac11(lay)
6939 fac211 = fk2*fac11(lay)
6940 else
6941 fac001 = (1._rb - fs1) * fac01(lay)
6942 fac011 = (1._rb - fs1) * fac11(lay)
6943 fac101 = fs1 * fac01(lay)
6944 fac111 = fs1 * fac11(lay)
6945 endif
6947 do ig = 1, ng12
6948 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
6949 (selfref(inds+1,ig) - selfref(inds,ig)))
6950 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
6951 (forref(indf+1,ig) - forref(indf,ig)))
6953 if (specparm .lt. 0.125_rb) then
6954 tau_major = speccomb * &
6955 (fac000 * absa(ind0,ig) + &
6956 fac100 * absa(ind0+1,ig) + &
6957 fac200 * absa(ind0+2,ig) + &
6958 fac010 * absa(ind0+9,ig) + &
6959 fac110 * absa(ind0+10,ig) + &
6960 fac210 * absa(ind0+11,ig))
6961 else if (specparm .gt. 0.875_rb) then
6962 tau_major = speccomb * &
6963 (fac200 * absa(ind0-1,ig) + &
6964 fac100 * absa(ind0,ig) + &
6965 fac000 * absa(ind0+1,ig) + &
6966 fac210 * absa(ind0+8,ig) + &
6967 fac110 * absa(ind0+9,ig) + &
6968 fac010 * absa(ind0+10,ig))
6969 else
6970 tau_major = speccomb * &
6971 (fac000 * absa(ind0,ig) + &
6972 fac100 * absa(ind0+1,ig) + &
6973 fac010 * absa(ind0+9,ig) + &
6974 fac110 * absa(ind0+10,ig))
6975 endif
6977 if (specparm1 .lt. 0.125_rb) then
6978 tau_major1 = speccomb1 * &
6979 (fac001 * absa(ind1,ig) + &
6980 fac101 * absa(ind1+1,ig) + &
6981 fac201 * absa(ind1+2,ig) + &
6982 fac011 * absa(ind1+9,ig) + &
6983 fac111 * absa(ind1+10,ig) + &
6984 fac211 * absa(ind1+11,ig))
6985 else if (specparm1 .gt. 0.875_rb) then
6986 tau_major1 = speccomb1 * &
6987 (fac201 * absa(ind1-1,ig) + &
6988 fac101 * absa(ind1,ig) + &
6989 fac001 * absa(ind1+1,ig) + &
6990 fac211 * absa(ind1+8,ig) + &
6991 fac111 * absa(ind1+9,ig) + &
6992 fac011 * absa(ind1+10,ig))
6993 else
6994 tau_major1 = speccomb1 * &
6995 (fac001 * absa(ind1,ig) + &
6996 fac101 * absa(ind1+1,ig) + &
6997 fac011 * absa(ind1+9,ig) + &
6998 fac111 * absa(ind1+10,ig))
6999 endif
7001 taug(lay,ngs11+ig) = tau_major + tau_major1 &
7002 + tauself + taufor
7003 fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
7004 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7005 enddo
7006 enddo
7008 ! Upper atmosphere loop
7009 do lay = laytrop+1, nlayers
7011 do ig = 1, ng12
7012 taug(lay,ngs11+ig) = 0.0_rb
7013 fracs(lay,ngs11+ig) = 0.0_rb
7014 enddo
7015 enddo
7017 end subroutine taugb12
7019 !----------------------------------------------------------------------------
7020 subroutine taugb13
7021 !----------------------------------------------------------------------------
7022 !
7023 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
7024 !----------------------------------------------------------------------------
7026 ! ------- Modules -------
7028 use parrrtm, only : ng13, ngs12
7029 use rrlw_ref, only : chi_mls
7030 use rrlw_kg13, only : fracrefa, fracrefb, absa, ka, &
7031 ka_mco2, ka_mco, kb_mo3, selfref, forref
7033 ! ------- Declarations -------
7035 ! Local
7036 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7037 integer(kind=im) :: js, js1, jmco2, jmco, jpl
7038 real(kind=rb) :: speccomb, specparm, specmult, fs
7039 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7040 real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
7041 real(kind=rb) :: speccomb_mco, specparm_mco, specmult_mco, fmco
7042 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7043 real(kind=rb) :: p, p4, fk0, fk1, fk2
7044 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7045 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7046 real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
7047 real(kind=rb) :: com1, com2, absco, abso3
7048 real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
7049 real(kind=rb) :: refrat_planck_a, refrat_m_a, refrat_m_a3
7050 real(kind=rb) :: tau_major, tau_major1
7052 ! Minor gas mapping levels :
7053 ! lower - co2, p = 1053.63 mb, t = 294.2 k
7054 ! lower - co, p = 706 mb, t = 278.94 k
7055 ! upper - o3, p = 95.5835 mb, t = 215.7 k
7057 ! Calculate reference ratio to be used in calculation of Planck
7058 ! fraction in lower/upper atmosphere.
7060 ! P = 473.420 mb (Level 5)
7061 refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
7063 ! P = 1053. (Level 1)
7064 refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
7066 ! P = 706. (Level 3)
7067 refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
7069 ! Compute the optical depth by interpolating in ln(pressure),
7070 ! temperature, and appropriate species. Below laytrop, the water
7071 ! vapor self-continuum and foreign continuum is interpolated
7072 ! (in temperature) separately.
7074 ! Lower atmosphere loop
7075 do lay = 1, laytrop
7077 speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay)
7078 specparm = colh2o(lay)/speccomb
7079 if (specparm .ge. oneminus) specparm = oneminus
7080 specmult = 8._rb*(specparm)
7081 js = 1 + int(specmult)
7082 fs = mod(specmult,1.0_rb)
7084 speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay)
7085 specparm1 = colh2o(lay)/speccomb1
7086 if (specparm1 .ge. oneminus) specparm1 = oneminus
7087 specmult1 = 8._rb*(specparm1)
7088 js1 = 1 + int(specmult1)
7089 fs1 = mod(specmult1,1.0_rb)
7091 speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay)
7092 specparm_mco2 = colh2o(lay)/speccomb_mco2
7093 if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
7094 specmult_mco2 = 8._rb*specparm_mco2
7095 jmco2 = 1 + int(specmult_mco2)
7096 fmco2 = mod(specmult_mco2,1.0_rb)
7098 ! In atmospheres where the amount of CO2 is too great to be considered
7099 ! a minor species, adjust the column amount of CO2 by an empirical factor
7100 ! to obtain the proper contribution.
7101 chi_co2 = colco2(lay)/(coldry(lay))
7102 ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb
7103 if (ratco2 .gt. 3.0_rb) then
7104 adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb
7105 adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb
7106 else
7107 adjcolco2 = colco2(lay)
7108 endif
7110 speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay)
7111 specparm_mco = colh2o(lay)/speccomb_mco
7112 if (specparm_mco .ge. oneminus) specparm_mco = oneminus
7113 specmult_mco = 8._rb*specparm_mco
7114 jmco = 1 + int(specmult_mco)
7115 fmco = mod(specmult_mco,1.0_rb)
7117 speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay)
7118 specparm_planck = colh2o(lay)/speccomb_planck
7119 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7120 specmult_planck = 8._rb*specparm_planck
7121 jpl= 1 + int(specmult_planck)
7122 fpl = mod(specmult_planck,1.0_rb)
7124 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js
7125 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1
7126 inds = indself(lay)
7127 indf = indfor(lay)
7128 indm = indminor(lay)
7130 if (specparm .lt. 0.125_rb) then
7131 p = fs - 1
7132 p4 = p**4
7133 fk0 = p4
7134 fk1 = 1 - p - 2.0_rb*p4
7135 fk2 = p + p4
7136 fac000 = fk0*fac00(lay)
7137 fac100 = fk1*fac00(lay)
7138 fac200 = fk2*fac00(lay)
7139 fac010 = fk0*fac10(lay)
7140 fac110 = fk1*fac10(lay)
7141 fac210 = fk2*fac10(lay)
7142 else if (specparm .gt. 0.875_rb) then
7143 p = -fs
7144 p4 = p**4
7145 fk0 = p4
7146 fk1 = 1 - p - 2.0_rb*p4
7147 fk2 = p + p4
7148 fac000 = fk0*fac00(lay)
7149 fac100 = fk1*fac00(lay)
7150 fac200 = fk2*fac00(lay)
7151 fac010 = fk0*fac10(lay)
7152 fac110 = fk1*fac10(lay)
7153 fac210 = fk2*fac10(lay)
7154 else
7155 fac000 = (1._rb - fs) * fac00(lay)
7156 fac010 = (1._rb - fs) * fac10(lay)
7157 fac100 = fs * fac00(lay)
7158 fac110 = fs * fac10(lay)
7159 endif
7161 if (specparm1 .lt. 0.125_rb) then
7162 p = fs1 - 1
7163 p4 = p**4
7164 fk0 = p4
7165 fk1 = 1 - p - 2.0_rb*p4
7166 fk2 = p + p4
7167 fac001 = fk0*fac01(lay)
7168 fac101 = fk1*fac01(lay)
7169 fac201 = fk2*fac01(lay)
7170 fac011 = fk0*fac11(lay)
7171 fac111 = fk1*fac11(lay)
7172 fac211 = fk2*fac11(lay)
7173 else if (specparm1 .gt. 0.875_rb) then
7174 p = -fs1
7175 p4 = p**4
7176 fk0 = p4
7177 fk1 = 1 - p - 2.0_rb*p4
7178 fk2 = p + p4
7179 fac001 = fk0*fac01(lay)
7180 fac101 = fk1*fac01(lay)
7181 fac201 = fk2*fac01(lay)
7182 fac011 = fk0*fac11(lay)
7183 fac111 = fk1*fac11(lay)
7184 fac211 = fk2*fac11(lay)
7185 else
7186 fac001 = (1._rb - fs1) * fac01(lay)
7187 fac011 = (1._rb - fs1) * fac11(lay)
7188 fac101 = fs1 * fac01(lay)
7189 fac111 = fs1 * fac11(lay)
7190 endif
7192 do ig = 1, ng13
7193 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7194 (selfref(inds+1,ig) - selfref(inds,ig)))
7195 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7196 (forref(indf+1,ig) - forref(indf,ig)))
7197 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
7198 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7199 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
7200 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7201 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7202 com1 = ka_mco(jmco,indm,ig) + fmco * &
7203 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7204 com2 = ka_mco(jmco,indm+1,ig) + fmco * &
7205 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7206 absco = com1 + minorfrac(lay) * (com2 - com1)
7208 if (specparm .lt. 0.125_rb) then
7209 tau_major = speccomb * &
7210 (fac000 * absa(ind0,ig) + &
7211 fac100 * absa(ind0+1,ig) + &
7212 fac200 * absa(ind0+2,ig) + &
7213 fac010 * absa(ind0+9,ig) + &
7214 fac110 * absa(ind0+10,ig) + &
7215 fac210 * absa(ind0+11,ig))
7216 else if (specparm .gt. 0.875_rb) then
7217 tau_major = speccomb * &
7218 (fac200 * absa(ind0-1,ig) + &
7219 fac100 * absa(ind0,ig) + &
7220 fac000 * absa(ind0+1,ig) + &
7221 fac210 * absa(ind0+8,ig) + &
7222 fac110 * absa(ind0+9,ig) + &
7223 fac010 * absa(ind0+10,ig))
7224 else
7225 tau_major = speccomb * &
7226 (fac000 * absa(ind0,ig) + &
7227 fac100 * absa(ind0+1,ig) + &
7228 fac010 * absa(ind0+9,ig) + &
7229 fac110 * absa(ind0+10,ig))
7230 endif
7232 if (specparm1 .lt. 0.125_rb) then
7233 tau_major1 = speccomb1 * &
7234 (fac001 * absa(ind1,ig) + &
7235 fac101 * absa(ind1+1,ig) + &
7236 fac201 * absa(ind1+2,ig) + &
7237 fac011 * absa(ind1+9,ig) + &
7238 fac111 * absa(ind1+10,ig) + &
7239 fac211 * absa(ind1+11,ig))
7240 else if (specparm1 .gt. 0.875_rb) then
7241 tau_major1 = speccomb1 * &
7242 (fac201 * absa(ind1-1,ig) + &
7243 fac101 * absa(ind1,ig) + &
7244 fac001 * absa(ind1+1,ig) + &
7245 fac211 * absa(ind1+8,ig) + &
7246 fac111 * absa(ind1+9,ig) + &
7247 fac011 * absa(ind1+10,ig))
7248 else
7249 tau_major1 = speccomb1 * &
7250 (fac001 * absa(ind1,ig) + &
7251 fac101 * absa(ind1+1,ig) + &
7252 fac011 * absa(ind1+9,ig) + &
7253 fac111 * absa(ind1+10,ig))
7254 endif
7256 taug(lay,ngs12+ig) = tau_major + tau_major1 &
7257 + tauself + taufor &
7258 + adjcolco2*absco2 &
7259 + colco(lay)*absco
7260 fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
7261 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7262 enddo
7263 enddo
7265 ! Upper atmosphere loop
7266 do lay = laytrop+1, nlayers
7267 indm = indminor(lay)
7268 do ig = 1, ng13
7269 abso3 = kb_mo3(indm,ig) + minorfrac(lay) * &
7270 (kb_mo3(indm+1,ig) - kb_mo3(indm,ig))
7271 taug(lay,ngs12+ig) = colo3(lay)*abso3
7272 fracs(lay,ngs12+ig) = fracrefb(ig)
7273 enddo
7274 enddo
7276 end subroutine taugb13
7278 !----------------------------------------------------------------------------
7279 subroutine taugb14
7280 !----------------------------------------------------------------------------
7281 !
7282 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
7283 !----------------------------------------------------------------------------
7285 ! ------- Modules -------
7287 use parrrtm, only : ng14, ngs13
7288 use rrlw_kg14, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7289 selfref, forref
7291 ! ------- Declarations -------
7293 ! Local
7294 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7295 real(kind=rb) :: tauself, taufor
7298 ! Compute the optical depth by interpolating in ln(pressure) and
7299 ! temperature. Below laytrop, the water vapor self-continuum
7300 ! and foreign continuum is interpolated (in temperature) separately.
7302 ! Lower atmosphere loop
7303 do lay = 1, laytrop
7304 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1
7305 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1
7306 inds = indself(lay)
7307 indf = indfor(lay)
7308 do ig = 1, ng14
7309 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
7310 (selfref(inds+1,ig) - selfref(inds,ig)))
7311 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7312 (forref(indf+1,ig) - forref(indf,ig)))
7313 taug(lay,ngs13+ig) = colco2(lay) * &
7314 (fac00(lay) * absa(ind0,ig) + &
7315 fac10(lay) * absa(ind0+1,ig) + &
7316 fac01(lay) * absa(ind1,ig) + &
7317 fac11(lay) * absa(ind1+1,ig)) &
7318 + tauself + taufor
7319 fracs(lay,ngs13+ig) = fracrefa(ig)
7320 enddo
7321 enddo
7323 ! Upper atmosphere loop
7324 do lay = laytrop+1, nlayers
7325 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1
7326 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1
7327 do ig = 1, ng14
7328 taug(lay,ngs13+ig) = colco2(lay) * &
7329 (fac00(lay) * absb(ind0,ig) + &
7330 fac10(lay) * absb(ind0+1,ig) + &
7331 fac01(lay) * absb(ind1,ig) + &
7332 fac11(lay) * absb(ind1+1,ig))
7333 fracs(lay,ngs13+ig) = fracrefb(ig)
7334 enddo
7335 enddo
7337 end subroutine taugb14
7339 !----------------------------------------------------------------------------
7340 subroutine taugb15
7341 !----------------------------------------------------------------------------
7342 !
7343 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
7344 ! (high - nothing)
7345 !----------------------------------------------------------------------------
7347 ! ------- Modules -------
7349 use parrrtm, only : ng15, ngs14
7350 use rrlw_ref, only : chi_mls
7351 use rrlw_kg15, only : fracrefa, absa, ka, &
7352 ka_mn2, selfref, forref
7354 ! ------- Declarations -------
7356 ! Local
7357 integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7358 integer(kind=im) :: js, js1, jmn2, jpl
7359 real(kind=rb) :: speccomb, specparm, specmult, fs
7360 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7361 real(kind=rb) :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
7362 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7363 real(kind=rb) :: p, p4, fk0, fk1, fk2
7364 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7365 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7366 real(kind=rb) :: scalen2, tauself, taufor, n2m1, n2m2, taun2
7367 real(kind=rb) :: refrat_planck_a, refrat_m_a
7368 real(kind=rb) :: tau_major, tau_major1
7371 ! Minor gas mapping level :
7372 ! Lower - Nitrogen Continuum, P = 1053., T = 294.
7374 ! Calculate reference ratio to be used in calculation of Planck
7375 ! fraction in lower atmosphere.
7376 ! P = 1053. mb (Level 1)
7377 refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
7379 ! P = 1053.
7380 refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
7382 ! Compute the optical depth by interpolating in ln(pressure),
7383 ! temperature, and appropriate species. Below laytrop, the water
7384 ! vapor self-continuum and foreign continuum is interpolated
7385 ! (in temperature) separately.
7387 ! Lower atmosphere loop
7388 do lay = 1, laytrop
7390 speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay)
7391 specparm = coln2o(lay)/speccomb
7392 if (specparm .ge. oneminus) specparm = oneminus
7393 specmult = 8._rb*(specparm)
7394 js = 1 + int(specmult)
7395 fs = mod(specmult,1.0_rb)
7397 speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay)
7398 specparm1 = coln2o(lay)/speccomb1
7399 if (specparm1 .ge. oneminus) specparm1 = oneminus
7400 specmult1 = 8._rb*(specparm1)
7401 js1 = 1 + int(specmult1)
7402 fs1 = mod(specmult1,1.0_rb)
7404 speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay)
7405 specparm_mn2 = coln2o(lay)/speccomb_mn2
7406 if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus
7407 specmult_mn2 = 8._rb*specparm_mn2
7408 jmn2 = 1 + int(specmult_mn2)
7409 fmn2 = mod(specmult_mn2,1.0_rb)
7411 speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay)
7412 specparm_planck = coln2o(lay)/speccomb_planck
7413 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7414 specmult_planck = 8._rb*specparm_planck
7415 jpl= 1 + int(specmult_planck)
7416 fpl = mod(specmult_planck,1.0_rb)
7418 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js
7419 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1
7420 inds = indself(lay)
7421 indf = indfor(lay)
7422 indm = indminor(lay)
7424 scalen2 = colbrd(lay)*scaleminor(lay)
7426 if (specparm .lt. 0.125_rb) then
7427 p = fs - 1
7428 p4 = p**4
7429 fk0 = p4
7430 fk1 = 1 - p - 2.0_rb*p4
7431 fk2 = p + p4
7432 fac000 = fk0*fac00(lay)
7433 fac100 = fk1*fac00(lay)
7434 fac200 = fk2*fac00(lay)
7435 fac010 = fk0*fac10(lay)
7436 fac110 = fk1*fac10(lay)
7437 fac210 = fk2*fac10(lay)
7438 else if (specparm .gt. 0.875_rb) then
7439 p = -fs
7440 p4 = p**4
7441 fk0 = p4
7442 fk1 = 1 - p - 2.0_rb*p4
7443 fk2 = p + p4
7444 fac000 = fk0*fac00(lay)
7445 fac100 = fk1*fac00(lay)
7446 fac200 = fk2*fac00(lay)
7447 fac010 = fk0*fac10(lay)
7448 fac110 = fk1*fac10(lay)
7449 fac210 = fk2*fac10(lay)
7450 else
7451 fac000 = (1._rb - fs) * fac00(lay)
7452 fac010 = (1._rb - fs) * fac10(lay)
7453 fac100 = fs * fac00(lay)
7454 fac110 = fs * fac10(lay)
7455 endif
7456 if (specparm1 .lt. 0.125_rb) then
7457 p = fs1 - 1
7458 p4 = p**4
7459 fk0 = p4
7460 fk1 = 1 - p - 2.0_rb*p4
7461 fk2 = p + p4
7462 fac001 = fk0*fac01(lay)
7463 fac101 = fk1*fac01(lay)
7464 fac201 = fk2*fac01(lay)
7465 fac011 = fk0*fac11(lay)
7466 fac111 = fk1*fac11(lay)
7467 fac211 = fk2*fac11(lay)
7468 else if (specparm1 .gt. 0.875_rb) then
7469 p = -fs1
7470 p4 = p**4
7471 fk0 = p4
7472 fk1 = 1 - p - 2.0_rb*p4
7473 fk2 = p + p4
7474 fac001 = fk0*fac01(lay)
7475 fac101 = fk1*fac01(lay)
7476 fac201 = fk2*fac01(lay)
7477 fac011 = fk0*fac11(lay)
7478 fac111 = fk1*fac11(lay)
7479 fac211 = fk2*fac11(lay)
7480 else
7481 fac001 = (1._rb - fs1) * fac01(lay)
7482 fac011 = (1._rb - fs1) * fac11(lay)
7483 fac101 = fs1 * fac01(lay)
7484 fac111 = fs1 * fac11(lay)
7485 endif
7487 do ig = 1, ng15
7488 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7489 (selfref(inds+1,ig) - selfref(inds,ig)))
7490 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7491 (forref(indf+1,ig) - forref(indf,ig)))
7492 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
7493 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7494 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
7495 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7496 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7498 if (specparm .lt. 0.125_rb) then
7499 tau_major = speccomb * &
7500 (fac000 * absa(ind0,ig) + &
7501 fac100 * absa(ind0+1,ig) + &
7502 fac200 * absa(ind0+2,ig) + &
7503 fac010 * absa(ind0+9,ig) + &
7504 fac110 * absa(ind0+10,ig) + &
7505 fac210 * absa(ind0+11,ig))
7506 else if (specparm .gt. 0.875_rb) then
7507 tau_major = speccomb * &
7508 (fac200 * absa(ind0-1,ig) + &
7509 fac100 * absa(ind0,ig) + &
7510 fac000 * absa(ind0+1,ig) + &
7511 fac210 * absa(ind0+8,ig) + &
7512 fac110 * absa(ind0+9,ig) + &
7513 fac010 * absa(ind0+10,ig))
7514 else
7515 tau_major = speccomb * &
7516 (fac000 * absa(ind0,ig) + &
7517 fac100 * absa(ind0+1,ig) + &
7518 fac010 * absa(ind0+9,ig) + &
7519 fac110 * absa(ind0+10,ig))
7520 endif
7522 if (specparm1 .lt. 0.125_rb) then
7523 tau_major1 = speccomb1 * &
7524 (fac001 * absa(ind1,ig) + &
7525 fac101 * absa(ind1+1,ig) + &
7526 fac201 * absa(ind1+2,ig) + &
7527 fac011 * absa(ind1+9,ig) + &
7528 fac111 * absa(ind1+10,ig) + &
7529 fac211 * absa(ind1+11,ig))
7530 else if (specparm1 .gt. 0.875_rb) then
7531 tau_major1 = speccomb1 * &
7532 (fac201 * absa(ind1-1,ig) + &
7533 fac101 * absa(ind1,ig) + &
7534 fac001 * absa(ind1+1,ig) + &
7535 fac211 * absa(ind1+8,ig) + &
7536 fac111 * absa(ind1+9,ig) + &
7537 fac011 * absa(ind1+10,ig))
7538 else
7539 tau_major1 = speccomb1 * &
7540 (fac001 * absa(ind1,ig) + &
7541 fac101 * absa(ind1+1,ig) + &
7542 fac011 * absa(ind1+9,ig) + &
7543 fac111 * absa(ind1+10,ig))
7544 endif
7546 taug(lay,ngs14+ig) = tau_major + tau_major1 &
7547 + tauself + taufor &
7548 + taun2
7549 fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
7550 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7551 enddo
7552 enddo
7554 ! Upper atmosphere loop
7555 do lay = laytrop+1, nlayers
7556 do ig = 1, ng15
7557 taug(lay,ngs14+ig) = 0.0_rb
7558 fracs(lay,ngs14+ig) = 0.0_rb
7559 enddo
7560 enddo
7562 end subroutine taugb15
7564 !----------------------------------------------------------------------------
7565 subroutine taugb16
7566 !----------------------------------------------------------------------------
7567 !
7568 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
7569 !----------------------------------------------------------------------------
7571 ! ------- Modules -------
7573 use parrrtm, only : ng16, ngs15
7574 use rrlw_ref, only : chi_mls
7575 use rrlw_kg16, only : fracrefa, fracrefb, absa, ka, absb, kb, &
7576 selfref, forref
7578 ! ------- Declarations -------
7580 ! Local
7581 integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7582 integer(kind=im) :: js, js1, jpl
7583 real(kind=rb) :: speccomb, specparm, specmult, fs
7584 real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
7585 real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
7586 real(kind=rb) :: p, p4, fk0, fk1, fk2
7587 real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
7588 real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
7589 real(kind=rb) :: tauself, taufor
7590 real(kind=rb) :: refrat_planck_a
7591 real(kind=rb) :: tau_major, tau_major1
7594 ! Calculate reference ratio to be used in calculation of Planck
7595 ! fraction in lower atmosphere.
7597 ! P = 387. mb (Level 6)
7598 refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
7600 ! Compute the optical depth by interpolating in ln(pressure),
7601 ! temperature,and appropriate species. Below laytrop, the water
7602 ! vapor self-continuum and foreign continuum is interpolated
7603 ! (in temperature) separately.
7605 ! Lower atmosphere loop
7606 do lay = 1, laytrop
7608 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
7609 specparm = colh2o(lay)/speccomb
7610 if (specparm .ge. oneminus) specparm = oneminus
7611 specmult = 8._rb*(specparm)
7612 js = 1 + int(specmult)
7613 fs = mod(specmult,1.0_rb)
7615 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
7616 specparm1 = colh2o(lay)/speccomb1
7617 if (specparm1 .ge. oneminus) specparm1 = oneminus
7618 specmult1 = 8._rb*(specparm1)
7619 js1 = 1 + int(specmult1)
7620 fs1 = mod(specmult1,1.0_rb)
7622 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
7623 specparm_planck = colh2o(lay)/speccomb_planck
7624 if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7625 specmult_planck = 8._rb*specparm_planck
7626 jpl= 1 + int(specmult_planck)
7627 fpl = mod(specmult_planck,1.0_rb)
7629 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
7630 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1
7631 inds = indself(lay)
7632 indf = indfor(lay)
7634 if (specparm .lt. 0.125_rb) then
7635 p = fs - 1
7636 p4 = p**4
7637 fk0 = p4
7638 fk1 = 1 - p - 2.0_rb*p4
7639 fk2 = p + p4
7640 fac000 = fk0*fac00(lay)
7641 fac100 = fk1*fac00(lay)
7642 fac200 = fk2*fac00(lay)
7643 fac010 = fk0*fac10(lay)
7644 fac110 = fk1*fac10(lay)
7645 fac210 = fk2*fac10(lay)
7646 else if (specparm .gt. 0.875_rb) then
7647 p = -fs
7648 p4 = p**4
7649 fk0 = p4
7650 fk1 = 1 - p - 2.0_rb*p4
7651 fk2 = p + p4
7652 fac000 = fk0*fac00(lay)
7653 fac100 = fk1*fac00(lay)
7654 fac200 = fk2*fac00(lay)
7655 fac010 = fk0*fac10(lay)
7656 fac110 = fk1*fac10(lay)
7657 fac210 = fk2*fac10(lay)
7658 else
7659 fac000 = (1._rb - fs) * fac00(lay)
7660 fac010 = (1._rb - fs) * fac10(lay)
7661 fac100 = fs * fac00(lay)
7662 fac110 = fs * fac10(lay)
7663 endif
7665 if (specparm1 .lt. 0.125_rb) then
7666 p = fs1 - 1
7667 p4 = p**4
7668 fk0 = p4
7669 fk1 = 1 - p - 2.0_rb*p4
7670 fk2 = p + p4
7671 fac001 = fk0*fac01(lay)
7672 fac101 = fk1*fac01(lay)
7673 fac201 = fk2*fac01(lay)
7674 fac011 = fk0*fac11(lay)
7675 fac111 = fk1*fac11(lay)
7676 fac211 = fk2*fac11(lay)
7677 else if (specparm1 .gt. 0.875_rb) then
7678 p = -fs1
7679 p4 = p**4
7680 fk0 = p4
7681 fk1 = 1 - p - 2.0_rb*p4
7682 fk2 = p + p4
7683 fac001 = fk0*fac01(lay)
7684 fac101 = fk1*fac01(lay)
7685 fac201 = fk2*fac01(lay)
7686 fac011 = fk0*fac11(lay)
7687 fac111 = fk1*fac11(lay)
7688 fac211 = fk2*fac11(lay)
7689 else
7690 fac001 = (1._rb - fs1) * fac01(lay)
7691 fac011 = (1._rb - fs1) * fac11(lay)
7692 fac101 = fs1 * fac01(lay)
7693 fac111 = fs1 * fac11(lay)
7694 endif
7696 do ig = 1, ng16
7697 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
7698 (selfref(inds+1,ig) - selfref(inds,ig)))
7699 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
7700 (forref(indf+1,ig) - forref(indf,ig)))
7702 if (specparm .lt. 0.125_rb) then
7703 tau_major = speccomb * &
7704 (fac000 * absa(ind0,ig) + &
7705 fac100 * absa(ind0+1,ig) + &
7706 fac200 * absa(ind0+2,ig) + &
7707 fac010 * absa(ind0+9,ig) + &
7708 fac110 * absa(ind0+10,ig) + &
7709 fac210 * absa(ind0+11,ig))
7710 else if (specparm .gt. 0.875_rb) then
7711 tau_major = speccomb * &
7712 (fac200 * absa(ind0-1,ig) + &
7713 fac100 * absa(ind0,ig) + &
7714 fac000 * absa(ind0+1,ig) + &
7715 fac210 * absa(ind0+8,ig) + &
7716 fac110 * absa(ind0+9,ig) + &
7717 fac010 * absa(ind0+10,ig))
7718 else
7719 tau_major = speccomb * &
7720 (fac000 * absa(ind0,ig) + &
7721 fac100 * absa(ind0+1,ig) + &
7722 fac010 * absa(ind0+9,ig) + &
7723 fac110 * absa(ind0+10,ig))
7724 endif
7726 if (specparm1 .lt. 0.125_rb) then
7727 tau_major1 = speccomb1 * &
7728 (fac001 * absa(ind1,ig) + &
7729 fac101 * absa(ind1+1,ig) + &
7730 fac201 * absa(ind1+2,ig) + &
7731 fac011 * absa(ind1+9,ig) + &
7732 fac111 * absa(ind1+10,ig) + &
7733 fac211 * absa(ind1+11,ig))
7734 else if (specparm1 .gt. 0.875_rb) then
7735 tau_major1 = speccomb1 * &
7736 (fac201 * absa(ind1-1,ig) + &
7737 fac101 * absa(ind1,ig) + &
7738 fac001 * absa(ind1+1,ig) + &
7739 fac211 * absa(ind1+8,ig) + &
7740 fac111 * absa(ind1+9,ig) + &
7741 fac011 * absa(ind1+10,ig))
7742 else
7743 tau_major1 = speccomb1 * &
7744 (fac001 * absa(ind1,ig) + &
7745 fac101 * absa(ind1+1,ig) + &
7746 fac011 * absa(ind1+9,ig) + &
7747 fac111 * absa(ind1+10,ig))
7748 endif
7750 taug(lay,ngs15+ig) = tau_major + tau_major1 &
7751 + tauself + taufor
7752 fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
7753 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7754 enddo
7755 enddo
7757 ! Upper atmosphere loop
7758 do lay = laytrop+1, nlayers
7759 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
7760 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
7761 do ig = 1, ng16
7762 taug(lay,ngs15+ig) = colch4(lay) * &
7763 (fac00(lay) * absb(ind0,ig) + &
7764 fac10(lay) * absb(ind0+1,ig) + &
7765 fac01(lay) * absb(ind1,ig) + &
7766 fac11(lay) * absb(ind1+1,ig))
7767 fracs(lay,ngs15+ig) = fracrefb(ig)
7768 enddo
7769 enddo
7771 end subroutine taugb16
7773 end subroutine taumol
7775 end module rrtmg_lw_taumol
7777 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
7778 ! author: $Author: trn $
7779 ! revision: $Revision: 1.3 $
7780 ! created: $Date: 2009/04/16 19:54:22 $
7781 !
7782 module rrtmg_lw_init
7784 ! --------------------------------------------------------------------------
7785 ! | |
7786 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
7787 ! | This software may be used, copied, or redistributed as long as it is |
7788 ! | not sold and this copyright notice is reproduced on each copy made. |
7789 ! | This model is provided as is without any express or implied warranties. |
7790 ! | (http://www.rtweb.aer.com/) |
7791 ! | |
7792 ! --------------------------------------------------------------------------
7794 ! ------- Modules -------
7795 use parkind, only : im => kind_im, rb => kind_rb
7796 use rrlw_wvn
7797 use rrtmg_lw_setcoef, only: lwatmref, lwavplank
7799 ! Steven Cavallo: added for buffer layer adjustment
7800 implicit none
7802 integer , save :: nlayers
7804 contains
7806 ! **************************************************************************
7807 subroutine rrtmg_lw_ini(cpdair)
7808 ! **************************************************************************
7809 !
7810 ! Original version: Michael J. Iacono; July, 1998
7811 ! First revision for GCMs: September, 1998
7812 ! Second revision for RRTM_V3.0: September, 2002
7813 !
7814 ! This subroutine performs calculations necessary for the initialization
7815 ! of the longwave model. Lookup tables are computed for use in the LW
7816 ! radiative transfer, and input absorption coefficient data for each
7817 ! spectral band are reduced from 256 g-point intervals to 140.
7818 ! **************************************************************************
7820 use parrrtm, only : mg, nbndlw, ngptlw
7821 use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
7822 use rrlw_vsn, only: hvrini, hnamini
7824 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
7825 ! at constant pressure at 273 K
7826 ! (J kg-1 K-1)
7828 ! ------- Local -------
7830 integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr
7831 integer(kind=im) :: igcsm, iprsm
7833 real(kind=rb) :: wtsum, wtsm(mg) !
7834 real(kind=rb) :: tfn !
7836 real(kind=rb), parameter :: expeps = 1.e-20 ! Smallest value for exponential table
7838 ! ------- Definitions -------
7839 ! Arrays for 10000-point look-up tables:
7840 ! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
7841 ! EXP_TBL Exponential lookup table for ransmittance
7842 ! TFN_TBL Tau transition function; i.e. the transition of the Planck
7843 ! function from that for the mean layer temperature to that for
7844 ! the layer boundary temperature as a function of optical depth.
7845 ! The "linear in tau" method is used to make the table.
7846 ! PADE Pade approximation constant (= 0.278)
7847 ! BPADE Inverse of the Pade approximation constant
7848 !
7850 hvrini = '$Revision: 1.3 $'
7852 ! Initialize model data
7853 call lwdatinit(cpdair)
7854 call lwcmbdat ! g-point interval reduction data
7855 call lwcldpr ! cloud optical properties
7856 call lwatmref ! reference MLS profile
7857 call lwavplank ! Planck function
7858 ! Moved to module_ra_rrtmg_lw for WRF
7859 ! call lw_kgb01 ! molecular absorption coefficients
7860 ! call lw_kgb02
7861 ! call lw_kgb03
7862 ! call lw_kgb04
7863 ! call lw_kgb05
7864 ! call lw_kgb06
7865 ! call lw_kgb07
7866 ! call lw_kgb08
7867 ! call lw_kgb09
7868 ! call lw_kgb10
7869 ! call lw_kgb11
7870 ! call lw_kgb12
7871 ! call lw_kgb13
7872 ! call lw_kgb14
7873 ! call lw_kgb15
7874 ! call lw_kgb16
7876 ! Compute lookup tables for transmittance, tau transition function,
7877 ! and clear sky tau (for the cloudy sky radiative transfer). Tau is
7878 ! computed as a function of the tau transition function, transmittance
7879 ! is calculated as a function of tau, and the tau transition function
7880 ! is calculated using the linear in tau formulation at values of tau
7881 ! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables
7882 ! are computed at intervals of 0.001. The inverse of the constant used
7883 ! in the Pade approximation to the tau transition function is set to b.
7885 tau_tbl(0) = 0.0_rb
7886 tau_tbl(ntbl) = 1.e10_rb
7887 exp_tbl(0) = 1.0_rb
7888 exp_tbl(ntbl) = expeps
7889 tfn_tbl(0) = 0.0_rb
7890 tfn_tbl(ntbl) = 1.0_rb
7891 bpade = 1.0_rb / pade
7892 do itr = 1, ntbl-1
7893 tfn = float(itr) / float(ntbl)
7894 tau_tbl(itr) = bpade * tfn / (1._rb - tfn)
7895 exp_tbl(itr) = exp(-tau_tbl(itr))
7896 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
7897 if (tau_tbl(itr) .lt. 0.06_rb) then
7898 tfn_tbl(itr) = tau_tbl(itr)/6._rb
7899 else
7900 tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
7901 endif
7902 enddo
7904 ! Perform g-point reduction from 16 per band (256 total points) to
7905 ! a band dependant number (140 total points) for all absorption
7906 ! coefficient input data and Planck fraction input data.
7907 ! Compute relative weighting for new g-point combinations.
7909 igcsm = 0
7910 do ibnd = 1,nbndlw
7911 iprsm = 0
7912 if (ngc(ibnd).lt.mg) then
7913 do igc = 1,ngc(ibnd)
7914 igcsm = igcsm + 1
7915 wtsum = 0._rb
7916 do ipr = 1, ngn(igcsm)
7917 iprsm = iprsm + 1
7918 wtsum = wtsum + wt(iprsm)
7919 enddo
7920 wtsm(igc) = wtsum
7921 enddo
7922 do ig = 1, ng(ibnd)
7923 ind = (ibnd-1)*mg + ig
7924 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
7925 enddo
7926 else
7927 do ig = 1, ng(ibnd)
7928 igcsm = igcsm + 1
7929 ind = (ibnd-1)*mg + ig
7930 rwgt(ind) = 1.0_rb
7931 enddo
7932 endif
7933 enddo
7935 ! Reduce g-points for absorption coefficient data in each LW spectral band.
7937 call cmbgb1
7938 call cmbgb2
7939 call cmbgb3
7940 call cmbgb4
7941 call cmbgb5
7942 call cmbgb6
7943 call cmbgb7
7944 call cmbgb8
7945 call cmbgb9
7946 call cmbgb10
7947 call cmbgb11
7948 call cmbgb12
7949 call cmbgb13
7950 call cmbgb14
7951 call cmbgb15
7952 call cmbgb16
7954 end subroutine rrtmg_lw_ini
7956 !***************************************************************************
7957 subroutine lwdatinit(cpdair)
7958 !***************************************************************************
7960 ! --------- Modules ----------
7962 use parrrtm, only : maxxsec, maxinpx
7963 use rrlw_con, only: heatfac, grav, planck, boltz, &
7964 clight, avogad, alosmt, gascon, radcn1, radcn2, &
7965 sbcnst, secdy
7966 use rrlw_vsn
7968 save
7970 real(kind=rb), intent(in) :: cpdair ! Specific heat capacity of dry air
7971 ! at constant pressure at 273 K
7972 ! (J kg-1 K-1)
7974 ! Longwave spectral band limits (wavenumbers)
7975 wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb, &
7976 980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb, &
7977 2080._rb,2250._rb,2380._rb,2600._rb/)
7978 wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb, &
7979 1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb, &
7980 2250._rb,2380._rb,2600._rb,3250._rb/)
7981 delwave(:) = (/340._rb, 150._rb, 130._rb, 70._rb, 120._rb, 160._rb, &
7982 100._rb, 100._rb, 210._rb, 90._rb, 320._rb, 280._rb, &
7983 170._rb, 130._rb, 220._rb, 650._rb/)
7985 ! Spectral band information
7986 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
7987 nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
7988 nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
7990 ! nxmol - number of cross-sections input by user
7991 ! ixindx(i) - index of cross-section molecule corresponding to Ith
7992 ! cross-section specified by user
7993 ! = 0 -- not allowed in rrtm
7994 ! = 1 -- ccl4
7995 ! = 2 -- cfc11
7996 ! = 3 -- cfc12
7997 ! = 4 -- cfc22
7998 nxmol = 4
7999 ixindx(1) = 1
8000 ixindx(2) = 2
8001 ixindx(3) = 3
8002 ixindx(4) = 4
8003 ixindx(5:maxinpx) = 0
8005 ! Fundamental physical constants from NIST 2002
8007 grav = 9.8066_rb ! Acceleration of gravity
8008 ! (m s-2)
8009 planck = 6.62606876e-27_rb ! Planck constant
8010 ! (ergs s; g cm2 s-1)
8011 boltz = 1.3806503e-16_rb ! Boltzmann constant
8012 ! (ergs K-1; g cm2 s-2 K-1)
8013 clight = 2.99792458e+10_rb ! Speed of light in a vacuum
8014 ! (cm s-1)
8015 avogad = 6.02214199e+23_rb ! Avogadro constant
8016 ! (mol-1)
8017 alosmt = 2.6867775e+19_rb ! Loschmidt constant
8018 ! (cm-3)
8019 gascon = 8.31447200e+07_rb ! Molar gas constant
8020 ! (ergs mol-1 K-1)
8021 radcn1 = 1.191042722e-12_rb ! First radiation constant
8022 ! (W cm2 sr-1)
8023 radcn2 = 1.4387752_rb ! Second radiation constant
8024 ! (cm K)
8025 sbcnst = 5.670400e-04_rb ! Stefan-Boltzmann constant
8026 ! (W cm-2 K-4)
8027 secdy = 8.6400e4_rb ! Number of seconds per day
8028 ! (s d-1)
8029 !
8030 ! units are generally cgs
8031 !
8032 ! The first and second radiation constants are taken from NIST.
8033 ! They were previously obtained from the relations:
8034 ! radcn1 = 2.*planck*clight*clight*1.e-07
8035 ! radcn2 = planck*clight/boltz
8037 ! Heatfac is the factor by which delta-flux / delta-pressure is
8038 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
8039 ! the heating rate in units of degrees/day. It is equal to:
8040 ! Original value:
8041 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8042 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
8043 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8044 ! = (9.8066)(86400)(1e-5)/(1.004)
8045 ! heatfac = 8.4391_rb
8046 !
8047 ! Modified value for consistency with CAM3:
8048 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8049 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
8050 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8051 ! = (9.80616)(86400)(1e-5)/(1.00464)
8052 ! heatfac = 8.43339130434_rb
8053 !
8054 ! Calculated value:
8055 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
8056 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
8057 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
8058 heatfac = grav * secdy / (cpdair * 1.e2_rb)
8060 end subroutine lwdatinit
8062 !***************************************************************************
8063 subroutine lwcmbdat
8064 !***************************************************************************
8066 save
8068 ! ------- Definitions -------
8069 ! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
8070 ! This mapping from 256 to 140 points has been carefully selected to
8071 ! minimize the effect on the resulting fluxes and cooling rates, and
8072 ! caution should be used if the mapping is modified. The full 256
8073 ! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
8074 ! ngptlw The total number of new g-points
8075 ! ngc The number of new g-points in each band
8076 ! ngs The cumulative sum of new g-points for each band
8077 ! ngm The index of each new g-point relative to the original
8078 ! 16 g-points for each band.
8079 ! ngn The number of original g-points that are combined to make
8080 ! each new g-point in each band.
8081 ! ngb The band index for each new g-point.
8082 ! wt RRTM weights for 16 g-points.
8084 ! ------- Data statements -------
8085 ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
8086 ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
8087 ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1
8088 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2
8089 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3
8090 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4
8091 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5
8092 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6
8093 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7
8094 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8
8095 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9
8096 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10
8097 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11
8098 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12
8099 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13
8100 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14
8101 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15
8102 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16
8103 ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1
8104 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2
8105 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3
8106 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4
8107 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5
8108 2,2,2,2,2,2,2,2, & ! band 6
8109 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7
8110 2,2,2,2,2,2,2,2, & ! band 8
8111 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9
8112 2,2,2,2,4,4, & ! band 10
8113 1,1,2,2,2,2,3,3, & ! band 11
8114 1,1,1,1,2,2,4,4, & ! band 12
8115 3,3,4,6, & ! band 13
8116 8,8, & ! band 14
8117 8,8, & ! band 15
8118 4,12/) ! band 16
8119 ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1
8120 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2
8121 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3
8122 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4
8123 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5
8124 6,6,6,6,6,6,6,6, & ! band 6
8125 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7
8126 8,8,8,8,8,8,8,8, & ! band 8
8127 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9
8128 10,10,10,10,10,10, & ! band 10
8129 11,11,11,11,11,11,11,11, & ! band 11
8130 12,12,12,12,12,12,12,12, & ! band 12
8131 13,13,13,13, & ! band 13
8132 14,14, & ! band 14
8133 15,15, & ! band 15
8134 16,16/) ! band 16
8135 wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
8136 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
8137 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
8138 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
8139 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
8140 0.0000750000_rb/)
8142 end subroutine lwcmbdat
8144 !***************************************************************************
8145 subroutine cmbgb1
8146 !***************************************************************************
8147 !
8148 ! Original version: MJIacono; July 1998
8149 ! Revision for GCMs: MJIacono; September 1998
8150 ! Revision for RRTMG: MJIacono, September 2002
8151 ! Revision for F90 reformatting: MJIacono, June 2006
8152 !
8153 ! The subroutines CMBGB1->CMBGB16 input the absorption coefficient
8154 ! data for each band, which are defined for 16 g-points and 16 spectral
8155 ! bands. The data are combined with appropriate weighting following the
8156 ! g-point mapping arrays specified in RRTMINIT. Plank fraction data
8157 ! in arrays FRACREFA and FRACREFB are combined without weighting. All
8158 ! g-point reduced data are put into new arrays for use in RRTM.
8159 !
8160 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
8161 ! (high key - h2o; high minor - n2)
8162 ! note: previous versions of rrtm band 1:
8163 ! 10-250 cm-1 (low - h2o; high - h2o)
8164 !***************************************************************************
8166 use parrrtm, only : mg, nbndlw, ngptlw, ng1
8167 use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
8168 selfrefo, forrefo, &
8169 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, &
8170 selfref, forref
8172 ! ------- Local -------
8173 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8174 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
8177 do jt = 1,5
8178 do jp = 1,13
8179 iprsm = 0
8180 do igc = 1,ngc(1)
8181 sumk = 0.
8182 do ipr = 1, ngn(igc)
8183 iprsm = iprsm + 1
8184 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
8185 enddo
8186 ka(jt,jp,igc) = sumk
8187 enddo
8188 enddo
8189 do jp = 13,59
8190 iprsm = 0
8191 do igc = 1,ngc(1)
8192 sumk = 0.
8193 do ipr = 1, ngn(igc)
8194 iprsm = iprsm + 1
8195 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
8196 enddo
8197 kb(jt,jp,igc) = sumk
8198 enddo
8199 enddo
8200 enddo
8202 do jt = 1,10
8203 iprsm = 0
8204 do igc = 1,ngc(1)
8205 sumk = 0.
8206 do ipr = 1, ngn(igc)
8207 iprsm = iprsm + 1
8208 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
8209 enddo
8210 selfref(jt,igc) = sumk
8211 enddo
8212 enddo
8214 do jt = 1,4
8215 iprsm = 0
8216 do igc = 1,ngc(1)
8217 sumk = 0.
8218 do ipr = 1, ngn(igc)
8219 iprsm = iprsm + 1
8220 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
8221 enddo
8222 forref(jt,igc) = sumk
8223 enddo
8224 enddo
8226 do jt = 1,19
8227 iprsm = 0
8228 do igc = 1,ngc(1)
8229 sumk1 = 0.
8230 sumk2 = 0.
8231 do ipr = 1, ngn(igc)
8232 iprsm = iprsm + 1
8233 sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
8234 sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
8235 enddo
8236 ka_mn2(jt,igc) = sumk1
8237 kb_mn2(jt,igc) = sumk2
8238 enddo
8239 enddo
8241 iprsm = 0
8242 do igc = 1,ngc(1)
8243 sumf1 = 0.
8244 sumf2 = 0.
8245 do ipr = 1, ngn(igc)
8246 iprsm = iprsm + 1
8247 sumf1= sumf1+ fracrefao(iprsm)
8248 sumf2= sumf2+ fracrefbo(iprsm)
8249 enddo
8250 fracrefa(igc) = sumf1
8251 fracrefb(igc) = sumf2
8252 enddo
8254 end subroutine cmbgb1
8256 !***************************************************************************
8257 subroutine cmbgb2
8258 !***************************************************************************
8259 !
8260 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
8261 !
8262 ! note: previous version of rrtm band 2:
8263 ! 250 - 500 cm-1 (low - h2o; high - h2o)
8264 !***************************************************************************
8266 use parrrtm, only : mg, nbndlw, ngptlw, ng2
8267 use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8268 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8270 ! ------- Local -------
8271 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8272 real(kind=rb) :: sumk, sumf1, sumf2
8275 do jt = 1,5
8276 do jp = 1,13
8277 iprsm = 0
8278 do igc = 1,ngc(2)
8279 sumk = 0.
8280 do ipr = 1, ngn(ngs(1)+igc)
8281 iprsm = iprsm + 1
8282 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
8283 enddo
8284 ka(jt,jp,igc) = sumk
8285 enddo
8286 enddo
8287 do jp = 13,59
8288 iprsm = 0
8289 do igc = 1,ngc(2)
8290 sumk = 0.
8291 do ipr = 1, ngn(ngs(1)+igc)
8292 iprsm = iprsm + 1
8293 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
8294 enddo
8295 kb(jt,jp,igc) = sumk
8296 enddo
8297 enddo
8298 enddo
8300 do jt = 1,10
8301 iprsm = 0
8302 do igc = 1,ngc(2)
8303 sumk = 0.
8304 do ipr = 1, ngn(ngs(1)+igc)
8305 iprsm = iprsm + 1
8306 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
8307 enddo
8308 selfref(jt,igc) = sumk
8309 enddo
8310 enddo
8312 do jt = 1,4
8313 iprsm = 0
8314 do igc = 1,ngc(2)
8315 sumk = 0.
8316 do ipr = 1, ngn(ngs(1)+igc)
8317 iprsm = iprsm + 1
8318 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
8319 enddo
8320 forref(jt,igc) = sumk
8321 enddo
8322 enddo
8324 iprsm = 0
8325 do igc = 1,ngc(2)
8326 sumf1 = 0.
8327 sumf2 = 0.
8328 do ipr = 1, ngn(ngs(1)+igc)
8329 iprsm = iprsm + 1
8330 sumf1= sumf1+ fracrefao(iprsm)
8331 sumf2= sumf2+ fracrefbo(iprsm)
8332 enddo
8333 fracrefa(igc) = sumf1
8334 fracrefb(igc) = sumf2
8335 enddo
8337 end subroutine cmbgb2
8339 !***************************************************************************
8340 subroutine cmbgb3
8341 !***************************************************************************
8342 !
8343 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
8344 ! (high key - h2o,co2; high minor - n2o)
8345 !
8346 ! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
8347 !***************************************************************************
8349 use parrrtm, only : mg, nbndlw, ngptlw, ng3
8350 use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
8351 selfrefo, forrefo, &
8352 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, &
8353 selfref, forref
8355 ! ------- Local -------
8356 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8357 real(kind=rb) :: sumk, sumf
8360 do jn = 1,9
8361 do jt = 1,5
8362 do jp = 1,13
8363 iprsm = 0
8364 do igc = 1,ngc(3)
8365 sumk = 0.
8366 do ipr = 1, ngn(ngs(2)+igc)
8367 iprsm = iprsm + 1
8368 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8369 enddo
8370 ka(jn,jt,jp,igc) = sumk
8371 enddo
8372 enddo
8373 enddo
8374 enddo
8375 do jn = 1,5
8376 do jt = 1,5
8377 do jp = 13,59
8378 iprsm = 0
8379 do igc = 1,ngc(3)
8380 sumk = 0.
8381 do ipr = 1, ngn(ngs(2)+igc)
8382 iprsm = iprsm + 1
8383 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8384 enddo
8385 kb(jn,jt,jp,igc) = sumk
8386 enddo
8387 enddo
8388 enddo
8389 enddo
8391 do jn = 1,9
8392 do jt = 1,19
8393 iprsm = 0
8394 do igc = 1,ngc(3)
8395 sumk = 0.
8396 do ipr = 1, ngn(ngs(2)+igc)
8397 iprsm = iprsm + 1
8398 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8399 enddo
8400 ka_mn2o(jn,jt,igc) = sumk
8401 enddo
8402 enddo
8403 enddo
8405 do jn = 1,5
8406 do jt = 1,19
8407 iprsm = 0
8408 do igc = 1,ngc(3)
8409 sumk = 0.
8410 do ipr = 1, ngn(ngs(2)+igc)
8411 iprsm = iprsm + 1
8412 sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8413 enddo
8414 kb_mn2o(jn,jt,igc) = sumk
8415 enddo
8416 enddo
8417 enddo
8419 do jt = 1,10
8420 iprsm = 0
8421 do igc = 1,ngc(3)
8422 sumk = 0.
8423 do ipr = 1, ngn(ngs(2)+igc)
8424 iprsm = iprsm + 1
8425 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
8426 enddo
8427 selfref(jt,igc) = sumk
8428 enddo
8429 enddo
8431 do jt = 1,4
8432 iprsm = 0
8433 do igc = 1,ngc(3)
8434 sumk = 0.
8435 do ipr = 1, ngn(ngs(2)+igc)
8436 iprsm = iprsm + 1
8437 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
8438 enddo
8439 forref(jt,igc) = sumk
8440 enddo
8441 enddo
8443 do jp = 1,9
8444 iprsm = 0
8445 do igc = 1,ngc(3)
8446 sumf = 0.
8447 do ipr = 1, ngn(ngs(2)+igc)
8448 iprsm = iprsm + 1
8449 sumf = sumf + fracrefao(iprsm,jp)
8450 enddo
8451 fracrefa(igc,jp) = sumf
8452 enddo
8453 enddo
8455 do jp = 1,5
8456 iprsm = 0
8457 do igc = 1,ngc(3)
8458 sumf = 0.
8459 do ipr = 1, ngn(ngs(2)+igc)
8460 iprsm = iprsm + 1
8461 sumf = sumf + fracrefbo(iprsm,jp)
8462 enddo
8463 fracrefb(igc,jp) = sumf
8464 enddo
8465 enddo
8467 end subroutine cmbgb3
8469 !***************************************************************************
8470 subroutine cmbgb4
8471 !***************************************************************************
8472 !
8473 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
8474 !
8475 ! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
8476 !***************************************************************************
8478 use parrrtm, only : mg, nbndlw, ngptlw, ng4
8479 use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
8480 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8482 ! ------- Local -------
8483 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8484 real(kind=rb) :: sumk, sumf
8487 do jn = 1,9
8488 do jt = 1,5
8489 do jp = 1,13
8490 iprsm = 0
8491 do igc = 1,ngc(4)
8492 sumk = 0.
8493 do ipr = 1, ngn(ngs(3)+igc)
8494 iprsm = iprsm + 1
8495 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8496 enddo
8497 ka(jn,jt,jp,igc) = sumk
8498 enddo
8499 enddo
8500 enddo
8501 enddo
8502 do jn = 1,5
8503 do jt = 1,5
8504 do jp = 13,59
8505 iprsm = 0
8506 do igc = 1,ngc(4)
8507 sumk = 0.
8508 do ipr = 1, ngn(ngs(3)+igc)
8509 iprsm = iprsm + 1
8510 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8511 enddo
8512 kb(jn,jt,jp,igc) = sumk
8513 enddo
8514 enddo
8515 enddo
8516 enddo
8518 do jt = 1,10
8519 iprsm = 0
8520 do igc = 1,ngc(4)
8521 sumk = 0.
8522 do ipr = 1, ngn(ngs(3)+igc)
8523 iprsm = iprsm + 1
8524 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
8525 enddo
8526 selfref(jt,igc) = sumk
8527 enddo
8528 enddo
8530 do jt = 1,4
8531 iprsm = 0
8532 do igc = 1,ngc(4)
8533 sumk = 0.
8534 do ipr = 1, ngn(ngs(3)+igc)
8535 iprsm = iprsm + 1
8536 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
8537 enddo
8538 forref(jt,igc) = sumk
8539 enddo
8540 enddo
8542 do jp = 1,9
8543 iprsm = 0
8544 do igc = 1,ngc(4)
8545 sumf = 0.
8546 do ipr = 1, ngn(ngs(3)+igc)
8547 iprsm = iprsm + 1
8548 sumf = sumf + fracrefao(iprsm,jp)
8549 enddo
8550 fracrefa(igc,jp) = sumf
8551 enddo
8552 enddo
8554 do jp = 1,5
8555 iprsm = 0
8556 do igc = 1,ngc(4)
8557 sumf = 0.
8558 do ipr = 1, ngn(ngs(3)+igc)
8559 iprsm = iprsm + 1
8560 sumf = sumf + fracrefbo(iprsm,jp)
8561 enddo
8562 fracrefb(igc,jp) = sumf
8563 enddo
8564 enddo
8566 end subroutine cmbgb4
8568 !***************************************************************************
8569 subroutine cmbgb5
8570 !***************************************************************************
8571 !
8572 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
8573 ! (high key - o3,co2)
8574 !
8575 ! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
8576 !***************************************************************************
8578 use parrrtm, only : mg, nbndlw, ngptlw, ng5
8579 use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
8580 selfrefo, forrefo, &
8581 fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
8582 selfref, forref
8584 ! ------- Local -------
8585 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8586 real(kind=rb) :: sumk, sumf
8589 do jn = 1,9
8590 do jt = 1,5
8591 do jp = 1,13
8592 iprsm = 0
8593 do igc = 1,ngc(5)
8594 sumk = 0.
8595 do ipr = 1, ngn(ngs(4)+igc)
8596 iprsm = iprsm + 1
8597 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8598 enddo
8599 ka(jn,jt,jp,igc) = sumk
8600 enddo
8601 enddo
8602 enddo
8603 enddo
8604 do jn = 1,5
8605 do jt = 1,5
8606 do jp = 13,59
8607 iprsm = 0
8608 do igc = 1,ngc(5)
8609 sumk = 0.
8610 do ipr = 1, ngn(ngs(4)+igc)
8611 iprsm = iprsm + 1
8612 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8613 enddo
8614 kb(jn,jt,jp,igc) = sumk
8615 enddo
8616 enddo
8617 enddo
8618 enddo
8620 do jn = 1,9
8621 do jt = 1,19
8622 iprsm = 0
8623 do igc = 1,ngc(5)
8624 sumk = 0.
8625 do ipr = 1, ngn(ngs(4)+igc)
8626 iprsm = iprsm + 1
8627 sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
8628 enddo
8629 ka_mo3(jn,jt,igc) = sumk
8630 enddo
8631 enddo
8632 enddo
8634 do jt = 1,10
8635 iprsm = 0
8636 do igc = 1,ngc(5)
8637 sumk = 0.
8638 do ipr = 1, ngn(ngs(4)+igc)
8639 iprsm = iprsm + 1
8640 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
8641 enddo
8642 selfref(jt,igc) = sumk
8643 enddo
8644 enddo
8646 do jt = 1,4
8647 iprsm = 0
8648 do igc = 1,ngc(5)
8649 sumk = 0.
8650 do ipr = 1, ngn(ngs(4)+igc)
8651 iprsm = iprsm + 1
8652 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
8653 enddo
8654 forref(jt,igc) = sumk
8655 enddo
8656 enddo
8658 do jp = 1,9
8659 iprsm = 0
8660 do igc = 1,ngc(5)
8661 sumf = 0.
8662 do ipr = 1, ngn(ngs(4)+igc)
8663 iprsm = iprsm + 1
8664 sumf = sumf + fracrefao(iprsm,jp)
8665 enddo
8666 fracrefa(igc,jp) = sumf
8667 enddo
8668 enddo
8670 do jp = 1,5
8671 iprsm = 0
8672 do igc = 1,ngc(5)
8673 sumf = 0.
8674 do ipr = 1, ngn(ngs(4)+igc)
8675 iprsm = iprsm + 1
8676 sumf = sumf + fracrefbo(iprsm,jp)
8677 enddo
8678 fracrefb(igc,jp) = sumf
8679 enddo
8680 enddo
8682 iprsm = 0
8683 do igc = 1,ngc(5)
8684 sumk = 0.
8685 do ipr = 1, ngn(ngs(4)+igc)
8686 iprsm = iprsm + 1
8687 sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
8688 enddo
8689 ccl4(igc) = sumk
8690 enddo
8692 end subroutine cmbgb5
8694 !***************************************************************************
8695 subroutine cmbgb6
8696 !***************************************************************************
8697 !
8698 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
8699 ! (high key - nothing; high minor - cfc11, cfc12)
8700 !
8701 ! old band 6: 820-980 cm-1 (low - h2o; high - nothing)
8702 !***************************************************************************
8704 use parrrtm, only : mg, nbndlw, ngptlw, ng6
8705 use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
8706 selfrefo, forrefo, &
8707 fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, &
8708 selfref, forref
8710 ! ------- Local -------
8711 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8712 real(kind=rb) :: sumk, sumf, sumk1, sumk2
8715 do jt = 1,5
8716 do jp = 1,13
8717 iprsm = 0
8718 do igc = 1,ngc(6)
8719 sumk = 0.
8720 do ipr = 1, ngn(ngs(5)+igc)
8721 iprsm = iprsm + 1
8722 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
8723 enddo
8724 ka(jt,jp,igc) = sumk
8725 enddo
8726 enddo
8727 enddo
8729 do jt = 1,19
8730 iprsm = 0
8731 do igc = 1,ngc(6)
8732 sumk = 0.
8733 do ipr = 1, ngn(ngs(5)+igc)
8734 iprsm = iprsm + 1
8735 sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
8736 enddo
8737 ka_mco2(jt,igc) = sumk
8738 enddo
8739 enddo
8741 do jt = 1,10
8742 iprsm = 0
8743 do igc = 1,ngc(6)
8744 sumk = 0.
8745 do ipr = 1, ngn(ngs(5)+igc)
8746 iprsm = iprsm + 1
8747 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
8748 enddo
8749 selfref(jt,igc) = sumk
8750 enddo
8751 enddo
8753 do jt = 1,4
8754 iprsm = 0
8755 do igc = 1,ngc(6)
8756 sumk = 0.
8757 do ipr = 1, ngn(ngs(5)+igc)
8758 iprsm = iprsm + 1
8759 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
8760 enddo
8761 forref(jt,igc) = sumk
8762 enddo
8763 enddo
8765 iprsm = 0
8766 do igc = 1,ngc(6)
8767 sumf = 0.
8768 sumk1= 0.
8769 sumk2= 0.
8770 do ipr = 1, ngn(ngs(5)+igc)
8771 iprsm = iprsm + 1
8772 sumf = sumf + fracrefao(iprsm)
8773 sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
8774 sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
8775 enddo
8776 fracrefa(igc) = sumf
8777 cfc11adj(igc) = sumk1
8778 cfc12(igc) = sumk2
8779 enddo
8781 end subroutine cmbgb6
8783 !***************************************************************************
8784 subroutine cmbgb7
8785 !***************************************************************************
8786 !
8787 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
8788 ! (high key - o3; high minor - co2)
8789 !
8790 ! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
8791 !***************************************************************************
8793 use parrrtm, only : mg, nbndlw, ngptlw, ng7
8794 use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
8795 selfrefo, forrefo, &
8796 fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, &
8797 selfref, forref
8799 ! ------- Local -------
8800 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8801 real(kind=rb) :: sumk, sumf
8804 do jn = 1,9
8805 do jt = 1,5
8806 do jp = 1,13
8807 iprsm = 0
8808 do igc = 1,ngc(7)
8809 sumk = 0.
8810 do ipr = 1, ngn(ngs(6)+igc)
8811 iprsm = iprsm + 1
8812 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
8813 enddo
8814 ka(jn,jt,jp,igc) = sumk
8815 enddo
8816 enddo
8817 enddo
8818 enddo
8819 do jt = 1,5
8820 do jp = 13,59
8821 iprsm = 0
8822 do igc = 1,ngc(7)
8823 sumk = 0.
8824 do ipr = 1, ngn(ngs(6)+igc)
8825 iprsm = iprsm + 1
8826 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
8827 enddo
8828 kb(jt,jp,igc) = sumk
8829 enddo
8830 enddo
8831 enddo
8833 do jn = 1,9
8834 do jt = 1,19
8835 iprsm = 0
8836 do igc = 1,ngc(7)
8837 sumk = 0.
8838 do ipr = 1, ngn(ngs(6)+igc)
8839 iprsm = iprsm + 1
8840 sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
8841 enddo
8842 ka_mco2(jn,jt,igc) = sumk
8843 enddo
8844 enddo
8845 enddo
8847 do jt = 1,19
8848 iprsm = 0
8849 do igc = 1,ngc(7)
8850 sumk = 0.
8851 do ipr = 1, ngn(ngs(6)+igc)
8852 iprsm = iprsm + 1
8853 sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
8854 enddo
8855 kb_mco2(jt,igc) = sumk
8856 enddo
8857 enddo
8859 do jt = 1,10
8860 iprsm = 0
8861 do igc = 1,ngc(7)
8862 sumk = 0.
8863 do ipr = 1, ngn(ngs(6)+igc)
8864 iprsm = iprsm + 1
8865 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
8866 enddo
8867 selfref(jt,igc) = sumk
8868 enddo
8869 enddo
8871 do jt = 1,4
8872 iprsm = 0
8873 do igc = 1,ngc(7)
8874 sumk = 0.
8875 do ipr = 1, ngn(ngs(6)+igc)
8876 iprsm = iprsm + 1
8877 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
8878 enddo
8879 forref(jt,igc) = sumk
8880 enddo
8881 enddo
8883 do jp = 1,9
8884 iprsm = 0
8885 do igc = 1,ngc(7)
8886 sumf = 0.
8887 do ipr = 1, ngn(ngs(6)+igc)
8888 iprsm = iprsm + 1
8889 sumf = sumf + fracrefao(iprsm,jp)
8890 enddo
8891 fracrefa(igc,jp) = sumf
8892 enddo
8893 enddo
8895 iprsm = 0
8896 do igc = 1,ngc(7)
8897 sumf = 0.
8898 do ipr = 1, ngn(ngs(6)+igc)
8899 iprsm = iprsm + 1
8900 sumf = sumf + fracrefbo(iprsm)
8901 enddo
8902 fracrefb(igc) = sumf
8903 enddo
8905 end subroutine cmbgb7
8907 !***************************************************************************
8908 subroutine cmbgb8
8909 !***************************************************************************
8910 !
8911 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
8912 ! (high key - o3; high minor - co2, n2o)
8913 !
8914 ! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
8915 !***************************************************************************
8917 use parrrtm, only : mg, nbndlw, ngptlw, ng8
8918 use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
8919 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
8920 cfc12o, cfc22adjo, &
8921 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, &
8922 ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, &
8923 cfc12, cfc22adj
8925 ! ------- Local -------
8926 integer(kind=im) :: jt, jp, igc, ipr, iprsm
8927 real(kind=rb) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
8930 do jt = 1,5
8931 do jp = 1,13
8932 iprsm = 0
8933 do igc = 1,ngc(8)
8934 sumk = 0.
8935 do ipr = 1, ngn(ngs(7)+igc)
8936 iprsm = iprsm + 1
8937 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
8938 enddo
8939 ka(jt,jp,igc) = sumk
8940 enddo
8941 enddo
8942 enddo
8943 do jt = 1,5
8944 do jp = 13,59
8945 iprsm = 0
8946 do igc = 1,ngc(8)
8947 sumk = 0.
8948 do ipr = 1, ngn(ngs(7)+igc)
8949 iprsm = iprsm + 1
8950 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
8951 enddo
8952 kb(jt,jp,igc) = sumk
8953 enddo
8954 enddo
8955 enddo
8957 do jt = 1,10
8958 iprsm = 0
8959 do igc = 1,ngc(8)
8960 sumk = 0.
8961 do ipr = 1, ngn(ngs(7)+igc)
8962 iprsm = iprsm + 1
8963 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
8964 enddo
8965 selfref(jt,igc) = sumk
8966 enddo
8967 enddo
8969 do jt = 1,4
8970 iprsm = 0
8971 do igc = 1,ngc(8)
8972 sumk = 0.
8973 do ipr = 1, ngn(ngs(7)+igc)
8974 iprsm = iprsm + 1
8975 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
8976 enddo
8977 forref(jt,igc) = sumk
8978 enddo
8979 enddo
8981 do jt = 1,19
8982 iprsm = 0
8983 do igc = 1,ngc(8)
8984 sumk1 = 0.
8985 sumk2 = 0.
8986 sumk3 = 0.
8987 sumk4 = 0.
8988 sumk5 = 0.
8989 do ipr = 1, ngn(ngs(7)+igc)
8990 iprsm = iprsm + 1
8991 sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
8992 sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
8993 sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
8994 sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
8995 sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
8996 enddo
8997 ka_mco2(jt,igc) = sumk1
8998 kb_mco2(jt,igc) = sumk2
8999 ka_mo3(jt,igc) = sumk3
9000 ka_mn2o(jt,igc) = sumk4
9001 kb_mn2o(jt,igc) = sumk5
9002 enddo
9003 enddo
9005 iprsm = 0
9006 do igc = 1,ngc(8)
9007 sumf1= 0.
9008 sumf2= 0.
9009 sumk1= 0.
9010 sumk2= 0.
9011 do ipr = 1, ngn(ngs(7)+igc)
9012 iprsm = iprsm + 1
9013 sumf1= sumf1+ fracrefao(iprsm)
9014 sumf2= sumf2+ fracrefbo(iprsm)
9015 sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
9016 sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
9017 enddo
9018 fracrefa(igc) = sumf1
9019 fracrefb(igc) = sumf2
9020 cfc12(igc) = sumk1
9021 cfc22adj(igc) = sumk2
9022 enddo
9024 end subroutine cmbgb8
9026 !***************************************************************************
9027 subroutine cmbgb9
9028 !***************************************************************************
9029 !
9030 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
9031 ! (high key - ch4; high minor - n2o)!
9033 ! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
9034 !***************************************************************************
9036 use parrrtm, only : mg, nbndlw, ngptlw, ng9
9037 use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, &
9038 kbo, kbo_mn2o, selfrefo, forrefo, &
9039 fracrefa, fracrefb, absa, ka, ka_mn2o, &
9040 absb, kb, kb_mn2o, selfref, forref
9042 ! ------- Local -------
9043 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9044 real(kind=rb) :: sumk, sumf
9047 do jn = 1,9
9048 do jt = 1,5
9049 do jp = 1,13
9050 iprsm = 0
9051 do igc = 1,ngc(9)
9052 sumk = 0.
9053 do ipr = 1, ngn(ngs(8)+igc)
9054 iprsm = iprsm + 1
9055 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
9056 enddo
9057 ka(jn,jt,jp,igc) = sumk
9058 enddo
9059 enddo
9060 enddo
9061 enddo
9063 do jt = 1,5
9064 do jp = 13,59
9065 iprsm = 0
9066 do igc = 1,ngc(9)
9067 sumk = 0.
9068 do ipr = 1, ngn(ngs(8)+igc)
9069 iprsm = iprsm + 1
9070 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
9071 enddo
9072 kb(jt,jp,igc) = sumk
9073 enddo
9074 enddo
9075 enddo
9077 do jn = 1,9
9078 do jt = 1,19
9079 iprsm = 0
9080 do igc = 1,ngc(9)
9081 sumk = 0.
9082 do ipr = 1, ngn(ngs(8)+igc)
9083 iprsm = iprsm + 1
9084 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
9085 enddo
9086 ka_mn2o(jn,jt,igc) = sumk
9087 enddo
9088 enddo
9089 enddo
9091 do jt = 1,19
9092 iprsm = 0
9093 do igc = 1,ngc(9)
9094 sumk = 0.
9095 do ipr = 1, ngn(ngs(8)+igc)
9096 iprsm = iprsm + 1
9097 sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
9098 enddo
9099 kb_mn2o(jt,igc) = sumk
9100 enddo
9101 enddo
9103 do jt = 1,10
9104 iprsm = 0
9105 do igc = 1,ngc(9)
9106 sumk = 0.
9107 do ipr = 1, ngn(ngs(8)+igc)
9108 iprsm = iprsm + 1
9109 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
9110 enddo
9111 selfref(jt,igc) = sumk
9112 enddo
9113 enddo
9115 do jt = 1,4
9116 iprsm = 0
9117 do igc = 1,ngc(9)
9118 sumk = 0.
9119 do ipr = 1, ngn(ngs(8)+igc)
9120 iprsm = iprsm + 1
9121 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
9122 enddo
9123 forref(jt,igc) = sumk
9124 enddo
9125 enddo
9127 do jp = 1,9
9128 iprsm = 0
9129 do igc = 1,ngc(9)
9130 sumf = 0.
9131 do ipr = 1, ngn(ngs(8)+igc)
9132 iprsm = iprsm + 1
9133 sumf = sumf + fracrefao(iprsm,jp)
9134 enddo
9135 fracrefa(igc,jp) = sumf
9136 enddo
9137 enddo
9139 iprsm = 0
9140 do igc = 1,ngc(9)
9141 sumf = 0.
9142 do ipr = 1, ngn(ngs(8)+igc)
9143 iprsm = iprsm + 1
9144 sumf = sumf + fracrefbo(iprsm)
9145 enddo
9146 fracrefb(igc) = sumf
9147 enddo
9149 end subroutine cmbgb9
9151 !***************************************************************************
9152 subroutine cmbgb10
9153 !***************************************************************************
9154 !
9155 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
9156 !
9157 ! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
9158 !***************************************************************************
9160 use parrrtm, only : mg, nbndlw, ngptlw, ng10
9161 use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, &
9162 selfrefo, forrefo, &
9163 fracrefa, fracrefb, absa, ka, absb, kb, &
9164 selfref, forref
9166 ! ------- Local -------
9167 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9168 real(kind=rb) :: sumk, sumf1, sumf2
9171 do jt = 1,5
9172 do jp = 1,13
9173 iprsm = 0
9174 do igc = 1,ngc(10)
9175 sumk = 0.
9176 do ipr = 1, ngn(ngs(9)+igc)
9177 iprsm = iprsm + 1
9178 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
9179 enddo
9180 ka(jt,jp,igc) = sumk
9181 enddo
9182 enddo
9183 enddo
9185 do jt = 1,5
9186 do jp = 13,59
9187 iprsm = 0
9188 do igc = 1,ngc(10)
9189 sumk = 0.
9190 do ipr = 1, ngn(ngs(9)+igc)
9191 iprsm = iprsm + 1
9192 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
9193 enddo
9194 kb(jt,jp,igc) = sumk
9195 enddo
9196 enddo
9197 enddo
9199 do jt = 1,10
9200 iprsm = 0
9201 do igc = 1,ngc(10)
9202 sumk = 0.
9203 do ipr = 1, ngn(ngs(9)+igc)
9204 iprsm = iprsm + 1
9205 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
9206 enddo
9207 selfref(jt,igc) = sumk
9208 enddo
9209 enddo
9211 do jt = 1,4
9212 iprsm = 0
9213 do igc = 1,ngc(10)
9214 sumk = 0.
9215 do ipr = 1, ngn(ngs(9)+igc)
9216 iprsm = iprsm + 1
9217 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
9218 enddo
9219 forref(jt,igc) = sumk
9220 enddo
9221 enddo
9223 iprsm = 0
9224 do igc = 1,ngc(10)
9225 sumf1= 0.
9226 sumf2= 0.
9227 do ipr = 1, ngn(ngs(9)+igc)
9228 iprsm = iprsm + 1
9229 sumf1= sumf1+ fracrefao(iprsm)
9230 sumf2= sumf2+ fracrefbo(iprsm)
9231 enddo
9232 fracrefa(igc) = sumf1
9233 fracrefb(igc) = sumf2
9234 enddo
9236 end subroutine cmbgb10
9238 !***************************************************************************
9239 subroutine cmbgb11
9240 !***************************************************************************
9241 !
9242 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9243 ! (high key - h2o; high minor - o2)
9244 !
9245 ! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
9246 ! (high key - h2o; high minor - o2)
9247 !***************************************************************************
9249 use parrrtm, only : mg, nbndlw, ngptlw, ng11
9250 use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, &
9251 kbo, kbo_mo2, selfrefo, forrefo, &
9252 fracrefa, fracrefb, absa, ka, ka_mo2, &
9253 absb, kb, kb_mo2, selfref, forref
9255 ! ------- Local -------
9256 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9257 real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
9260 do jt = 1,5
9261 do jp = 1,13
9262 iprsm = 0
9263 do igc = 1,ngc(11)
9264 sumk = 0.
9265 do ipr = 1, ngn(ngs(10)+igc)
9266 iprsm = iprsm + 1
9267 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
9268 enddo
9269 ka(jt,jp,igc) = sumk
9270 enddo
9271 enddo
9272 enddo
9273 do jt = 1,5
9274 do jp = 13,59
9275 iprsm = 0
9276 do igc = 1,ngc(11)
9277 sumk = 0.
9278 do ipr = 1, ngn(ngs(10)+igc)
9279 iprsm = iprsm + 1
9280 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
9281 enddo
9282 kb(jt,jp,igc) = sumk
9283 enddo
9284 enddo
9285 enddo
9287 do jt = 1,19
9288 iprsm = 0
9289 do igc = 1,ngc(11)
9290 sumk1 = 0.
9291 sumk2 = 0.
9292 do ipr = 1, ngn(ngs(10)+igc)
9293 iprsm = iprsm + 1
9294 sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
9295 sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
9296 enddo
9297 ka_mo2(jt,igc) = sumk1
9298 kb_mo2(jt,igc) = sumk2
9299 enddo
9300 enddo
9302 do jt = 1,10
9303 iprsm = 0
9304 do igc = 1,ngc(11)
9305 sumk = 0.
9306 do ipr = 1, ngn(ngs(10)+igc)
9307 iprsm = iprsm + 1
9308 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
9309 enddo
9310 selfref(jt,igc) = sumk
9311 enddo
9312 enddo
9314 do jt = 1,4
9315 iprsm = 0
9316 do igc = 1,ngc(11)
9317 sumk = 0.
9318 do ipr = 1, ngn(ngs(10)+igc)
9319 iprsm = iprsm + 1
9320 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
9321 enddo
9322 forref(jt,igc) = sumk
9323 enddo
9324 enddo
9326 iprsm = 0
9327 do igc = 1,ngc(11)
9328 sumf1= 0.
9329 sumf2= 0.
9330 do ipr = 1, ngn(ngs(10)+igc)
9331 iprsm = iprsm + 1
9332 sumf1= sumf1+ fracrefao(iprsm)
9333 sumf2= sumf2+ fracrefbo(iprsm)
9334 enddo
9335 fracrefa(igc) = sumf1
9336 fracrefb(igc) = sumf2
9337 enddo
9339 end subroutine cmbgb11
9341 !***************************************************************************
9342 subroutine cmbgb12
9343 !***************************************************************************
9344 !
9345 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9346 !
9347 ! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
9348 !***************************************************************************
9350 use parrrtm, only : mg, nbndlw, ngptlw, ng12
9351 use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, &
9352 fracrefa, absa, ka, selfref, forref
9354 ! ------- Local -------
9355 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9356 real(kind=rb) :: sumk, sumf
9359 do jn = 1,9
9360 do jt = 1,5
9361 do jp = 1,13
9362 iprsm = 0
9363 do igc = 1,ngc(12)
9364 sumk = 0.
9365 do ipr = 1, ngn(ngs(11)+igc)
9366 iprsm = iprsm + 1
9367 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
9368 enddo
9369 ka(jn,jt,jp,igc) = sumk
9370 enddo
9371 enddo
9372 enddo
9373 enddo
9375 do jt = 1,10
9376 iprsm = 0
9377 do igc = 1,ngc(12)
9378 sumk = 0.
9379 do ipr = 1, ngn(ngs(11)+igc)
9380 iprsm = iprsm + 1
9381 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
9382 enddo
9383 selfref(jt,igc) = sumk
9384 enddo
9385 enddo
9387 do jt = 1,4
9388 iprsm = 0
9389 do igc = 1,ngc(12)
9390 sumk = 0.
9391 do ipr = 1, ngn(ngs(11)+igc)
9392 iprsm = iprsm + 1
9393 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
9394 enddo
9395 forref(jt,igc) = sumk
9396 enddo
9397 enddo
9399 do jp = 1,9
9400 iprsm = 0
9401 do igc = 1,ngc(12)
9402 sumf = 0.
9403 do ipr = 1, ngn(ngs(11)+igc)
9404 iprsm = iprsm + 1
9405 sumf = sumf + fracrefao(iprsm,jp)
9406 enddo
9407 fracrefa(igc,jp) = sumf
9408 enddo
9409 enddo
9411 end subroutine cmbgb12
9413 !***************************************************************************
9414 subroutine cmbgb13
9415 !***************************************************************************
9416 !
9417 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
9418 !
9419 ! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
9420 !***************************************************************************
9422 use parrrtm, only : mg, nbndlw, ngptlw, ng13
9423 use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
9424 kbo_mo3, selfrefo, forrefo, &
9425 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, &
9426 kb_mo3, selfref, forref
9428 ! ------- Local -------
9429 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9430 real(kind=rb) :: sumk, sumk1, sumk2, sumf
9433 do jn = 1,9
9434 do jt = 1,5
9435 do jp = 1,13
9436 iprsm = 0
9437 do igc = 1,ngc(13)
9438 sumk = 0.
9439 do ipr = 1, ngn(ngs(12)+igc)
9440 iprsm = iprsm + 1
9441 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
9442 enddo
9443 ka(jn,jt,jp,igc) = sumk
9444 enddo
9445 enddo
9446 enddo
9447 enddo
9449 do jn = 1,9
9450 do jt = 1,19
9451 iprsm = 0
9452 do igc = 1,ngc(13)
9453 sumk1 = 0.
9454 sumk2 = 0.
9455 do ipr = 1, ngn(ngs(12)+igc)
9456 iprsm = iprsm + 1
9457 sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
9458 sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
9459 enddo
9460 ka_mco2(jn,jt,igc) = sumk1
9461 ka_mco(jn,jt,igc) = sumk2
9462 enddo
9463 enddo
9464 enddo
9466 do jt = 1,19
9467 iprsm = 0
9468 do igc = 1,ngc(13)
9469 sumk = 0.
9470 do ipr = 1, ngn(ngs(12)+igc)
9471 iprsm = iprsm + 1
9472 sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
9473 enddo
9474 kb_mo3(jt,igc) = sumk
9475 enddo
9476 enddo
9478 do jt = 1,10
9479 iprsm = 0
9480 do igc = 1,ngc(13)
9481 sumk = 0.
9482 do ipr = 1, ngn(ngs(12)+igc)
9483 iprsm = iprsm + 1
9484 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
9485 enddo
9486 selfref(jt,igc) = sumk
9487 enddo
9488 enddo
9490 do jt = 1,4
9491 iprsm = 0
9492 do igc = 1,ngc(13)
9493 sumk = 0.
9494 do ipr = 1, ngn(ngs(12)+igc)
9495 iprsm = iprsm + 1
9496 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
9497 enddo
9498 forref(jt,igc) = sumk
9499 enddo
9500 enddo
9502 iprsm = 0
9503 do igc = 1,ngc(13)
9504 sumf = 0.
9505 do ipr = 1, ngn(ngs(12)+igc)
9506 iprsm = iprsm + 1
9507 sumf = sumf + fracrefbo(iprsm)
9508 enddo
9509 fracrefb(igc) = sumf
9510 enddo
9512 do jp = 1,9
9513 iprsm = 0
9514 do igc = 1,ngc(13)
9515 sumf = 0.
9516 do ipr = 1, ngn(ngs(12)+igc)
9517 iprsm = iprsm + 1
9518 sumf = sumf + fracrefao(iprsm,jp)
9519 enddo
9520 fracrefa(igc,jp) = sumf
9521 enddo
9522 enddo
9524 end subroutine cmbgb13
9526 !***************************************************************************
9527 subroutine cmbgb14
9528 !***************************************************************************
9529 !
9530 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
9531 !
9532 ! old band 14: 2250-2380 cm-1 (low - co2; high - co2)
9533 !***************************************************************************
9535 use parrrtm, only : mg, nbndlw, ngptlw, ng14
9536 use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, &
9537 selfrefo, forrefo, &
9538 fracrefa, fracrefb, absa, ka, absb, kb, &
9539 selfref, forref
9541 ! ------- Local -------
9542 integer(kind=im) :: jt, jp, igc, ipr, iprsm
9543 real(kind=rb) :: sumk, sumf1, sumf2
9546 do jt = 1,5
9547 do jp = 1,13
9548 iprsm = 0
9549 do igc = 1,ngc(14)
9550 sumk = 0.
9551 do ipr = 1, ngn(ngs(13)+igc)
9552 iprsm = iprsm + 1
9553 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
9554 enddo
9555 ka(jt,jp,igc) = sumk
9556 enddo
9557 enddo
9558 enddo
9560 do jt = 1,5
9561 do jp = 13,59
9562 iprsm = 0
9563 do igc = 1,ngc(14)
9564 sumk = 0.
9565 do ipr = 1, ngn(ngs(13)+igc)
9566 iprsm = iprsm + 1
9567 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
9568 enddo
9569 kb(jt,jp,igc) = sumk
9570 enddo
9571 enddo
9572 enddo
9574 do jt = 1,10
9575 iprsm = 0
9576 do igc = 1,ngc(14)
9577 sumk = 0.
9578 do ipr = 1, ngn(ngs(13)+igc)
9579 iprsm = iprsm + 1
9580 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
9581 enddo
9582 selfref(jt,igc) = sumk
9583 enddo
9584 enddo
9586 do jt = 1,4
9587 iprsm = 0
9588 do igc = 1,ngc(14)
9589 sumk = 0.
9590 do ipr = 1, ngn(ngs(13)+igc)
9591 iprsm = iprsm + 1
9592 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
9593 enddo
9594 forref(jt,igc) = sumk
9595 enddo
9596 enddo
9598 iprsm = 0
9599 do igc = 1,ngc(14)
9600 sumf1= 0.
9601 sumf2= 0.
9602 do ipr = 1, ngn(ngs(13)+igc)
9603 iprsm = iprsm + 1
9604 sumf1= sumf1+ fracrefao(iprsm)
9605 sumf2= sumf2+ fracrefbo(iprsm)
9606 enddo
9607 fracrefa(igc) = sumf1
9608 fracrefb(igc) = sumf2
9609 enddo
9611 end subroutine cmbgb14
9613 !***************************************************************************
9614 subroutine cmbgb15
9615 !***************************************************************************
9616 !
9617 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
9618 ! (high - nothing)
9619 !
9620 ! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
9621 !***************************************************************************
9623 use parrrtm, only : mg, nbndlw, ngptlw, ng15
9624 use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
9625 fracrefa, absa, ka, ka_mn2, selfref, forref
9627 ! ------- Local -------
9628 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9629 real(kind=rb) :: sumk, sumf
9632 do jn = 1,9
9633 do jt = 1,5
9634 do jp = 1,13
9635 iprsm = 0
9636 do igc = 1,ngc(15)
9637 sumk = 0.
9638 do ipr = 1, ngn(ngs(14)+igc)
9639 iprsm = iprsm + 1
9640 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
9641 enddo
9642 ka(jn,jt,jp,igc) = sumk
9643 enddo
9644 enddo
9645 enddo
9646 enddo
9648 do jn = 1,9
9649 do jt = 1,19
9650 iprsm = 0
9651 do igc = 1,ngc(15)
9652 sumk = 0.
9653 do ipr = 1, ngn(ngs(14)+igc)
9654 iprsm = iprsm + 1
9655 sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
9656 enddo
9657 ka_mn2(jn,jt,igc) = sumk
9658 enddo
9659 enddo
9660 enddo
9662 do jt = 1,10
9663 iprsm = 0
9664 do igc = 1,ngc(15)
9665 sumk = 0.
9666 do ipr = 1, ngn(ngs(14)+igc)
9667 iprsm = iprsm + 1
9668 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
9669 enddo
9670 selfref(jt,igc) = sumk
9671 enddo
9672 enddo
9674 do jt = 1,4
9675 iprsm = 0
9676 do igc = 1,ngc(15)
9677 sumk = 0.
9678 do ipr = 1, ngn(ngs(14)+igc)
9679 iprsm = iprsm + 1
9680 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
9681 enddo
9682 forref(jt,igc) = sumk
9683 enddo
9684 enddo
9686 do jp = 1,9
9687 iprsm = 0
9688 do igc = 1,ngc(15)
9689 sumf = 0.
9690 do ipr = 1, ngn(ngs(14)+igc)
9691 iprsm = iprsm + 1
9692 sumf = sumf + fracrefao(iprsm,jp)
9693 enddo
9694 fracrefa(igc,jp) = sumf
9695 enddo
9696 enddo
9698 end subroutine cmbgb15
9700 !***************************************************************************
9701 subroutine cmbgb16
9702 !***************************************************************************
9703 !
9704 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
9705 !
9706 ! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
9707 !***************************************************************************
9709 use parrrtm, only : mg, nbndlw, ngptlw, ng16
9710 use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
9711 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
9713 ! ------- Local -------
9714 integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9715 real(kind=rb) :: sumk, sumf
9718 do jn = 1,9
9719 do jt = 1,5
9720 do jp = 1,13
9721 iprsm = 0
9722 do igc = 1,ngc(16)
9723 sumk = 0.
9724 do ipr = 1, ngn(ngs(15)+igc)
9725 iprsm = iprsm + 1
9726 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
9727 enddo
9728 ka(jn,jt,jp,igc) = sumk
9729 enddo
9730 enddo
9731 enddo
9732 enddo
9734 do jt = 1,5
9735 do jp = 13,59
9736 iprsm = 0
9737 do igc = 1,ngc(16)
9738 sumk = 0.
9739 do ipr = 1, ngn(ngs(15)+igc)
9740 iprsm = iprsm + 1
9741 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
9742 enddo
9743 kb(jt,jp,igc) = sumk
9744 enddo
9745 enddo
9746 enddo
9748 do jt = 1,10
9749 iprsm = 0
9750 do igc = 1,ngc(16)
9751 sumk = 0.
9752 do ipr = 1, ngn(ngs(15)+igc)
9753 iprsm = iprsm + 1
9754 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
9755 enddo
9756 selfref(jt,igc) = sumk
9757 enddo
9758 enddo
9760 do jt = 1,4
9761 iprsm = 0
9762 do igc = 1,ngc(16)
9763 sumk = 0.
9764 do ipr = 1, ngn(ngs(15)+igc)
9765 iprsm = iprsm + 1
9766 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
9767 enddo
9768 forref(jt,igc) = sumk
9769 enddo
9770 enddo
9772 iprsm = 0
9773 do igc = 1,ngc(16)
9774 sumf = 0.
9775 do ipr = 1, ngn(ngs(15)+igc)
9776 iprsm = iprsm + 1
9777 sumf = sumf + fracrefbo(iprsm)
9778 enddo
9779 fracrefb(igc) = sumf
9780 enddo
9782 do jp = 1,9
9783 iprsm = 0
9784 do igc = 1,ngc(16)
9785 sumf = 0.
9786 do ipr = 1, ngn(ngs(15)+igc)
9787 iprsm = iprsm + 1
9788 sumf = sumf + fracrefao(iprsm,jp)
9789 enddo
9790 fracrefa(igc,jp) = sumf
9791 enddo
9792 enddo
9794 end subroutine cmbgb16
9796 !***************************************************************************
9797 subroutine lwcldpr
9798 !***************************************************************************
9800 ! --------- Modules ----------
9802 use rrlw_cld, only: abscld1, absliq0, absliq1, &
9803 absice0, absice1, absice2, absice3
9805 save
9807 ! ABSCLDn is the liquid water absorption coefficient (m2/g).
9808 ! For INFLAG = 1.
9809 abscld1 = 0.0602410_rb
9810 !
9811 ! Everything below is for INFLAG = 2.
9813 ! ABSICEn(J,IB) are the parameters needed to compute the liquid water
9814 ! absorption coefficient in spectral region IB for ICEFLAG=n. The units
9815 ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)).
9816 ! For ICEFLAG = 0.
9818 absice0(:)= (/0.005_rb, 1.0_rb/)
9820 ! For ICEFLAG = 1.
9821 absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/)
9822 absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /)
9824 ! For ICEFLAG = 2. In each band, the absorption
9825 ! coefficients are listed for a range of effective radii from 5.0
9826 ! to 131.0 microns in increments of 3.0 microns.
9827 ! Spherical Ice Particle Parameterization
9828 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
9829 absice2(:,1) = (/ &
9830 ! band 1
9831 7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, &
9832 3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, &
9833 2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, &
9834 2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, &
9835 1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, &
9836 1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, &
9837 1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, &
9838 8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, &
9839 7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/)
9840 absice2(:,2) = (/ &
9841 ! band 2
9842 2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, &
9843 2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, &
9844 2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, &
9845 1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, &
9846 1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, &
9847 1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, &
9848 9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, &
9849 7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, &
9850 5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/)
9851 absice2(:,3) = (/ &
9852 ! band 3
9853 1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, &
9854 4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, &
9855 2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, &
9856 2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, &
9857 1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, &
9858 1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, &
9859 9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, &
9860 7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, &
9861 5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/)
9862 absice2(:,4) = (/ &
9863 ! band 4
9864 1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, &
9865 4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, &
9866 2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, &
9867 1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, &
9868 1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, &
9869 1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, &
9870 8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, &
9871 7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, &
9872 5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/)
9873 absice2(:,5) = (/ &
9874 ! band 5
9875 2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, &
9876 4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, &
9877 2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, &
9878 1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, &
9879 1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, &
9880 1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, &
9881 8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, &
9882 6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, &
9883 5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/)
9884 absice2(:,6) = (/ &
9885 ! band 6
9886 1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, &
9887 4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, &
9888 2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, &
9889 1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, &
9890 1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, &
9891 1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, &
9892 8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, &
9893 6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, &
9894 5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/)
9895 absice2(:,7) = (/ &
9896 ! band 7
9897 7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, &
9898 3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, &
9899 2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, &
9900 1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, &
9901 1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, &
9902 1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, &
9903 9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, &
9904 7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, &
9905 5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/)
9906 absice2(:,8) = (/ &
9907 ! band 8
9908 9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, &
9909 3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, &
9910 2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, &
9911 1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, &
9912 1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, &
9913 1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, &
9914 9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, &
9915 7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, &
9916 5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/)
9917 absice2(:,9) = (/ &
9918 ! band 9
9919 1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, &
9920 4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, &
9921 2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, &
9922 1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, &
9923 1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, &
9924 1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, &
9925 8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, &
9926 7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, &
9927 6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/)
9928 absice2(:,10) = (/ &
9929 ! band 10
9930 1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, &
9931 4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, &
9932 2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, &
9933 1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, &
9934 1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, &
9935 1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, &
9936 8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, &
9937 7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, &
9938 6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/)
9939 absice2(:,11) = (/ &
9940 ! band 11
9941 1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, &
9942 4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, &
9943 2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, &
9944 1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, &
9945 1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, &
9946 1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, &
9947 8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, &
9948 7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, &
9949 6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/)
9950 absice2(:,12) = (/ &
9951 ! band 12
9952 9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, &
9953 2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, &
9954 1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, &
9955 1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, &
9956 1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, &
9957 9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, &
9958 8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, &
9959 7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, &
9960 7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/)
9961 absice2(:,13) = (/ &
9962 ! band 13
9963 1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, &
9964 3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, &
9965 2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, &
9966 1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, &
9967 1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, &
9968 1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, &
9969 8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, &
9970 8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, &
9971 7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/)
9972 absice2(:,14) = (/ &
9973 ! band 14
9974 1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, &
9975 3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, &
9976 1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, &
9977 1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, &
9978 1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, &
9979 9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, &
9980 8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, &
9981 8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, &
9982 7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/)
9983 absice2(:,15) = (/ &
9984 ! band 15
9985 8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, &
9986 2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, &
9987 1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, &
9988 1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, &
9989 1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, &
9990 9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, &
9991 8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, &
9992 7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, &
9993 6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/)
9994 absice2(:,16) = (/ &
9995 ! band 16
9996 1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, &
9997 3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, &
9998 1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, &
9999 1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, &
10000 1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, &
10001 9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, &
10002 7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, &
10003 6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, &
10004 6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/)
10006 ! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in
10007 ! increments of 3 microns.
10008 ! units = m2/g
10009 ! Hexagonal Ice Particle Parameterization
10010 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10011 absice3(:,1) = (/ &
10012 ! band 1
10013 3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, &
10014 5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, &
10015 3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, &
10016 2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, &
10017 1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, &
10018 1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, &
10019 1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, &
10020 1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, &
10021 1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, &
10022 9.602126e-03_rb/)
10023 absice3(:,2) = (/ &
10024 ! band 2
10025 3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, &
10026 2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, &
10027 2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, &
10028 1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, &
10029 1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, &
10030 1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, &
10031 1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, &
10032 8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, &
10033 7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, &
10034 6.326424e-03_rb/)
10035 absice3(:,3) = (/ &
10036 ! band 3
10037 6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, &
10038 5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, &
10039 3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, &
10040 2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, &
10041 1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, &
10042 1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, &
10043 1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, &
10044 9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, &
10045 8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, &
10046 6.769036e-03_rb/)
10047 absice3(:,4) = (/ &
10048 ! band 4
10049 1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, &
10050 6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, &
10051 3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, &
10052 2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, &
10053 1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, &
10054 1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, &
10055 1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, &
10056 1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, &
10057 8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, &
10058 7.621418e-03_rb/)
10059 absice3(:,5) = (/ &
10060 ! band 5
10061 2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, &
10062 7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, &
10063 4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, &
10064 2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, &
10065 2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, &
10066 1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, &
10067 1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, &
10068 1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, &
10069 9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, &
10070 7.890412e-03_rb/)
10071 absice3(:,6) = (/ &
10072 ! band 6
10073 1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, &
10074 6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, &
10075 3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, &
10076 2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, &
10077 1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, &
10078 1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, &
10079 1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, &
10080 1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, &
10081 9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, &
10082 8.114723e-03_rb/)
10083 absice3(:,7) = (/ &
10084 ! band 7
10085 1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, &
10086 4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, &
10087 2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, &
10088 2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, &
10089 1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, &
10090 1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, &
10091 1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, &
10092 9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, &
10093 8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, &
10094 7.026186e-03_rb/)
10095 absice3(:,8) = (/ &
10096 ! band 8
10097 6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, &
10098 4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, &
10099 2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, &
10100 2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, &
10101 1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, &
10102 1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, &
10103 1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, &
10104 9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, &
10105 8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, &
10106 7.060305e-03_rb/)
10107 absice3(:,9) = (/ &
10108 ! band 9
10109 1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, &
10110 4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, &
10111 3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, &
10112 2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, &
10113 1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, &
10114 1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, &
10115 1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, &
10116 1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, &
10117 8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, &
10118 7.964013e-03_rb/)
10119 absice3(:,10) = (/ &
10120 ! band 10
10121 1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, &
10122 5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, &
10123 3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, &
10124 2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, &
10125 1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, &
10126 1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, &
10127 1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, &
10128 1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, &
10129 9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, &
10130 8.442725e-03_rb/)
10131 absice3(:,11) = (/ &
10132 ! band 11
10133 1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, &
10134 5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, &
10135 3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, &
10136 2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, &
10137 1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, &
10138 1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, &
10139 1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, &
10140 1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, &
10141 9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, &
10142 8.422115e-03_rb/)
10143 absice3(:,12) = (/ &
10144 ! band 12
10145 9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, &
10146 3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, &
10147 2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, &
10148 1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, &
10149 1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, &
10150 1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, &
10151 1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, &
10152 9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, &
10153 8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, &
10154 7.947730e-03_rb/)
10155 absice3(:,13) = (/ &
10156 ! band 13
10157 1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, &
10158 4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, &
10159 2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, &
10160 2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, &
10161 1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, &
10162 1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, &
10163 1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, &
10164 1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, &
10165 9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, &
10166 8.652951e-03_rb/)
10167 absice3(:,14) = (/ &
10168 ! band 14
10169 1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, &
10170 4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, &
10171 2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, &
10172 2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, &
10173 1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, &
10174 1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, &
10175 1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, &
10176 1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, &
10177 9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, &
10178 8.785184e-03_rb/)
10179 absice3(:,15) = (/ &
10180 ! band 15
10181 1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, &
10182 3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, &
10183 2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, &
10184 1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, &
10185 1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, &
10186 1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, &
10187 1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, &
10188 1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, &
10189 9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, &
10190 8.560232e-03_rb/)
10191 absice3(:,16) = (/ &
10192 ! band 16
10193 1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, &
10194 4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, &
10195 2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, &
10196 2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, &
10197 1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, &
10198 1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, &
10199 1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, &
10200 1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, &
10201 8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, &
10202 8.123136e-03_rb/)
10204 ! For LIQFLAG = 0.
10205 absliq0 = 0.0903614_rb
10207 ! For LIQFLAG = 1. In each band, the absorption
10208 ! coefficients are listed for a range of effective radii from 2.5
10209 ! to 59.5 microns in increments of 1.0 micron.
10210 absliq1(:, 1) = (/ &
10211 ! band 1
10212 1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, &
10213 7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, &
10214 6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, &
10215 5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, &
10216 4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, &
10217 3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, &
10218 3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, &
10219 2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, &
10220 2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, &
10221 2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, &
10222 1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, &
10223 1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/)
10224 absliq1(:, 2) = (/ &
10225 ! band 2
10226 2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, &
10227 1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, &
10228 8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, &
10229 5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, &
10230 4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, &
10231 3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, &
10232 2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, &
10233 2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, &
10234 2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, &
10235 1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, &
10236 1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, &
10237 1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/)
10238 absliq1(:, 3) = (/ &
10239 ! band 3
10240 2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, &
10241 1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, &
10242 8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, &
10243 5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, &
10244 4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, &
10245 3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, &
10246 2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, &
10247 2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, &
10248 1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, &
10249 1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, &
10250 1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, &
10251 1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/)
10252 absliq1(:, 4) = (/ &
10253 ! band 4
10254 3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, &
10255 1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, &
10256 7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, &
10257 5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, &
10258 3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, &
10259 3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, &
10260 2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, &
10261 2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, &
10262 1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, &
10263 1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, &
10264 1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, &
10265 1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/)
10266 absliq1(:, 5) = (/ &
10267 ! band 5
10268 2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, &
10269 1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, &
10270 7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, &
10271 5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, &
10272 3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, &
10273 3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, &
10274 2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, &
10275 2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, &
10276 1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, &
10277 1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, &
10278 1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, &
10279 1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/)
10280 absliq1(:, 6) = (/ &
10281 ! band 6
10282 8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, &
10283 7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, &
10284 5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, &
10285 4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, &
10286 3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, &
10287 3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, &
10288 2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, &
10289 2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, &
10290 1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, &
10291 1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, &
10292 1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, &
10293 1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/)
10294 absliq1(:, 7) = (/ &
10295 ! band 7
10296 4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, &
10297 6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, &
10298 4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, &
10299 4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, &
10300 3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, &
10301 2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, &
10302 2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, &
10303 2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, &
10304 1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, &
10305 1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, &
10306 1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, &
10307 1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/)
10308 absliq1(:, 8) = (/ &
10309 ! band 8
10310 1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, &
10311 5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, &
10312 4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, &
10313 4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, &
10314 3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, &
10315 2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, &
10316 2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, &
10317 2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, &
10318 1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, &
10319 1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, &
10320 1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, &
10321 1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/)
10322 absliq1(:, 9) = (/ &
10323 ! band 9
10324 6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, &
10325 6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, &
10326 4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, &
10327 4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, &
10328 3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, &
10329 2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, &
10330 2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, &
10331 2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, &
10332 1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, &
10333 1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, &
10334 1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, &
10335 1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/)
10336 absliq1(:,10) = (/ &
10337 ! band 10
10338 7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, &
10339 6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, &
10340 5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, &
10341 4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, &
10342 3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, &
10343 2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, &
10344 2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, &
10345 2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, &
10346 1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, &
10347 1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, &
10348 1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, &
10349 1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/)
10350 absliq1(:,11) = (/ &
10351 ! band 11
10352 1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, &
10353 9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, &
10354 6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, &
10355 4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, &
10356 3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, &
10357 2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, &
10358 2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, &
10359 2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, &
10360 1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, &
10361 1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, &
10362 1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, &
10363 1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/)
10364 absliq1(:,12) = (/ &
10365 ! band 12
10366 3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, &
10367 3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, &
10368 3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, &
10369 2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, &
10370 2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, &
10371 2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, &
10372 1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, &
10373 1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, &
10374 1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, &
10375 1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, &
10376 1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, &
10377 1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/)
10378 absliq1(:,13) = (/ &
10379 ! band 13
10380 3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, &
10381 4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, &
10382 3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, &
10383 3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, &
10384 2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, &
10385 2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, &
10386 2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, &
10387 1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, &
10388 1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, &
10389 1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, &
10390 1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, &
10391 1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/)
10392 absliq1(:,14) = (/ &
10393 ! band 14
10394 1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, &
10395 3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, &
10396 3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, &
10397 2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, &
10398 2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, &
10399 2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, &
10400 1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, &
10401 1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, &
10402 1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, &
10403 1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, &
10404 1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, &
10405 1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/)
10406 absliq1(:,15) = (/ &
10407 ! band 15
10408 5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, &
10409 2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, &
10410 2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, &
10411 1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, &
10412 1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, &
10413 1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, &
10414 1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, &
10415 1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, &
10416 1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, &
10417 1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, &
10418 1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, &
10419 9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/)
10420 absliq1(:,16) = (/ &
10421 ! band 16
10422 5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, &
10423 5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, &
10424 3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, &
10425 2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, &
10426 2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, &
10427 2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, &
10428 1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, &
10429 1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, &
10430 1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, &
10431 1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, &
10432 1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, &
10433 1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/)
10435 end subroutine lwcldpr
10437 end module rrtmg_lw_init
10439 ! path: $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
10440 ! author: $Author: trn $
10441 ! revision: $Revision: 1.3 $
10442 ! created: $Date: 2009/04/16 19:54:22 $
10443 !
10444 module rrtmg_lw_rad
10446 ! --------------------------------------------------------------------------
10447 ! | |
10448 ! | Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER). |
10449 ! | This software may be used, copied, or redistributed as long as it is |
10450 ! | not sold and this copyright notice is reproduced on each copy made. |
10451 ! | This model is provided as is without any express or implied warranties. |
10452 ! | (http://www.rtweb.aer.com/) |
10453 ! | |
10454 ! --------------------------------------------------------------------------
10455 !
10456 ! ****************************************************************************
10457 ! * *
10458 ! * RRTMG_LW *
10459 ! * *
10460 ! * *
10461 ! * *
10462 ! * a rapid radiative transfer model *
10463 ! * for the longwave region *
10464 ! * for application to general circulation models *
10465 ! * *
10466 ! * *
10467 ! * Atmospheric and Environmental Research, Inc. *
10468 ! * 131 Hartwell Avenue *
10469 ! * Lexington, MA 02421 *
10470 ! * *
10471 ! * *
10472 ! * Eli J. Mlawer *
10473 ! * Jennifer S. Delamere *
10474 ! * Michael J. Iacono *
10475 ! * Shepard A. Clough *
10476 ! * *
10477 ! * *
10478 ! * *
10479 ! * *
10480 ! * *
10481 ! * *
10482 ! * email: miacono@aer.com *
10483 ! * email: emlawer@aer.com *
10484 ! * email: jdelamer@aer.com *
10485 ! * *
10486 ! * The authors wish to acknowledge the contributions of the *
10487 ! * following people: Steven J. Taubman, Karen Cady-Pereira, *
10488 ! * Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
10489 ! * *
10490 ! ****************************************************************************
10492 ! -------- Modules --------
10493 use parkind, only : im => kind_im, rb => kind_rb
10494 use rrlw_vsn
10495 use mcica_subcol_gen_lw, only: mcica_subcol_lw
10496 use rrtmg_lw_cldprmc, only: cldprmc
10497 ! *** Move the required call to rrtmg_lw_ini below and the following
10498 ! use association to the GCM initialization area ***
10499 ! use rrtmg_lw_init, only: rrtmg_lw_ini
10500 use rrtmg_lw_rtrnmc, only: rtrnmc
10501 use rrtmg_lw_setcoef, only: setcoef
10502 use rrtmg_lw_taumol, only: taumol
10504 implicit none
10506 ! public interfaces/functions/subroutines
10507 public :: rrtmg_lw, inatm
10509 !------------------------------------------------------------------
10510 contains
10511 !------------------------------------------------------------------
10513 !------------------------------------------------------------------
10514 ! Public subroutines
10515 !------------------------------------------------------------------
10517 subroutine rrtmg_lw &
10518 (ncol ,nlay ,icld , &
10519 play ,plev ,tlay ,tlev ,tsfc , &
10520 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
10521 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
10522 inflglw ,iceflglw,liqflglw,cldfmcl , &
10523 taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
10524 tauaer , &
10525 uflx ,dflx ,hr ,uflxc ,dflxc, hrc)
10527 ! -------- Description --------
10529 ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation
10530 ! model for application to GCMs, that has been adapted from RRTM_LW for
10531 ! improved efficiency.
10532 !
10533 ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization
10534 ! area, since this has to be called only once.
10535 !
10536 ! This routine:
10537 ! a) calls INATM to read in the atmospheric profile from GCM;
10538 ! all layering in RRTMG is ordered from surface to toa.
10539 ! b) calls CLDPRMC to set cloud optical depth for McICA based
10540 ! on input cloud properties
10541 ! c) calls SETCOEF to calculate various quantities needed for
10542 ! the radiative transfer algorithm
10543 ! d) calls TAUMOL to calculate gaseous optical depths for each
10544 ! of the 16 spectral bands
10545 ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the
10546 ! radiative transfer calculation using McICA, the Monte-Carlo
10547 ! Independent Column Approximation, to represent sub-grid scale
10548 ! cloud variability
10549 ! f) passes the necessary fluxes and cooling rates back to GCM
10550 !
10551 ! Two modes of operation are possible:
10552 ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
10553 ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM.
10554 !
10555 ! 1) Standard, single forward model calculation (imca = 0)
10556 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
10557 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
10558 !
10559 ! This call to RRTMG_LW must be preceeded by a call to the module
10560 ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
10561 ! which will provide the cloud physical or cloud optical properties
10562 ! on the RRTMG quadrature point (ngpt) dimension.
10563 ! Two random number generators are available for use when imca = 1.
10564 ! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
10565 ! 1) KISSVEC (irnd = 0)
10566 ! 2) Mersenne-Twister (irnd = 1)
10567 !
10568 ! Two methods of cloud property input are possible:
10569 ! Cloud properties can be input in one of two ways (controlled by input
10570 ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
10571 ! and subroutine rrtmg_lw_cldprop.f90 for further details):
10572 !
10573 ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
10574 ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);
10575 ! cloud optical properties are calculated by cldprop or cldprmc based
10576 ! on input settings of iceflglw and liqflglw. Ice particle size provided
10577 ! must be appropriately defined for the ice parameterization selected.
10578 !
10579 ! One method of aerosol property input is possible:
10580 ! Aerosol properties can be input in only one way (controlled by input
10581 ! flag iaer; see text file rrtmg_lw_instructions for further details):
10582 !
10583 ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10);
10584 ! band average optical depth at the mid-point of each spectral band.
10585 ! RRTMG_LW currently treats only aerosol absorption;
10586 ! scattering capability is not presently available.
10587 !
10588 !
10589 ! ------- Modifications -------
10590 !
10591 ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced
10592 ! set of g-points for application to GCMs.
10593 !
10594 !-- Original version (derived from RRTM_LW), reduction of g-points, other
10595 ! revisions for use with GCMs.
10596 ! 1999: M. J. Iacono, AER, Inc.
10597 !-- Adapted for use with NCAR/CAM.
10598 ! May 2004: M. J. Iacono, AER, Inc.
10599 !-- Revised to add McICA capability.
10600 ! Nov 2005: M. J. Iacono, AER, Inc.
10601 !-- Conversion to F90 formatting for consistency with rrtmg_sw.
10602 ! Feb 2007: M. J. Iacono, AER, Inc.
10603 !-- Modifications to formatting to use assumed-shape arrays.
10604 ! Aug 2007: M. J. Iacono, AER, Inc.
10605 !-- Modified to add longwave aerosol absorption.
10606 ! Apr 2008: M. J. Iacono, AER, Inc.
10608 ! --------- Modules ----------
10610 use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol
10611 use rrlw_con, only: fluxfac, heatfac, oneminus, pi
10612 use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
10614 ! ------- Declarations -------
10616 ! ----- Input -----
10617 integer(kind=im), intent(in) :: ncol ! Number of horizontal columns
10618 integer(kind=im), intent(in) :: nlay ! Number of model layers
10619 integer(kind=im), intent(inout) :: icld ! Cloud overlap method
10620 ! 0: Clear only
10621 ! 1: Random
10622 ! 2: Maximum/random
10623 ! 3: Maximum
10624 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
10625 ! Dimensions: (ncol,nlay)
10626 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
10627 ! Dimensions: (ncol,nlay+1)
10628 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
10629 ! Dimensions: (ncol,nlay)
10630 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
10631 ! Dimensions: (ncol,nlay+1)
10632 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
10633 ! Dimensions: (ncol)
10634 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
10635 ! Dimensions: (ncol,nlay)
10636 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
10637 ! Dimensions: (ncol,nlay)
10638 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
10639 ! Dimensions: (ncol,nlay)
10640 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
10641 ! Dimensions: (ncol,nlay)
10642 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
10643 ! Dimensions: (ncol,nlay)
10644 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
10645 ! Dimensions: (ncol,nlay)
10646 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
10647 ! Dimensions: (ncol,nlay)
10648 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
10649 ! Dimensions: (ncol,nlay)
10650 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
10651 ! Dimensions: (ncol,nlay)
10652 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
10653 ! Dimensions: (ncol,nlay)
10654 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
10655 ! Dimensions: (ncol,nbndlw)
10657 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
10658 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
10659 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
10661 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
10662 ! Dimensions: (ngptlw,ncol,nlay)
10663 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
10664 ! Dimensions: (ngptlw,ncol,nlay)
10665 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
10666 ! Dimensions: (ngptlw,ncol,nlay)
10667 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice particle effective size (microns)
10668 ! Dimensions: (ncol,nlay)
10669 ! specific definition of reicmcl depends on setting of iceflglw:
10670 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
10671 ! r_ec must be >= 10.0 microns
10672 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
10673 ! r_ec range is limited to 13.0 to 130.0 microns
10674 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
10675 ! r_k range is limited to 5.0 to 131.0 microns
10676 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
10677 ! dge range is limited to 5.0 to 140.0 microns
10678 ! [dge = 1.0315 * r_ec]
10679 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
10680 ! Dimensions: (ncol,nlay)
10681 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
10682 ! Dimensions: (ngptlw,ncol,nlay)
10683 ! real(kind=rb), intent(in) :: ssacmcl(:,:,:) ! In-cloud single scattering albedo
10684 ! Dimensions: (ngptlw,ncol,nlay)
10685 ! for future expansion
10686 ! lw scattering not yet available
10687 ! real(kind=rb), intent(in) :: asmcmcl(:,:,:) ! In-cloud asymmetry parameter
10688 ! Dimensions: (ngptlw,ncol,nlay)
10689 ! for future expansion
10690 ! lw scattering not yet available
10691 real(kind=rb), intent(in) :: tauaer(:,:,:) ! aerosol optical depth
10692 ! at mid-point of LW spectral bands
10693 ! Dimensions: (ncol,nlay,nbndlw)
10694 ! real(kind=rb), intent(in) :: ssaaer(:,:,:) ! aerosol single scattering albedo
10695 ! Dimensions: (ncol,nlay,nbndlw)
10696 ! for future expansion
10697 ! (lw aerosols/scattering not yet available)
10698 ! real(kind=rb), intent(in) :: asmaer(:,:,:) ! aerosol asymmetry parameter
10699 ! Dimensions: (ncol,nlay,nbndlw)
10700 ! for future expansion
10701 ! (lw aerosols/scattering not yet available)
10703 ! ----- Output -----
10705 real(kind=rb), intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2)
10706 ! Dimensions: (ncol,nlay+1)
10707 real(kind=rb), intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2)
10708 ! Dimensions: (ncol,nlay+1)
10709 real(kind=rb), intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d)
10710 ! Dimensions: (ncol,nlay)
10711 real(kind=rb), intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2)
10712 ! Dimensions: (ncol,nlay+1)
10713 real(kind=rb), intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2)
10714 ! Dimensions: (ncol,nlay+1)
10715 real(kind=rb), intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d)
10716 ! Dimensions: (ncol,nlay)
10718 ! ----- Local -----
10720 ! Control
10721 integer(kind=im) :: nlayers ! total number of layers
10722 integer(kind=im) :: istart ! beginning band of calculation
10723 integer(kind=im) :: iend ! ending band of calculation
10724 integer(kind=im) :: iout ! output option flag (inactive)
10725 integer(kind=im) :: iaer ! aerosol option flag
10726 integer(kind=im) :: iplon ! column loop index
10727 integer(kind=im) :: imca ! flag for mcica [0=off, 1=on]
10728 integer(kind=im) :: ims ! value for changing mcica permute seed
10729 integer(kind=im) :: k ! layer loop index
10730 integer(kind=im) :: ig ! g-point loop index
10732 ! Atmosphere
10733 real(kind=rb) :: pavel(nlay+1) ! layer pressures (mb)
10734 real(kind=rb) :: tavel(nlay+1) ! layer temperatures (K)
10735 real(kind=rb) :: pz(0:nlay+1) ! level (interface) pressures (hPa, mb)
10736 real(kind=rb) :: tz(0:nlay+1) ! level (interface) temperatures (K)
10737 real(kind=rb) :: tbound ! surface temperature (K)
10738 real(kind=rb) :: coldry(nlay+1) ! dry air column density (mol/cm2)
10739 real(kind=rb) :: wbrodl(nlay+1) ! broadening gas column density (mol/cm2)
10740 real(kind=rb) :: wkl(mxmol,nlay+1) ! molecular amounts (mol/cm-2)
10741 real(kind=rb) :: wx(maxxsec,nlay+1) ! cross-section amounts (mol/cm-2)
10742 real(kind=rb) :: pwvcm ! precipitable water vapor (cm)
10743 real(kind=rb) :: semiss(nbndlw) ! lw surface emissivity
10744 real(kind=rb) :: fracs(nlay+1,ngptlw) !
10745 real(kind=rb) :: taug(nlay+1,ngptlw) ! gaseous optical depths
10746 real(kind=rb) :: taut(nlay+1,ngptlw) ! gaseous + aerosol optical depths
10748 real(kind=rb) :: taua(nlay+1,nbndlw) ! aerosol optical depth
10749 ! real(kind=rb) :: ssaa(nlay+1,nbndlw) ! aerosol single scattering albedo
10750 ! for future expansion
10751 ! (lw aerosols/scattering not yet available)
10752 ! real(kind=rb) :: asma(nlay+1,nbndlw) ! aerosol asymmetry parameter
10753 ! for future expansion
10754 ! (lw aerosols/scattering not yet available)
10756 ! Atmosphere - setcoef
10757 integer(kind=im) :: laytrop ! tropopause layer index
10758 integer(kind=im) :: jp(nlay+1) ! lookup table index
10759 integer(kind=im) :: jt(nlay+1) ! lookup table index
10760 integer(kind=im) :: jt1(nlay+1) ! lookup table index
10761 real(kind=rb) :: planklay(nlay+1,nbndlw)!
10762 real(kind=rb) :: planklev(0:nlay+1,nbndlw)!
10763 real(kind=rb) :: plankbnd(nbndlw) !
10765 real(kind=rb) :: colh2o(nlay+1) ! column amount (h2o)
10766 real(kind=rb) :: colco2(nlay+1) ! column amount (co2)
10767 real(kind=rb) :: colo3(nlay+1) ! column amount (o3)
10768 real(kind=rb) :: coln2o(nlay+1) ! column amount (n2o)
10769 real(kind=rb) :: colco(nlay+1) ! column amount (co)
10770 real(kind=rb) :: colch4(nlay+1) ! column amount (ch4)
10771 real(kind=rb) :: colo2(nlay+1) ! column amount (o2)
10772 real(kind=rb) :: colbrd(nlay+1) ! column amount (broadening gases)
10774 integer(kind=im) :: indself(nlay+1)
10775 integer(kind=im) :: indfor(nlay+1)
10776 real(kind=rb) :: selffac(nlay+1)
10777 real(kind=rb) :: selffrac(nlay+1)
10778 real(kind=rb) :: forfac(nlay+1)
10779 real(kind=rb) :: forfrac(nlay+1)
10781 integer(kind=im) :: indminor(nlay+1)
10782 real(kind=rb) :: minorfrac(nlay+1)
10783 real(kind=rb) :: scaleminor(nlay+1)
10784 real(kind=rb) :: scaleminorn2(nlay+1)
10786 real(kind=rb) :: & !
10787 fac00(nlay+1), fac01(nlay+1), &
10788 fac10(nlay+1), fac11(nlay+1)
10789 real(kind=rb) :: & !
10790 rat_h2oco2(nlay+1),rat_h2oco2_1(nlay+1), &
10791 rat_h2oo3(nlay+1),rat_h2oo3_1(nlay+1), &
10792 rat_h2on2o(nlay+1),rat_h2on2o_1(nlay+1), &
10793 rat_h2och4(nlay+1),rat_h2och4_1(nlay+1), &
10794 rat_n2oco2(nlay+1),rat_n2oco2_1(nlay+1), &
10795 rat_o3co2(nlay+1),rat_o3co2_1(nlay+1)
10797 ! Atmosphere/clouds - cldprop
10798 integer(kind=im) :: ncbands ! number of cloud spectral bands
10799 integer(kind=im) :: inflag ! flag for cloud property method
10800 integer(kind=im) :: iceflag ! flag for ice cloud properties
10801 integer(kind=im) :: liqflag ! flag for liquid cloud properties
10803 ! Atmosphere/clouds - cldprmc [mcica]
10804 real(kind=rb) :: cldfmc(ngptlw,nlay+1) ! cloud fraction [mcica]
10805 real(kind=rb) :: ciwpmc(ngptlw,nlay+1) ! in-cloud ice water path [mcica]
10806 real(kind=rb) :: clwpmc(ngptlw,nlay+1) ! in-cloud liquid water path [mcica]
10807 real(kind=rb) :: relqmc(nlay+1) ! liquid particle effective radius (microns)
10808 real(kind=rb) :: reicmc(nlay+1) ! ice particle effective size (microns)
10809 real(kind=rb) :: taucmc(ngptlw,nlay+1) ! in-cloud optical depth [mcica]
10810 ! real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica]
10811 ! for future expansion
10812 ! (lw scattering not yet available)
10813 ! real(kind=rb) :: asmcmc(ngptlw,nlay+1) ! in-cloud asymmetry parameter [mcica]
10814 ! for future expansion
10815 ! (lw scattering not yet available)
10817 ! Output
10818 real(kind=rb) :: totuflux(0:nlay+1) ! upward longwave flux (w/m2)
10819 real(kind=rb) :: totdflux(0:nlay+1) ! downward longwave flux (w/m2)
10820 real(kind=rb) :: fnet(0:nlay+1) ! net longwave flux (w/m2)
10821 real(kind=rb) :: htr(0:nlay+1) ! longwave heating rate (k/day)
10822 real(kind=rb) :: totuclfl(0:nlay+1) ! clear sky upward longwave flux (w/m2)
10823 real(kind=rb) :: totdclfl(0:nlay+1) ! clear sky downward longwave flux (w/m2)
10824 real(kind=rb) :: fnetc(0:nlay+1) ! clear sky net longwave flux (w/m2)
10825 real(kind=rb) :: htrc(0:nlay+1) ! clear sky longwave heating rate (k/day)
10827 !
10828 ! Initializations
10830 oneminus = 1._rb - 1.e-6_rb
10831 pi = 2._rb * asin(1._rb)
10832 fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4
10833 istart = 1
10834 iend = 16
10835 iout = 0
10836 ims = 1
10838 ! Set imca to select calculation type:
10839 ! imca = 0, use standard forward model calculation
10840 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
10842 ! *** This version uses McICA (imca = 1) ***
10844 ! Set icld to select of clear or cloud calculation and cloud overlap method
10845 ! icld = 0, clear only
10846 ! icld = 1, with clouds using random cloud overlap
10847 ! icld = 2, with clouds using maximum/random cloud overlap
10848 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
10849 if (icld.lt.0.or.icld.gt.3) icld = 2
10851 ! Set iaer to select aerosol option
10852 ! iaer = 0, no aerosols
10853 ! icld = 10, input total aerosol optical depth (tauaer) directly
10854 iaer = 10
10856 ! Call model and data initialization, compute lookup tables, perform
10857 ! reduction of g-points from 256 to 140 for input absorption coefficient
10858 ! data and other arrays.
10859 !
10860 ! In a GCM this call should be placed in the model initialization
10861 ! area, since this has to be called only once.
10862 ! call rrtmg_lw_ini(cpdair)
10864 ! This is the main longitude/column loop within RRTMG.
10865 do iplon = 1, ncol
10867 ! Prepare atmospheric profile from GCM for use in RRTMG, and define
10868 ! other input parameters.
10870 call inatm (iplon, nlay, icld, iaer, &
10871 play, plev, tlay, tlev, tsfc, h2ovmr, &
10872 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
10873 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
10874 cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
10875 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
10876 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
10877 cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
10879 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
10880 ! input cloud physical properties. Select method based on choices described
10881 ! in cldprop. Cloud fraction, water path, liquid droplet and ice particle
10882 ! effective radius must be passed into cldprop. Cloud fraction and cloud
10883 ! optical depth are transferred to rrtmg_lw arrays in cldprop.
10885 call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, &
10886 clwpmc, reicmc, relqmc, ncbands, taucmc)
10888 ! Calculate information needed by the radiative transfer routine
10889 ! that is specific to this atmosphere, especially some of the
10890 ! coefficients and indices needed to compute the optical depths
10891 ! by interpolating data from stored reference atmospheres.
10893 call setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
10894 coldry, wkl, wbrodl, &
10895 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
10896 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
10897 colbrd, fac00, fac01, fac10, fac11, &
10898 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
10899 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
10900 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
10901 selffac, selffrac, indself, forfac, forfrac, indfor, &
10902 minorfrac, scaleminor, scaleminorn2, indminor)
10904 ! Calculate the gaseous optical depths and Planck fractions for
10905 ! each longwave spectral band.
10907 call taumol(nlayers, pavel, wx, coldry, &
10908 laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
10909 colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
10910 colbrd, fac00, fac01, fac10, fac11, &
10911 rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
10912 rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
10913 rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
10914 selffac, selffrac, indself, forfac, forfrac, indfor, &
10915 minorfrac, scaleminor, scaleminorn2, indminor, &
10916 fracs, taug)
10919 ! Combine gaseous and aerosol optical depths, if aerosol active
10920 if (iaer .eq. 0) then
10921 do k = 1, nlayers
10922 do ig = 1, ngptlw
10923 taut(k,ig) = taug(k,ig)
10924 enddo
10925 enddo
10926 elseif (iaer .eq. 10) then
10927 do k = 1, nlayers
10928 do ig = 1, ngptlw
10929 taut(k,ig) = taug(k,ig) + taua(k,ngb(ig))
10930 enddo
10931 enddo
10932 endif
10934 ! Call the radiative transfer routine.
10935 ! Either routine can be called to do clear sky calculation. If clouds
10936 ! are present, then select routine based on cloud overlap assumption
10937 ! to be used. Clear sky calculation is done simultaneously.
10938 ! For McICA, RTRNMC is called for clear and cloudy calculations.
10940 call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
10941 cldfmc, taucmc, planklay, planklev, plankbnd, &
10942 pwvcm, fracs, taut, &
10943 totuflux, totdflux, fnet, htr, &
10944 totuclfl, totdclfl, fnetc, htrc )
10946 ! Transfer up and down fluxes and heating rate to output arrays.
10947 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
10949 do k = 0, nlayers
10950 uflx(iplon,k+1) = totuflux(k)
10951 dflx(iplon,k+1) = totdflux(k)
10952 uflxc(iplon,k+1) = totuclfl(k)
10953 dflxc(iplon,k+1) = totdclfl(k)
10954 enddo
10955 do k = 0, nlayers-1
10956 hr(iplon,k+1) = htr(k)
10957 hrc(iplon,k+1) = htrc(k)
10958 enddo
10960 enddo
10962 end subroutine rrtmg_lw
10964 !***************************************************************************
10965 subroutine inatm (iplon, nlay, icld, iaer, &
10966 play, plev, tlay, tlev, tsfc, h2ovmr, &
10967 o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
10968 cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
10969 cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
10970 nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
10971 wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
10972 cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
10973 !***************************************************************************
10974 !
10975 ! Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
10976 ! Set other RRTMG_LW input parameters.
10977 !
10978 !***************************************************************************
10980 ! --------- Modules ----------
10982 use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol
10983 use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad
10984 use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
10986 ! ------- Declarations -------
10988 ! ----- Input -----
10989 integer(kind=im), intent(in) :: iplon ! column loop index
10990 integer(kind=im), intent(in) :: nlay ! Number of model layers
10991 integer(kind=im), intent(in) :: icld ! clear/cloud and cloud overlap flag
10992 integer(kind=im), intent(in) :: iaer ! aerosol option flag
10994 real(kind=rb), intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
10995 ! Dimensions: (ncol,nlay)
10996 real(kind=rb), intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
10997 ! Dimensions: (ncol,nlay+1)
10998 real(kind=rb), intent(in) :: tlay(:,:) ! Layer temperatures (K)
10999 ! Dimensions: (ncol,nlay)
11000 real(kind=rb), intent(in) :: tlev(:,:) ! Interface temperatures (K)
11001 ! Dimensions: (ncol,nlay+1)
11002 real(kind=rb), intent(in) :: tsfc(:) ! Surface temperature (K)
11003 ! Dimensions: (ncol)
11004 real(kind=rb), intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
11005 ! Dimensions: (ncol,nlay)
11006 real(kind=rb), intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
11007 ! Dimensions: (ncol,nlay)
11008 real(kind=rb), intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
11009 ! Dimensions: (ncol,nlay)
11010 real(kind=rb), intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
11011 ! Dimensions: (ncol,nlay)
11012 real(kind=rb), intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
11013 ! Dimensions: (ncol,nlay)
11014 real(kind=rb), intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
11015 ! Dimensions: (ncol,nlay)
11016 real(kind=rb), intent(in) :: cfc11vmr(:,:) ! CFC11 volume mixing ratio
11017 ! Dimensions: (ncol,nlay)
11018 real(kind=rb), intent(in) :: cfc12vmr(:,:) ! CFC12 volume mixing ratio
11019 ! Dimensions: (ncol,nlay)
11020 real(kind=rb), intent(in) :: cfc22vmr(:,:) ! CFC22 volume mixing ratio
11021 ! Dimensions: (ncol,nlay)
11022 real(kind=rb), intent(in) :: ccl4vmr(:,:) ! CCL4 volume mixing ratio
11023 ! Dimensions: (ncol,nlay)
11024 real(kind=rb), intent(in) :: emis(:,:) ! Surface emissivity
11025 ! Dimensions: (ncol,nbndlw)
11027 integer(kind=im), intent(in) :: inflglw ! Flag for cloud optical properties
11028 integer(kind=im), intent(in) :: iceflglw ! Flag for ice particle specification
11029 integer(kind=im), intent(in) :: liqflglw ! Flag for liquid droplet specification
11031 real(kind=rb), intent(in) :: cldfmcl(:,:,:) ! Cloud fraction
11032 ! Dimensions: (ngptlw,ncol,nlay)
11033 real(kind=rb), intent(in) :: ciwpmcl(:,:,:) ! In-cloud ice water path (g/m2)
11034 ! Dimensions: (ngptlw,ncol,nlay)
11035 real(kind=rb), intent(in) :: clwpmcl(:,:,:) ! In-cloud liquid water path (g/m2)
11036 ! Dimensions: (ngptlw,ncol,nlay)
11037 real(kind=rb), intent(in) :: relqmcl(:,:) ! Cloud water drop effective radius (microns)
11038 ! Dimensions: (ncol,nlay)
11039 real(kind=rb), intent(in) :: reicmcl(:,:) ! Cloud ice effective size (microns)
11040 ! Dimensions: (ncol,nlay)
11041 real(kind=rb), intent(in) :: taucmcl(:,:,:) ! In-cloud optical depth
11042 ! Dimensions: (ngptlw,ncol,nlay)
11043 real(kind=rb), intent(in) :: tauaer(:,:,:) ! Aerosol optical depth
11044 ! Dimensions: (ncol,nlay,nbndlw)
11046 ! ----- Output -----
11047 ! Atmosphere
11048 integer(kind=im), intent(out) :: nlayers ! number of layers
11050 real(kind=rb), intent(out) :: pavel(:) ! layer pressures (mb)
11051 ! Dimensions: (nlay)
11052 real(kind=rb), intent(out) :: tavel(:) ! layer temperatures (K)
11053 ! Dimensions: (nlay)
11054 real(kind=rb), intent(out) :: pz(0:) ! level (interface) pressures (hPa, mb)
11055 ! Dimensions: (0:nlay)
11056 real(kind=rb), intent(out) :: tz(0:) ! level (interface) temperatures (K)
11057 ! Dimensions: (0:nlay)
11058 real(kind=rb), intent(out) :: tbound ! surface temperature (K)
11059 real(kind=rb), intent(out) :: coldry(:) ! dry air column density (mol/cm2)
11060 ! Dimensions: (nlay)
11061 real(kind=rb), intent(out) :: wbrodl(:) ! broadening gas column density (mol/cm2)
11062 ! Dimensions: (nlay)
11063 real(kind=rb), intent(out) :: wkl(:,:) ! molecular amounts (mol/cm-2)
11064 ! Dimensions: (mxmol,nlay)
11065 real(kind=rb), intent(out) :: wx(:,:) ! cross-section amounts (mol/cm-2)
11066 ! Dimensions: (maxxsec,nlay)
11067 real(kind=rb), intent(out) :: pwvcm ! precipitable water vapor (cm)
11068 real(kind=rb), intent(out) :: semiss(:) ! lw surface emissivity
11069 ! Dimensions: (nbndlw)
11071 ! Atmosphere/clouds - cldprop
11072 integer(kind=im), intent(out) :: inflag ! flag for cloud property method
11073 integer(kind=im), intent(out) :: iceflag ! flag for ice cloud properties
11074 integer(kind=im), intent(out) :: liqflag ! flag for liquid cloud properties
11076 real(kind=rb), intent(out) :: cldfmc(:,:) ! cloud fraction [mcica]
11077 ! Dimensions: (ngptlw,nlay)
11078 real(kind=rb), intent(out) :: ciwpmc(:,:) ! in-cloud ice water path [mcica]
11079 ! Dimensions: (ngptlw,nlay)
11080 real(kind=rb), intent(out) :: clwpmc(:,:) ! in-cloud liquid water path [mcica]
11081 ! Dimensions: (ngptlw,nlay)
11082 real(kind=rb), intent(out) :: relqmc(:) ! liquid particle effective radius (microns)
11083 ! Dimensions: (nlay)
11084 real(kind=rb), intent(out) :: reicmc(:) ! ice particle effective size (microns)
11085 ! Dimensions: (nlay)
11086 real(kind=rb), intent(out) :: taucmc(:,:) ! in-cloud optical depth [mcica]
11087 ! Dimensions: (ngptlw,nlay)
11088 real(kind=rb), intent(out) :: taua(:,:) ! aerosol optical depth
11089 ! Dimensions: (nlay,nbndlw)
11092 ! ----- Local -----
11093 real(kind=rb), parameter :: amd = 28.9660_rb ! Effective molecular weight of dry air (g/mol)
11094 real(kind=rb), parameter :: amw = 18.0160_rb ! Molecular weight of water vapor (g/mol)
11095 ! real(kind=rb), parameter :: amc = 44.0098_rb ! Molecular weight of carbon dioxide (g/mol)
11096 ! real(kind=rb), parameter :: amo = 47.9998_rb ! Molecular weight of ozone (g/mol)
11097 ! real(kind=rb), parameter :: amo2 = 31.9999_rb ! Molecular weight of oxygen (g/mol)
11098 ! real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
11099 ! real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
11100 ! real(kind=rb), parameter :: amc11 = 137.3684_rb ! Molecular weight of CFC11 (g/mol) - CCL3F
11101 ! real(kind=rb), parameter :: amc12 = 120.9138_rb ! Molecular weight of CFC12 (g/mol) - CCL2F2
11102 ! real(kind=rb), parameter :: amc22 = 86.4688_rb ! Molecular weight of CFC22 (g/mol) - CHCLF2
11103 ! real(kind=rb), parameter :: amcl4 = 153.823_rb ! Molecular weight of CCL4 (g/mol) - CCL4
11105 ! Set molecular weight ratios (for converting mmr to vmr)
11106 ! e.g. h2ovmr = h2ommr * amdw)
11107 real(kind=rb), parameter :: amdw = 1.607793_rb ! Molecular weight of dry air / water vapor
11108 real(kind=rb), parameter :: amdc = 0.658114_rb ! Molecular weight of dry air / carbon dioxide
11109 real(kind=rb), parameter :: amdo = 0.603428_rb ! Molecular weight of dry air / ozone
11110 real(kind=rb), parameter :: amdm = 1.805423_rb ! Molecular weight of dry air / methane
11111 real(kind=rb), parameter :: amdn = 0.658090_rb ! Molecular weight of dry air / nitrous oxide
11112 real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
11113 real(kind=rb), parameter :: amdc1 = 0.210852_rb ! Molecular weight of dry air / CFC11
11114 real(kind=rb), parameter :: amdc2 = 0.239546_rb ! Molecular weight of dry air / CFC12
11116 integer(kind=im) :: isp, l, ix, n, imol, ib, ig ! Loop indices
11117 real(kind=rb) :: amm, amttl, wvttl, wvsh, summol
11119 ! Add one to nlayers here to include extra model layer at top of atmosphere
11120 nlayers = nlay
11122 ! Initialize all molecular amounts and cloud properties to zero here, then pass input amounts
11123 ! into RRTM arrays below.
11125 wkl(:,:) = 0.0_rb
11126 wx(:,:) = 0.0_rb
11127 cldfmc(:,:) = 0.0_rb
11128 taucmc(:,:) = 0.0_rb
11129 ciwpmc(:,:) = 0.0_rb
11130 clwpmc(:,:) = 0.0_rb
11131 reicmc(:) = 0.0_rb
11132 relqmc(:) = 0.0_rb
11133 taua(:,:) = 0.0_rb
11134 amttl = 0.0_rb
11135 wvttl = 0.0_rb
11137 ! Set surface temperature.
11138 tbound = tsfc(iplon)
11140 ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature,
11141 ! and molecular amounts.
11142 ! Pressures are input in mb, or are converted to mb here.
11143 ! Molecular amounts are input in volume mixing ratio, or are converted from
11144 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
11145 ! here. These are then converted to molecular amount (molec/cm2) below.
11146 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
11147 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
11148 ! correction to account for h2o in the layer. The molecular weight of moist
11149 ! air (amm) is calculated for each layer.
11150 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
11151 ! assumes GCM input fields are also bottom to top. Input layer indexing
11152 ! from GCM fields should be reversed here if necessary.
11154 pz(0) = plev(iplon,1)
11155 tz(0) = tlev(iplon,1)
11156 do l = 1, nlayers
11157 pavel(l) = play(iplon,l)
11158 tavel(l) = tlay(iplon,l)
11159 pz(l) = plev(iplon,l+1)
11160 tz(l) = tlev(iplon,l+1)
11161 ! For h2o input in vmr:
11162 wkl(1,l) = h2ovmr(iplon,l)
11163 ! For h2o input in mmr:
11164 ! wkl(1,l) = h2o(iplon,l)*amdw
11165 ! For h2o input in specific humidity;
11166 ! wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
11167 wkl(2,l) = co2vmr(iplon,l)
11168 wkl(3,l) = o3vmr(iplon,l)
11169 wkl(4,l) = n2ovmr(iplon,l)
11170 wkl(6,l) = ch4vmr(iplon,l)
11171 wkl(7,l) = o2vmr(iplon,l)
11172 amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
11173 coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
11174 (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
11175 enddo
11177 ! Set cross section molecule amounts from input; convert to vmr if necessary
11178 do l=1, nlayers
11179 wx(1,l) = ccl4vmr(iplon,l)
11180 wx(2,l) = cfc11vmr(iplon,l)
11181 wx(3,l) = cfc12vmr(iplon,l)
11182 wx(4,l) = cfc22vmr(iplon,l)
11183 enddo
11185 ! The following section can be used to set values for an additional layer (from
11186 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
11187 ! Temperature and molecular amounts in the extra model layer are set to
11188 ! their values in the top GCM model layer, though these can be modified
11189 ! here if necessary.
11190 ! If this feature is utilized, increase nlayers by one above, limit the two
11191 ! loops above to (nlayers-1), and set the top most (extra) layer values here.
11193 ! pavel(nlayers) = 0.5_rb * pz(nlayers-1)
11194 ! tavel(nlayers) = tavel(nlayers-1)
11195 ! pz(nlayers) = 1.e-4_rb
11196 ! tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
11197 ! tz(nlayers) = tz(nlayers-1)
11198 ! wkl(1,nlayers) = wkl(1,nlayers-1)
11199 ! wkl(2,nlayers) = wkl(2,nlayers-1)
11200 ! wkl(3,nlayers) = wkl(3,nlayers-1)
11201 ! wkl(4,nlayers) = wkl(4,nlayers-1)
11202 ! wkl(6,nlayers) = wkl(6,nlayers-1)
11203 ! wkl(7,nlayers) = wkl(7,nlayers-1)
11204 ! amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
11205 ! coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
11206 ! (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
11207 ! wx(1,nlayers) = wx(1,nlayers-1)
11208 ! wx(2,nlayers) = wx(2,nlayers-1)
11209 ! wx(3,nlayers) = wx(3,nlayers-1)
11210 ! wx(4,nlayers) = wx(4,nlayers-1)
11212 ! At this point all molecular amounts in wkl and wx are in volume mixing ratio;
11213 ! convert to molec/cm2 based on coldry for use in rrtm. also, compute precipitable
11214 ! water vapor for diffusivity angle adjustments in rtrn and rtrnmr.
11216 do l = 1, nlayers
11217 summol = 0.0_rb
11218 do imol = 2, nmol
11219 summol = summol + wkl(imol,l)
11220 enddo
11221 wbrodl(l) = coldry(l) * (1._rb - summol)
11222 do imol = 1, nmol
11223 wkl(imol,l) = coldry(l) * wkl(imol,l)
11224 enddo
11225 amttl = amttl + coldry(l)+wkl(1,l)
11226 wvttl = wvttl + wkl(1,l)
11227 do ix = 1,maxxsec
11228 if (ixindx(ix) .ne. 0) then
11229 wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb
11230 endif
11231 enddo
11232 enddo
11234 wvsh = (amw * wvttl) / (amd * amttl)
11235 pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav)
11237 ! Set spectral surface emissivity for each longwave band.
11239 do n=1,nbndlw
11240 semiss(n) = emis(iplon,n)
11241 ! semiss(n) = 1.0_rb
11242 enddo
11244 ! Transfer aerosol optical properties to RRTM variable;
11245 ! modify to reverse layer indexing here if necessary.
11247 if (iaer .ge. 1) then
11248 do l = 1, nlayers
11249 do ib = 1, nbndlw
11250 taua(l,ib) = tauaer(iplon,l,ib)
11251 enddo
11252 enddo
11253 endif
11255 ! Transfer cloud fraction and cloud optical properties to RRTM variables,
11256 ! modify to reverse layer indexing here if necessary.
11258 if (icld .ge. 1) then
11259 inflag = inflglw
11260 iceflag = iceflglw
11261 liqflag = liqflglw
11263 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
11264 ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw)
11266 do l = 1, nlayers
11267 do ig = 1, ngptlw
11268 cldfmc(ig,l) = cldfmcl(ig,iplon,l)
11269 taucmc(ig,l) = taucmcl(ig,iplon,l)
11270 ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
11271 clwpmc(ig,l) = clwpmcl(ig,iplon,l)
11272 enddo
11273 reicmc(l) = reicmcl(iplon,l)
11274 relqmc(l) = relqmcl(iplon,l)
11275 enddo
11277 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
11279 ! cldfmc(:,nlayers) = 0.0_rb
11280 ! taucmc(:,nlayers) = 0.0_rb
11281 ! ciwpmc(:,nlayers) = 0.0_rb
11282 ! clwpmc(:,nlayers) = 0.0_rb
11283 ! reicmc(nlayers) = 0.0_rb
11284 ! relqmc(nlayers) = 0.0_rb
11285 ! taua(nlayers,:) = 0.0_rb
11287 endif
11289 end subroutine inatm
11291 end module rrtmg_lw_rad
11293 !------------------------------------------------------------------
11294 MODULE module_ra_rrtmg_lw
11296 use module_model_constants, only : cp
11297 use module_wrf_error
11298 !use module_dm
11300 use parrrtm, only : nbndlw, ngptlw
11301 use rrtmg_lw_init, only: rrtmg_lw_ini
11302 use rrtmg_lw_rad, only: rrtmg_lw
11303 use mcica_subcol_gen_lw, only: mcica_subcol_lw
11305 real retab(95)
11306 data retab / &
11307 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
11308 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
11309 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
11310 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
11311 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
11312 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
11313 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
11314 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
11315 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
11316 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
11317 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
11318 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
11319 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
11320 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
11321 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
11322 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
11323 !
11324 save retab
11325 ! For buffer layer adjustment. Steven Cavallo, Dec 2010.
11326 integer , save :: nlayers
11327 real, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb
11329 CONTAINS
11331 !------------------------------------------------------------------
11332 SUBROUTINE RRTMG_LWRAD( &
11333 rthratenlw, &
11334 lwupt, lwuptc, lwdnt, lwdntc, &
11335 lwupb, lwupbc, lwdnb, lwdnbc, &
11336 ! lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
11337 glw, olr, lwcf, emiss, &
11338 p8w, p3d, pi3d, &
11339 dz8w, tsk, t3d, t8w, rho3d, r, g, &
11340 icloud, warm_rain, cldfra3d, &
11341 f_ice_phy, f_rain_phy, &
11342 xland, xice, snow, &
11343 qv3d, qc3d, qr3d, &
11344 qi3d, qs3d, qg3d, &
11345 f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
11346 tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
11347 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
11348 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
11349 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao
11350 aer_ra_feedback, & !czhao
11351 !jdfcz progn,prescribe, & !czhao
11352 progn, & !czhao
11353 qndrop3d,f_qndrop, & !czhao
11354 ids,ide, jds,jde, kds,kde, &
11355 ims,ime, jms,jme, kms,kme, &
11356 its,ite, jts,jte, kts,kte, &
11357 lwupflx, lwupflxc, lwdnflx, lwdnflxc &
11358 )
11359 !------------------------------------------------------------------
11360 IMPLICIT NONE
11361 !------------------------------------------------------------------
11362 LOGICAL, INTENT(IN ) :: warm_rain
11363 !
11364 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
11365 ims,ime, jms,jme, kms,kme, &
11366 its,ite, jts,jte, kts,kte
11368 INTEGER, INTENT(IN ) :: ICLOUD
11369 !
11370 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11371 INTENT(IN ) :: dz8w, &
11372 t3d, &
11373 t8w, &
11374 p8w, &
11375 p3d, &
11376 pi3d, &
11377 rho3d
11379 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11380 INTENT(INOUT) :: RTHRATENLW
11382 REAL, DIMENSION( ims:ime, jms:jme ) , &
11383 INTENT(INOUT) :: GLW, &
11384 OLR, &
11385 LWCF
11387 REAL, DIMENSION( ims:ime, jms:jme ) , &
11388 INTENT(IN ) :: EMISS, &
11389 TSK
11391 REAL, INTENT(IN ) :: R,G
11393 REAL, DIMENSION( ims:ime, jms:jme ) , &
11394 INTENT(IN ) :: XLAND, &
11395 XICE, &
11396 SNOW
11397 !
11398 ! Optional
11399 !
11400 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11401 OPTIONAL , &
11402 INTENT(IN ) :: &
11403 CLDFRA3D, &
11404 QV3D, &
11405 QC3D, &
11406 QR3D, &
11407 QI3D, &
11408 QS3D, &
11409 QG3D, &
11410 QNDROP3D
11411 real pi,third,relconst,lwpmin,rhoh2o
11413 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
11414 OPTIONAL , &
11415 INTENT(IN ) :: &
11416 F_ICE_PHY, &
11417 F_RAIN_PHY
11419 LOGICAL, OPTIONAL, INTENT(IN) :: &
11420 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
11421 ! Optional
11422 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
11423 INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
11424 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
11425 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
11426 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
11428 INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
11429 !jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
11430 INTEGER, INTENT(IN ), OPTIONAL :: progn
11432 real, parameter :: thresh=1.e-9
11433 real slope
11434 character(len=200) :: msg
11437 ! Top of atmosphere and surface longwave fluxes (W m-2)
11438 REAL, DIMENSION( ims:ime, jms:jme ), &
11439 OPTIONAL, INTENT(INOUT) :: &
11440 LWUPT,LWUPTC,LWDNT,LWDNTC, &
11441 LWUPB,LWUPBC,LWDNB,LWDNBC
11443 ! Layer longwave fluxes (including extra layer above model top)
11444 ! Vertical ordering is from bottom to top (W m-2)
11445 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
11446 OPTIONAL, INTENT(OUT) :: &
11447 LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
11449 ! LOCAL VARS
11451 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
11452 Tw1D
11454 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
11455 CLDFRA1D, &
11456 DZ1D, &
11457 P1D, &
11458 T1D, &
11459 QV1D, &
11460 QC1D, &
11461 QR1D, &
11462 QI1D, &
11463 QS1D, &
11464 QG1D, &
11465 qndrop1d
11467 ! Added local arrays for RRTMG
11468 integer :: ncol, &
11469 nlay, &
11470 icld, &
11471 inflglw, &
11472 iceflglw, &
11473 liqflglw
11474 ! Dimension with extra layer from model top to TOA
11475 real, dimension( 1, kts:nlayers+1 ) :: plev, &
11476 tlev
11477 real, dimension( 1, kts:nlayers ) :: play, &
11478 tlay, &
11479 h2ovmr, &
11480 o3vmr, &
11481 co2vmr, &
11482 o2vmr, &
11483 ch4vmr, &
11484 n2ovmr, &
11485 cfc11vmr, &
11486 cfc12vmr, &
11487 cfc22vmr, &
11488 ccl4vmr
11489 real, dimension( kts:nlayers ) :: o3mmr
11490 ! For old cloud property specification for rrtm_lw
11491 real, dimension( kts:kte ) :: clwp, &
11492 ciwp, &
11493 plwp, &
11494 piwp
11495 ! Surface emissivity (for 16 LW spectral bands)
11496 real, dimension( 1, nbndlw ) :: emis
11497 ! Dimension with extra layer from model top to TOA,
11498 ! though no clouds are allowed in extra layer
11499 real, dimension( 1, kts:nlayers ) :: clwpth, &
11500 ciwpth, &
11501 rel, &
11502 rei, &
11503 cldfrac, &
11504 relqmcl, &
11505 reicmcl
11506 real, dimension( nbndlw, 1, kts:nlayers ) :: taucld
11507 real, dimension( ngptlw, 1, kts:nlayers ) :: cldfmcl, &
11508 clwpmcl, &
11509 ciwpmcl, &
11510 taucmcl
11511 real, dimension( 1, kts:nlayers, nbndlw ) :: tauaer
11513 ! Output arrays contain extra layer from model top to TOA
11514 real, dimension( 1, kts:nlayers+1 ) :: uflx, &
11515 dflx, &
11516 uflxc, &
11517 dflxc
11518 real, dimension( 1, kts:nlayers ) :: hr, &
11519 hrc
11521 real, dimension ( 1 ) :: tsfc, &
11522 ps
11523 real :: ro, &
11524 dz
11526 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11527 ! carbon dioxide (379 ppmv)
11528 real :: co2
11529 data co2 / 379.e-6 /
11530 ! methane (1774 ppbv)
11531 real :: ch4
11532 data ch4 / 1774.e-9 /
11533 ! nitrous oxide (319 ppbv)
11534 real :: n2o
11535 data n2o / 319.e-9 /
11536 ! cfc-11 (251 ppt)
11537 real :: cfc11
11538 data cfc11 / 0.251e-9 /
11539 ! cfc-12 (538 ppt)
11540 real :: cfc12
11541 data cfc12 / 0.538e-9 /
11542 ! cfc-22 (169 ppt)
11543 real :: cfc22
11544 data cfc22 / 0.169e-9 /
11545 ! ccl4 (93 ppt)
11546 real :: ccl4
11547 data ccl4 / 0.093e-9 /
11548 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
11549 real :: o2
11550 data o2 / 0.209488 /
11552 integer :: iplon, irng, permuteseed
11553 integer :: nb
11555 ! For old cloud property specification for rrtm_lw
11556 ! Cloud and precipitation absorption coefficients
11557 real :: abcw,abice,abrn,absn
11558 data abcw /0.144/
11559 data abice /0.0735/
11560 data abrn /0.330e-3/
11561 data absn /2.34e-3/
11563 ! Molecular weights and ratios for converting mmr to vmr units
11564 ! real :: amd ! Effective molecular weight of dry air (g/mol)
11565 ! real :: amw ! Molecular weight of water vapor (g/mol)
11566 ! real :: amo ! Molecular weight of ozone (g/mol)
11567 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
11568 ! Atomic weights for conversion from mass to volume mixing ratios
11569 ! data amd / 28.9660 /
11570 ! data amw / 18.0160 /
11571 ! data amo / 47.9998 /
11572 ! data amo2 / 31.9999 /
11574 real :: amdw ! Molecular weight of dry air / water vapor
11575 real :: amdo ! Molecular weight of dry air / ozone
11576 real :: amdo2 ! Molecular weight of dry air / oxygen
11577 data amdw / 1.607793 /
11578 data amdo / 0.603461 /
11579 data amdo2 / 0.905190 /
11581 !!
11582 real, dimension( 1, 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
11584 real, dimension(1, 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
11585 cliqwp, & ! in-cloud cloud liquid water path
11586 reliq, & ! effective drop radius (microns)
11587 reice ! ice effective drop size (microns)
11588 real :: gliqwp, gicewp, gravmks
11590 !
11591 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
11593 real, dimension (1) :: landfrac, landm, snowh, icefrac
11595 integer :: pcols, pver
11597 !
11598 INTEGER :: i,j,K
11599 LOGICAL :: predicate
11601 ! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010
11602 INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table
11603 INTEGER :: L, LL, klev ! Loop indices
11604 REAL, DIMENSION( kts:nlayers+1 ) :: varint
11605 REAL :: wght,vark,vark1
11606 REAL :: PPROF(nproflevs), TPROF(nproflevs)
11607 ! Weighted mean pressure and temperature profiles from midlatitude
11608 ! summer (MLS),midlatitude winter (MLW), sub-Arctic
11609 ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP)
11610 ! standard atmospheres.
11611 DATA PPROF /1000.00,855.47,731.82,626.05,535.57,458.16, &
11612 391.94,335.29,286.83,245.38,209.91,179.57, &
11613 153.62,131.41,112.42,96.17,82.27,70.38, &
11614 60.21,51.51,44.06,37.69,32.25,27.59, &
11615 23.60,20.19,17.27,14.77,12.64,10.81, &
11616 9.25,7.91,6.77,5.79,4.95,4.24, &
11617 3.63,3.10,2.65,2.27,1.94,1.66, &
11618 1.42,1.22,1.04,0.89,0.76,0.65, &
11619 0.56,0.48,0.41,0.35,0.30,0.26, &
11620 0.22,0.19,0.16,0.14,0.12,0.10/
11621 DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, &
11622 245.62,238.41,231.57,225.91,221.72,217.79, &
11623 215.06,212.74,210.25,210.16,210.69,212.14, &
11624 213.74,215.37,216.82,217.94,219.03,220.18, &
11625 221.37,222.64,224.16,225.88,227.63,229.51, &
11626 231.50,233.73,236.18,238.78,241.60,244.44, &
11627 247.35,250.33,253.32,256.30,259.22,262.12, &
11628 264.80,266.50,267.59,268.44,268.69,267.76, &
11629 266.13,263.96,261.54,258.93,256.15,253.23, &
11630 249.89,246.67,243.48,240.25,236.66,233.86/
11631 !------------------------------------------------------------------
11632 #ifdef WRF_CHEM
11633 IF ( aer_ra_feedback == 1) then
11634 IF ( .NOT. &
11635 ( PRESENT(tauaerlw1) .AND. &
11636 PRESENT(tauaerlw2) .AND. &
11637 PRESENT(tauaerlw3) .AND. &
11638 PRESENT(tauaerlw4) .AND. &
11639 PRESENT(tauaerlw5) .AND. &
11640 PRESENT(tauaerlw6) .AND. &
11641 PRESENT(tauaerlw7) .AND. &
11642 PRESENT(tauaerlw8) .AND. &
11643 PRESENT(tauaerlw9) .AND. &
11644 PRESENT(tauaerlw10) .AND. &
11645 PRESENT(tauaerlw11) .AND. &
11646 PRESENT(tauaerlw12) .AND. &
11647 PRESENT(tauaerlw13) .AND. &
11648 PRESENT(tauaerlw14) .AND. &
11649 PRESENT(tauaerlw15) .AND. &
11650 PRESENT(tauaerlw16) ) ) THEN
11651 CALL wrf_error_fatal &
11652 ('Warning: missing fields required for aerosol radiation' )
11653 ENDIF
11654 ENDIF
11655 #endif
11658 !-----CALCULATE LONG WAVE RADIATION
11659 !
11660 ! All fields are ordered vertically from bottom to top
11661 ! Pressures are in mb
11663 ! latitude loop
11664 j_loop: do j = jts,jte
11666 ! longitude loop
11667 i_loop: do i = its,ite
11669 do k=kts,kte+1
11670 Pw1D(K) = p8w(I,K,J)/100.
11671 Tw1D(K) = t8w(I,K,J)
11672 enddo
11674 DO K=kts,kte
11675 QV1D(K)=0.
11676 QC1D(K)=0.
11677 QR1D(K)=0.
11678 QI1D(K)=0.
11679 QS1D(K)=0.
11680 CLDFRA1D(k)=0.
11681 ENDDO
11683 DO K=kts,kte
11684 QV1D(K)=QV3D(I,K,J)
11685 QV1D(K)=max(0.,QV1D(K))
11686 ENDDO
11688 DO K=kts,kte
11689 TTEN1D(K)=0.
11690 T1D(K)=T3D(I,K,J)
11691 P1D(K)=P3D(I,K,J)/100.
11692 DZ1D(K)=dz8w(I,K,J)
11693 ENDDO
11695 ! moist variables
11697 IF (ICLOUD .ne. 0) THEN
11698 IF ( PRESENT( CLDFRA3D ) ) THEN
11699 DO K=kts,kte
11700 CLDFRA1D(k)=CLDFRA3D(I,K,J)
11701 ENDDO
11702 ENDIF
11704 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
11705 IF ( F_QC) THEN
11706 DO K=kts,kte
11707 QC1D(K)=QC3D(I,K,J)
11708 QC1D(K)=max(0.,QC1D(K))
11709 ENDDO
11710 ENDIF
11711 ENDIF
11713 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
11714 IF ( F_QR) THEN
11715 DO K=kts,kte
11716 QR1D(K)=QR3D(I,K,J)
11717 QR1D(K)=max(0.,QR1D(K))
11718 ENDDO
11719 ENDIF
11720 ENDIF
11722 IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
11723 IF (F_QNDROP) THEN
11724 DO K=kts,kte
11725 qndrop1d(K)=qndrop3d(I,K,J)
11726 ENDDO
11727 ENDIF
11728 ENDIF
11730 ! This logic is tortured because cannot test F_QI unless
11731 ! it is present, and order of evaluation of expressions
11732 ! is not specified in Fortran
11734 IF ( PRESENT ( F_QI ) ) THEN
11735 predicate = F_QI
11736 ELSE
11737 predicate = .FALSE.
11738 ENDIF
11740 ! For MP option 3
11741 IF (.NOT. predicate .and. .not. warm_rain) THEN
11742 DO K=kts,kte
11743 IF (T1D(K) .lt. 273.15) THEN
11744 QI1D(K)=QC1D(K)
11745 QS1D(K)=QR1D(K)
11746 QC1D(K)=0.
11747 QR1D(K)=0.
11748 ENDIF
11749 ENDDO
11750 ENDIF
11752 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
11753 IF (F_QI) THEN
11754 DO K=kts,kte
11755 QI1D(K)=QI3D(I,K,J)
11756 QI1D(K)=max(0.,QI1D(K))
11757 ENDDO
11758 ENDIF
11759 ENDIF
11761 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
11762 IF (F_QS) THEN
11763 DO K=kts,kte
11764 QS1D(K)=QS3D(I,K,J)
11765 QS1D(K)=max(0.,QS1D(K))
11766 ENDDO
11767 ENDIF
11768 ENDIF
11770 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
11771 IF (F_QG) THEN
11772 DO K=kts,kte
11773 QG1D(K)=QG3D(I,K,J)
11774 QG1D(K)=max(0.,QG1D(K))
11775 ENDDO
11776 ENDIF
11777 ENDIF
11779 ! mji - For MP option 5
11780 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
11781 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
11782 DO K=kts,kte
11783 qi1d(k) = qs3d(i,k,j)
11784 qc1d(k) = qc3d(i,k,j)
11785 qi1d(k) = max(0.,qi1d(k))
11786 qc1d(k) = max(0.,qc1d(k))
11787 ENDDO
11788 ENDIF
11789 ENDIF
11791 ENDIF
11793 ! EMISS0=EMISS(I,J)
11794 ! GLW0=0.
11795 ! OLR0=0.
11796 ! TSFC=TSK(I,J)
11797 DO K=kts,kte
11798 QV1D(K)=AMAX1(QV1D(K),1.E-12)
11799 ENDDO
11801 ! Set up input for longwave
11802 ncol = 1
11803 ! Add extra layer from top of model to top of atmosphere
11804 ! nlay = (kte - kts + 1) + 1
11805 ! Edited for top of model adjustment (nlayers = kte + 1).
11806 ! Steven Cavallo, December 2010
11807 nlay = nlayers ! Keep these indices the same
11810 ! Select cloud liquid and ice optics parameterization options
11811 ! For passing in cloud optical properties directly:
11812 ! icld = 2
11813 ! inflglw = 0
11814 ! iceflglw = 0
11815 ! liqflglw = 0
11816 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
11817 icld = 2
11818 inflglw = 2
11819 iceflglw = 3
11820 liqflglw = 1
11822 ! Layer indexing goes bottom to top here for all fields.
11823 ! Water vapor and ozone are converted from mmr to vmr.
11824 ! Pressures are in units of mb here.
11825 plev(ncol,1) = pw1d(1)
11826 tlev(ncol,1) = tw1d(1)
11827 tsfc(ncol) = tsk(i,j)
11828 do k = kts, kte
11829 play(ncol,k) = p1d(k)
11830 plev(ncol,k+1) = pw1d(k+1)
11831 pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
11832 tlay(ncol,k) = t1d(k)
11833 tlev(ncol,k+1) = tw1d(k+1)
11834 h2ovmr(ncol,k) = qv1d(k) * amdw
11835 co2vmr(ncol,k) = co2
11836 o2vmr(ncol,k) = o2
11837 ch4vmr(ncol,k) = ch4
11838 n2ovmr(ncol,k) = n2o
11839 cfc11vmr(ncol,k) = cfc11
11840 cfc12vmr(ncol,k) = cfc12
11841 cfc22vmr(ncol,k) = cfc22
11842 ccl4vmr(ncol,k) = ccl4
11843 enddo
11845 ! This section is replaced with a new method to deal with model top
11846 if ( 1 == 0 ) then
11848 ! Define profile values for extra layer from model top to top of atmosphere.
11849 ! The top layer temperature for all gridpoints is set to the top layer-1
11850 ! temperature plus a constant (0 K) that represents an isothermal layer
11851 ! above ptop. Top layer interface temperatures are linearly interpolated
11852 ! from the layer temperatures.
11854 play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
11855 tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
11856 plev(ncol,kte+2) = 1.0e-5
11857 tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
11858 h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
11859 co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
11860 o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
11861 ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
11862 n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
11863 cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte)
11864 cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte)
11865 cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte)
11866 ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte)
11868 endif
11870 ! Set up values for extra layers to the top of the atmosphere.
11871 ! Temperature is calculated based on an average temperature profile given
11872 ! here in a table. The input table data is linearly interpolated to the
11873 ! column pressure. Mixing ratios are held constant except for ozone.
11874 ! Caution should be used if model top pressure is less than 5 hPa.
11875 ! Steven Cavallo, NCAR/MMM, December 2010
11876 ! Calculate the column pressure buffer levels above the
11877 ! model top
11878 do L=kte+1,nlayers,1
11879 plev(ncol,L+1) = plev(ncol,L) - deltap
11880 play(ncol,L) = 0.5*(plev(ncol,L) + plev(ncol,L+1))
11881 enddo
11882 ! Add zero as top level. This gets the temperature max at the
11883 ! stratopause, reducing the downward flux errors in the top
11884 ! levels. If zero happened to be the top level already,
11885 ! this will add another level with zero, but will not affect
11886 ! the radiative transfer calculation.
11887 plev(ncol,nlayers+1) = 0.00
11888 play(ncol,nlayers) = 0.5*(plev(ncol,nlayers) + plev(ncol,nlayers+1))
11890 ! Interpolate the table temperatures to column pressure levels
11891 do L=1,nlayers+1,1
11892 if ( PPROF(nproflevs) .lt. plev(ncol,L) ) then
11893 do LL=2,nproflevs,1
11894 if ( PPROF(LL) .lt. plev(ncol,L) ) then
11895 klev = LL - 1
11896 exit
11897 endif
11898 enddo
11900 else
11901 klev = nproflevs
11902 endif
11904 if (klev .ne. nproflevs ) then
11905 vark = TPROF(klev)
11906 vark1 = TPROF(klev+1)
11907 wght=(plev(ncol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev))
11908 else
11909 vark = TPROF(klev)
11910 vark1 = TPROF(klev)
11911 wght = 0.0
11912 endif
11913 varint(L) = wght*(vark1-vark)+vark
11915 enddo
11917 ! Match the interpolated table temperature profile to WRF column
11918 do L=kte+1,nlayers+1,1
11919 tlev(ncol,L) = varint(L) + (tlev(ncol,kte) - varint(kte))
11920 !if ( L .le. nlay ) then
11921 tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1))
11922 !endif
11923 enddo
11925 ! Now the chemical species (except for ozone)
11926 do L=kte+1,nlayers,1
11927 h2ovmr(ncol,L) = h2ovmr(ncol,kte)
11928 co2vmr(ncol,L) = co2vmr(ncol,kte)
11929 o2vmr(ncol,L) = o2vmr(ncol,kte)
11930 ch4vmr(ncol,L) = ch4vmr(ncol,kte)
11931 n2ovmr(ncol,L) = n2ovmr(ncol,kte)
11932 cfc11vmr(ncol,L) = cfc11vmr(ncol,kte)
11933 cfc12vmr(ncol,L) = cfc12vmr(ncol,kte)
11934 cfc22vmr(ncol,L) = cfc22vmr(ncol,kte)
11935 ccl4vmr(ncol,L) = ccl4vmr(ncol,kte)
11936 enddo
11937 ! End top of model buffer
11938 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
11939 ! Get ozone profile including amount in extra layer above model top.
11940 ! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers
11941 ! dimension for o3mmr
11942 call inirad (o3mmr,plev,kts,nlay-1)
11944 ! Steven Cavallo: Changed to nlayers from kte+1
11945 do k = kts, nlayers
11946 o3vmr(ncol,k) = o3mmr(k) * amdo
11947 enddo
11949 ! Set surface emissivity in each RRTMG longwave band
11950 do nb = 1, nbndlw
11951 emis(ncol, nb) = emiss(i,j)
11952 enddo
11954 ! Define cloud optical properties for radiation (inflglw = 0)
11955 ! This is approach used with older RRTM_LW;
11956 ! Cloud and precipitation paths in g/m2
11957 ! qi=0 if no ice phase
11958 ! qs=0 if no ice phase
11959 if (inflglw .eq. 0) then
11960 do k = kts,kte
11961 ro = p1d(k) / (r * t1d(k))*100.
11962 dz = dz1d(k)
11963 clwp(k) = ro*qc1d(k)*dz*1000.
11964 ciwp(k) = ro*qi1d(k)*dz*1000.
11965 plwp(k) = (ro*qr1d(k))**0.75*dz*1000.
11966 piwp(k) = (ro*qs1d(k))**0.75*dz*1000.
11967 enddo
11969 ! Cloud fraction and cloud optical depth; old approach used with RRTM_LW
11970 do k = kts, kte
11971 cldfrac(ncol,k) = cldfra1d(k)
11972 do nb = 1, nbndlw
11973 taucld(nb,ncol,k) = abcw*clwp(k) + abice*ciwp(k) &
11974 +abrn*plwp(k) + absn*piwp(k)
11975 if (taucld(nb,ncol,k) .gt. 0.01) cldfrac(ncol,k) = 1.
11976 enddo
11977 enddo
11979 ! Zero out cloud physical property arrays; not used when passing optical properties
11980 ! into radiation
11981 do k = kts, kte
11982 clwpth(ncol,k) = 0.0
11983 ciwpth(ncol,k) = 0.0
11984 rel(ncol,k) = 10.0
11985 rei(ncol,k) = 10.0
11986 enddo
11987 endif
11989 ! Define cloud physical properties for radiation (inflglw = 1 or 2)
11990 ! Cloud fraction
11991 ! Set cloud arrays if passing cloud physical properties into radiation
11992 if (inflglw .gt. 0) then
11993 do k = kts, kte
11994 cldfrac(ncol,k) = cldfra1d(k)
11995 enddo
11997 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
11998 pcols = ncol
11999 pver = kte - kts + 1
12000 gravmks = g
12001 landfrac(ncol) = 2.-XLAND(I,J)
12002 landm(ncol) = landfrac(ncol)
12003 snowh(ncol) = 0.001*SNOW(I,J)
12004 icefrac(ncol) = XICE(I,J)
12006 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
12007 ! pdel is in mb here; convert back to Pa (*100.)
12008 ! Water paths are in units of g/m2
12009 ! snow added as ice cloud (JD 091022)
12010 do k = kts, kte
12011 gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
12012 gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
12013 cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k)) ! In-cloud ice water path.
12014 cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k)) ! In-cloud liquid water path.
12015 end do
12017 !link the aerosol feedback to cloud -czhao
12018 if( PRESENT( progn ) ) then
12019 if (progn == 1) then
12020 !jdfcz if(prescribe==0) then
12022 pi = 4.*atan(1.0)
12023 third=1./3.
12024 rhoh2o=1.e3
12025 relconst=3/(4.*pi*rhoh2o)
12026 ! minimun liquid water path to calculate rel
12027 ! corresponds to optical depth of 1.e-3 for radius 4 microns.
12028 lwpmin=3.e-5
12029 do k = kts, kte
12030 reliq(ncol,k) = 10.
12031 if( PRESENT( F_QNDROP ) ) then
12032 if( F_QNDROP ) then
12033 if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
12034 qndrop1d(k).gt.1000. ) then
12035 reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
12036 ! apply scaling from Martin et al., JAS 51, 1830.
12037 reliq(ncol,k)=1.1*reliq(ncol,k)
12038 reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
12039 reliq(ncol,k)=max(reliq(ncol,k),4.)
12040 reliq(ncol,k)=min(reliq(ncol,k),20.)
12041 end if
12042 end if
12043 end if
12044 end do
12045 !jdfcz else ! prescribe
12046 ! following Kiehl
12047 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12048 ! write(0,*) 'lw prescribe aerosol',maxval(qndrop3d)
12049 !jdfcz endif
12050 else ! progn
12051 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12052 endif
12053 else !present(progn)
12054 call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12055 endif
12057 ! following Kristjansson and Mitchell
12058 call reicalc(ncol, pcols, pver, tlay, reice)
12060 ! Limit upper bound of reice for Fu ice parameterization and convert
12061 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
12062 if (iceflglw .eq. 3) then
12063 do k = kts, kte
12064 reice(ncol,k) = reice(ncol,k) * 1.0315
12065 reice(ncol,k) = min(140.0,reice(ncol,k))
12066 end do
12067 endif
12069 ! Set cloud physical property arrays
12070 do k = kts, kte
12071 clwpth(ncol,k) = cliqwp(ncol,k)
12072 ciwpth(ncol,k) = cicewp(ncol,k)
12073 rel(ncol,k) = reliq(ncol,k)
12074 rei(ncol,k) = reice(ncol,k)
12075 enddo
12077 ! Zero out cloud optical properties here; not used when passing physical properties
12078 ! to radiation and taucld is calculated in radiation
12079 do k = kts, kte
12080 do nb = 1, nbndlw
12081 taucld(nb,ncol,k) = 0.0
12082 enddo
12083 enddo
12084 endif
12086 ! No clouds are allowed in the extra layer from model top to TOA
12087 ! Steven Cavallo: Edited out for buffer adjustment below
12088 if ( 1 == 0 ) then
12091 clwpth(ncol,kte+1) = 0.
12092 ciwpth(ncol,kte+1) = 0.
12093 rel(ncol,kte+1) = 10.
12094 rei(ncol,kte+1) = 10.
12095 cldfrac(ncol,kte+1) = 0.
12096 do nb = 1, nbndlw
12097 taucld(nb,ncol,kte+1) = 0.
12098 enddo
12100 endif
12102 ! Buffer adjustment. Steven Cavallo December 2010
12103 do k=kte+1,nlayers
12104 clwpth(ncol,k) = 0.
12105 ciwpth(ncol,k) = 0.
12106 rel(ncol,k) = 10.
12107 rei(ncol,k) = 10.
12108 cldfrac(ncol,k) = 0.
12109 do nb = 1,nbndlw
12110 taucld(nb,ncol,k) = 0.
12111 enddo
12112 enddo
12114 iplon = 1
12115 irng = 0
12116 permuteseed = 150
12118 ! Sub-column generator for McICA
12119 call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
12120 cldfrac, ciwpth, clwpth, rei, rel, taucld, cldfmcl, &
12121 ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
12123 !--------------------------------------------------------------------------
12124 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
12125 !--------------------------------------------------------------------------
12126 ! Aerosol optical depth by layer for each RRTMG longwave band
12127 ! No aerosols in layer above model top (kte+1)
12128 ! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1
12129 ! do nb = 1, nbndlw
12130 ! do k = kts, kte+1
12131 ! tauaer(ncol,k,nb) = 0.
12132 ! enddo
12133 ! enddo
12135 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
12136 !
12137 do nb = 1, nbndlw
12138 do k = kts,nlayers
12139 tauaer(ncol,k,nb) = 0.
12140 end do
12141 end do
12143 #ifdef WRF_CHEM
12144 IF ( AER_RA_FEEDBACK == 1) then
12145 ! do nb = 1, nbndlw
12146 do k = kts,kte !wig
12147 if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then
12148 tauaer(ncol,k,1)=tauaerlw1(i,k,j)
12149 tauaer(ncol,k,2)=tauaerlw2(i,k,j)
12150 tauaer(ncol,k,3)=tauaerlw3(i,k,j)
12151 tauaer(ncol,k,4)=tauaerlw4(i,k,j)
12152 tauaer(ncol,k,5)=tauaerlw5(i,k,j)
12153 tauaer(ncol,k,6)=tauaerlw6(i,k,j)
12154 tauaer(ncol,k,7)=tauaerlw7(i,k,j)
12155 tauaer(ncol,k,8)=tauaerlw8(i,k,j)
12156 tauaer(ncol,k,9)=tauaerlw9(i,k,j)
12157 tauaer(ncol,k,10)=tauaerlw10(i,k,j)
12158 tauaer(ncol,k,11)=tauaerlw11(i,k,j)
12159 tauaer(ncol,k,12)=tauaerlw12(i,k,j)
12160 tauaer(ncol,k,13)=tauaerlw13(i,k,j)
12161 tauaer(ncol,k,14)=tauaerlw14(i,k,j)
12162 tauaer(ncol,k,15)=tauaerlw15(i,k,j)
12163 tauaer(ncol,k,16)=tauaerlw16(i,k,j)
12164 endif
12165 enddo ! k
12166 ! end do ! nb
12168 !wig beg
12169 do nb = 1, nbndlw
12170 slope = 0. !use slope as a sum holder
12171 do k = kts,kte
12172 slope = slope + tauaer(ncol,k,nb)
12173 end do
12174 if( slope < 0. ) then
12175 write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
12176 call wrf_error_fatal(msg)
12177 else if( slope > 5. ) then
12178 call wrf_message("-------------------------")
12179 write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
12180 call wrf_message(msg)
12182 call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16")
12183 do k=kts,kte
12184 write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j)
12185 call wrf_message(msg)
12186 end do
12187 call wrf_message("-------------------------")
12188 endif
12189 enddo ! nb
12190 endif ! aer_ra_feedback
12191 #endif
12193 ! Call RRTMG longwave radiation model
12194 call rrtmg_lw &
12195 (ncol ,nlay ,icld , &
12196 play ,plev ,tlay ,tlev ,tsfc , &
12197 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
12198 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
12199 inflglw ,iceflglw,liqflglw,cldfmcl , &
12200 taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
12201 tauaer , &
12202 uflx ,dflx ,hr ,uflxc ,dflxc, hrc)
12204 ! Output downard surface flux, and outgoing longwave flux and cloud forcing
12205 ! at the top of atmosphere (W/m2)
12206 glw(i,j) = dflx(1,1)
12207 ! olr(i,j) = uflx(1,kte+2)
12208 ! lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
12209 ! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead
12210 ! of top of model. Dec 2010.
12211 olr(i,j) = uflx(1,nlayers+1)
12212 lwcf(i,j) = uflxc(1,nlayers+1) - uflx(1,nlayers+1)
12214 if (present(lwupt)) then
12215 ! Output up and down toa fluxes for total and clear sky
12216 lwupt(i,j) = uflx(1,kte+2)
12217 lwuptc(i,j) = uflxc(1,kte+2)
12218 lwdnt(i,j) = dflx(1,kte+2)
12219 lwdntc(i,j) = dflxc(1,kte+2)
12220 ! Output up and down surface fluxes for total and clear sky
12221 lwupb(i,j) = uflx(1,1)
12222 lwupbc(i,j) = uflxc(1,1)
12223 lwdnb(i,j) = dflx(1,1)
12224 lwdnbc(i,j) = dflxc(1,1)
12225 endif
12227 ! Output up and down layer fluxes for total and clear sky.
12228 ! Vertical ordering is from bottom to top in units of W m-2.
12229 if ( present (lwupflx) ) then
12230 do k=kts,kte+2
12231 lwupflx(i,k,j) = uflx(1,k)
12232 lwupflxc(i,k,j) = uflxc(1,k)
12233 lwdnflx(i,k,j) = dflx(1,k)
12234 lwdnflxc(i,k,j) = dflxc(1,k)
12235 enddo
12236 endif
12238 ! Output heating rate tendency; convert heating rate from K/d to K/s
12239 ! Heating rate arrays are ordered vertically from bottom to top here.
12240 do k=kts,kte
12241 tten1d(k) = hr(ncol,k)/86400.
12242 rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j)
12243 enddo
12245 !
12246 end do i_loop
12247 end do j_loop
12249 !-------------------------------------------------------------------
12251 END SUBROUTINE RRTMG_LWRAD
12254 !-------------------------------------------------------------------------
12255 SUBROUTINE INIRAD (O3PROF,Plev, kts, kte)
12256 !-------------------------------------------------------------------------
12257 IMPLICIT NONE
12258 !-------------------------------------------------------------------------
12259 INTEGER, INTENT(IN ) :: kts,kte
12261 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12263 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12265 ! LOCAL VAR
12267 INTEGER :: k
12269 !
12270 ! COMPUTE OZONE MIXING RATIO DISTRIBUTION
12271 !
12272 DO K=kts,kte+1
12273 O3PROF(K)=0.
12274 ENDDO
12276 CALL O3DATA(O3PROF, Plev, kts, kte)
12278 END SUBROUTINE INIRAD
12280 !-------------------------------------------------------------------------
12281 SUBROUTINE O3DATA (O3PROF, Plev, kts, kte)
12282 !-------------------------------------------------------------------------
12283 IMPLICIT NONE
12284 !-------------------------------------------------------------------------
12285 !
12286 INTEGER, INTENT(IN ) :: kts, kte
12287 !
12288 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
12290 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
12292 ! LOCAL VAR
12293 INTEGER :: K, JJ
12295 REAL :: PRLEVH(kts:kte+2),PPWRKH(32), &
12296 O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), &
12297 O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31)
12299 REAL :: PB1, PB2, PT1, PT2
12301 DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, &
12302 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, &
12303 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, &
12304 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, &
12305 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, &
12306 9.856E-6,5.960E-6,5.960E-6/
12308 DATA PPSUM /955.890,850.532,754.599,667.742,589.841, &
12309 519.421,455.480,398.085,347.171,301.735,261.310,225.360, &
12310 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, &
12311 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, &
12312 9.277, 4.660, 2.421, 1.294, 0.647/
12313 !
12314 DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, &
12315 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, &
12316 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, &
12317 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, &
12318 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, &
12319 9.389E-6,6.135E-6,6.135E-6/
12321 DATA PPWIN /955.747,841.783,740.199,649.538,568.404, &
12322 495.815,431.069,373.464,322.354,277.190,237.635,203.433, &
12323 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, &
12324 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, &
12325 7.583, 3.620, 1.807, 0.938, 0.469/
12326 !
12328 DO K=1,31
12329 PPANN(K)=PPSUM(K)
12330 ENDDO
12331 !
12332 O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1))
12333 !
12334 DO K=2,31
12335 O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* &
12336 (PPSUM(K)-PPWIN(K-1))
12337 ENDDO
12338 !
12339 DO K=2,31
12340 O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K))
12341 ENDDO
12342 !
12343 DO K=1,31
12344 O3WRK(K)=O3ANN(K)
12345 PPWRK(K)=PPANN(K)
12346 ENDDO
12347 !
12348 ! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS
12349 !
12351 ! Plev is total P at model levels, from bottom to top
12352 ! Plev is in mb
12354 DO K=kts,kte+2
12355 PRLEVH(K)=Plev(K)
12356 ENDDO
12357 !
12358 PPWRKH(1)=1100.
12359 DO K=2,31
12360 PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2.
12361 ENDDO
12362 PPWRKH(32)=0.
12363 DO K=kts,kte+1
12364 DO 25 JJ=1,31
12365 IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN
12366 PB1=0.
12367 ELSE
12368 PB1=PRLEVH(K)-PPWRKH(JJ)
12369 ENDIF
12370 IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN
12371 PB2=0.
12372 ELSE
12373 PB2=PRLEVH(K)-PPWRKH(JJ+1)
12374 ENDIF
12375 IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN
12376 PT1=0.
12377 ELSE
12378 PT1=PRLEVH(K+1)-PPWRKH(JJ)
12379 ENDIF
12380 IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN
12381 PT2=0.
12382 ELSE
12383 PT2=PRLEVH(K+1)-PPWRKH(JJ+1)
12384 ENDIF
12385 O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ)
12386 25 CONTINUE
12387 O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1))
12389 ENDDO
12390 !
12391 END SUBROUTINE O3DATA
12393 !------------------------------------------------------------------
12395 !====================================================================
12396 SUBROUTINE rrtmg_lwinit( &
12397 p_top, allowed_to_read , &
12398 ids, ide, jds, jde, kds, kde, &
12399 ims, ime, jms, jme, kms, kme, &
12400 its, ite, jts, jte, kts, kte )
12401 !--------------------------------------------------------------------
12402 IMPLICIT NONE
12403 !--------------------------------------------------------------------
12405 LOGICAL , INTENT(IN) :: allowed_to_read
12406 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
12407 ims, ime, jms, jme, kms, kme, &
12408 its, ite, jts, jte, kts, kte
12409 REAL, INTENT(IN) :: p_top
12411 ! Steven Cavallo. Added for buffer layer adjustment. December 2010.
12412 NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels.
12413 ! nlayers will subsequently
12414 ! replace kte+1
12416 ! Read in absorption coefficients and other data
12417 IF ( allowed_to_read ) THEN
12418 CALL rrtmg_lwlookuptable
12419 ENDIF
12421 ! Perform g-point reduction and other initializations
12422 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
12423 call rrtmg_lw_ini(cp)
12425 END SUBROUTINE rrtmg_lwinit
12428 ! **************************************************************************
12429 SUBROUTINE rrtmg_lwlookuptable
12430 ! **************************************************************************
12432 IMPLICIT NONE
12434 ! Local
12435 INTEGER :: i
12436 LOGICAL :: opened
12437 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
12439 CHARACTER*80 errmess
12440 INTEGER rrtmg_unit
12442 IF ( wrf_dm_on_monitor() ) THEN
12443 DO i = 10,99
12444 INQUIRE ( i , OPENED = opened )
12445 IF ( .NOT. opened ) THEN
12446 rrtmg_unit = i
12447 GOTO 2010
12448 ENDIF
12449 ENDDO
12450 rrtmg_unit = -1
12451 2010 CONTINUE
12452 ENDIF
12453 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
12454 IF ( rrtmg_unit < 0 ) THEN
12455 CALL wrf_error_fatal ( 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// &
12456 'find unused fortran unit to read in lookup table.' )
12457 ENDIF
12459 IF ( wrf_dm_on_monitor() ) THEN
12460 OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA', &
12461 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
12462 ENDIF
12464 call lw_kgb01(rrtmg_unit)
12465 call lw_kgb02(rrtmg_unit)
12466 call lw_kgb03(rrtmg_unit)
12467 call lw_kgb04(rrtmg_unit)
12468 call lw_kgb05(rrtmg_unit)
12469 call lw_kgb06(rrtmg_unit)
12470 call lw_kgb07(rrtmg_unit)
12471 call lw_kgb08(rrtmg_unit)
12472 call lw_kgb09(rrtmg_unit)
12473 call lw_kgb10(rrtmg_unit)
12474 call lw_kgb11(rrtmg_unit)
12475 call lw_kgb12(rrtmg_unit)
12476 call lw_kgb13(rrtmg_unit)
12477 call lw_kgb14(rrtmg_unit)
12478 call lw_kgb15(rrtmg_unit)
12479 call lw_kgb16(rrtmg_unit)
12481 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
12483 RETURN
12484 9009 CONTINUE
12485 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_DATA on unit ',rrtmg_unit
12486 CALL wrf_error_fatal(errmess)
12488 END SUBROUTINE rrtmg_lwlookuptable
12490 ! **************************************************************************
12491 ! RRTMG Longwave Radiative Transfer Model
12492 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
12493 !
12494 ! Original version: E. J. Mlawer, et al.
12495 ! Revision for GCMs: Michael J. Iacono; October, 2002
12496 ! Revision for F90 formatting: Michael J. Iacono; June 2006
12497 !
12498 ! This file contains 16 READ statements that include the
12499 ! absorption coefficients and other data for each of the 16 longwave
12500 ! spectral bands used in RRTMG_LW. Here, the data are defined for 16
12501 ! g-points, or sub-intervals, per band. These data are combined and
12502 ! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce
12503 ! the total number of g-points from 256 to 140 for use in the GCM.
12504 ! **************************************************************************
12506 ! **************************************************************************
12507 subroutine lw_kgb01(rrtmg_unit)
12508 ! **************************************************************************
12510 use rrlw_kg01, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
12511 absa, absb, &
12512 selfrefo, forrefo
12514 implicit none
12515 save
12517 ! Input
12518 integer, intent(in) :: rrtmg_unit
12520 ! Local
12521 character*80 errmess
12522 logical, external :: wrf_dm_on_monitor
12524 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12525 ! and upper atmosphere.
12526 ! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
12528 ! The array KAO contains absorption coefs at the 16 chosen g-values
12529 ! for a range of pressure levels > ~100mb and temperatures. The first
12530 ! index in the array, JT, which runs from 1 to 5, corresponds to
12531 ! different temperatures. More specifically, JT = 3 means that the
12532 ! data are for the corresponding TREF for this pressure level,
12533 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12534 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
12535 ! index, JP, runs from 1 to 13 and refers to the corresponding
12536 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12537 ! The third index, IG, goes from 1 to 16, and tells us which
12538 ! g-interval the absorption coefficients are for.
12540 ! The array KBO contains absorption coefs at the 16 chosen g-values
12541 ! for a range of pressure levels < ~100mb and temperatures. The first
12542 ! index in the array, JT, which runs from 1 to 5, corresponds to
12543 ! different temperatures. More specifically, JT = 3 means that the
12544 ! data are for the reference temperature TREF for this pressure
12545 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12546 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12547 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12548 ! reference pressure level (see taumol.f for the value of these
12549 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12550 ! and tells us which g-interval the absorption coefficients are for.
12552 ! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the
12553 ! nitrogen continuum for the upper and lower atmosphere.
12554 ! Minor gas mapping levels:
12555 ! Lower - n2: P = 142.5490 mbar, T = 215.70 K
12556 ! Upper - n2: P = 142.5490 mbar, T = 215.70 K
12558 ! The array FORREFO contains the coefficient of the water vapor
12559 ! foreign-continuum (including the energy term). The first
12560 ! index refers to reference temperature (296,260,224,260) and
12561 ! pressure (970,475,219,3 mbar) levels. The second index
12562 ! runs over the g-channel (1 to 16).
12564 ! The array SELFREFO contains the coefficient of the water vapor
12565 ! self-continuum (including the energy term). The first index
12566 ! refers to temperature in 7.2 degree increments. For instance,
12567 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12568 ! etc. The second index runs over the g-channel (1 to 16).
12570 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12572 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12573 fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
12574 DM_BCAST_MACRO(fracrefao)
12575 DM_BCAST_MACRO(fracrefbo)
12576 DM_BCAST_MACRO(kao)
12577 DM_BCAST_MACRO(kbo)
12578 DM_BCAST_MACRO(kao_mn2)
12579 DM_BCAST_MACRO(kbo_mn2)
12580 DM_BCAST_MACRO(selfrefo)
12581 DM_BCAST_MACRO(forrefo)
12583 RETURN
12584 9010 CONTINUE
12585 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12586 CALL wrf_error_fatal(errmess)
12588 end subroutine lw_kgb01
12590 ! **************************************************************************
12591 subroutine lw_kgb02(rrtmg_unit)
12592 ! **************************************************************************
12594 use rrlw_kg02, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12596 implicit none
12597 save
12599 ! Input
12600 integer, intent(in) :: rrtmg_unit
12602 ! Local
12603 character*80 errmess
12604 logical, external :: wrf_dm_on_monitor
12606 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12607 ! and upper atmosphere.
12608 ! Planck fraction mapping levels:
12609 ! Lower: P = 1053.630 mbar, T = 294.2 K
12610 ! Upper: P = 3.206e-2 mb, T = 197.92 K
12612 ! The array KAO contains absorption coefs at the 16 chosen g-values
12613 ! for a range of pressure levels > ~100mb and temperatures. The first
12614 ! index in the array, JT, which runs from 1 to 5, corresponds to
12615 ! different temperatures. More specifically, JT = 3 means that the
12616 ! data are for the corresponding TREF for this pressure level,
12617 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12618 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
12619 ! index, JP, runs from 1 to 13 and refers to the corresponding
12620 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12621 ! The third index, IG, goes from 1 to 16, and tells us which
12622 ! g-interval the absorption coefficients are for.
12624 ! The array KBO contains absorption coefs at the 16 chosen g-values
12625 ! for a range of pressure levels < ~100mb and temperatures. The first
12626 ! index in the array, JT, which runs from 1 to 5, corresponds to
12627 ! different temperatures. More specifically, JT = 3 means that the
12628 ! data are for the reference temperature TREF for this pressure
12629 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12630 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12631 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12632 ! reference pressure level (see taumol.f for the value of these
12633 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12634 ! and tells us which g-interval the absorption coefficients are for.
12636 ! The array FORREFO contains the coefficient of the water vapor
12637 ! foreign-continuum (including the energy term). The first
12638 ! index refers to reference temperature (296,260,224,260) and
12639 ! pressure (970,475,219,3 mbar) levels. The second index
12640 ! runs over the g-channel (1 to 16).
12642 ! The array SELFREFO contains the coefficient of the water vapor
12643 ! self-continuum (including the energy term). The first index
12644 ! refers to temperature in 7.2 degree increments. For instance,
12645 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12646 ! etc. The second index runs over the g-channel (1 to 16).
12648 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12650 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12651 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12652 DM_BCAST_MACRO(fracrefao)
12653 DM_BCAST_MACRO(fracrefbo)
12654 DM_BCAST_MACRO(kao)
12655 DM_BCAST_MACRO(kbo)
12656 DM_BCAST_MACRO(selfrefo)
12657 DM_BCAST_MACRO(forrefo)
12659 RETURN
12660 9010 CONTINUE
12661 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12662 CALL wrf_error_fatal(errmess)
12664 end subroutine lw_kgb02
12666 ! **************************************************************************
12667 subroutine lw_kgb03(rrtmg_unit)
12668 ! **************************************************************************
12670 use rrlw_kg03, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
12671 kbo_mn2o, selfrefo, forrefo
12673 implicit none
12674 save
12676 ! Input
12677 integer, intent(in) :: rrtmg_unit
12679 ! Local
12680 character*80 errmess
12681 logical, external :: wrf_dm_on_monitor
12683 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12684 ! and upper atmosphere.
12685 ! Planck fraction mapping levels:
12686 ! Lower: P = 212.7250 mbar, T = 223.06 K
12687 ! Upper: P = 95.8 mbar, T = 215.7 k
12689 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12690 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12691 ! of water vapor to CO2. The first index in the array, JS, runs
12692 ! from 1 to 10, and corresponds to different gas column amount ratios,
12693 ! as expressed through the binary species parameter eta, defined as
12694 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12695 ! ratio of the reference MLS column amount value of gas 1
12696 ! to that of gas2.
12697 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12698 ! to different temperatures. More specifically, JT = 3 means that the
12699 ! data are for the reference temperature TREF for this pressure
12700 ! level, JT = 2 refers to the temperature
12701 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12702 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12703 ! to the reference pressure level (e.g. JP = 1 is for a
12704 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12705 ! and tells us which g-interval the absorption coefficients are for.
12707 ! The array KBO contains absorption coefs at the 16 chosen g-values
12708 ! for a range of pressure levels < ~100mb and temperatures. The first
12709 ! index in the array, JT, which runs from 1 to 5, corresponds to
12710 ! different temperatures. More specifically, JT = 3 means that the
12711 ! data are for the reference temperature TREF for this pressure
12712 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12713 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12714 ! The second index, JP, runs from 13 to 59 and refers to the JPth
12715 ! reference pressure level (see taumol.f for the value of these
12716 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
12717 ! and tells us which g-interval the absorption coefficients are for.
12718 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12719 ! to different temperatures. More specifically, JT = 3 means that the
12720 ! data are for the reference temperature TREF for this pressure
12721 ! level, JT = 2 refers to the temperature
12722 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12723 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12724 ! to the reference pressure level (e.g. JP = 1 is for a
12725 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12726 ! and tells us which g-interval the absorption coefficients are for.
12728 ! The array KAO_Mxx contains the absorption coefficient for
12729 ! a minor species at the 16 chosen g-values for a reference pressure
12730 ! level below 100~ mb. The first index in the array, JS, runs
12731 ! from 1 to 10, and corresponds to different gas column amount ratios,
12732 ! as expressed through the binary species parameter eta, defined as
12733 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12734 ! ratio of the reference MLS column amount value of gas 1
12735 ! to that of gas2. The second index refers to temperature
12736 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12737 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12738 ! runs over the g-channel (1 to 16).
12740 ! The array KBO_Mxx contains the absorption coefficient for
12741 ! a minor species at the 16 chosen g-values for a reference pressure
12742 ! level above 100~ mb. The first index in the array, JS, runs
12743 ! from 1 to 10, and corresponds to different gas column amounts ratios,
12744 ! as expressed through the binary species parameter eta, defined as
12745 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12746 ! ratio of the reference MLS column amount value of gas 1 to
12747 ! that of gas2. The second index refers to temperature
12748 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12749 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12750 ! runs over the g-channel (1 to 16).
12752 ! The array FORREFO contains the coefficient of the water vapor
12753 ! foreign-continuum (including the energy term). The first
12754 ! index refers to reference temperature (296,260,224,260) and
12755 ! pressure (970,475,219,3 mbar) levels. The second index
12756 ! runs over the g-channel (1 to 16).
12758 ! The array SELFREFO contains the coefficient of the water vapor
12759 ! self-continuum (including the energy term). The first index
12760 ! refers to temperature in 7.2 degree increments. For instance,
12761 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12762 ! etc. The second index runs over the g-channel (1 to 16).
12764 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12766 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12767 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
12768 DM_BCAST_MACRO(fracrefao)
12769 DM_BCAST_MACRO(fracrefbo)
12770 DM_BCAST_MACRO(kao)
12771 DM_BCAST_MACRO(kbo)
12772 DM_BCAST_MACRO(kao_mn2o)
12773 DM_BCAST_MACRO(kbo_mn2o)
12774 DM_BCAST_MACRO(selfrefo)
12775 DM_BCAST_MACRO(forrefo)
12777 RETURN
12778 9010 CONTINUE
12779 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12780 CALL wrf_error_fatal(errmess)
12782 end subroutine lw_kgb03
12784 ! **************************************************************************
12785 subroutine lw_kgb04(rrtmg_unit)
12786 ! **************************************************************************
12788 use rrlw_kg04, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12790 implicit none
12791 save
12793 ! Input
12794 integer, intent(in) :: rrtmg_unit
12796 ! Local
12797 character*80 errmess
12798 logical, external :: wrf_dm_on_monitor
12800 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12801 ! and upper atmosphere.
12802 ! Planck fraction mapping levels:
12803 ! Lower : P = 142.5940 mbar, T = 215.70 K
12804 ! Upper : P = 95.58350 mb, T = 215.70 K
12806 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12807 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12808 ! of water vapor to CO2. The first index in the array, JS, runs
12809 ! from 1 to 10, and corresponds to different gas column amount ratios,
12810 ! as expressed through the binary species parameter eta, defined as
12811 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12812 ! ratio of the reference MLS column amount value of gas 1
12813 ! to that of gas2.
12814 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12815 ! to different temperatures. More specifically, JT = 3 means that the
12816 ! data are for the reference temperature TREF for this pressure
12817 ! level, JT = 2 refers to the temperature
12818 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12819 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12820 ! to the reference pressure level (e.g. JP = 1 is for a
12821 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12822 ! and tells us which g-interval the absorption coefficients are for.
12824 ! The array KBO contains absorption coefs for each of the 16 g-intervals
12825 ! for a range of pressure levels < ~100mb, temperatures, and ratios
12826 ! of H2O to CO2. The first index in the array, JS, runs
12827 ! from 1 to 10, and corresponds to different gas column amount ratios,
12828 ! as expressed through the binary species parameter eta, defined as
12829 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12830 ! ratio of the reference MLS column amount value of gas 1
12831 ! to that of gas2. The second index, JT, which
12832 ! runs from 1 to 5, corresponds to different temperatures. More
12833 ! specifically, JT = 3 means that the data are for the corresponding
12834 ! reference temperature TREF for this pressure level, JT = 2 refers
12835 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12836 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
12837 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12838 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
12839 ! 16, and tells us which g-interval the absorption coefficients are for.
12841 ! The array FORREFO contains the coefficient of the water vapor
12842 ! foreign-continuum (including the energy term). The first
12843 ! index refers to reference temperature (296,260,224,260) and
12844 ! pressure (970,475,219,3 mbar) levels. The second index
12845 ! runs over the g-channel (1 to 16).
12847 ! The array SELFREFO contains the coefficient of the water vapor
12848 ! self-continuum (including the energy term). The first index
12849 ! refers to temperature in 7.2 degree increments. For instance,
12850 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12851 ! etc. The second index runs over the g-channel (1 to 16).
12853 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12855 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12856 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12857 DM_BCAST_MACRO(fracrefao)
12858 DM_BCAST_MACRO(fracrefbo)
12859 DM_BCAST_MACRO(kao)
12860 DM_BCAST_MACRO(kbo)
12861 DM_BCAST_MACRO(selfrefo)
12862 DM_BCAST_MACRO(forrefo)
12864 RETURN
12865 9010 CONTINUE
12866 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12867 CALL wrf_error_fatal(errmess)
12869 end subroutine lw_kgb04
12871 ! **************************************************************************
12872 subroutine lw_kgb05(rrtmg_unit)
12873 ! **************************************************************************
12875 use rrlw_kg05, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, &
12876 selfrefo, forrefo, ccl4o
12878 implicit none
12879 save
12881 ! Input
12882 integer, intent(in) :: rrtmg_unit
12884 ! Local
12885 character*80 errmess
12886 logical, external :: wrf_dm_on_monitor
12888 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12889 ! and upper atmosphere.
12890 ! Planck fraction mapping levels:
12891 ! Lower: P = 473.42 mb, T = 259.83
12892 ! Upper: P = 0.2369280 mbar, T = 253.60 K
12894 ! The arrays kao_mo3 and ccl4o contain the coefficients for
12895 ! ozone and ccl4 in the lower atmosphere.
12896 ! Minor gas mapping level:
12897 ! Lower - o3: P = 317.34 mbar, T = 240.77 k
12898 ! Lower - ccl4:
12900 ! The array KAO contains absorption coefs for each of the 16 g-intervals
12901 ! for a range of pressure levels > ~100mb, temperatures, and ratios
12902 ! of water vapor to CO2. The first index in the array, JS, runs
12903 ! from 1 to 10, and corresponds to different gas column amount ratios,
12904 ! as expressed through the binary species parameter eta, defined as
12905 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12906 ! ratio of the reference MLS column amount value of gas 1
12907 ! to that of gas2.
12908 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12909 ! to different temperatures. More specifically, JT = 3 means that the
12910 ! data are for the reference temperature TREF for this pressure
12911 ! level, JT = 2 refers to the temperature
12912 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12913 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
12914 ! to the reference pressure level (e.g. JP = 1 is for a
12915 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
12916 ! and tells us which g-interval the absorption coefficients are for.
12918 ! The array KBO contains absorption coefs for each of the 16 g-intervals
12919 ! for a range of pressure levels < ~100mb, temperatures, and ratios
12920 ! of H2O to CO2. The first index in the array, JS, runs
12921 ! from 1 to 10, and corresponds to different gas column amount ratios,
12922 ! as expressed through the binary species parameter eta, defined as
12923 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12924 ! ratio of the reference MLS column amount value of gas 1
12925 ! to that of gas2. The second index, JT, which
12926 ! runs from 1 to 5, corresponds to different temperatures. More
12927 ! specifically, JT = 3 means that the data are for the corresponding
12928 ! reference temperature TREF for this pressure level, JT = 2 refers
12929 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12930 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
12931 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12932 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
12933 ! 16, and tells us which g-interval the absorption coefficients are for.
12935 ! The array KAO_Mxx contains the absorption coefficient for
12936 ! a minor species at the 16 chosen g-values for a reference pressure
12937 ! level below 100~ mb. The first index in the array, JS, runs
12938 ! from 1 to 10, and corresponds to different gas column amount ratios,
12939 ! as expressed through the binary species parameter eta, defined as
12940 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
12941 ! ratio of the reference MLS column amount value of gas 1
12942 ! to that of gas2. The second index refers to temperature
12943 ! in 7.2 degree increments. For instance, JT = 1 refers to a
12944 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12945 ! runs over the g-channel (1 to 16).
12947 ! The array FORREFO contains the coefficient of the water vapor
12948 ! foreign-continuum (including the energy term). The first
12949 ! index refers to reference temperature (296,260,224,260) and
12950 ! pressure (970,475,219,3 mbar) levels. The second index
12951 ! runs over the g-channel (1 to 16).
12953 ! The array SELFREFO contains the coefficient of the water vapor
12954 ! self-continuum (including the energy term). The first index
12955 ! refers to temperature in 7.2 degree increments. For instance,
12956 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12957 ! etc. The second index runs over the g-channel (1 to 16).
12959 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12961 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12962 fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
12963 DM_BCAST_MACRO(fracrefao)
12964 DM_BCAST_MACRO(fracrefbo)
12965 DM_BCAST_MACRO(kao)
12966 DM_BCAST_MACRO(kbo)
12967 DM_BCAST_MACRO(kao_mo3)
12968 DM_BCAST_MACRO(ccl4o)
12969 DM_BCAST_MACRO(selfrefo)
12970 DM_BCAST_MACRO(forrefo)
12972 RETURN
12973 9010 CONTINUE
12974 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
12975 CALL wrf_error_fatal(errmess)
12977 end subroutine lw_kgb05
12979 ! **************************************************************************
12980 subroutine lw_kgb06(rrtmg_unit)
12981 ! **************************************************************************
12983 use rrlw_kg06, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, &
12984 cfc11adjo, cfc12o
12986 implicit none
12987 save
12989 ! Input
12990 integer, intent(in) :: rrtmg_unit
12992 ! Local
12993 character*80 errmess
12994 logical, external :: wrf_dm_on_monitor
12996 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12997 ! and upper atmosphere.
12998 ! Planck fraction mapping levels:
12999 ! Lower: : P = 473.4280 mb, T = 259.83 K
13001 ! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
13002 ! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
13003 ! atmosphere.
13004 ! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
13005 ! Minor gas mapping level:
13006 ! Lower - co2: P = 706.2720 mb, T = 294.2 k
13007 ! Upper - cfc11, cfc12
13009 ! The array KAO contains absorption coefs at the 16 chosen g-values
13010 ! for a range of pressure levels > ~100mb and temperatures. The first
13011 ! index in the array, JT, which runs from 1 to 5, corresponds to
13012 ! different temperatures. More specifically, JT = 3 means that the
13013 ! data are for the corresponding TREF for this pressure level,
13014 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13015 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13016 ! index, JP, runs from 1 to 13 and refers to the corresponding
13017 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13018 ! The third index, IG, goes from 1 to 16, and tells us which
13019 ! g-interval the absorption coefficients are for.
13021 ! The array KAO_Mxx contains the absorption coefficient for
13022 ! a minor species at the 16 chosen g-values for a reference pressure
13023 ! level below 100~ mb. The first index refers to temperature
13024 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13025 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13026 ! runs over the g-channel (1 to 16).
13028 ! The array FORREFO contains the coefficient of the water vapor
13029 ! foreign-continuum (including the energy term). The first
13030 ! index refers to reference temperature (296,260,224,260) and
13031 ! pressure (970,475,219,3 mbar) levels. The second index
13032 ! runs over the g-channel (1 to 16).
13034 ! The array SELFREFO contains the coefficient of the water vapor
13035 ! self-continuum (including the energy term). The first index
13036 ! refers to temperature in 7.2 degree increments. For instance,
13037 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13038 ! etc. The second index runs over the g-channel (1 to 16).
13040 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13042 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13043 fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
13044 DM_BCAST_MACRO(fracrefao)
13045 DM_BCAST_MACRO(kao)
13046 DM_BCAST_MACRO(kao_mco2)
13047 DM_BCAST_MACRO(cfc11adjo)
13048 DM_BCAST_MACRO(cfc12o)
13049 DM_BCAST_MACRO(selfrefo)
13050 DM_BCAST_MACRO(forrefo)
13052 RETURN
13053 9010 CONTINUE
13054 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13055 CALL wrf_error_fatal(errmess)
13057 end subroutine lw_kgb06
13059 ! **************************************************************************
13060 subroutine lw_kgb07(rrtmg_unit)
13061 ! **************************************************************************
13063 use rrlw_kg07, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, &
13064 kbo_mco2, selfrefo, forrefo
13066 implicit none
13067 save
13069 ! Input
13070 integer, intent(in) :: rrtmg_unit
13072 ! Local
13073 character*80 errmess
13074 logical, external :: wrf_dm_on_monitor
13076 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13077 ! and upper atmosphere.
13078 ! Planck fraction mapping levels:
13079 ! Lower : P = 706.27 mb, T = 278.94 K
13080 ! Upper : P = 95.58 mbar, T= 215.70 K
13082 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13083 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13084 ! of water vapor to CO2. The first index in the array, JS, runs
13085 ! from 1 to 10, and corresponds to different gas column amount ratios,
13086 ! as expressed through the binary species parameter eta, defined as
13087 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13088 ! ratio of the reference MLS column amount value of gas 1
13089 ! to that of gas2.
13090 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13091 ! to different temperatures. More specifically, JT = 3 means that the
13092 ! data are for the reference temperature TREF for this pressure
13093 ! level, JT = 2 refers to the temperature
13094 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13095 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13096 ! to the reference pressure level (e.g. JP = 1 is for a
13097 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13098 ! and tells us which g-interval the absorption coefficients are for.
13100 ! The array KBO contains absorption coefs at the 16 chosen g-values
13101 ! for a range of pressure levels < ~100mb and temperatures. The first
13102 ! index in the array, JT, which runs from 1 to 5, corresponds to
13103 ! different temperatures. More specifically, JT = 3 means that the
13104 ! data are for the reference temperature TREF for this pressure
13105 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13106 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13107 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13108 ! reference pressure level (see taumol.f for the value of these
13109 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13110 ! and tells us which g-interval the absorption coefficients are for.
13112 ! The array KAO_Mxx contains the absorption coefficient for
13113 ! a minor species at the 16 chosen g-values for a reference pressure
13114 ! level below 100~ mb. The first index in the array, JS, runs
13115 ! from 1 to 10, and corresponds to different gas column amount ratios,
13116 ! as expressed through the binary species parameter eta, defined as
13117 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13118 ! ratio of the reference MLS column amount value of gas 1
13119 ! to that of gas2. The second index refers to temperature
13120 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13121 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13122 ! runs over the g-channel (1 to 16).
13124 ! The array KBO_Mxx contains the absorption coefficient for
13125 ! a minor species at the 16 chosen g-values for a reference pressure
13126 ! level above 100~ mb. The first index refers to temperature
13127 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13128 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13129 ! runs over the g-channel (1 to 16).
13131 ! The array FORREFO contains the coefficient of the water vapor
13132 ! foreign-continuum (including the energy term). The first
13133 ! index refers to reference temperature (296_rb,260_rb,224,260) and
13134 ! pressure (970,475,219,3 mbar) levels. The second index
13135 ! runs over the g-channel (1 to 16).
13137 ! The array SELFREFO contains the coefficient of the water vapor
13138 ! self-continuum (including the energy term). The first index
13139 ! refers to temperature in 7.2 degree increments. For instance,
13140 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13141 ! etc. The second index runs over the g-channel (1 to 16).
13143 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13145 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13146 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
13147 DM_BCAST_MACRO(fracrefao)
13148 DM_BCAST_MACRO(fracrefbo)
13149 DM_BCAST_MACRO(kao)
13150 DM_BCAST_MACRO(kbo)
13151 DM_BCAST_MACRO(kao_mco2)
13152 DM_BCAST_MACRO(kbo_mco2)
13153 DM_BCAST_MACRO(selfrefo)
13154 DM_BCAST_MACRO(forrefo)
13156 RETURN
13157 9010 CONTINUE
13158 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13159 CALL wrf_error_fatal(errmess)
13161 end subroutine lw_kgb07
13163 ! **************************************************************************
13164 subroutine lw_kgb08(rrtmg_unit)
13165 ! **************************************************************************
13167 use rrlw_kg08, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
13168 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
13169 cfc12o, cfc22adjo
13171 implicit none
13172 save
13174 ! Input
13175 integer, intent(in) :: rrtmg_unit
13177 ! Local
13178 character*80 errmess
13179 logical, external :: wrf_dm_on_monitor
13181 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13182 ! and upper atmosphere.
13183 ! Planck fraction mapping levels:
13184 ! Lower: P=473.4280 mb, T = 259.83 K
13185 ! Upper: P=95.5835 mb, T= 215.7 K
13187 ! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for
13188 ! carbon dioxide and n2o in the lower and upper atmosphere.
13189 ! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere,
13190 ! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22.
13191 ! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1
13192 ! and 1290-1335 cm-1 bands.
13193 ! Minor gas mapping level:
13194 ! Lower - co2: P = 1053.63 mb, T = 294.2 k
13195 ! Lower - o3: P = 317.348 mb, T = 240.77 k
13196 ! Lower - n2o: P = 706.2720 mb, T= 278.94 k
13197 ! Lower - cfc12, cfc22
13198 ! Upper - co2: P = 35.1632 mb, T = 223.28 k
13199 ! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
13201 ! The array KAO contains absorption coefs at the 16 chosen g-values
13202 ! for a range of pressure levels > ~100mb and temperatures. The first
13203 ! index in the array, JT, which runs from 1 to 5, corresponds to
13204 ! different temperatures. More specifically, JT = 3 means that the
13205 ! data are for the corresponding TREF for this pressure level,
13206 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13207 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13208 ! index, JP, runs from 1 to 13 and refers to the corresponding
13209 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13210 ! The third index, IG, goes from 1 to 16, and tells us which
13211 ! g-interval the absorption coefficients are for.
13213 ! The array KBO contains absorption coefs at the 16 chosen g-values
13214 ! for a range of pressure levels < ~100mb and temperatures. The first
13215 ! index in the array, JT, which runs from 1 to 5, corresponds to
13216 ! different temperatures. More specifically, JT = 3 means that the
13217 ! data are for the reference temperature TREF for this pressure
13218 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13219 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13220 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13221 ! reference pressure level (see taumol.f for the value of these
13222 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13223 ! and tells us which g-interval the absorption coefficients are for.
13225 ! The array KAO_Mxx contains the absorption coefficient for
13226 ! a minor species at the 16 chosen g-values for a reference pressure
13227 ! level below 100~ mb. The first index refers to temperature
13228 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13229 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13230 ! runs over the g-channel (1 to 16).
13232 ! The array KBO_Mxx contains the absorption coefficient for
13233 ! a minor species at the 16 chosen g-values for a reference pressure
13234 ! level above 100~ mb. The first index refers to temperature
13235 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13236 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13237 ! runs over the g-channel (1 to 16).
13239 ! The array FORREFO contains the coefficient of the water vapor
13240 ! foreign-continuum (including the energy term). The first
13241 ! index refers to reference temperature (296,260,224,260) and
13242 ! pressure (970,475,219,3 mbar) levels. The second index
13243 ! runs over the g-channel (1 to 16).
13245 ! The array SELFREFO contains the coefficient of the water vapor
13246 ! self-continuum (including the energy term). The first index
13247 ! refers to temperature in 7.2 degree increments. For instance,
13248 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13249 ! etc. The second index runs over the g-channel (1 to 16).
13251 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13253 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13254 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, &
13255 kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
13256 DM_BCAST_MACRO(fracrefao)
13257 DM_BCAST_MACRO(fracrefbo)
13258 DM_BCAST_MACRO(kao)
13259 DM_BCAST_MACRO(kbo)
13260 DM_BCAST_MACRO(kao_mco2)
13261 DM_BCAST_MACRO(kbo_mco2)
13262 DM_BCAST_MACRO(kao_mn2o)
13263 DM_BCAST_MACRO(kbo_mn2o)
13264 DM_BCAST_MACRO(kao_mo3)
13265 DM_BCAST_MACRO(cfc12o)
13266 DM_BCAST_MACRO(cfc22adjo)
13267 DM_BCAST_MACRO(selfrefo)
13268 DM_BCAST_MACRO(forrefo)
13270 RETURN
13271 9010 CONTINUE
13272 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13273 CALL wrf_error_fatal(errmess)
13275 end subroutine lw_kgb08
13277 ! **************************************************************************
13278 subroutine lw_kgb09(rrtmg_unit)
13279 ! **************************************************************************
13281 use rrlw_kg09, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
13282 kbo_mn2o, selfrefo, forrefo
13284 implicit none
13285 save
13287 ! Input
13288 integer, intent(in) :: rrtmg_unit
13290 ! Local
13291 character*80 errmess
13292 logical, external :: wrf_dm_on_monitor
13294 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13295 ! and upper atmosphere.
13296 ! Planck fraction mapping levels:
13297 ! Lower: P=212.7250 mb, T = 223.06 K
13298 ! Upper: P=3.20e-2 mb, T = 197.92 k
13300 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13301 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13302 ! of water vapor to CO2. The first index in the array, JS, runs
13303 ! from 1 to 10, and corresponds to different gas column amount ratios,
13304 ! as expressed through the binary species parameter eta, defined as
13305 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13306 ! ratio of the reference MLS column amount value of gas 1
13307 ! to that of gas2.
13308 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13309 ! to different temperatures. More specifically, JT = 3 means that the
13310 ! data are for the reference temperature TREF for this pressure
13311 ! level, JT = 2 refers to the temperature
13312 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13313 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13314 ! to the reference pressure level (e.g. JP = 1 is for a
13315 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13316 ! and tells us which g-interval the absorption coefficients are for.
13318 ! The array KBO contains absorption coefs at the 16 chosen g-values
13319 ! for a range of pressure levels < ~100mb and temperatures. The first
13320 ! index in the array, JT, which runs from 1 to 5, corresponds to
13321 ! different temperatures. More specifically, JT = 3 means that the
13322 ! data are for the reference temperature TREF for this pressure
13323 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13324 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13325 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13326 ! reference pressure level (see taumol.f for the value of these
13327 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13328 ! and tells us which g-interval the absorption coefficients are for.
13330 ! The array KAO_Mxx contains the absorption coefficient for
13331 ! a minor species at the 16 chosen g-values for a reference pressure
13332 ! level below 100~ mb. The first index in the array, JS, runs
13333 ! from 1 to 10, and corresponds to different gas column amount ratios,
13334 ! as expressed through the binary species parameter eta, defined as
13335 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13336 ! ratio of the reference MLS column amount value of gas 1
13337 ! to that of gas2. The second index refers to temperature
13338 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13339 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13340 ! runs over the g-channel (1 to 16).
13342 ! The array KBO_Mxx contains the absorption coefficient for
13343 ! a minor species at the 16 chosen g-values for a reference pressure
13344 ! level above 100~ mb. The first index refers to temperature
13345 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13346 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13347 ! runs over the g-channel (1 to 16).
13349 ! The array FORREFO contains the coefficient of the water vapor
13350 ! foreign-continuum (including the energy term). The first
13351 ! index refers to reference temperature (296,260,224,260) and
13352 ! pressure (970,475,219,3 mbar) levels. The second index
13353 ! runs over the g-channel (1 to 16).
13355 ! The array SELFREFO contains the coefficient of the water vapor
13356 ! self-continuum (including the energy term). The first index
13357 ! refers to temperature in 7.2 degree increments. For instance,
13358 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13359 ! etc. The second index runs over the g-channel (1 to 16).
13361 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13363 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13364 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
13365 DM_BCAST_MACRO(fracrefao)
13366 DM_BCAST_MACRO(fracrefbo)
13367 DM_BCAST_MACRO(kao)
13368 DM_BCAST_MACRO(kbo)
13369 DM_BCAST_MACRO(kao_mn2o)
13370 DM_BCAST_MACRO(kbo_mn2o)
13371 DM_BCAST_MACRO(selfrefo)
13372 DM_BCAST_MACRO(forrefo)
13374 RETURN
13375 9010 CONTINUE
13376 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13377 CALL wrf_error_fatal(errmess)
13379 end subroutine lw_kgb09
13381 ! **************************************************************************
13382 subroutine lw_kgb10(rrtmg_unit)
13383 ! **************************************************************************
13385 use rrlw_kg10, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13387 implicit none
13388 save
13390 ! Input
13391 integer, intent(in) :: rrtmg_unit
13393 ! Local
13394 character*80 errmess
13395 logical, external :: wrf_dm_on_monitor
13397 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13398 ! and upper atmosphere.
13399 ! Planck fraction mapping levels:
13400 ! Lower: P = 212.7250 mb, T = 223.06 K
13401 ! Upper: P = 95.58350 mb, T = 215.70 K
13403 ! The array KAO contains absorption coefs at the 16 chosen g-values
13404 ! for a range of pressure levels > ~100mb and temperatures. The first
13405 ! index in the array, JT, which runs from 1 to 5, corresponds to
13406 ! different temperatures. More specifically, JT = 3 means that the
13407 ! data are for the corresponding TREF for this pressure level,
13408 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13409 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13410 ! index, JP, runs from 1 to 13 and refers to the corresponding
13411 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13412 ! The third index, IG, goes from 1 to 16, and tells us which
13413 ! g-interval the absorption coefficients are for.
13415 ! The array KBO contains absorption coefs at the 16 chosen g-values
13416 ! for a range of pressure levels < ~100mb and temperatures. The first
13417 ! index in the array, JT, which runs from 1 to 5, corresponds to
13418 ! different temperatures. More specifically, JT = 3 means that the
13419 ! data are for the reference temperature TREF for this pressure
13420 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13421 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13422 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13423 ! reference pressure level (see taumol.f for the value of these
13424 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13425 ! and tells us which g-interval the absorption coefficients are for.
13427 ! The array FORREFO contains the coefficient of the water vapor
13428 ! foreign-continuum (including the energy term). The first
13429 ! index refers to reference temperature (296,260,224,260) and
13430 ! pressure (970,475,219,3 mbar) levels. The second index
13431 ! runs over the g-channel (1 to 16).
13433 ! The array SELFREFO contains the coefficient of the water vapor
13434 ! self-continuum (including the energy term). The first index
13435 ! refers to temperature in 7.2 degree increments. For instance,
13436 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13437 ! etc. The second index runs over the g-channel (1 to 16).
13439 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13441 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13442 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13443 DM_BCAST_MACRO(fracrefao)
13444 DM_BCAST_MACRO(fracrefbo)
13445 DM_BCAST_MACRO(kao)
13446 DM_BCAST_MACRO(kbo)
13447 DM_BCAST_MACRO(selfrefo)
13448 DM_BCAST_MACRO(forrefo)
13450 RETURN
13451 9010 CONTINUE
13452 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13453 CALL wrf_error_fatal(errmess)
13455 end subroutine lw_kgb10
13457 ! **************************************************************************
13458 subroutine lw_kgb11(rrtmg_unit)
13459 ! **************************************************************************
13461 use rrlw_kg11, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, &
13462 kbo_mo2, selfrefo, forrefo
13464 implicit none
13465 save
13467 ! Input
13468 integer, intent(in) :: rrtmg_unit
13470 ! Local
13471 character*80 errmess
13472 logical, external :: wrf_dm_on_monitor
13474 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13475 ! and upper atmosphere.
13476 ! Planck fraction mapping levels:
13477 ! Lower: P=1053.63 mb, T= 294.2 K
13478 ! Upper: P=0.353 mb, T = 262.11 K
13480 ! The array KAO contains absorption coefs at the 16 chosen g-values
13481 ! for a range of pressure levels > ~100mb and temperatures. The first
13482 ! index in the array, JT, which runs from 1 to 5, corresponds to
13483 ! different temperatures. More specifically, JT = 3 means that the
13484 ! data are for the corresponding TREF for this pressure level,
13485 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13486 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
13487 ! index, JP, runs from 1 to 13 and refers to the corresponding
13488 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13489 ! The third index, IG, goes from 1 to 16, and tells us which
13490 ! g-interval the absorption coefficients are for.
13492 ! The array KBO contains absorption coefs at the 16 chosen g-values
13493 ! for a range of pressure levels < ~100mb and temperatures. The first
13494 ! index in the array, JT, which runs from 1 to 5, corresponds to
13495 ! different temperatures. More specifically, JT = 3 means that the
13496 ! data are for the reference temperature TREF for this pressure
13497 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13498 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13499 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13500 ! reference pressure level (see taumol.f for the value of these
13501 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13502 ! and tells us which g-interval the absorption coefficients are for.
13504 ! The array KAO_Mxx contains the absorption coefficient for
13505 ! a minor species at the 16 chosen g-values for a reference pressure
13506 ! level below 100~ mb. The first index refers to temperature
13507 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13508 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13509 ! runs over the g-channel (1 to 16).
13511 ! The array KBO_Mxx contains the absorption coefficient for
13512 ! a minor species at the 16 chosen g-values for a reference pressure
13513 ! level above 100~ mb. The first index refers to temperature
13514 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13515 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13516 ! runs over the g-channel (1 to 16).
13518 ! The array FORREFO contains the coefficient of the water vapor
13519 ! foreign-continuum (including the energy term). The first
13520 ! index refers to reference temperature (296,260,224,260) and
13521 ! pressure (970,475,219,3 mbar) levels. The second index
13522 ! runs over the g-channel (1 to 16).
13524 ! The array SELFREFO contains the coefficient of the water vapor
13525 ! self-continuum (including the energy term). The first index
13526 ! refers to temperature in 7.2 degree increments. For instance,
13527 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13528 ! etc. The second index runs over the g-channel (1 to 16).
13530 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13532 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13533 fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
13534 DM_BCAST_MACRO(fracrefao)
13535 DM_BCAST_MACRO(fracrefbo)
13536 DM_BCAST_MACRO(kao)
13537 DM_BCAST_MACRO(kbo)
13538 DM_BCAST_MACRO(kao_mo2)
13539 DM_BCAST_MACRO(kbo_mo2)
13540 DM_BCAST_MACRO(selfrefo)
13541 DM_BCAST_MACRO(forrefo)
13543 RETURN
13544 9010 CONTINUE
13545 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13546 CALL wrf_error_fatal(errmess)
13548 end subroutine lw_kgb11
13550 ! **************************************************************************
13551 subroutine lw_kgb12(rrtmg_unit)
13552 ! **************************************************************************
13554 use rrlw_kg12, only : fracrefao, kao, selfrefo, forrefo
13556 implicit none
13557 save
13559 ! Input
13560 integer, intent(in) :: rrtmg_unit
13562 ! Local
13563 character*80 errmess
13564 logical, external :: wrf_dm_on_monitor
13566 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13567 ! and upper atmosphere.
13568 ! Planck fraction mapping levels:
13569 ! Lower: P = 174.1640 mbar, T= 215.78 K
13571 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13572 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13573 ! of water vapor to CO2. The first index in the array, JS, runs
13574 ! from 1 to 10, and corresponds to different gas column amount ratios,
13575 ! as expressed through the binary species parameter eta, defined as
13576 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13577 ! ratio of the reference MLS column amount value of gas 1
13578 ! to that of gas2.
13579 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13580 ! to different temperatures. More specifically, JT = 3 means that the
13581 ! data are for the reference temperature TREF for this pressure
13582 ! level, JT = 2 refers to the temperature
13583 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13584 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13585 ! to the reference pressure level (e.g. JP = 1 is for a
13586 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13587 ! and tells us which g-interval the absorption coefficients are for.
13589 ! The array FORREFO contains the coefficient of the water vapor
13590 ! foreign-continuum (including the energy term). The first
13591 ! index refers to reference temperature (296,260,224,260) and
13592 ! pressure (970,475,219,3 mbar) levels. The second index
13593 ! runs over the g-channel (1 to 16).
13595 ! The array SELFREFO contains the coefficient of the water vapor
13596 ! self-continuum (including the energy term). The first index
13597 ! refers to temperature in 7.2 degree increments. For instance,
13598 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13599 ! etc. The second index runs over the g-channel (1 to 16).
13601 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13603 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13604 fracrefao, kao, selfrefo, forrefo
13605 DM_BCAST_MACRO(fracrefao)
13606 DM_BCAST_MACRO(kao)
13607 DM_BCAST_MACRO(selfrefo)
13608 DM_BCAST_MACRO(forrefo)
13610 RETURN
13611 9010 CONTINUE
13612 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13613 CALL wrf_error_fatal(errmess)
13615 end subroutine lw_kgb12
13617 ! **************************************************************************
13618 subroutine lw_kgb13(rrtmg_unit)
13619 ! **************************************************************************
13621 use rrlw_kg13, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
13622 kbo_mo3, selfrefo, forrefo
13624 implicit none
13625 save
13627 ! Input
13628 integer, intent(in) :: rrtmg_unit
13630 ! Local
13631 character*80 errmess
13632 logical, external :: wrf_dm_on_monitor
13634 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13635 ! and upper atmosphere.
13636 ! Planck fraction mapping levels:
13637 ! Lower: P=473.4280 mb, T = 259.83 K
13638 ! Upper: P=4.758820 mb, T = 250.85 K
13640 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13641 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13642 ! of water vapor to CO2. The first index in the array, JS, runs
13643 ! from 1 to 10, and corresponds to different gas column amount ratios,
13644 ! as expressed through the binary species parameter eta, defined as
13645 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13646 ! ratio of the reference MLS column amount value of gas 1
13647 ! to that of gas2.
13648 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13649 ! to different temperatures. More specifically, JT = 3 means that the
13650 ! data are for the reference temperature TREF for this pressure
13651 ! level, JT = 2 refers to the temperature
13652 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13653 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13654 ! to the reference pressure level (e.g. JP = 1 is for a
13655 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13656 ! and tells us which g-interval the absorption coefficients are for.
13658 ! The array KAO_Mxx contains the absorption coefficient for
13659 ! a minor species at the 16 chosen g-values for a reference pressure
13660 ! level below 100~ mb. The first index in the array, JS, runs
13661 ! from 1 to 10, and corresponds to different gas column amount ratios,
13662 ! as expressed through the binary species parameter eta, defined as
13663 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13664 ! ratio of the reference MLS column amount value of gas 1
13665 ! to that of gas2. The second index refers to temperature
13666 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13667 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13668 ! runs over the g-channel (1 to 16).
13670 ! The array KBO_Mxx contains the absorption coefficient for
13671 ! a minor species at the 16 chosen g-values for a reference pressure
13672 ! level above 100~ mb. The first index refers to temperature
13673 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13674 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13675 ! runs over the g-channel (1 to 16).
13677 ! The array FORREFO contains the coefficient of the water vapor
13678 ! foreign-continuum (including the energy term). The first
13679 ! index refers to reference temperature (296,260,224,260) and
13680 ! pressure (970,475,219,3 mbar) levels. The second index
13681 ! runs over the g-channel (1 to 16).
13683 ! The array SELFREFO contains the coefficient of the water vapor
13684 ! self-continuum (including the energy term). The first index
13685 ! refers to temperature in 7.2 degree increments. For instance,
13686 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13687 ! etc. The second index runs over the g-channel (1 to 16).
13689 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13691 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13692 fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
13693 DM_BCAST_MACRO(fracrefao)
13694 DM_BCAST_MACRO(fracrefbo)
13695 DM_BCAST_MACRO(kao)
13696 DM_BCAST_MACRO(kao_mco2)
13697 DM_BCAST_MACRO(kao_mco)
13698 DM_BCAST_MACRO(kbo_mo3)
13699 DM_BCAST_MACRO(selfrefo)
13700 DM_BCAST_MACRO(forrefo)
13702 RETURN
13703 9010 CONTINUE
13704 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13705 CALL wrf_error_fatal(errmess)
13707 end subroutine lw_kgb13
13709 ! **************************************************************************
13710 subroutine lw_kgb14(rrtmg_unit)
13711 ! **************************************************************************
13713 use rrlw_kg14, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13715 implicit none
13716 save
13718 ! Input
13719 integer, intent(in) :: rrtmg_unit
13721 ! Local
13722 character*80 errmess
13723 logical, external :: wrf_dm_on_monitor
13725 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13726 ! and upper atmosphere.
13727 ! Planck fraction mapping levels:
13728 ! Lower: P = 142.5940 mb, T = 215.70 K
13729 ! Upper: P = 4.758820 mb, T = 250.85 K
13731 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13732 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13733 ! of water vapor to CO2. The first index in the array, JS, runs
13734 ! from 1 to 10, and corresponds to different gas column amount ratios,
13735 ! as expressed through the binary species parameter eta, defined as
13736 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13737 ! ratio of the reference MLS column amount value of gas 1
13738 ! to that of gas2.
13739 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13740 ! to different temperatures. More specifically, JT = 3 means that the
13741 ! data are for the reference temperature TREF for this pressure
13742 ! level, JT = 2 refers to the temperature
13743 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13744 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13745 ! to the reference pressure level (e.g. JP = 1 is for a
13746 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13747 ! and tells us which g-interval the absorption coefficients are for.
13749 ! The array KBO contains absorption coefs at the 16 chosen g-values
13750 ! for a range of pressure levels < ~100mb and temperatures. The first
13751 ! index in the array, JT, which runs from 1 to 5, corresponds to
13752 ! different temperatures. More specifically, JT = 3 means that the
13753 ! data are for the reference temperature TREF for this pressure
13754 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13755 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13756 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13757 ! reference pressure level (see taumol.f for the value of these
13758 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13759 ! and tells us which g-interval the absorption coefficients are for.
13761 ! The array FORREFO contains the coefficient of the water vapor
13762 ! foreign-continuum (including the energy term). The first
13763 ! index refers to reference temperature (296,260,224,260) and
13764 ! pressure (970,475,219,3 mbar) levels. The second index
13765 ! runs over the g-channel (1 to 16).
13767 ! The array SELFREFO contains the coefficient of the water vapor
13768 ! self-continuum (including the energy term). The first index
13769 ! refers to temperature in 7.2 degree increments. For instance,
13770 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13771 ! etc. The second index runs over the g-channel (1 to 16).
13773 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13775 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13776 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13777 DM_BCAST_MACRO(fracrefao)
13778 DM_BCAST_MACRO(fracrefbo)
13779 DM_BCAST_MACRO(kao)
13780 DM_BCAST_MACRO(kbo)
13781 DM_BCAST_MACRO(selfrefo)
13782 DM_BCAST_MACRO(forrefo)
13784 RETURN
13785 9010 CONTINUE
13786 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13787 CALL wrf_error_fatal(errmess)
13789 end subroutine lw_kgb14
13791 ! **************************************************************************
13792 subroutine lw_kgb15(rrtmg_unit)
13793 ! **************************************************************************
13795 use rrlw_kg15, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
13797 implicit none
13798 save
13800 ! Input
13801 integer, intent(in) :: rrtmg_unit
13803 ! Local
13804 character*80 errmess
13805 logical, external :: wrf_dm_on_monitor
13807 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13808 ! and upper atmosphere.
13809 ! Planck fraction mapping levels:
13810 ! Lower: P = 1053. mb, T = 294.2 K
13812 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13813 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13814 ! of water vapor to CO2. The first index in the array, JS, runs
13815 ! from 1 to 10, and corresponds to different gas column amount ratios,
13816 ! as expressed through the binary species parameter eta, defined as
13817 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13818 ! ratio of the reference MLS column amount value of gas 1
13819 ! to that of gas2.
13820 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13821 ! to different temperatures. More specifically, JT = 3 means that the
13822 ! data are for the reference temperature TREF for this pressure
13823 ! level, JT = 2 refers to the temperature
13824 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13825 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13826 ! to the reference pressure level (e.g. JP = 1 is for a
13827 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13828 ! and tells us which g-interval the absorption coefficients are for.
13830 ! The array KA_Mxx contains the absorption coefficient for
13831 ! a minor species at the 16 chosen g-values for a reference pressure
13832 ! level below 100~ mb. The first index in the array, JS, runs
13833 ! from 1 to 10, and corresponds to different gas column amount ratios,
13834 ! as expressed through the binary species parameter eta, defined as
13835 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13836 ! ratio of the reference MLS column amount value of gas 1
13837 ! to that of gas2. The second index refers to temperature
13838 ! in 7.2 degree increments. For instance, JT = 1 refers to a
13839 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13840 ! runs over the g-channel (1 to 16).
13842 ! The array FORREFO contains the coefficient of the water vapor
13843 ! foreign-continuum (including the energy term). The first
13844 ! index refers to reference temperature (296,260,224,260) and
13845 ! pressure (970,475,219,3 mbar) levels. The second index
13846 ! runs over the g-channel (1 to 16).
13848 ! The array SELFREFO contains the coefficient of the water vapor
13849 ! self-continuum (including the energy term). The first index
13850 ! refers to temperature in 7.2 degree increments. For instance,
13851 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13852 ! etc. The second index runs over the g-channel (1 to 16).
13854 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13856 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13857 fracrefao, kao, kao_mn2, selfrefo, forrefo
13858 DM_BCAST_MACRO(fracrefao)
13859 DM_BCAST_MACRO(kao)
13860 DM_BCAST_MACRO(kao_mn2)
13861 DM_BCAST_MACRO(selfrefo)
13862 DM_BCAST_MACRO(forrefo)
13864 RETURN
13865 9010 CONTINUE
13866 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13867 CALL wrf_error_fatal(errmess)
13869 end subroutine lw_kgb15
13871 ! **************************************************************************
13872 subroutine lw_kgb16(rrtmg_unit)
13873 ! **************************************************************************
13875 use rrlw_kg16, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13877 implicit none
13878 save
13880 ! Input
13881 integer, intent(in) :: rrtmg_unit
13883 ! Local
13884 character*80 errmess
13885 logical, external :: wrf_dm_on_monitor
13887 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13888 ! and upper atmosphere.
13889 ! Planck fraction mapping levels:
13890 ! Lower: P = 387.6100 mbar, T = 250.17 K
13891 ! Upper: P=95.58350 mb, T = 215.70 K
13893 ! The array KAO contains absorption coefs for each of the 16 g-intervals
13894 ! for a range of pressure levels > ~100mb, temperatures, and ratios
13895 ! of water vapor to CO2. The first index in the array, JS, runs
13896 ! from 1 to 10, and corresponds to different gas column amount ratios,
13897 ! as expressed through the binary species parameter eta, defined as
13898 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
13899 ! ratio of the reference MLS column amount value of gas 1
13900 ! to that of gas2.
13901 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13902 ! to different temperatures. More specifically, JT = 3 means that the
13903 ! data are for the reference temperature TREF for this pressure
13904 ! level, JT = 2 refers to the temperature
13905 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13906 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
13907 ! to the reference pressure level (e.g. JP = 1 is for a
13908 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
13909 ! and tells us which g-interval the absorption coefficients are for.
13911 ! The array KBO contains absorption coefs at the 16 chosen g-values
13912 ! for a range of pressure levels < ~100mb and temperatures. The first
13913 ! index in the array, JT, which runs from 1 to 5, corresponds to
13914 ! different temperatures. More specifically, JT = 3 means that the
13915 ! data are for the reference temperature TREF for this pressure
13916 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13917 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13918 ! The second index, JP, runs from 13 to 59 and refers to the JPth
13919 ! reference pressure level (see taumol.f for the value of these
13920 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
13921 ! and tells us which g-interval the absorption coefficients are for.
13923 ! The array FORREFO contains the coefficient of the water vapor
13924 ! foreign-continuum (including the energy term). The first
13925 ! index refers to reference temperature (296,260,224,260) and
13926 ! pressure (970,475,219,3 mbar) levels. The second index
13927 ! runs over the g-channel (1 to 16).
13929 ! The array SELFREFO contains the coefficient of the water vapor
13930 ! self-continuum (including the energy term). The first index
13931 ! refers to temperature in 7.2 degree increments. For instance,
13932 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13933 ! etc. The second index runs over the g-channel (1 to 16).
13935 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13937 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13938 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13939 DM_BCAST_MACRO(fracrefao)
13940 DM_BCAST_MACRO(fracrefbo)
13941 DM_BCAST_MACRO(kao)
13942 DM_BCAST_MACRO(kbo)
13943 DM_BCAST_MACRO(selfrefo)
13944 DM_BCAST_MACRO(forrefo)
13946 RETURN
13947 9010 CONTINUE
13948 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
13949 CALL wrf_error_fatal(errmess)
13951 end subroutine lw_kgb16
13953 !===============================================================================
13954 subroutine relcalc(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
13955 !-----------------------------------------------------------------------
13956 !
13957 ! Purpose:
13958 ! Compute cloud water size
13959 !
13960 ! Method:
13961 ! analytic formula following the formulation originally developed by J. T. Kiehl
13962 !
13963 ! Author: Phil Rasch
13964 !
13965 !-----------------------------------------------------------------------
13966 implicit none
13967 !------------------------------Arguments--------------------------------
13968 !
13969 ! Input arguments
13970 !
13971 integer, intent(in) :: ncol
13972 integer, intent(in) :: pcols, pver
13973 real, intent(in) :: landfrac(pcols) ! Land fraction
13974 real, intent(in) :: icefrac(pcols) ! Ice fraction
13975 real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
13976 real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
13977 real, intent(in) :: t(pcols,pver) ! Temperature
13979 !
13980 ! Output arguments
13981 !
13982 real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
13983 !
13984 !---------------------------Local workspace-----------------------------
13985 !
13986 integer i,k ! Lon, lev indices
13987 real tmelt ! freezing temperature of fresh water (K)
13988 real rliqland ! liquid drop size if over land
13989 real rliqocean ! liquid drop size if over ocean
13990 real rliqice ! liquid drop size if over sea ice
13991 !
13992 !-----------------------------------------------------------------------
13993 !
13994 tmelt = 273.16
13995 rliqocean = 14.0
13996 rliqice = 14.0
13997 rliqland = 8.0
13998 do k=1,pver
13999 do i=1,ncol
14000 ! jrm Reworked effective radius algorithm
14001 ! Start with temperature-dependent value appropriate for continental air
14002 ! Note: findmcnew has a pressure dependence here
14003 rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(i,k))*0.05))
14004 ! Modify for snow depth over land
14005 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,snowh(i)*10.))
14006 ! Ramp between polluted value over land to clean value over ocean.
14007 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0,max(0.0,1.0-landm(i)))
14008 ! Ramp between the resultant value and a sea ice value in the presence of ice.
14009 rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0,max(0.0,icefrac(i)))
14010 ! end jrm
14011 end do
14012 end do
14013 end subroutine relcalc
14014 !===============================================================================
14015 subroutine reicalc(ncol, pcols, pver, t, re)
14016 !
14018 integer, intent(in) :: ncol, pcols, pver
14019 real, intent(out) :: re(pcols,pver)
14020 real, intent(in) :: t(pcols,pver)
14021 real corr
14022 integer i
14023 integer k
14024 integer index
14025 !
14026 ! Tabulated values of re(T) in the temperature interval
14027 ! 180 K -- 274 K; hexagonal columns assumed:
14028 !
14029 !
14030 do k=1,pver
14031 do i=1,ncol
14032 index = int(t(i,k)-179.)
14033 index = min(max(index,1),94)
14034 corr = t(i,k) - int(t(i,k))
14035 re(i,k) = retab(index)*(1.-corr) &
14036 +retab(index+1)*corr
14037 ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
14038 end do
14039 end do
14040 !
14041 return
14042 end subroutine reicalc
14043 !------------------------------------------------------------------
14045 END MODULE module_ra_rrtmg_lw