phys/module_ra_rrtmg_lwk.F

   1 #if( BUILD_RRTMK != 1)
   2       MODULE module_ra_rrtmg_lwk
   3       CONTAINS
   4       SUBROUTINE rrtmg_lw
   5          REAL :: dummy
   6          dummy = 1
   7       END SUBROUTINE rrtmg_lw
   8       END MODULE module_ra_rrtmg_lwk
   9 #else
  10 !
  11 ! module module_ra_rrtmg_lw
  12 !
  13 !-------------------------------------------------------------------------------
  14    module parkind_k
  15 !-------------------------------------------------------------------------------
  16 !
  17 !  abstract : rrtmg kinds
  18 !  Define integer and real kinds for various types.
  19 !
  20 !  Initial version: MJIacono, AER, jun2006
  21 !  Revised: MJIacono, AER, aug2008
  22 !
  23 !-------------------------------------------------------------------------------
  24 !
  25 !  implicit none
  26 !
  27    save
  28 !
  29 ! integer kinds
  30 !
  31    integer, parameter :: kind_ib = selected_int_kind(13)  ! 8 byte integer
  32    integer, parameter :: kind_im = selected_int_kind(6)   ! 4 byte integer
  33    integer, parameter :: kind_in = kind(1)                ! native integer
  34 !
  35 ! real kinds
  36 !
  37 !  integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
  38 !  integer, parameter :: kind_rm = selected_real_kind(6)  ! 4 byte real
  39 !  integer, parameter :: kind_rn = kind(1.0)              ! native real
  40 !
  41    integer, parameter :: kind_rb = kind(1.0)              ! native real
  42 !
  43 !-------------------------------------------------------------------------------
  44    end module parkind_k
  45 !-------------------------------------------------------------------------------
  46 !
  47 !
  48 !-------------------------------------------------------------------------------
  49    module parrrtm_k
  50 !-------------------------------------------------------------------------------
  51 !
  52 !  abstract : rrtmg_lw main parameters
  53 !
  54 !  Initial version:  JJMorcrette, ECMWF, Jul 1998
  55 !  Revised: MJIacono, AER, Jun 2006
  56 !  Revised: MJIacono, AER, Aug 2007
  57 !  Revised: MJIacono, AER, Aug 2008
  58 !
  59 !  name      type     purpose
  60 !  -----  :  ----   : ----------------------------------------------
  61 !  mxlay  :  integer: maximum number of layers
  62 !  mg     :  integer: number of original g-intervals per spectral band
  63 !  nbndlw :  integer: number of spectral bands
  64 !  maxxsec:  integer: maximum number of cross-section molecules
  65 !                    (e.g. cfcs)
  66 !  maxinpx:  integer:
  67 !  ngptlw :  integer: total number of reduced g-intervals for rrtmg_lw
  68 !  ngNN   :  integer: number of reduced g-intervals per spectral band
  69 !  ngsNN  :  integer: cumulative number of g-intervals per band
  70 !
  71 !-------------------------------------------------------------------------------
  72    use parkind_k,  only : im => kind_im
  73 !
  74 !  implicit none
  75 !
  76    save
  77 !
  78    integer(kind=im), parameter :: mxlay  = 203
  79    integer(kind=im), parameter :: mg     = 16
  80    integer(kind=im), parameter :: nbndlw = 16
  81    integer(kind=im), parameter :: maxxsec= 4
  82    integer(kind=im), parameter :: mxmol  = 38
  83    integer(kind=im), parameter :: maxinpx= 38
  84    integer(kind=im), parameter :: nmol   = 7
  85 !
  86 ! Use for 140 g-point model
  87 !
  88    integer(kind=im), parameter :: ngptlw = 140
  89 !
  90 ! Use for 256 g-point model
  91 !  integer(kind=im), parameter :: ngptlw = 256
  92 !
  93 ! Use for 140 g-point model
  94 !
  95    integer(kind=im), parameter :: ng1  = 10
  96    integer(kind=im), parameter :: ng2  = 12
  97    integer(kind=im), parameter :: ng3  = 16
  98    integer(kind=im), parameter :: ng4  = 14
  99    integer(kind=im), parameter :: ng5  = 16
 100    integer(kind=im), parameter :: ng6  = 8
 101    integer(kind=im), parameter :: ng7  = 12
 102    integer(kind=im), parameter :: ng8  = 8
 103    integer(kind=im), parameter :: ng9  = 12
 104    integer(kind=im), parameter :: ng10 = 6
 105    integer(kind=im), parameter :: ng11 = 8
 106    integer(kind=im), parameter :: ng12 = 8
 107    integer(kind=im), parameter :: ng13 = 4
 108    integer(kind=im), parameter :: ng14 = 2
 109    integer(kind=im), parameter :: ng15 = 2
 110    integer(kind=im), parameter :: ng16 = 2
 111 !
 112    integer(kind=im), parameter :: ngs1  = 10
 113    integer(kind=im), parameter :: ngs2  = 22
 114    integer(kind=im), parameter :: ngs3  = 38
 115    integer(kind=im), parameter :: ngs4  = 52
 116    integer(kind=im), parameter :: ngs5  = 68
 117    integer(kind=im), parameter :: ngs6  = 76
 118    integer(kind=im), parameter :: ngs7  = 88
 119    integer(kind=im), parameter :: ngs8  = 96
 120    integer(kind=im), parameter :: ngs9  = 108
 121    integer(kind=im), parameter :: ngs10 = 114
 122    integer(kind=im), parameter :: ngs11 = 122
 123    integer(kind=im), parameter :: ngs12 = 130
 124    integer(kind=im), parameter :: ngs13 = 134
 125    integer(kind=im), parameter :: ngs14 = 136
 126    integer(kind=im), parameter :: ngs15 = 138
 127 !
 128 ! Use for 256 g-point model
 129 !  integer(kind=im), parameter :: ng1  = 16
 130 !  integer(kind=im), parameter :: ng2  = 16
 131 !  integer(kind=im), parameter :: ng3  = 16
 132 !  integer(kind=im), parameter :: ng4  = 16
 133 !  integer(kind=im), parameter :: ng5  = 16
 134 !  integer(kind=im), parameter :: ng6  = 16
 135 !  integer(kind=im), parameter :: ng7  = 16
 136 !  integer(kind=im), parameter :: ng8  = 16
 137 !  integer(kind=im), parameter :: ng9  = 16
 138 !  integer(kind=im), parameter :: ng10 = 16
 139 !  integer(kind=im), parameter :: ng11 = 16
 140 !  integer(kind=im), parameter :: ng12 = 16
 141 !  integer(kind=im), parameter :: ng13 = 16
 142 !  integer(kind=im), parameter :: ng14 = 16
 143 !  integer(kind=im), parameter :: ng15 = 16
 144 !  integer(kind=im), parameter :: ng16 = 16
 145 !  integer(kind=im), parameter :: ngs1  = 16
 146 !  integer(kind=im), parameter :: ngs2  = 32
 147 !  integer(kind=im), parameter :: ngs3  = 48
 148 !  integer(kind=im), parameter :: ngs4  = 64
 149 !  integer(kind=im), parameter :: ngs5  = 80
 150 !  integer(kind=im), parameter :: ngs6  = 96
 151 !  integer(kind=im), parameter :: ngs7  = 112
 152 !  integer(kind=im), parameter :: ngs8  = 128
 153 !  integer(kind=im), parameter :: ngs9  = 144
 154 !  integer(kind=im), parameter :: ngs10 = 160
 155 !  integer(kind=im), parameter :: ngs11 = 176
 156 !  integer(kind=im), parameter :: ngs12 = 192
 157 !  integer(kind=im), parameter :: ngs13 = 208
 158 !  integer(kind=im), parameter :: ngs14 = 224
 159 !  integer(kind=im), parameter :: ngs15 = 240
 160 !  integer(kind=im), parameter :: ngs16 = 256
 161 !
 162 !-------------------------------------------------------------------------------
 163    end module parrrtm_k
 164 !-------------------------------------------------------------------------------
 165 !
 166 !
 167 !-------------------------------------------------------------------------------
 168    module rrlw_cld_k
 169 !-------------------------------------------------------------------------------
 170 !
 171 !  abstract : rrtmg_lw cloud property coefficients
 172 !
 173 !  Revised: MJIacono, AER, jun2006
 174 !  Revised: MJIacono, AER, aug2008
 175 !
 176 !  name      type     purpose
 177 !  -----  :  ----   : ----------------------------------------------
 178 !  abscld1:  real   :
 179 !  absice0:  real   :
 180 !  absice1:  real   :
 181 !  absice2:  real   :
 182 !  absice3:  real   :
 183 !  absliq0:  real   :
 184 !  absliq1:  real   :
 185 !
 186 !-------------------------------------------------------------------------------
 187    use parkind_k, only : rb => kind_rb
 188 !
 189 !  implicit none
 190 !
 191    save
 192 !
 193    real(kind=rb)                   :: abscld1
 194    real(kind=rb), dimension(2)     :: absice0
 195    real(kind=rb), dimension(2,5)   :: absice1
 196    real(kind=rb), dimension(43,16) :: absice2
 197    real(kind=rb), dimension(46,16) :: absice3
 198    real(kind=rb)                   :: absliq0
 199    real(kind=rb), dimension(58,16) :: absliq1
 200 !
 201 !-------------------------------------------------------------------------------
 202    end module rrlw_cld_k
 203 !-------------------------------------------------------------------------------
 204 !
 205 !
 206 !-------------------------------------------------------------------------------
 207    module rrlw_con_k
 208 !-------------------------------------------------------------------------------
 209 !
 210 !  abstract : rrtmg_lw constants
 211 !
 212 !  Initial version: MJIacono, AER, jun2006
 213 !  Revised: MJIacono, AER, aug2008
 214 !
 215 !  name      type     purpose
 216 !  -----   :  ----   : ----------------------------------------------
 217 !  fluxfac :  real   : radiance to flux conversion factor
 218 !  heatfac :  real   : flux to heating rate conversion factor
 219 !  oneminus:  real   : 1.-1.e-6
 220 !  pi      :  real   : pi
 221 !  grav    :  real   : acceleration of gravity
 222 !  planck  :  real   : planck constant
 223 !  boltz   :  real   : boltzmann constant
 224 !  clight  :  real   : speed of light
 225 !  avogad  :  real   : avogadro constant
 226 !  alosmt  :  real   : loschmidt constant
 227 !  gascon  :  real   : molar gas constant
 228 !  radcn1  :  real   : first radiation constant
 229 !  radcn2  :  real   : second radiation constant
 230 !  sbcnst  :  real   : stefan-boltzmann constant
 231 !  secdy   :  real   : seconds per day
 232 !
 233 !-------------------------------------------------------------------------------
 234    use parkind_k, only : rb => kind_rb
 235 !
 236 !  implicit none
 237 !
 238    save
 239 !
 240    real(kind=rb)        :: fluxfac, heatfac
 241    real(kind=rb)        :: oneminus, pi, grav
 242    real(kind=rb)        :: planck, boltz, clight
 243    real(kind=rb)        :: avogad, alosmt, gascon
 244    real(kind=rb)        :: radcn1, radcn2
 245    real(kind=rb)        :: sbcnst, secdy
 246 !
 247 !-------------------------------------------------------------------------------
 248    end module rrlw_con_k
 249 !-------------------------------------------------------------------------------
 250 !
 251 !
 252 !-------------------------------------------------------------------------------
 253    module rrlw_kg01_k
 254 !-------------------------------------------------------------------------------
 255 !
 256 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 1
 257 !  band 1:  10-250 cm-1 (low - h2o; high - h2o)
 258 !
 259 !  Initial version:  JJMorcrette, ECMWF, jul1998
 260 !  Revised: MJIacono, AER, jun2006
 261 !  Revised: MJIacono, AER, aug2008
 262 !
 263 !  ORIGINAL
 264 !  name       type     purpose
 265 !  ----     : ----   : ---------------------------------------------
 266 !  fracrefao: real
 267 !  fracrefbo: real
 268 !  kao      : real
 269 !  kbo      : real
 270 !  kao_mn2  : real
 271 !  kbo_mn2  : real
 272 !  selfrefo : real
 273 !  forrefo  : real
 274 !
 275 !  COMBINED
 276 !  name      type     purpose
 277 !  ----     : ----   : ---------------------------------------------
 278 !  fracrefa : real
 279 !  fracrefb : real
 280 !  ka       : real
 281 !  kb       : real
 282 !  absa     : real
 283 !  absb     : real
 284 !  ka_mn2   : real
 285 !  kb_mn2   : real
 286 !  selfref  : real
 287 !  forref   : real
 288 !
 289 !-------------------------------------------------------------------------------
 290    use parkind_k, only : im => kind_im, rb => kind_rb
 291 !
 292 !  implicit none
 293 !
 294    save
 295 !
 296    integer(kind=im), parameter :: no1  = 16
 297 !
 298    real(kind=rb), dimension(no1)         :: fracrefao, fracrefbo
 299    real(kind=rb), dimension(5,13,no1)    :: kao
 300    real(kind=rb), dimension(5,13:59,no1) :: kbo
 301    real(kind=rb), dimension(19,no1)      :: kao_mn2, kbo_mn2
 302    real(kind=rb), dimension(10,no1)      :: selfrefo
 303    real(kind=rb), dimension(4,no1)       :: forrefo
 304 !
 305    integer(kind=im), parameter :: ng1  = 10
 306 !
 307    real(kind=rb), dimension(ng1)         :: fracrefa, fracrefb
 308    real(kind=rb), dimension(5,13,ng1)    :: ka
 309    real(kind=rb), dimension(65,ng1)      :: absa
 310    real(kind=rb), dimension(5,13:59,ng1) :: kb
 311    real(kind=rb), dimension(235,ng1)     :: absb
 312    real(kind=rb), dimension(19,ng1)      :: ka_mn2, kb_mn2
 313    real(kind=rb), dimension(10,ng1)      :: selfref(10,ng1)
 314    real(kind=rb), dimension(4,ng1)       :: forref(4,ng1)
 315 !
 316    equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 317 !
 318 !-------------------------------------------------------------------------------
 319    end module rrlw_kg01_k
 320 !-------------------------------------------------------------------------------
 321 !
 322 !
 323 !-------------------------------------------------------------------------------
 324    module rrlw_kg02_k
 325 !-------------------------------------------------------------------------------
 326 !
 327 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 2
 328 !  band 2:  250-500 cm-1 (low - h2o; high - h2o)
 329 !
 330 !  Initial version:  JJMorcrette, ECMWF, jul1998
 331 !  Revised: MJIacono, AER, jun2006
 332 !  Revised: MJIacono, AER, aug2008
 333 !
 334 !  ORIGINAL
 335 !  name       type     purpose
 336 !  ----     : ----   : ---------------------------------------------
 337 !  fracrefao: real
 338 !  fracrefbo: real
 339 !  kao      : real
 340 !  kbo      : real
 341 !  selfrefo : real
 342 !  forrefo  : real
 343 !
 344 !  COMBINED
 345 !  name       type     purpose
 346 !  ----     : ----   : ---------------------------------------------
 347 !  fracrefa : real
 348 !  fracrefb : real
 349 !  ka       : real
 350 !  kb       : real
 351 !  absa     : real
 352 !  absb     : real
 353 !  selfref  : real
 354 !  forref   : real
 355 !
 356 !  refparam : real
 357 !
 358 !-------------------------------------------------------------------------------
 359    use parkind_k, only : im => kind_im, rb => kind_rb
 360 !
 361 !  implicit none
 362 !
 363    save
 364 !
 365    integer(kind=im), parameter :: no2  = 16
 366 !
 367    real(kind=rb), dimension(no2) :: fracrefao, fracrefbo
 368    real(kind=rb), dimension(5,13,no2) :: kao
 369    real(kind=rb), dimension(5,13:59,no2) :: kbo
 370    real(kind=rb), dimension(10,no2) :: selfrefo(10,no2)
 371    real(kind=rb), dimension(4,no2) :: forrefo(4,no2)
 372 !
 373    integer(kind=im), parameter :: ng2  = 12
 374 !
 375    real(kind=rb), dimension(ng2)         :: fracrefa, fracrefb
 376    real(kind=rb), dimension(5,13,ng2)    :: ka(5,13,ng2)
 377    real(kind=rb), dimension(65,ng2)      :: absa
 378    real(kind=rb), dimension(5,13:59,ng2) :: kb
 379    real(kind=rb), dimension(235,ng2)     :: absb
 380    real(kind=rb), dimension(10,ng2)      :: selfref(10,ng2)
 381    real(kind=rb), dimension(4,ng2)       :: forref(4,ng2)
 382 !
 383    real(kind=rb), dimension(13) :: refparam
 384 !
 385    equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
 386 !
 387 !-------------------------------------------------------------------------------
 388    end module rrlw_kg02_k
 389 !-------------------------------------------------------------------------------
 390 !
 391 !
 392 !-------------------------------------------------------------------------------
 393    module rrlw_kg03_k
 394 !-------------------------------------------------------------------------------
 395 !
 396 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 3
 397 !  band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
 398 !
 399 !  Initial version:  JJMorcrette, ECMWF, jul1998
 400 !  Revised: MJIacono, AER, jun2006
 401 !  Revised: MJIacono, AER, aug2008
 402 !
 403 !  ORIGINAL
 404 !  name       type     purpose
 405 !  ----     : ----   : ---------------------------------------------
 406 !  fracrefao: real
 407 !  fracrefbo: real
 408 !  kao      : real
 409 !  kbo      : real
 410 !  kao_mn2o : real
 411 !  kbo_mn2o : real
 412 !  selfrefo : real
 413 !  forrefo  : real
 414 !
 415 !  COMBINED
 416 !  name      type     purpose
 417 !  ----   : ----   : ---------------------------------------------
 418 !  fracrefa : real
 419 !  fracrefb : real
 420 !  ka      : real
 421 !  kb      : real
 422 !  ka_mn2o : real
 423 !  kb_mn2o : real
 424 !  selfref : real
 425 !  forref  : real
 426 !
 427 !  absa    : real
 428 !  absb    : real
 429 !
 430 !-------------------------------------------------------------------------------
 431    use parkind_k, only : im => kind_im, rb => kind_rb
 432 !
 433 !  implicit none
 434 !
 435    save
 436 !
 437    integer(kind=im), parameter :: no3  = 16
 438 !
 439    real(kind=rb), dimension(no3,9)         :: fracrefao
 440    real(kind=rb), dimension(no3,5)         :: fracrefbo(no3,5)
 441    real(kind=rb), dimension(9,5,13,no3)    :: kao
 442    real(kind=rb), dimension(5,5,13:59,no3) :: kbo
 443    real(kind=rb), dimension(9,19,no3)      :: kao_mn2o
 444    real(kind=rb), dimension(5,19,no3)      :: kbo_mn2o
 445    real(kind=rb), dimension(10,no3)        :: selfrefo
 446    real(kind=rb), dimension(4,no3)         :: forrefo
 447 !
 448    integer(kind=im), parameter :: ng3  = 16
 449 !
 450    real(kind=rb), dimension(ng3,9)         :: fracrefa
 451    real(kind=rb), dimension(ng3,5)         :: fracrefb
 452    real(kind=rb), dimension(9,5,13,ng3)    :: ka
 453    real(kind=rb), dimension(585,ng3)       :: absa
 454    real(kind=rb), dimension(5,5,13:59,ng3) :: kb
 455    real(kind=rb), dimension(1175,ng3)      :: absb
 456    real(kind=rb), dimension(9,19,ng3)      :: ka_mn2o
 457    real(kind=rb), dimension(5,19,ng3)      :: kb_mn2o
 458    real(kind=rb), dimension(10,ng3)        :: selfref
 459    real(kind=rb), dimension(4,ng3)         :: forref
 460 !
 461    equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
 462 !
 463 !-------------------------------------------------------------------------------
 464    end module rrlw_kg03_k
 465 !-------------------------------------------------------------------------------
 466 !
 467 !
 468 !-------------------------------------------------------------------------------
 469    module rrlw_kg04_k
 470 !-------------------------------------------------------------------------------
 471 !
 472 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 4
 473 !  band 4:  630-700 cm-1 (low - h2o,co2; high - o3,co2)
 474 !
 475 !  Initial version:  JJMorcrette, ECMWF, jul1998
 476 !  Revised: MJIacono, AER, jun2006
 477 !  Revised: MJIacono, AER, aug2008
 478 !
 479 !  ORIGINAL
 480 !  name       type     purpose
 481 !  ----     : ----   : ---------------------------------------------
 482 !  fracrefao: real
 483 !  fracrefbo: real
 484 !  kao      : real
 485 !  kbo      : real
 486 !  selfrefo : real
 487 !  forrefo  : real
 488 !
 489 !  COMBINED
 490 !  name       type     purpose
 491 !  ----     : ----   : ---------------------------------------------
 492 !  absa     : real
 493 !  absb     : real
 494 !  fracrefa : real
 495 !  fracrefb : real
 496 !  ka       : real
 497 !  kb       : real
 498 !  selfref  : real
 499 !  forref   : real
 500 !
 501 !-------------------------------------------------------------------------------
 502    use parkind_k, only : im => kind_im, rb => kind_rb
 503 !
 504 !  implicit none
 505 !
 506    save
 507 !
 508    integer(kind=im), parameter :: no4  = 16
 509 !
 510    real(kind=rb), dimension(no4,9) :: fracrefao
 511    real(kind=rb), dimension(no4,5) :: fracrefbo
 512    real(kind=rb), dimension(9,5,13,no4) :: kao
 513    real(kind=rb), dimension(5,5,13:59,no4) :: kbo
 514    real(kind=rb), dimension(10,no4) :: selfrefo
 515    real(kind=rb), dimension(4,no4) :: forrefo
 516 !
 517    integer(kind=im), parameter :: ng4  = 14
 518 !
 519    real(kind=rb), dimension(ng4,9) :: fracrefa
 520    real(kind=rb), dimension(ng4,5) :: fracrefb
 521    real(kind=rb), dimension(9,5,13,ng4) :: ka
 522    real(kind=rb), dimension(585,ng4) :: absa
 523    real(kind=rb), dimension(5,5,13:59,ng4) :: kb
 524    real(kind=rb), dimension(1175,ng4) :: absb
 525    real(kind=rb), dimension(10,ng4) :: selfref
 526    real(kind=rb), dimension(4,ng4) :: forref
 527 !
 528    equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
 529 !
 530 !-------------------------------------------------------------------------------
 531    end module rrlw_kg04_k
 532 !-------------------------------------------------------------------------------
 533 !
 534 !
 535 !-------------------------------------------------------------------------------
 536    module rrlw_kg05_k
 537 !-------------------------------------------------------------------------------
 538 !
 539 !  abstract :  rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 5
 540 !  band 5:  700-820 cm-1 (low - h2o,co2; high - o3,co2)
 541 !
 542 !  Initial version:  JJMorcrette, ECMWF, jul1998
 543 !  Revised: MJIacono, AER, jun2006
 544 !  Revised: MJIacono, AER, aug2008
 545 !
 546 !  ORIGINAL
 547 !  name       type     purpose
 548 !  ----     : ----   : ---------------------------------------------
 549 !  fracrefao: real
 550 !  fracrefbo: real
 551 !  kao      : real
 552 !  kbo      : real
 553 !  kao_mo3  : real
 554 !  selfrefo : real
 555 !  forrefo  : real
 556 !  ccl4o    : real
 557 !
 558 !  COMBINED
 559 !  name       type     purpose
 560 !  ----     : ----   : ---------------------------------------------
 561 !  fracrefa : real
 562 !  fracrefb : real
 563 !  ka       : real
 564 !  kb       : real
 565 !  ka_mo3   : real
 566 !  selfref  : real
 567 !  forref   : real
 568 !  ccl4     : real
 569 !
 570 !  absa     : real
 571 !  absb     : real
 572 !
 573 !-------------------------------------------------------------------------------
 574    use parkind_k, only : im => kind_im, rb => kind_rb
 575 !
 576 !  implicit none
 577 !
 578    save
 579 !
 580    integer(kind=im), parameter :: no5  = 16
 581 !
 582    real(kind=rb), dimension(no5,9)         :: fracrefao
 583    real(kind=rb), dimension(no5,5)         :: fracrefbo
 584    real(kind=rb), dimension(9,5,13,no5)    :: kao
 585    real(kind=rb), dimension(5,5,13:59,no5) :: kbo
 586    real(kind=rb), dimension(9,19,no5)      :: kao_mo3
 587    real(kind=rb), dimension(10,no5)        :: selfrefo
 588    real(kind=rb), dimension(4,no5)         :: forrefo
 589    real(kind=rb), dimension(no5)           :: ccl4o
 590 !
 591    integer(kind=im), parameter :: ng5  = 16
 592 !
 593    real(kind=rb), dimension(ng5,9)         :: fracrefa
 594    real(kind=rb), dimension(ng5,5)         :: fracrefb
 595    real(kind=rb), dimension(9,5,13,ng5)    :: ka
 596    real(kind=rb), dimension(585,ng5)       :: absa
 597    real(kind=rb), dimension(5,5,13:59,ng5) :: kb
 598    real(kind=rb), dimension(1175,ng5)      :: absb
 599    real(kind=rb), dimension(9,19,ng5)      :: ka_mo3
 600    real(kind=rb), dimension(10,ng5)        :: selfref
 601    real(kind=rb), dimension(4,ng5)         :: forref
 602    real(kind=rb), dimension(ng5)           :: ccl4
 603 !
 604    equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
 605 !
 606 !-------------------------------------------------------------------------------
 607    end module rrlw_kg05_k
 608 !-------------------------------------------------------------------------------
 609 !
 610 !
 611 !-------------------------------------------------------------------------------
 612    module rrlw_kg06_k
 613 !-------------------------------------------------------------------------------
 614 !
 615 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 6
 616 !  band 6:  820-980 cm-1 (low - h2o; high - nothing)
 617 !
 618 !  Initial version:  JJMorcrette, ECMWF, jul1998
 619 !  Revised: MJIacono, AER, jun2006
 620 !  Revised: MJIacono, AER, aug2008
 621 !
 622 !  ORIGINAL
 623 !  name       type     purpose
 624 !  ----     : ----   : ---------------------------------------------
 625 !  fracrefao: real
 626 !  kao      : real
 627 !  kao_mco2 : real
 628 !  selfrefo : real
 629 !  forrefo  : real
 630 !  cfc11adjo: real
 631 !  cfc12o   : real
 632 !
 633 !  COMBINED
 634 !  name       type     purpose
 635 !  ----     : ----   : ---------------------------------------------
 636 !  fracrefa : real
 637 !  ka       : real
 638 !  ka_mco2  : real
 639 !  selfref  : real
 640 !  forref   : real
 641 !  cfc11adj : real
 642 !  cfc12    : real
 643 !
 644 !  absa     : real
 645 !
 646 !-------------------------------------------------------------------------------
 647    use parkind_k, only : im => kind_im, rb => kind_rb
 648 !
 649 !  implicit none
 650 !
 651    save
 652 !
 653    integer(kind=im), parameter :: no6  = 16
 654 !
 655    real(kind=rb), dimension(no6)      :: fracrefao
 656    real(kind=rb), dimension(5,13,no6) :: kao
 657    real(kind=rb), dimension(19,no6)   :: kao_mco2
 658    real(kind=rb), dimension(10,no6)   :: selfrefo
 659    real(kind=rb), dimension(4,no6)    :: forrefo
 660 !
 661    real(kind=rb) , dimension(no6) :: cfc11adjo, cfc12o
 662 !
 663    integer(kind=im), parameter :: ng6  = 8
 664 !
 665    real(kind=rb), dimension(ng6)      :: fracrefa
 666    real(kind=rb), dimension(5,13,ng6) :: ka
 667    real(kind=rb), dimension(65,ng6)   :: absa
 668    real(kind=rb), dimension(19,ng6)   :: ka_mco2
 669    real(kind=rb), dimension(10,ng6)   :: selfref
 670    real(kind=rb), dimension(4,ng6)    :: forref
 671 !
 672    real(kind=rb) , dimension(ng6) :: cfc11adj, cfc12
 673 !
 674    equivalence (ka(1,1,1),absa(1,1))
 675 !
 676 !-------------------------------------------------------------------------------
 677    end module rrlw_kg06_k
 678 !-------------------------------------------------------------------------------
 679 !
 680 !
 681 !-------------------------------------------------------------------------------
 682    module rrlw_kg07_k
 683 !-------------------------------------------------------------------------------
 684 !
 685 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 7
 686 !  band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
 687 !
 688 !  Initial version:  JJMorcrette, ECMWF, jul1998
 689 !  Revised: MJIacono, AER, jun2006
 690 !  Revised: MJIacono, AER, aug2008
 691 !
 692 !  ORIGINAL
 693 !  name       type     purpose
 694 !  ----     : ----   : ---------------------------------------------
 695 !  fracrefao: real
 696 !  fracrefbo: real
 697 !  kao      : real
 698 !  kbo      : real
 699 !  kao_mco2 : real
 700 !  kbo_mco2 : real
 701 !  selfrefo : real
 702 !  forrefo  : real
 703 !
 704 !  COMBINED
 705 !  name       type     purpose
 706 !  ----     : ----   : ---------------------------------------------
 707 !  fracrefa : real
 708 !  fracrefb : real
 709 !  ka       : real
 710 !  kb       : real
 711 !  ka_mco2  : real
 712 !  kb_mco2  : real
 713 !  selfref  : real
 714 !  forref   : real
 715 !
 716 !  absa     : real
 717 !
 718 !-------------------------------------------------------------------------------
 719    use parkind_k, only : im => kind_im, rb => kind_rb
 720 !
 721 !  implicit none
 722 !
 723    save
 724 !
 725    integer(kind=im), parameter :: no7  = 16
 726 !
 727    real(kind=rb), dimension(no7)         :: fracrefbo
 728    real(kind=rb), dimension(no7,9)       :: fracrefao
 729    real(kind=rb), dimension(9,5,13,no7)  :: kao
 730    real(kind=rb), dimension(5,13:59,no7) :: kbo
 731    real(kind=rb), dimension(9,19,no7)    :: kao_mco2
 732    real(kind=rb), dimension(19,no7)      :: kbo_mco2
 733    real(kind=rb), dimension(10,no7)      :: selfrefo
 734    real(kind=rb), dimension(4,no7)       :: forrefo
 735 !
 736    integer(kind=im), parameter :: ng7  = 12
 737 !
 738    real(kind=rb), dimension(ng7)         :: fracrefb
 739    real(kind=rb), dimension(ng7,9)       :: fracrefa
 740    real(kind=rb), dimension(9,5,13,ng7)  :: ka
 741    real(kind=rb), dimension(585,ng7)     :: absa
 742    real(kind=rb), dimension(5,13:59,ng7) :: kb
 743    real(kind=rb), dimension(235,ng7)     :: absb
 744    real(kind=rb), dimension(9,19,ng7)    :: ka_mco2
 745    real(kind=rb), dimension(19,ng7)      :: kb_mco2
 746    real(kind=rb), dimension(10,ng7)      :: selfref
 747    real(kind=rb), dimension(4,ng7)       :: forref
 748 !
 749    equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
 750 !
 751 !-------------------------------------------------------------------------------
 752    end module rrlw_kg07_k
 753 !-------------------------------------------------------------------------------
 754 !
 755 !
 756 !-------------------------------------------------------------------------------
 757    module rrlw_kg08_k
 758 !-------------------------------------------------------------------------------
 759 !
 760 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 8
 761 !  band 8:  1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
 762 !
 763 !  Initial version:  JJMorcrette, ECMWF, jul1998
 764 !  Revised: MJIacono, AER, jun2006
 765 !  Revised: MJIacono, AER, aug2008
 766 !
 767 !  ORIGINAL
 768 !  name       type     purpose
 769 !  ----     : ----   : ---------------------------------------------
 770 !  fracrefao: real
 771 !  fracrefbo: real
 772 !  kao      : real
 773 !  kbo      : real
 774 !  kao_mco2 : real
 775 !  kbo_mco2 : real
 776 !  kao_mn2o : real
 777 !  kbo_mn2o : real
 778 !  kao_mo3  : real
 779 !  selfrefo : real
 780 !  forrefo  : real
 781 !  cfc12o   : real
 782 !  cfc22adjo: real
 783 !
 784 !  COMBINED
 785 !  name       type     purpose
 786 !  ----     : ----   : ---------------------------------------------
 787 !  fracrefa : real
 788 !  fracrefb : real
 789 !  ka       : real
 790 !  kb       : real
 791 !  ka_mco2  : real
 792 !  kb_mco2  : real
 793 !  ka_mn2o  : real
 794 !  kb_mn2o  : real
 795 !  ka_mo3   : real
 796 !  selfref  : real
 797 !  forref   : real
 798 !  cfc12    : real
 799 !  cfc22adj : real
 800 !
 801 !  absa     : real
 802 !  absb     : real
 803 !
 804 !-------------------------------------------------------------------------------
 805    use parkind_k, only : im => kind_im, rb => kind_rb
 806 !
 807 !  implicit none
 808 !
 809    save
 810 !
 811    integer(kind=im), parameter :: no8  = 16
 812 !
 813    real(kind=rb), dimension(no8) :: fracrefao, fracrefbo, cfc12o, cfc22adjo
 814 !
 815    real(kind=rb), dimension(5,13,no8)    :: kao(5,13,no8)
 816    real(kind=rb), dimension(19,no8)      :: kao_mco2, kao_mn2o, kao_mo3
 817    real(kind=rb), dimension(5,13:59,no8) :: kbo
 818    real(kind=rb), dimension(19,no8)      :: kbo_mco2, kbo_mn2o
 819    real(kind=rb), dimension(10,no8)      :: selfrefo
 820    real(kind=rb), dimension(4,no8)       :: forrefo
 821 !
 822    integer(kind=im), parameter :: ng8  = 8
 823 !
 824    real(kind=rb) , dimension(ng8) :: fracrefa, fracrefb, cfc12, cfc22adj
 825 !
 826    real(kind=rb), dimension(5,13,ng8)    :: ka
 827    real(kind=rb), dimension(65,ng8)      :: absa
 828    real(kind=rb), dimension(5,13:59,ng8) :: kb
 829    real(kind=rb), dimension(235,ng8)     :: absb
 830    real(kind=rb), dimension(19,ng8)      :: ka_mco2, ka_mn2o, ka_mo3,          &
 831                                             kb_mco2, kb_mn2o
 832    real(kind=rb), dimension(10,ng8)      :: selfref
 833    real(kind=rb), dimension(4,ng8)       :: forref
 834 !
 835    equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
 836 !
 837 !-------------------------------------------------------------------------------
 838    end module rrlw_kg08_k
 839 !-------------------------------------------------------------------------------
 840 !
 841 !
 842 !-------------------------------------------------------------------------------
 843    module rrlw_kg09_k
 844 !-------------------------------------------------------------------------------
 845 !
 846 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 9
 847 !  band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
 848 !
 849 !  Initial version:  JJMorcrette, ECMWF, jul1998
 850 !  Revised: MJIacono, AER, jun2006
 851 !  Revised: MJIacono, AER, aug2008
 852 !
 853 !  ORIGINAL
 854 !  name       type     purpose
 855 !  ----     : ----   : ---------------------------------------------
 856 !  fracrefao: real
 857 !  fracrefbo: real
 858 !  kao      : real
 859 !  kbo      : real
 860 !  kao_mn2o : real
 861 !  kbo_mn2o : real
 862 !  selfrefo : real
 863 !  forrefo  : real
 864 !
 865 !  COMBINED
 866 !  name       type     purpose
 867 !  ----     : ----   : ---------------------------------------------
 868 !  fracrefa : real
 869 !  fracrefb : real
 870 !  ka       : real
 871 !  kb       : real
 872 !  ka_mn2o  : real
 873 !  kb_mn2o  : real
 874 !  selfref  : real
 875 !  forref   : real
 876 !
 877 !  absa     : real
 878 !  absb     : real
 879 !
 880 !-------------------------------------------------------------------------------
 881    use parkind_k, only : im => kind_im, rb => kind_rb
 882 !
 883 !  implicit none
 884 !
 885    save
 886 !
 887    integer(kind=im), parameter :: no9  = 16
 888 !
 889    real(kind=rb), dimension(no9) :: fracrefbo
 890 !
 891    real(kind=rb), dimension(no9,9)       :: fracrefao
 892    real(kind=rb), dimension(9,5,13,no9)  :: kao
 893    real(kind=rb), dimension(5,13:59,no9) :: kbo
 894    real(kind=rb), dimension(9,19,no9)    :: kao_mn2o
 895    real(kind=rb), dimension(19,no9)      :: kbo_mn2o
 896    real(kind=rb), dimension(10,no9)      :: selfrefo
 897    real(kind=rb), dimension(4,no9)       :: forrefo
 898 !
 899    integer(kind=im), parameter :: ng9  = 12
 900 !
 901    real(kind=rb), dimension(ng9)         :: fracrefb
 902    real(kind=rb), dimension(ng9,9)       :: fracrefa
 903    real(kind=rb), dimension(9,5,13,ng9)  :: ka
 904    real(kind=rb), dimension(585,ng9)     :: absa
 905    real(kind=rb), dimension(5,13:59,ng9) :: kb
 906    real(kind=rb), dimension(235,ng9)     :: absb
 907    real(kind=rb), dimension(9,19,ng9)    :: ka_mn2o
 908    real(kind=rb), dimension(19,ng9)      :: kb_mn2o
 909    real(kind=rb), dimension(10,ng9)      :: selfref
 910    real(kind=rb), dimension(4,ng9)       :: forref
 911 !
 912    equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
 913 !
 914 !-------------------------------------------------------------------------------
 915    end module rrlw_kg09_k
 916 !-------------------------------------------------------------------------------
 917 !
 918 !
 919 !-------------------------------------------------------------------------------
 920    module rrlw_kg10_k
 921 !-------------------------------------------------------------------------------
 922 !
 923 !  abstarct : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 10
 924 !  band 10:  1390-1480 cm-1 (low - h2o; high - h2o)
 925 !
 926 !  Initial version:  JJMorcrette, ECMWF, jul1998
 927 !  Revised: MJIacono, AER, jun2006
 928 !  Revised: MJIacono, AER, aug2008
 929 !
 930 !  ORIGINAL
 931 !  name       type     purpose
 932 !  ----     : ----   : ---------------------------------------------
 933 !  fracrefao: real
 934 !  fracrefbo: real
 935 !  kao      : real
 936 !  kbo      : real
 937 !  selfrefo : real
 938 !  forrefo  : real
 939 !
 940 !  COMBINED
 941 !  name       type     purpose
 942 !  ----     : ----   : ---------------------------------------------
 943 !  fracrefao: real
 944 !  fracrefbo: real
 945 !  kao      : real
 946 !  kbo      : real
 947 !  selfref  : real
 948 !  forref   : real
 949 !
 950 !  absa     : real
 951 !  absb     : real
 952 !
 953 !-------------------------------------------------------------------------------
 954    use parkind_k, only : im => kind_im, rb => kind_rb
 955 !
 956 !  implicit none
 957 !
 958    save
 959 !
 960    integer(kind=im), parameter :: no10 = 16
 961 !
 962    real(kind=rb), dimension(no10) :: fracrefao, fracrefbo
 963 !
 964    real(kind=rb), dimension(5,13,no10)    :: kao
 965    real(kind=rb), dimension(5,13:59,no10) :: kbo
 966    real(kind=rb), dimension(10,no10)      :: selfrefo
 967    real(kind=rb), dimension(4,no10)       :: forrefo
 968 !
 969    integer(kind=im), parameter :: ng10 = 6
 970 !
 971    real(kind=rb), dimension(ng10)         :: fracrefa, fracrefb
 972    real(kind=rb), dimension(5,13,ng10)    :: ka
 973    real(kind=rb), dimension(65,ng10)      :: absa
 974    real(kind=rb), dimension(5,13:59,ng10) :: kb
 975    real(kind=rb), dimension(235,ng10)     :: absb
 976    real(kind=rb), dimension(10,ng10)      :: selfref
 977    real(kind=rb), dimension(4,ng10)       :: forref
 978 !
 979    equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
 980 !
 981 !-------------------------------------------------------------------------------
 982    end module rrlw_kg10_k
 983 !-------------------------------------------------------------------------------
 984 !
 985 !
 986 !-------------------------------------------------------------------------------
 987    module rrlw_kg11_k
 988 !-------------------------------------------------------------------------------
 989 !
 990 !  abtract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 11
 991 !  band 11:  1480-1800 cm-1 (low - h2o; high - h2o)
 992 !
 993 !  Initial version:  JJMorcrette, ECMWF, jul1998
 994 !  Revised: MJIacono, AER, jun2006
 995 !  Revised: MJIacono, AER, aug2008
 996 !
 997 !  ORIGINAL
 998 !  name       type     purpose
 999 !  ----     : ----   : ---------------------------------------------
1000 !  fracrefao: real
1001 !  fracrefbo: real
1002 !  kao      : real
1003 !  kbo      : real
1004 !  kao_mo2  : real
1005 !  kbo_mo2  : real
1006 !  selfrefo : real
1007 !  forrefo  : real
1008 !
1009 !  COMBINED
1010 !  name       type     purpose
1011 !  ----     : ----   : ---------------------------------------------
1012 !  fracrefa : real
1013 !  fracrefb : real
1014 !  ka       : real
1015 !  kb       : real
1016 !  ka_mo2   : real
1017 !  kb_mo2   : real
1018 !  selfref  : real
1019 !  forref   : real
1020 !
1021 !  absa     : real
1022 !  absb     : real
1023 !
1024 !-------------------------------------------------------------------------------
1025    use parkind_k, only : im => kind_im, rb => kind_rb
1026 !
1027 !  implicit none
1028 !
1029    save
1030 !
1031    integer(kind=im), parameter :: no11 = 16
1032 !
1033    real(kind=rb), dimension(no11) :: fracrefao, fracrefbo
1034 !
1035    real(kind=rb), dimension(5,13,no11)    :: kao
1036    real(kind=rb), dimension(5,13:59,no11) :: kbo
1037    real(kind=rb), dimension(19,no11)      :: kao_mo2, kbo_mo2
1038    real(kind=rb), dimension(10,no11)      :: selfrefo
1039    real(kind=rb), dimension(4,no11)       :: forrefo
1040 !
1041    integer(kind=im), parameter :: ng11 = 8
1042 !
1043    real(kind=rb) , dimension(ng11) :: fracrefa, fracrefb
1044 !
1045    real(kind=rb), dimension(5,13,ng11)    :: ka
1046    real(kind=rb), dimension(65,ng11)      :: absa
1047    real(kind=rb), dimension(5,13:59,ng11) :: kb
1048    real(kind=rb), dimension(235,ng11)     :: absb
1049    real(kind=rb), dimension(19,ng11)      :: ka_mo2, kb_mo2
1050    real(kind=rb), dimension(10,ng11)      :: selfref
1051    real(kind=rb), dimension(4,ng11)       :: forref
1052 !
1053    equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1054 !
1055 !-------------------------------------------------------------------------------
1056    end module rrlw_kg11_k
1057 !-------------------------------------------------------------------------------
1058 !
1059 !
1060 !-------------------------------------------------------------------------------
1061    module rrlw_kg12_k
1062 !-------------------------------------------------------------------------------
1063 !
1064 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 12
1065 !  band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
1066 !
1067 !  Initial version:  JJMorcrette, ECMWF, jul1998
1068 !  Revised: MJIacono, AER, jun2006
1069 !  Revised: MJIacono, AER, aug2008
1070 !
1071 !  ORIGINAL
1072 !  name       type     purpose
1073 !  ----     : ----   : ---------------------------------------------
1074 !  fracrefao: real
1075 !  kao      : real
1076 !  selfrefo : real
1077 !  forrefo  : real
1078 !
1079 !  COMBINED
1080 !  name       type     purpose
1081 !  ----     : ----   : ---------------------------------------------
1082 !  fracrefa : real
1083 !  ka       : real
1084 !  selfref  : real
1085 !  forref   : real
1086 !
1087 !  absa     : real
1088 !
1089 !-------------------------------------------------------------------------------
1090    use parkind_k, only : im => kind_im, rb => kind_rb
1091 !
1092 !  implicit none
1093 !
1094    save
1095 !
1096    integer(kind=im), parameter :: no12 = 16
1097 !
1098    real(kind=rb),dimension(no12,9)      :: fracrefao
1099    real(kind=rb),dimension(9,5,13,no12) :: kao
1100    real(kind=rb),dimension(10,no12)     :: selfrefo
1101    real(kind=rb),dimension(4,no12)      :: forrefo
1102 !
1103    integer(kind=im), parameter :: ng12 = 8
1104 !
1105    real(kind=rb),dimension(ng12,9)      :: fracrefa
1106    real(kind=rb),dimension(9,5,13,ng12) :: ka
1107    real(kind=rb),dimension(585,ng12)    :: absa
1108    real(kind=rb),dimension(10,ng12)     :: selfref
1109    real(kind=rb),dimension(4,ng12)      :: forref
1110 !
1111    equivalence (ka(1,1,1,1),absa(1,1))
1112 !
1113 !-------------------------------------------------------------------------------
1114    end module rrlw_kg12_k
1115 !-------------------------------------------------------------------------------
1116 !
1117 !
1118 !-------------------------------------------------------------------------------
1119    module rrlw_kg13_k
1120 !-------------------------------------------------------------------------------
1121 !
1122 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 13
1123 !  band 13:  2080-2250 cm-1 (low - h2o,n2o; high - nothing)
1124 !
1125 !  Initial version:  JJMorcrette, ECMWF, jul1998
1126 !  Revised: MJIacono, AER, jun2006
1127 !  Revised: MJIacono, AER, aug2008
1128 !
1129 !  ORIGINAL
1130 !  name       type     purpose
1131 !  ----     : ----   : ---------------------------------------------
1132 !  fracrefao: real
1133 !  kao      : real
1134 !  kao_mco2 : real
1135 !  kao_mco  : real
1136 !  kbo_mo3  : real
1137 !  selfrefo : real
1138 !  forrefo  : real
1139 !
1140 !  COMBINED
1141 !  name       type     purpose
1142 !  ----     : ----   : ---------------------------------------------
1143 !  fracrefa : real
1144 !  ka       : real
1145 !  ka_mco2  : real
1146 !  ka_mco   : real
1147 !  kb_mo3   : real
1148 !  selfref  : real
1149 !  forref   : real
1150 !
1151 !  absa     : real
1152 !
1153 !-------------------------------------------------------------------------------
1154    use parkind_k, only : im => kind_im, rb => kind_rb
1155 !
1156 !  implicit none
1157 !
1158    save
1159 !
1160    integer(kind=im), parameter :: no13 = 16
1161 !
1162    real(kind=rb), dimension(no13) :: fracrefbo
1163 !
1164    real(kind=rb), dimension(no13,9)      :: fracrefao
1165    real(kind=rb), dimension(9,5,13,no13) :: kao
1166    real(kind=rb), dimension(9,19,no13)   :: kao_mco2, kao_mco
1167    real(kind=rb), dimension(19,no13)     :: kbo_mo3
1168    real(kind=rb), dimension(10,no13)     :: selfrefo
1169    real(kind=rb), dimension(4,no13)      :: forrefo
1170 !
1171 !
1172    integer(kind=im), parameter :: ng13 = 4
1173 !
1174    real(kind=rb) , dimension(ng13) :: fracrefb
1175 !
1176    real(kind=rb), dimension(ng13,9)      :: fracrefa
1177    real(kind=rb), dimension(9,5,13,ng13) :: ka
1178    real(kind=rb), dimension(585,ng13)    :: absa
1179    real(kind=rb), dimension(9,19,ng13)   :: ka_mco2, ka_mco
1180    real(kind=rb), dimension(19,ng13)     :: kb_mo3
1181    real(kind=rb), dimension(10,ng13)     :: selfref
1182    real(kind=rb), dimension(4,ng13)      :: forref
1183 !
1184    equivalence (ka(1,1,1,1),absa(1,1))
1185 !
1186 !-------------------------------------------------------------------------------
1187    end module rrlw_kg13_k
1188 !-------------------------------------------------------------------------------
1189 !
1190 !
1191 !-------------------------------------------------------------------------------
1192    module rrlw_kg14_k
1193 !-------------------------------------------------------------------------------
1194 !
1195 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 14
1196 !  band 14:  2250-2380 cm-1 (low - co2; high - co2)
1197 !
1198 !  Initial version:  JJMorcrette, ECMWF, jul1998
1199 !  Revised: MJIacono, AER, jun2006
1200 !  Revised: MJIacono, AER, aug2008
1201 !
1202 !  ORIGINAL
1203 !  name       type     purpose
1204 !  ----     : ----   : ---------------------------------------------
1205 !  fracrefao: real
1206 !  fracrefbo: real
1207 !  kao      : real
1208 !  kbo      : real
1209 !  selfrefo : real
1210 !  forrefo  : real
1211 !
1212 !  COMBINED
1213 !  name       type     purpose
1214 !  ----     : ----   : ---------------------------------------------
1215 !  fracrefa : real
1216 !  fracrefb : real
1217 !  ka       : real
1218 !  kb       : real
1219 !  selfref  : real
1220 !  forref   : real
1221 !
1222 !  absa     : real
1223 !  absb     : real
1224 !
1225 !-------------------------------------------------------------------------------
1226    use parkind_k, only : im => kind_im, rb => kind_rb
1227 !
1228 !  implicit none
1229 !
1230    save
1231 !
1232    integer(kind=im), parameter :: no14 = 16
1233 !
1234    real(kind=rb), dimension(no14) :: fracrefao, fracrefbo
1235 !
1236    real(kind=rb), dimension(5,13,no14)    :: kao
1237    real(kind=rb), dimension(5,13:59,no14) :: kbo
1238    real(kind=rb), dimension(10,no14)      :: selfrefo
1239    real(kind=rb), dimension(4,no14)       :: forrefo
1240 !
1241    integer(kind=im), parameter :: ng14 = 2
1242 !
1243    real(kind=rb) , dimension(ng14) :: fracrefa, fracrefb
1244 !
1245    real(kind=rb), dimension(5,13,ng14)    :: ka
1246    real(kind=rb), dimension(65,ng14)      :: absa
1247    real(kind=rb), dimension(5,13:59,ng14) :: kb
1248    real(kind=rb), dimension(235,ng14)     :: absb
1249    real(kind=rb), dimension(10,ng14)      :: selfref
1250    real(kind=rb), dimension(4,ng14)       :: forref
1251 !
1252    equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1253 !
1254 !-------------------------------------------------------------------------------
1255    end module rrlw_kg14_k
1256 !-------------------------------------------------------------------------------
1257 !
1258 !
1259 !-------------------------------------------------------------------------------
1260    module rrlw_kg15_k
1261 !-------------------------------------------------------------------------------
1262 !
1263 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 15
1264 !  band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
1265 !
1266 !  Initial version:  JJMorcrette, ECMWF, jul1998
1267 !  Revised: MJIacono, AER, jun2006
1268 !  Revised: MJIacono, AER, aug2008
1269 !
1270 !  ORIGINAL
1271 !  name       type     purpose
1272 !  ----     : ----   : ---------------------------------------------
1273 !  fracrefao: real
1274 !  kao      : real
1275 !  kao_mn2  : real
1276 !  selfrefo : real
1277 !  forrefo  : real
1278 !
1279 !  COMBINED
1280 !  name       type     purpose
1281 !  ----     : ----   : ---------------------------------------------
1282 !  fracrefa : real
1283 !  ka       : real
1284 !  ka_mn2   : real
1285 !  selfref  : real
1286 !  forref   : real
1287 !
1288 !  absa     : real
1289 !
1290 !-------------------------------------------------------------------------------
1291    use parkind_k, only : im => kind_im, rb => kind_rb
1292 !
1293 !  implicit none
1294 !
1295    save
1296 !
1297    integer(kind=im), parameter :: no15 = 16
1298 !
1299    real(kind=rb), dimension(no15,9)      :: fracrefao
1300    real(kind=rb), dimension(9,5,13,no15) :: kao
1301    real(kind=rb), dimension(9,19,no15)   :: kao_mn2
1302    real(kind=rb), dimension(10,no15)     :: selfrefo
1303    real(kind=rb), dimension(4,no15)      :: forrefo
1304 !
1305    integer(kind=im), parameter :: ng15 = 2
1306 !
1307    real(kind=rb), dimension(ng15,9)      :: fracrefa
1308    real(kind=rb), dimension(9,5,13,ng15) :: ka
1309    real(kind=rb), dimension(585,ng15)    :: absa
1310    real(kind=rb), dimension(9,19,ng15)   :: ka_mn2
1311    real(kind=rb), dimension(10,ng15)     :: selfref
1312    real(kind=rb), dimension(4,ng15)      :: forref
1313 !
1314    equivalence (ka(1,1,1,1),absa(1,1))
1315 !
1316 !-------------------------------------------------------------------------------
1317    end module rrlw_kg15_k
1318 !-------------------------------------------------------------------------------
1319 !
1320 !
1321 !-------------------------------------------------------------------------------
1322    module rrlw_kg16_k
1323 !-------------------------------------------------------------------------------
1324 !
1325 !  abstract : rrtmg_lw ORIGINAL/COMBINED abs. coefficients for interval 16
1326 !  band 16:  2600-3000 cm-1 (low - h2o,ch4; high - nothing)
1327 !
1328 !  Initial version:  JJMorcrette, ECMWF, jul1998
1329 !  Revised: MJIacono, AER, jun2006
1330 !  Revised: MJIacono, AER, aug2008
1331 !
1332 !  ORIGINAL
1333 !  name       type     purpose
1334 !  ----     : ----   : ---------------------------------------------
1335 !  fracrefao: real
1336 !  kao      : real
1337 !  kbo      : real
1338 !  selfrefo : real
1339 !  forrefo  : real
1340 !
1341 !  COMBINED
1342 !  name       type     purpose
1343 !  ----     : ----   : ---------------------------------------------
1344 !  fracrefa : real
1345 !  ka       : real
1346 !  kb       : real
1347 !  selfref  : real
1348 !  forref   : real
1349 !
1350 !  absa     : real
1351 !  absb     : real
1352 !
1353 !-------------------------------------------------------------------------------
1354    use parkind_k, only : im => kind_im, rb => kind_rb
1355 !
1356 !  implicit none
1357 !
1358    save
1359 !
1360    integer(kind=im), parameter :: no16 = 16
1361 !
1362    real(kind=rb), dimension(no16) :: fracrefbo
1363 !
1364    real(kind=rb), dimension(no16,9)       :: fracrefao
1365    real(kind=rb), dimension(9,5,13,no16)  :: kao
1366    real(kind=rb), dimension(5,13:59,no16) :: kbo
1367    real(kind=rb), dimension(10,no16)      :: selfrefo
1368    real(kind=rb), dimension(4,no16)       :: forrefo
1369 !
1370 !
1371    integer(kind=im), parameter :: ng16 = 2
1372 !
1373    real(kind=rb) , dimension(ng16) :: fracrefb
1374 !
1375    real(kind=rb), dimension(ng16,9)       :: fracrefa
1376    real(kind=rb), dimension(9,5,13,ng16)  :: ka
1377    real(kind=rb), dimension(585,ng16)     :: absa
1378    real(kind=rb), dimension(5,13:59,ng16) :: kb
1379    real(kind=rb), dimension(235,ng16)     :: absb
1380    real(kind=rb), dimension(10,ng16)      :: selfref
1381    real(kind=rb), dimension(4,ng16)       :: forref
1382 !
1383    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1384 !
1385 !-------------------------------------------------------------------------------
1386    end module rrlw_kg16_k
1387 !-------------------------------------------------------------------------------
1388 !
1389 !
1390 !-------------------------------------------------------------------------------
1391    module rrlw_ref_k
1392 !-------------------------------------------------------------------------------
1393 !
1394 !  abstract : rrtmg_lw reference atmosphere
1395 !  Based on standard mid-latitude summer profile
1396 !
1397 !  Initial version:  JJMorcrette, ECMWF, jul1998
1398 !  Revised: MJIacono, AER, jun2006
1399 !  Revised: MJIacono, AER, aug2008
1400 !
1401 !  name      type     purpose
1402 !  -----  :  ----   : ----------------------------------------------
1403 !  pref   :  real   : Reference pressure levels
1404 !  preflog:  real   : Reference pressure levels, ln(pref)
1405 !  tref   :  real   : Reference temperature levels for MLS profile
1406 !  chi_mls:  real   :
1407 !
1408 !-------------------------------------------------------------------------------
1409    use parkind_k, only : im => kind_im, rb => kind_rb
1410 !
1411 !  implicit none
1412 !
1413    save
1414 !
1415    real(kind=rb), dimension(59)   :: pref
1416    real(kind=rb), dimension(59)   :: preflog
1417    real(kind=rb), dimension(59)   :: tref
1418    real(kind=rb), dimension(7,59) :: chi_mls
1419 !
1420 !-------------------------------------------------------------------------------
1421    end module rrlw_ref_k
1422 !-------------------------------------------------------------------------------
1423 !
1424 !
1425 !-------------------------------------------------------------------------------
1426    module rrlw_tbl_k
1427 !-------------------------------------------------------------------------------
1428 !
1429 !  abstract : rrtmg_lw exponential lookup table arrays
1430 !
1431 !  Initial version:  JJMorcrette, ECMWF, jul1998
1432 !  Revised: MJIacono, AER, Jun 2006
1433 !  Revised: MJIacono, AER, Aug 2007
1434 !  Revised: MJIacono, AER, Aug 2008
1435 !
1436 !  name      type     purpose
1437 !  -----  :  ----   : ----------------------------------------------
1438 !  ntbl   :  integer: Lookup table dimension
1439 !  tblint :  real   : Lookup table conversion factor
1440 !  tau_tbl:  real   : Clear-sky optical depth (used in cloudy radiative
1441 !                     transfer)
1442 !  exp_tbl:  real   : Transmittance lookup table
1443 !  tfn_tbl:  real   : Tau transition function; i.e. the transition of
1444 !                     the Planck function from that for the mean layer
1445 !                     temperature to that for the layer boundary
1446 !                     temperature as a function of optical depth.
1447 !                     The "linear in tau" method is used to make
1448 !                     the table.
1449 !  pade   :  real   : Pade constant
1450 !  bpade  :  real   : Inverse of Pade constant
1451 !
1452 !-------------------------------------------------------------------------------
1453    use parkind_k, only : im => kind_im, rb => kind_rb
1454 !
1455 !  implicit none
1456 !
1457    save
1458 !
1459    integer(kind=im), parameter :: ntbl = 10000
1460 !
1461    real(kind=rb), parameter :: tblint = 10000.0_rb
1462 !
1463    real(kind=rb), dimension(0:ntbl) :: tau_tbl
1464    real(kind=rb), dimension(0:ntbl) :: exp_tbl
1465    real(kind=rb), dimension(0:ntbl) :: tfn_tbl
1466 !
1467    real(kind=rb), parameter :: pade = 0.278_rb
1468    real(kind=rb) :: bpade
1469 !
1470 !-------------------------------------------------------------------------------
1471    end module rrlw_tbl_k
1472 !-------------------------------------------------------------------------------
1473 !
1474 !
1475 !-------------------------------------------------------------------------------
1476    module rrlw_vsn_k
1477 !-------------------------------------------------------------------------------
1478 !
1479 !  abstract : rrtmg_lw version information
1480 !
1481 !  Initial version:  JJMorcrette, ECMWF, jul1998
1482 !  Revised: MJIacono, AER, jun2006
1483 !  Revised: MJIacono, AER, aug2008
1484 !
1485 !  name      type     purpose
1486 !  -----  :  ----   : ----------------------------------------------
1487 !  hnamrtm :character:
1488 !  hnamini :character:
1489 !  hnamcld :character:
1490 !  hnamclc :character:
1491 !  hnamrtr :character:
1492 !  hnamrtx :character:
1493 !  hnamrtc :character:
1494 !  hnamset :character:
1495 !  hnamtau :character:
1496 !  hnamatm :character:
1497 !  hnamutl :character:
1498 !  hnamext :character:
1499 !  hnamkg  :character:
1500 !
1501 !  hvrrtm :character:
1502 !  hvrini :character:
1503 !  hvrcld :character:
1504 !  hvrclc :character:
1505 !  hvrrtr :character:
1506 !  hvrrtx :character:
1507 !  hvrrtc :character:
1508 !  hvrset :character:
1509 !  hvrtau :character:
1510 !  hvratm :character:
1511 !  hvrutl :character:
1512 !  hvrext :character:
1513 !  hvrkg  :character:
1514 !
1515 !-------------------------------------------------------------------------------
1516 !
1517 !  implicit none
1518 !
1519    save
1520 !
1521    character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx,                     &
1522                 hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
1523    character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx,               &
1524                 hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
1525 !
1526    character*18 hvrkg
1527    character*20 hnamkg
1528 !
1529 !-------------------------------------------------------------------------------
1530    end module rrlw_vsn_k
1531 !-------------------------------------------------------------------------------
1532 !
1533 !
1534 !-------------------------------------------------------------------------------
1535    module rrlw_wvn_k
1536 !-------------------------------------------------------------------------------
1537 !
1538 !  abstract : rrtmg_lw spectral information
1539 !
1540 !  Initial version:  JJMorcrette, ECMWF, jul1998
1541 !  Revised: MJIacono, AER, jun2006
1542 !  Revised: MJIacono, AER, aug2008
1543 !
1544 !  name       type     purpose
1545 !  -----   :  ----   : ----------------------------------------------
1546 !  ng      :  integer: number of original g-intervals in each spectral band
1547 !  nspa    :  integer: For the lower atmosphere, the number of reference
1548 !                      atmospheres that are stored for each spectral band
1549 !                      per pressure level and temperature.  Each of these
1550 !                      atmospheres has different relative amounts of the
1551 !                      key species for the band (i.e. different binary
1552 !                      species parameters).
1553 !  nspb    :  integer: Same as nspa for the upper atmosphere
1554 !  wavenum1:  real   : Spectral band lower boundary in wavenumbers
1555 !  wavenum2:  real   : Spectral band upper boundary in wavenumbers
1556 !  delwave :  real   : Spectral band width in wavenumbers
1557 !  totplnk :  real   : integrated Planck value for each band; (band 16
1558 !                      includes total from 2600 cm-1 to infinity)
1559 !                      Used for calculation across total spectrum
1560 !  totplk16:  real   : integrated Planck value for band 16 (2600-3250 cm-1)
1561 !                      Used for calculation in band 16 only if
1562 !                      individual band output requested
1563 !
1564 !  ngc     :  integer: The number of new g-intervals in each band
1565 !  ngs     :  integer: The cumulative sum of new g-intervals for each band
1566 !  ngm     :  integer: The index of each new g-interval relative to the
1567 !                      original 16 g-intervals in each band
1568 !  ngn     :  integer: The number of original g-intervals that are
1569 !                      combined to make each new g-intervals in each band
1570 !  ngb     :  integer: The band index for each new g-interval
1571 !  wt      :  real   : RRTM weights for the original 16 g-intervals
1572 !  rwgt    :  real   : Weights for combining original 16 g-intervals
1573 !                      (256 total) into reduced set of g-intervals
1574 !                      (140 total)
1575 !  nxmol   :  integer: number of cross-section molecules
1576 !  ixindx  :  integer: Flag for active cross-sections in calculation
1577 !
1578 !-------------------------------------------------------------------------------
1579    use parkind_k, only : im => kind_im, rb => kind_rb
1580    use parrrtm_k, only : nbndlw, mg, ngptlw, maxinpx
1581 !
1582 !  implicit none
1583 !
1584    save
1585 !
1586    integer(kind=im), dimension(nbndlw) :: ng
1587    integer(kind=im), dimension(nbndlw) :: nspa
1588    integer(kind=im), dimension(nbndlw) :: nspb
1589 !
1590    real(kind=rb), dimension(nbndlw) :: wavenum1
1591    real(kind=rb), dimension(nbndlw) :: wavenum2
1592    real(kind=rb), dimension(nbndlw) :: delwave
1593 !
1594    real(kind=rb), dimension(181,nbndlw) :: totplnk
1595    real(kind=rb), dimension(181)        :: totplk16
1596 !
1597    integer(kind=im), dimension(nbndlw)    :: ngc
1598    integer(kind=im), dimension(nbndlw)    :: ngs
1599    integer(kind=im), dimension(ngptlw)    :: ngn
1600    integer(kind=im), dimension(ngptlw)    :: ngb
1601    integer(kind=im), dimension(nbndlw*mg) :: ngm
1602 !
1603    real(kind=rb), dimension(mg)        :: wt
1604    real(kind=rb), dimension(nbndlw*mg) :: rwgt
1605 !
1606    integer(kind=im)                     :: nxmol
1607    integer(kind=im), dimension(maxinpx) :: ixindx
1608 !
1609 !-------------------------------------------------------------------------------
1610    end module rrlw_wvn_k
1611 !-------------------------------------------------------------------------------
1612 !
1613 !
1614 !-------------------------------------------------------------------------------
1615    module mersennetwister_k
1616 !-------------------------------------------------------------------------------
1617 !
1618 !  abstract :
1619 !  path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
1620 !  author:    $Author: trn $
1621 !  revision:  $Revision: 1.3 $
1622 !  created:   $Date: 2009/04/16 19:54:22 $
1623 !
1624 !  Fortran-95 implementation of the Mersenne Twister 19937, following
1625 !  the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10),
1626 !  adapted cosmetically by making the names more general.
1627 !  Users must declare one or more variables of type randomnumbersequence
1628 !  in the calling
1629 !  procedure which are then initialized using a required seed. If the
1630 !  variable is not initialized the random numbers will all be 0.
1631 !  For example:
1632 !  program testrandoms
1633 !  use randomnumbers
1634 !  type(randomnumbersequence) :: randomnumbers
1635 !  integer                    :: i
1636 !
1637 !  randomnumbers = new_randomnumbersequence(seed = 100)
1638 !  do i = 1, 10
1639 !    print ('(f12.10, 2x)'), getrandomreal(randomnumbers)
1640 !  end do
1641 !  end program testrandoms
1642 !
1643 !  Fortran-95 implementation by
1644 !  Robert Pincus
1645 !  NOAA-CIRES Climate Diagnostics Center
1646 !  Boulder, CO 80305
1647 !  email: Robert.Pincus@colorado.edu
1648 !
1649 !  This documentation in the original C program reads:
1650 !  --------------------------------------------------------------
1651 !  A C-program for MT19937, with initialization improved 2002/2/10.
1652 !  Coded by Takuji Nishimura and Makoto Matsumoto.
1653 !  This is a faster version by taking Shawn Cokus's optimization,
1654 !  Matthe Bellew's simplification, Isaku Wada's real version.
1655 !
1656 !  Before using, initialize the state by using init_genrand(seed)
1657 !  or init_by_array(init_key, key_length).
1658 !
1659 !  Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
1660 !  All rights reserved.
1661 !
1662 !  Redistribution and use in source and binary forms, with or without
1663 !  modification, are permitted provided that the following conditions
1664 !  are met:
1665 !
1666 !  1. Redistributions of source code must retain the above copyright
1667 !     notice, this list of conditions and the following disclaimer.
1668 !
1669 !  2. Redistributions in binary form must reproduce the above copyright
1670 !     notice, this list of conditions and the following disclaimer in the
1671 !     documentation and/or other materials provided with the distribution.
1672 !
1673 !  3. The names of its contributors may not be used to endorse or promote
1674 !     products derived from this software without specific prior written
1675 !     permission.
1676 !
1677 !  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1678 !  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1679 !  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1680 !  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
1681 !  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
1682 !  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
1683 !  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF use, data, OR
1684 !  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAuseD AND ON ANY THEORY OF
1685 !  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
1686 !  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY out OF THE use OF THIS
1687 !  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1688 !
1689 !  Any feedback is very welcome.
1690 !  http://www.math.keio.ac.jp/matumoto/emt.html
1691 !  email: matumoto@math.keio.ac.jp
1692 !
1693 !-------------------------------------------------------------------------------
1694    use parkind_k, only : im => kind_im, rb => kind_rb
1695 !
1696    implicit none
1697 !
1698    private
1699 !
1700 ! Algorithm parameters
1701 ! -------
1702 ! Period parameters
1703 !
1704    integer(kind=im), parameter :: blocksize = 624,                             &
1705                                   m         = 397,                             &
1706 ! constant vector a (0x9908b0dfUL)
1707                                   matrix_a  = -1727483681,                     &
1708 ! most significant w-r bits (0x80000000UL)
1709                                   umask     = -2147483647-1,                   &
1710 ! least significant r bits (0x7fffffffUL)
1711                                   lmask     =  2147483647
1712 !
1713 ! Tempering parameters
1714 !
1715 ! (0x9d2c5680UL)
1716    integer(kind=im), parameter :: tmaskb = -1658038656,                        &
1717 ! (0xefc60000UL)
1718                                   tmaskc = -272236544
1719 !
1720 ! The type containing the state variable
1721 !
1722    type randomnumbersequence
1723      integer(kind=im)                            :: currentelement ! = blocksize
1724      integer(kind=im), dimension(0:blocksize -1) :: state          ! = 0
1725    end type randomnumbersequence
1726 !-------------------------------------------------------------------------------
1727 !
1728    interface new_randomnumbersequence
1729      module procedure initialize_scalar, initialize_vector
1730    end interface new_randomnumbersequence
1731 !
1732    public :: randomnumbersequence
1733    public :: new_randomnumbersequence, finalize_randomnumbersequence,          &
1734             getrandomint, getrandompositiveint, getrandomreal
1735 !
1736    contains
1737 !-------------------------------------------------------------------------------
1738 !
1739 !
1740 !-------------------------------------------------------------------------------
1741    function mixbits(u, v)
1742 !-------------------------------------------------------------------------------
1743    integer(kind=im), intent(in   ) :: u, v
1744    integer(kind=im)                :: mixbits
1745 !-------------------------------------------------------------------------------
1746    mixbits = ior(iand(u, umask), iand(v, lmask))
1747 !
1748    end function mixbits
1749 !-------------------------------------------------------------------------------
1750 !
1751 !
1752 !-------------------------------------------------------------------------------
1753    function twist(u, v)
1754 !-------------------------------------------------------------------------------
1755    integer(kind=im), intent(in   ) :: u, v
1756    integer(kind=im)             :: twist
1757 !
1758 ! Local variable
1759 !
1760    integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/0_im, matrix_a/)
1761 !-------------------------------------------------------------------------------
1762    twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1763    twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
1764 !
1765    end function twist
1766 !-------------------------------------------------------------------------------
1767 !
1768 !
1769 !-------------------------------------------------------------------------------
1770    subroutine nextstate(twister)
1771 !-------------------------------------------------------------------------------
1772    type(randomnumbersequence), intent(inout) :: twister
1773 !
1774 ! Local variables
1775 !
1776    integer(kind=im) :: k
1777 !-------------------------------------------------------------------------------
1778 !
1779    do k = 0,blocksize-m-1
1780      twister%state(k) = ieor(twister%state(k+m),                               &
1781                              twist(twister%state(k),twister%state(k+1_im)))
1782    enddo
1783 !
1784    do k = blocksize-m,blocksize-2
1785      twister%state(k) = ieor(twister%state(k+m-blocksize),                     &
1786                              twist(twister%state(k),twister%state(k+1_im)))
1787    enddo
1788 !
1789    twister%state(blocksize-1_im) = ieor(twister%state(m-1_im),                 &
1790                                         twist(twister%state(blocksize-1_im),   &
1791                                         twister%state(0_im)))
1792    twister%currentelement = 0_im
1793 !
1794    end subroutine nextstate
1795 !-------------------------------------------------------------------------------
1796 !
1797 !
1798 !-------------------------------------------------------------------------------
1799    elemental function temper(y)
1800 !-------------------------------------------------------------------------------
1801    integer(kind=im), intent(in   ) :: y
1802    integer(kind=im)                :: temper
1803 !
1804    integer(kind=im) :: x
1805 !-------------------------------------------------------------------------------
1806 !
1807 ! Tempering
1808 !
1809    x      = ieor(y, ishft(y, -11))
1810    x      = ieor(x, iand(ishft(x,  7), tmaskb))
1811    x      = ieor(x, iand(ishft(x, 15), tmaskc))
1812    temper = ieor(x, ishft(x, -18))
1813 !
1814    end function temper
1815 !-------------------------------------------------------------------------------
1816 !
1817 ! public (but hidden) functions
1818 !
1819 !-------------------------------------------------------------------------------
1820    function initialize_scalar(seed) result(twister)
1821 !-------------------------------------------------------------------------------
1822    integer(kind=im), intent(in   ) :: seed
1823    type(randomnumbersequence)      :: twister
1824 !
1825    integer(kind=im) :: i
1826 !-------------------------------------------------------------------------------
1827 !
1828 ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions,
1829 ! MSBs of the seed affect only MSBs of the array state[].
1830 ! 2002/01/09 modified by Makoto Matsumoto
1831 !
1832    twister%state(0) = iand(seed,-1_im)
1833 !
1834    do i = 1,blocksize-1 ! ubound(twister%state)
1835      twister%state(i) = 1812433253_im*ieor(twister%state(i-1),                 &
1836                                            ishft(twister%state(i-1),-30_im))+i
1837      twister%state(i) = iand(twister%state(i),-1_im) ! for >32 bit machines
1838    enddo
1839 !
1840    twister%currentelement = blocksize
1841 !
1842    end function initialize_scalar
1843 !-------------------------------------------------------------------------------
1844 !
1845 !
1846 !-------------------------------------------------------------------------------
1847    function initialize_vector(seed) result(twister)
1848 !-------------------------------------------------------------------------------
1849    integer(kind=im), dimension(0:), intent(in   ) :: seed
1850    type(randomnumbersequence)                     :: twister
1851 !
1852    integer(kind=im) :: i, j, k, nfirstloop, nwraps
1853 !-------------------------------------------------------------------------------
1854    nwraps  = 0
1855    twister = initialize_scalar(19650218_im)
1856 !
1857    nfirstloop = max(blocksize,size(seed))
1858 !
1859    do k = 1,nfirstloop
1860      i = mod(k+nwraps,blocksize)
1861      j = mod(k-1,     size(seed))
1862      if (i == 0) then
1863        twister%state(i) = twister%state(blocksize-1)
1864        twister%state(1) = ieor(twister%state(1),                               &
1865                                ieor(twister%state(1-1),                        &
1866                                ishft(twister%state(1-1),-30_im))               &
1867                                *1664525_im)+seed(j)+j   ! Non-linear
1868        twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1869        nwraps = nwraps+1
1870      else
1871        twister%state(i) = ieor(twister%state(i),                               &
1872                           ieor(twister%state(i-1),                             &
1873                           ishft(twister%state(i-1),-30_im))                    &
1874                           *1664525_im)+seed(j)+j        ! Non-linear
1875        twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1876      endif
1877    enddo
1878 !
1879 ! Walk through the state array, beginning where we left off in the block above
1880 !
1881    do i = mod(nfirstloop,blocksize)+nwraps+1,blocksize-1
1882      twister%state(i) = ieor(twister%state(i),                                 &
1883                         ieor(twister%state(i-1),                               &
1884                         ishft(twister%state(i-1),-30_im))                      &
1885                         *1566083941_im)-i             ! Non-linear
1886      twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1887    enddo
1888 !
1889    twister%state(0) = twister%state(blocksize-1)
1890 !
1891    do i = 1,mod(nfirstloop,blocksize)+nwraps
1892      twister%state(i) = ieor(twister%state(i),                                 &
1893                         ieor(twister%state(i-1),                               &
1894                         ishft(twister%state(i-1),-30_im))                      &
1895                         *1566083941_im)-i             ! Non-linear
1896      twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
1897    enddo
1898 !
1899    twister%state(0) = umask
1900    twister%currentelement = blocksize
1901 !
1902    end function initialize_vector
1903 !-------------------------------------------------------------------------------
1904 !
1905 ! public functions
1906 !
1907 !-------------------------------------------------------------------------------
1908    function getrandomint(twister)
1909 !-------------------------------------------------------------------------------
1910 !
1911 !  abstract : Generate a random integer on the interval [0,0xffffffff]
1912 !  Equivalent to genrand_int32 in the C code.
1913 !  Fortran doesn't have a type that's unsigned like C does,
1914 !  so this is integers in the range -2**31 - 2**31
1915 !  All functions for getting random numbers call this one,
1916 !  then manipulate the result
1917 !
1918 !-------------------------------------------------------------------------------
1919    type(randomnumbersequence), intent(inout) :: twister
1920    integer(kind=im)                          :: getrandomint
1921 !-------------------------------------------------------------------------------
1922 !
1923    if (twister%currentelement >= blocksize) call nextstate(twister)
1924 !
1925    getrandomint = temper(twister%state(twister%currentelement))
1926    twister%currentelement = twister%currentelement + 1
1927    end function getrandomint
1928 !-------------------------------------------------------------------------------
1929 !
1930 !
1931 !-------------------------------------------------------------------------------
1932    function getrandompositiveint(twister)
1933 !-------------------------------------------------------------------------------
1934 !
1935 !  abstact :  Generate a random integer on the interval [0,0x7fffffff]
1936 !  or [0,2**31]
1937 !  Equivalent to genrand_int31 in the C code.
1938 !
1939 !-------------------------------------------------------------------------------
1940    type(randomnumbersequence), intent(inout) :: twister
1941    integer(kind=im)                          :: getrandompositiveint
1942 !
1943 ! Local integers
1944 !
1945    integer(kind=im) :: localint
1946 !-------------------------------------------------------------------------------
1947    localint = getrandomint(twister)
1948    getrandompositiveint = ishft(localint, -1)
1949 !
1950    end function getrandompositiveint
1951 !-------------------------------------------------------------------------------
1952 !
1953 ! mji - modified Jan 2007, double converted to rrtmg real kind type
1954 !
1955 !-------------------------------------------------------------------------------
1956    function getrandomreal(twister)
1957 !-------------------------------------------------------------------------------
1958 !
1959 !  abstract : Generate a random number on [0,1]
1960 !  Equivalent to genrand_real1 in the C code
1961 !  The result is stored as double precision but has 32 bit resolution
1962 !
1963 !-------------------------------------------------------------------------------
1964    type(randomnumbersequence), intent(inout) :: twister
1965 !  double precision                          :: getrandomreal
1966    real(kind=rb)                             :: getrandomreal
1967 !
1968    integer(kind=im) :: localint
1969 !-------------------------------------------------------------------------------
1970    localint = getrandomint(twister)
1971    if (localint < 0) then
1972 !    getrandomreal = real(localint + 2.0**32)/(2.0**32 - 1.0)
1973      getrandomreal = (localint+2.0**32_rb)/(2.0**32_rb-1.0_rb)
1974    else
1975 !    getrandomreal = real(localint        )/(2.0**32 - 1.0)
1976      getrandomreal = (localint            )/(2.0**32_rb-1.0_rb)
1977    endif
1978 !
1979    end function getrandomreal
1980 !-------------------------------------------------------------------------------
1981 !
1982 !
1983 !-------------------------------------------------------------------------------
1984    subroutine finalize_randomnumbersequence(twister)
1985 !-------------------------------------------------------------------------------
1986    type(randomnumbersequence), intent(inout) :: twister
1987 !
1988    twister%currentelement = blocksize
1989    twister%state(:) = 0_im
1990 !
1991    end subroutine finalize_randomnumbersequence
1992 !-------------------------------------------------------------------------------
1993 !
1994 !
1995 !-------------------------------------------------------------------------------
1996    end module mersennetwister_k
1997 !-------------------------------------------------------------------------------
1998 !
1999 !
2000 !-------------------------------------------------------------------------------
2001    module mcica_random_numbers_k
2002 !-------------------------------------------------------------------------------
2003 !
2004 !  abstract : Generic module to wrap random number generators.
2005 !  The module defines a type that identifies the particular stream of random
2006 !  numbers, and has procedures for initializing it and getting real numbers
2007 !  in the range 0 to 1.
2008 !  This version uses the Mersenne Twister to generate random numbers on [0, 1].
2009 !
2010 !-------------------------------------------------------------------------------
2011 ! The random number engine.
2012    use mersennetwister_k,  only : randomnumbersequence,                        &
2013                                 new_randomnumbersequence, getrandomreal
2014 ! mji
2015 !  use time_manager_mod, only : time_type, get_date
2016 !
2017    use parkind_k,          only : im => kind_im, rb => kind_rb
2018 !
2019    implicit none
2020 !
2021    private
2022 !
2023    type randomnumberstream
2024      type(randomnumbersequence) :: thenumbers
2025    end type randomnumberstream
2026 !-------------------------------------------------------------------------------
2027 !
2028    interface getrandomnumbers
2029      module procedure getrandomnumber_scalar, getrandomnumber_1d,              &
2030                       getrandomnumber_2d
2031    end interface getrandomnumbers
2032 !
2033    interface initializerandomnumberstream
2034      module procedure initializerandomnumberstream_s,                          &
2035                       initializerandomnumberstream_v
2036    end interface initializerandomnumberstream
2037 !
2038    public :: randomnumberstream,                                               &
2039              initializerandomnumberstream, getrandomnumbers
2040 !! mji
2041 !!           initializerandomnumberstream, getrandomnumbers,                   &
2042 !!           constructSeed
2043 !
2044    contains
2045 !-------------------------------------------------------------------------------
2046 !
2047 !
2048 !-------------------------------------------------------------------------------
2049    function initializerandomnumberstream_s(seed) result(new)
2050 !-------------------------------------------------------------------------------
2051    integer(kind=im), intent(in   ) :: seed
2052    type(randomnumberstream)        :: new
2053 !-------------------------------------------------------------------------------
2054    new%thenumbers = new_randomnumbersequence(seed)
2055 !
2056    end function initializerandomnumberstream_s
2057 !-------------------------------------------------------------------------------
2058 !
2059 !
2060 !-------------------------------------------------------------------------------
2061    function initializerandomnumberstream_v(seed) result(new)
2062 !-------------------------------------------------------------------------------
2063    integer(kind=im), dimension(:), intent(in   ) :: seed
2064    type(randomnumberstream)                      :: new
2065 !-------------------------------------------------------------------------------
2066    new%thenumbers = new_randomnumbersequence(seed)
2067 !
2068    end function initializerandomnumberstream_v
2069 !-------------------------------------------------------------------------------
2070 !
2071 !
2072 !-------------------------------------------------------------------------------
2073    subroutine getrandomnumber_scalar(stream, number)
2074 !-------------------------------------------------------------------------------
2075 !
2076 !  abstract : Procedures for drawing random numbers
2077 !
2078 !-------------------------------------------------------------------------------
2079    type(randomnumberstream), intent(inout) :: stream
2080    real(kind=rb)           , intent(  out) :: number
2081 !-------------------------------------------------------------------------------
2082    number = getrandomreal(stream%thenumbers)
2083 !
2084    end subroutine getrandomnumber_scalar
2085 !-------------------------------------------------------------------------------
2086 !
2087 !
2088 !-------------------------------------------------------------------------------
2089    subroutine getrandomnumber_1d(stream, numbers)
2090 !-------------------------------------------------------------------------------
2091    type(randomnumberstream)   , intent(inout) :: stream
2092    real(kind=rb), dimension(:), intent(  out) :: numbers
2093 !
2094 ! Local variables
2095 !
2096    integer(kind=im) :: i
2097 !-------------------------------------------------------------------------------
2098 !
2099    do i = 1,size(numbers)
2100      numbers(i) = getrandomreal(stream%thenumbers)
2101    enddo
2102 !
2103    end subroutine getrandomnumber_1d
2104 !-------------------------------------------------------------------------------
2105 !
2106 !
2107 !-------------------------------------------------------------------------------
2108    subroutine getrandomnumber_2d(stream, numbers)
2109 !-------------------------------------------------------------------------------
2110    type(randomnumberstream)     , intent(inout) :: stream
2111    real(kind=rb), dimension(:,:), intent(  out) :: numbers
2112 !
2113 ! Local variables
2114 !
2115    integer(kind=im) :: i
2116 !-------------------------------------------------------------------------------
2117 !
2118    do i = 1,size(numbers,2)
2119      call getrandomnumber_1d(stream, numbers(:, i))
2120    enddo
2121 !
2122    end subroutine getrandomnumber_2d
2123 !-------------------------------------------------------------------------------
2124 ! mji
2125 !  ! ---------------------------------------------------------------------------
2126 !  ! Constructing a unique seed from grid cell index and model date/time
2127 !  !   Once we have the GFDL stuff we'll add the year, month, day, hour, minute
2128 !  ! ---------------------------------------------------------------------------
2129 !  function constructSeed(i, j, time) result(seed)
2130 !    integer(kind=im),         intent(in   )  :: i, j
2131 !    type(time_type), intent(in   ) :: time
2132 !    integer(kind=im), dimension(8) :: seed
2133 !
2134 !    ! Local variables
2135 !    integer(kind=im) :: year, month, day, hour, minute, second
2136 !
2137 !
2138 !    call get_date(time, year, month, day, hour, minute, second)
2139 !    seed = (/ i, j, year, month, day, hour, minute, second /)
2140 !  end function constructSeed
2141 !
2142 !-------------------------------------------------------------------------------
2143 !
2144 !
2145 !-------------------------------------------------------------------------------
2146    end module mcica_random_numbers_k
2147 !-------------------------------------------------------------------------------
2148 !
2149 !
2150 !-------------------------------------------------------------------------------
2151    module mcica_subcol_gen_k
2152 !-------------------------------------------------------------------------------
2153 !   --------------------------------------------------------------------------
2154 !  |                                                                          |
2155 !  |  Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER).  |
2156 !  |  This software may be used, copied, or redistributed as long as it is    |
2157 !  |  not sold and this copyright notice is reproduced on each copy made.     |
2158 !  |  This model is provided as is without any express or implied warranties. |
2159 !  |                       (http://www.rtweb.aer.com/)                        |
2160 !  |                                                                          |
2161 !   --------------------------------------------------------------------------
2162 !
2163 !  Purpose: Create McICA stochastic arrays for cloud physical or optical
2164 !  properties.
2165 !  Two options are possible:
2166 !  1) Input cloud physical properties: cloud fraction, ice and liquid water
2167 !     paths, ice fraction, and particle sizes.  Output will be stochastic
2168 !     arrays of these variables.  (inflag = 1)
2169 !  2) Input cloud optical properties directly: cloud optical depth, single
2170 !     scattering albedo and asymmetry parameter.  Output will be stochastic
2171 !     arrays of these variables.  (inflag = 0; longwave scattering is not
2172 !     yet available, ssac and asmc are for future expansion)
2173 !
2174 !-------------------------------------------------------------------------------
2175    use parkind_k,  only : im => kind_im, rb => kind_rb
2176    use parrrtm_k,  only : nbndlw, ngptlw
2177    use rrlw_con_k, only : grav
2178    use rrlw_wvn_k, only : ngb
2179    use rrlw_vsn_k
2180 !
2181    implicit none
2182 !
2183 ! public interfaces/functions/subroutines
2184 !
2185    public :: mcica_subcol, generate_stochastic_redu
2186 !
2187    contains
2188 !-------------------------------------------------------------------------------
2189 !
2190 !
2191 !-------------------------------------------------------------------------------
2192   subroutine mcica_subcol (iplon, ncol, nlay, icld, permuteseed, irng, play,   &
2193                            cldfrac, ciwp, clwp, ciwpmcl, clwpmcl,              &
2194                            cswp, cswpmcl,                                      &
2195                            cldfmcl)
2196 !-------------------------------------------------------------------------------
2197 !
2198 !  abstract :  REDUCED SUBCOLUMN FOR MCICA
2199 !  Sunghye Baek 2016.5.17
2200 !
2201 !  input :
2202 !    iplon        - column/longitude index
2203 !    ncol         - number of columns
2204 !    nlay         - number of model layers
2205 !    icld         - clear/cloud, cloud overlap flag
2206 !    permuteseed  - if the cloud generator is called multiple times, permute
2207 !                   the seed between each call.
2208 !                   recommended
2209 !                   permuteseed differes by 'ngpt'
2210 !    irng         - flag for random number generator
2211 !                   0 = kissvec
2212 !                   1 = Mersenne Twister
2213 !    play(:,:)    - layer pressures (mb)
2214 !                   Dimensions: (ncol,nlay)
2215 !    cldfrac(:,:) - layer cloud fraction
2216 !                   Dimensions: (ncol,nlay)
2217 !    ciwp(:,:)    - in-cloud ice water path
2218 !                   Dimensions: (ncol,nlay)
2219 !    clwp(:,:)    - in-cloud liquid water path
2220 !                   Dimensions: (ncol,nlay)
2221 !    cswp(:,:)    - in-cloud snow path
2222 !                   Dimensions: (ncol,nlay)
2223 !
2224 !  output :
2225 !    cldfmcl(:,:,:) - cloud fraction [mcica]
2226 !                     Dimensions: (ngptlw,ncol,nlay)
2227 !    ciwpmcl(:,:,:) - in-cloud ice water path [mcica]
2228 !                     Dimensions: (ngptlw,ncol,nlay)
2229 !    clwpmcl(:,:,:) - in-cloud liquid water path [mcica]
2230 !                     Dimensions: (ngptlw,ncol,nlay)
2231 !    cswpmcl(:,:,:) - in-cloud snow path [mcica]
2232 !                     Dimensions: (ngptlw,ncol,nlay)
2233 !
2234 !  local variables :
2235 !  nsubclw          - number of sub-columns (g-point intervals)
2236 !  ilev             - loop index
2237 !  pmid(ncol, nlay) - layer pressures (Pa)
2238 !
2239 !-------------------------------------------------------------------------------
2240 ! ----- Input -----
2241 ! Control
2242 !
2243    integer(kind=im), intent(in   ) :: iplon
2244    integer(kind=im), intent(in   ) :: ncol
2245    integer(kind=im), intent(in   ) :: nlay
2246    integer(kind=im), intent(in   ) :: icld
2247    integer(kind=im), intent(in   ) :: permuteseed
2248    integer(kind=im), intent(inout) :: irng
2249 !
2250 ! Atmosphere
2251 !
2252    real(kind=rb), dimension(:,:), intent(in   ) :: play
2253 !
2254 ! Atmosphere/clouds - cldprop
2255 !
2256    real(kind=rb), dimension(:,:), intent(in   ) :: cldfrac
2257    real(kind=rb), dimension(:,:), intent(in   ) :: ciwp
2258    real(kind=rb), dimension(:,:), intent(in   ) :: clwp
2259    real(kind=rb), dimension(:,:), intent(in   ) :: cswp
2260 !
2261 ! ----- Output -----
2262 !
2263 ! Atmosphere/clouds - cldprmc [mcica]
2264 !
2265    real(kind=rb), dimension(:,:,:), intent(  out) :: cldfmcl
2266    real(kind=rb), dimension(:,:,:), intent(  out) :: ciwpmcl
2267    real(kind=rb), dimension(:,:,:), intent(  out) :: clwpmcl
2268    real(kind=rb), dimension(:,:,:), intent(  out) :: cswpmcl
2269 !
2270 ! ----- Local -----
2271 !
2272 ! Stochastic cloud generator variables [mcica]
2273 !
2274    integer(kind=im), parameter :: nsubclw = ngptlw
2275    integer(kind=im) :: ilev
2276 !
2277    real(kind=rb), dimension(ncol, nlay) :: pmid
2278 !-------------------------------------------------------------------------------
2279 !
2280 ! Return if clear sky; or stop if icld out of range
2281 !
2282    if (icld.eq.0) return
2283    if (icld.lt.0.or.icld.gt.3) then
2284      stop 'MCICA_sUBCOL: INVALID ICLD'
2285    endif
2286 !
2287    pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
2288 !
2289    call generate_stochastic_redu(ncol, nlay, nsubclw, icld, irng, pmid,        &
2290                                  cldfrac, clwp, ciwp,                          &
2291                                  cldfmcl, clwpmcl, ciwpmcl,                    &
2292                                  cswp, cswpmcl,                                &
2293                                  permuteseed )
2294 !
2295    end subroutine mcica_subcol
2296 !-------------------------------------------------------------------------------
2297 !
2298 !
2299 !-------------------------------------------------------------------------------
2300    subroutine generate_stochastic_redu (ncol, nlay, nsubcol, icld, irng, pmid, &
2301                                         cld, clwp, ciwp,                       &
2302                                         cld_stoch, clwp_stoch, ciwp_stoch,     &
2303                                         cswp, cswp_stoch,                      &
2304                                         changeSeed )
2305 !-------------------------------------------------------------------------------
2306 !
2307 !  input :
2308 !    ncol       - number of columns
2309 !    nlay       - number of layers
2310 !    icld       - clear/cloud, cloud overlap flag
2311 !    irng       - flag for random number generator
2312 !                 0 = kissvec
2313 !                 1 = Mersenne Twister
2314 !    nsubcol    - number of sub-columns (g-point intervals)
2315 !    changeSeed - allows permuting seed
2316 !    pmid(:,:)  - layer pressure (Pa)
2317 !                 Dimensions: (ncol,nlay)
2318 !    cld(:,:)   - cloud fraction
2319 !                 Dimensions: (ncol,nlay)
2320 !    clwp(:,:)  - in-cloud liquid water path
2321 !                 Dimensions: (ncol,nlay)
2322 !    ciwp(:,:)  - in-cloud ice water path
2323 !                 Dimensions: (ncol,nlay)
2324 !    cswp(:,:)  - in-cloud snow path
2325 !                 Dimensions: (ncol,nlay)
2326 !  output :
2327 !    cld_stoch(:,:,:)  - subcolumn cloud fraction
2328 !                        Dimensions: (ngptlw,ncol,nlay)
2329 !    clwp_stoch(:,:,:) - subcolumn in-cloud liquid water path
2330 !                        Dimensions: (ngptlw,ncol,nlay)
2331 !    ciwp_stoch(:,:,:) - subcolumn in-cloud ice water path
2332 !                        Dimensions: (ngptlw,ncol,nlay)
2333 !    cswp_stoch(:,:,:) - subcolumn in-cloud snow path
2334 !                        Dimensions: (ngptlw,ncol,nlay)
2335 !    cswp_stoch(:,:,:) - subcolumn in-cloud snow path
2336 !                        Dimensions: (ngptlw,ncol,nlay)
2337 !
2338 !  local variables :
2339 !    cldf(ncol,nlay)            ! cloud fraction
2340 !    overlap                    ! 1 = random overlap,
2341 !                                 2 = maximum/random,
2342 !                                 3 = maximum overlap,
2343 !    cldmin                     ! min cloud fraction
2344 !    cdf, cdf2                  ! random numbers
2345 !    seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
2346 !    rand_num                   ! random number (kissvec)
2347 !    iseed                      ! seed to create random number(Mersenne Teister)
2348 !    rand_num_mt                ! random number (Mersenne Twister)
2349 !    iscloudy                   ! flag that says whether a gridbox is cloudy
2350 !    ilev, isubcol, i, n        ! indices
2351 !    nsub28                     ! REDUCED SUBCOL
2352 !
2353 !-------------------------------------------------------------------------------
2354    use mcica_random_numbers_k
2355 !
2356 ! The Mersenne Twister random number engine
2357 !
2358    use mersennetwister_k, only : randomnumbersequence,                         &
2359                                new_randomnumbersequence, getrandomreal
2360 !
2361    type(randomnumbersequence) :: randomnumbers
2362 !
2363 ! Arguments
2364 !
2365    integer(kind=im), intent(in   ) :: ncol
2366    integer(kind=im), intent(in   ) :: nlay
2367    integer(kind=im), intent(in   ) :: icld
2368    integer(kind=im), intent(inout) :: irng
2369    integer(kind=im), intent(in   ) :: nsubcol
2370    integer(kind=im), optional, intent(in   ) :: changeSeed
2371 !
2372 ! Column state (cloud fraction, cloud water, cloud ice) +
2373 ! variables needed to read physics state
2374 !
2375    real(kind=rb), intent(in   ) :: pmid(:,:)
2376    real(kind=rb), intent(in   ) :: cld(:,:)
2377    real(kind=rb), intent(in   ) :: clwp(:,:)
2378    real(kind=rb), intent(in   ) :: ciwp(:,:)
2379    real(kind=rb), intent(in   ) :: cswp(:,:)
2380    real(kind=rb), intent(  out) :: cld_stoch(:,:,:)
2381    real(kind=rb), intent(  out) :: clwp_stoch(:,:,:)
2382    real(kind=rb), intent(  out) :: ciwp_stoch(:,:,:)
2383    real(kind=rb), intent(  out) :: cswp_stoch(:,:,:)
2384 !
2385 ! Local variables
2386 !
2387    real(kind=rb), dimension(ncol,nlay) :: cldf
2388 !
2389 ! Set overlap
2390 !
2391    integer(kind=im) :: overlap
2392 !
2393 ! Constants (min value for cloud fraction and cloud water and ice)
2394 !
2395    real(kind=rb), parameter :: cldmin = 1.0e-20_rb
2396 !
2397 ! Variables related to random number and seed
2398 !
2399    real(kind=rb), dimension(nsubcol,ncol,nlay) :: cdf, cdf2
2400    integer(kind=im), dimension(ncol)           :: seed1, seed2, seed3, seed4
2401    real(kind=rb), dimension(ncol)              :: rand_num
2402    integer(kind=im)                            :: iseed
2403    real(kind=rb)                               :: rand_num_mt
2404 !
2405 ! Flag to identify cloud fraction in subcolumns
2406 !
2407    logical, dimension(nsubcol,ncol,nlay) :: iscloudy
2408 !
2409 ! Indices
2410 !
2411    integer(kind=im) :: ilev, isubcol, i, n
2412 !
2413 ! REDUCED SUBCOL
2414    integer(kind=im) :: nsub28 = 28
2415 !-------------------------------------------------------------------------------
2416 !
2417 ! Check that irng is in bounds; if not, set to default
2418 !
2419    if (irng.ne.0) irng = 1
2420 !
2421 ! Pass input cloud overlap setting to local variable
2422 !
2423    overlap = icld
2424 !
2425 ! Ensure that cloud fractions are in bounds
2426 !
2427    do ilev = 1,nlay
2428      do i = 1,ncol
2429        cldf(i,ilev) = cld(i,ilev)
2430        if (cldf(i,ilev) < cldmin) then
2431          cldf(i,ilev) = 0._rb
2432        endif
2433      enddo
2434    enddo
2435 !
2436 ! ----- Create seed  --------
2437 !
2438 ! Advance randum number generator by changeseed values
2439 !
2440    if (irng.eq.0) then
2441 !
2442 ! For kissvec, create a seed that depends on the state of the columns.
2443 ! Maybe not the best way, but it works.
2444 ! Must use pmid from bottom four layers.
2445 !
2446      do i = 1,ncol
2447        if (pmid(i,1).lt.pmid(i,2)) then
2448          stop 'MCICA_sUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM '//     &
2449               'BOTTOM FOUR LAYERS.'
2450        endif
2451        seed1(i) = (pmid(i,1) - int(pmid(i,1)))  * 1000000000_im
2452        seed2(i) = (pmid(i,2) - int(pmid(i,2)))  * 1000000000_im
2453        seed3(i) = (pmid(i,3) - int(pmid(i,3)))  * 1000000000_im
2454        seed4(i) = (pmid(i,4) - int(pmid(i,4)))  * 1000000000_im
2455      enddo
2456 !
2457      do i = 1,changeSeed
2458        call kissvec(seed1, seed2, seed3, seed4, rand_num)
2459      enddo
2460    else if (irng.eq.1) then
2461      randomnumbers = new_randomnumbersequence(seed = changeSeed)
2462    endif
2463 !
2464 ! ------ Apply overlap assumption --------
2465 !
2466 ! generate the random numbers
2467 !
2468    select case (overlap)
2469      case(2)
2470 !
2471 ! Maximum-random overlap
2472 ! i) pick a random number for top layer.
2473 ! ii) walk down the column:
2474 ! - if the layer above is cloudy, we use the same random number than
2475 ! in the layer above
2476 ! - if the layer above is clear, we use a new random number
2477 !
2478        if (irng.eq.0) then
2479 !        do isubcol = 1,nsubcol
2480          do isubcol = 1, nsub28
2481            do ilev = 1,nlay
2482              call kissvec(seed1, seed2, seed3, seed4, rand_num)
2483              cdf(isubcol,:,ilev) = rand_num
2484            enddo
2485          enddo
2486        else if (irng.eq.1) then
2487 !        do isubcol = 1,nsubcol
2488          do isubcol = 1, nsub28
2489            do i = 1,ncol
2490              do ilev = 1,nlay
2491                rand_num_mt = getrandomreal(randomnumbers)
2492                cdf(isubcol,i,ilev) = rand_num_mt
2493              enddo
2494            enddo
2495          enddo
2496        endif
2497 !
2498 !      do ilev = 2,nlay
2499        do ilev = nlay-1,1,-1
2500          do i = 1,ncol
2501 !          do isubcol = 1,nsubcol
2502            do isubcol = 1, nsub28
2503 !            if (cdf(isubcol, i, ilev-1)>1._rb-cldf(i,ilev-1) ) then
2504 !              cdf(isubcol,i,ilev) = cdf(isubcol,i,ilev-1)
2505              if (cdf(isubcol, i, ilev+1) > 1._rb - cldf(i,ilev+1) ) then
2506                cdf(isubcol,i,ilev) = cdf(isubcol,i,ilev+1)
2507              else
2508 !              cdf(isubcol,i,ilev) = cdf(isubcol,i,ilev)*(1._rb-cldf(i,ilev-1))
2509                cdf(isubcol,i,ilev) = cdf(isubcol,i,ilev)*(1._rb-cldf(i,ilev+1))
2510              endif
2511            enddo
2512          enddo
2513        enddo
2514    end select
2515 !
2516 ! !!!!! COPY !!!!!!!!!
2517 !
2518    cdf(nsub28+1:nsub28*2,:,:)   = cdf(1:nsub28,:,:)
2519    cdf(nsub28*2+1:nsub28*3,:,:) = cdf(1:nsub28,:,:)
2520    cdf(nsub28*3+1:nsub28*4,:,:) = cdf(1:nsub28,:,:)
2521    cdf(nsub28*4+1:nsub28*5,:,:) = cdf(1:nsub28,:,:)
2522 !
2523 ! -- generate subcolumns for homogeneous clouds -----
2524 !
2525    do ilev = 1,nlay
2526      iscloudy(:,:,ilev) = (cdf(:,:,ilev)>=                                     &
2527                            1._rb-spread(cldf(:,ilev), dim=1, nCopies=nsubcol))
2528    enddo
2529 !
2530 ! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
2531 ! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
2532 ! where there is a cloud, define the subcolumn cloud properties,
2533 ! otherwise set these to zero
2534 !
2535    do ilev = 1,nlay
2536      do i = 1,ncol
2537        do isubcol = 1,nsubcol
2538          if (iscloudy(isubcol,i,ilev) ) then
2539            cld_stoch(isubcol,i,ilev) = 1._rb
2540            clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
2541            ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
2542            cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
2543          else
2544            cld_stoch(isubcol,i,ilev) = 0._rb
2545            clwp_stoch(isubcol,i,ilev) = 0._rb
2546            ciwp_stoch(isubcol,i,ilev) = 0._rb
2547            cswp_stoch(isubcol,i,ilev) = 0._rb
2548          endif
2549        enddo
2550      enddo
2551    enddo
2552 !
2553   end subroutine generate_stochastic_redu
2554 !-------------------------------------------------------------------------------
2555 !
2556 ! Private subroutines
2557 !
2558 !-------------------------------------------------------------------------------
2559    subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
2560 !-------------------------------------------------------------------------------
2561 !
2562 ! public domain code
2563 ! made available from http://www.fortran.com/
2564 ! downloaded by pjr on 03/16/04 for NCAR CAM
2565 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
2566 !
2567 ! The  KISS (Keep It Simple Stupid) random number generator. Combines:
2568 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
2569 ! (2) A 3-shift shift-register generator, period 2^32-1,
2570 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
2571 !  Overall period>2^123;
2572 !
2573 !-------------------------------------------------------------------------------
2574    real(kind=rb), dimension(:), intent(inout)  :: ran_arr
2575    integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
2576    integer(kind=im) :: i,sz,kiss
2577    integer(kind=im) :: m, k, n
2578 !-------------------------------------------------------------------------------
2579 !
2580 ! inline function
2581 !
2582    m(k, n) = ieor (k, ishft (k, n) )
2583 !
2584    sz = size(ran_arr)
2585 !
2586    do i = 1,sz
2587      seed1(i) = 69069_im*seed1(i)+1327217885_im
2588      seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
2589      seed3(i) = 18000_im*iand(seed3(i),65535_im)+ishft(seed3(i),- 16_im)
2590      seed4(i) = 30903_im*iand(seed4(i),65535_im)+ishft(seed4(i),- 16_im)
2591      kiss = seed1(i)+seed2(i)+ishft(seed3(i),16_im)+seed4(i)
2592      ran_arr(i) = kiss*2.328306e-10_rb+0.5_rb
2593    enddo
2594 !
2595    end subroutine kissvec
2596 !-------------------------------------------------------------------------------
2597 !
2598 !
2599 !-------------------------------------------------------------------------------
2600    end module mcica_subcol_gen_k
2601 !-------------------------------------------------------------------------------
2602 !
2603 !
2604 !-------------------------------------------------------------------------------
2605    module rrtmg_lw_cldprmc_k
2606 !-------------------------------------------------------------------------------
2607 !   --------------------------------------------------------------------------
2608 !  |                                                                          |
2609 !  |  Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER).  |
2610 !  |  This software may be used, copied, or redistributed as long as it is    |
2611 !  |  not sold and this copyright notice is reproduced on each copy made.     |
2612 !  |  This model is provided as is without any express or implied warranties. |
2613 !  |                       (http://www.rtweb.aer.com/)                        |
2614 !  |                                                                          |
2615 !   --------------------------------------------------------------------------
2616 !-------------------------------------------------------------------------------
2617    use parkind_k,  only : im => kind_im, rb => kind_rb
2618    use parrrtm_k,  only : ngptlw, nbndlw
2619    use rrlw_cld_k, only : abscld1, absliq0, absliq1,                           &
2620                         absice0, absice1, absice2, absice3
2621    use rrlw_wvn_k, only : ngb
2622    use rrlw_vsn_k, only : hvrclc, hnamclc
2623 !
2624    implicit none
2625 !
2626    contains
2627 !-------------------------------------------------------------------------------
2628 !
2629 !
2630 !-------------------------------------------------------------------------------
2631    subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc,               &
2632                       ciwpmc, clwpmc, reicmc, relqmc,                          &
2633                       cswpmc, resnmc,                                          &
2634                       ncbands, taucmc)
2635 !-------------------------------------------------------------------------------
2636 !
2637 !  Purpose:  Compute the cloud optical depth(s) for each cloudy layer.
2638 !
2639 !  input :
2640 !    nlayers      - total number of layers
2641 !    nflag        - see definitions
2642 !    ceflag       - see definitions
2643 !    iqflag       - see definitions
2644 !    cldfmc(:,:)  - cloud fraction [mcica]
2645 !                   Dimensions: (ngptlw,nlayers)
2646 !    ciwpmc(:,:)  - cloud ice water path [mcica]
2647 !                   Dimensions: (ngptlw,nlayers)
2648 !    clwpmc(:,:)  - cloud liquid water path [mcica]
2649 !                   Dimensions: (ngptlw,nlayers)
2650 !    cswpmc(:,:)  - cloud snow path [mcica]
2651 !                   Dimensions: (ngptlw,nlayers)
2652 !    relqmc(:)    - liquid particle effective radius (microns)
2653 !                   Dimensions: (nlayers)
2654 !    reicmc(:)    - ice particle effective radius (microns)
2655 !                   Dimensions: (nlayers)
2656 !    resnmc(:)    - snow particle effective radius (microns)
2657 !                   Dimensions: (nlayers)
2658 !  output :
2659 !    ncbands      - number of cloud spectral bands
2660 !    taucmc(:,:)  - cloud optical depth [mcica]
2661 !                   Dimensions: (ngptlw,nlayers)
2662 !
2663 !  local variables :
2664 !    lay                 - Layer index
2665 !    ib                  - spectral band index
2666 !    ig                  - g-point interval index
2667 !    index
2668 !    icb(nbndlw)
2669 !    abscoice(ngptlw)    - ice absorption coefficients
2670 !    abscoliq(ngptlw)    - liquid absorption coefficients
2671 !    abscosno(ngptlw)    - snow absorption coefficients
2672 !    cwp                 - cloud water path
2673 !    radice              - cloud ice effective size (microns)
2674 !    factor              -
2675 !    fint                -
2676 !    radliq              - cloud liquid droplet radius (microns)
2677 !    radsno              - cloud snow effective size (microns)
2678 !    eps                 - epsilon
2679 !    cldmin              - minimum value for cloud quantities
2680 !
2681 !-------------------------------------------------------------------------------
2682 !
2683 ! Input
2684 !
2685    integer(kind=im), intent(in   ) :: nlayers
2686    integer(kind=im), intent(in   ) :: inflag
2687    integer(kind=im), intent(in   ) :: iceflag
2688    integer(kind=im), intent(in   ) :: liqflag
2689 !
2690    real(kind=rb), dimension(:,:), intent(in   ) :: cldfmc
2691    real(kind=rb), dimension(:,:), intent(in   ) :: ciwpmc
2692    real(kind=rb), dimension(:,:), intent(in   ) :: clwpmc
2693    real(kind=rb), dimension(:,:), intent(in   ) :: cswpmc
2694    real(kind=rb), dimension(:)  , intent(in   ) :: relqmc
2695    real(kind=rb), dimension(:)  , intent(in   ) :: reicmc
2696    real(kind=rb), dimension(:)  , intent(in   ) :: resnmc
2697 !
2698 ! specific definition of reicmc depends on setting of iceflag:
2699 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
2700 !              r_ec must be >= 10.0 microns
2701 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
2702 !              r_ec range is limited to 13.0 to 130.0 microns
2703 ! iceflag = 2: ice effective radius, r_k, (Key, streamer Ref. Manual, 1996)
2704 !              r_k range is limited to 5.0 to 131.0 microns
2705 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
2706 !              dge range is limited to 5.0 to 140.0 microns
2707 !              [dge = 1.0315 * r_ec]
2708 !
2709 ! Output
2710 !
2711    integer(kind=im)             , intent(  out) :: ncbands
2712    real(kind=rb), dimension(:,:), intent(inout) :: taucmc
2713 !
2714 ! Local
2715 !
2716    integer(kind=im)                    :: lay
2717    integer(kind=im)                    :: ib
2718    integer(kind=im)                    :: ig
2719    integer(kind=im)                    :: index
2720    integer(kind=im), dimension(nbndlw) :: icb
2721 !
2722    real(kind=rb), dimension(ngptlw) :: abscoice
2723    real(kind=rb), dimension(ngptlw) :: abscoliq
2724    real(kind=rb), dimension(ngptlw) :: abscosno
2725    real(kind=rb) :: cwp
2726    real(kind=rb) :: radice
2727    real(kind=rb) :: factor
2728    real(kind=rb) :: fint
2729    real(kind=rb) :: radliq
2730    real(kind=rb) :: radsno
2731    real(kind=rb), parameter :: eps = 1.e-6_rb
2732    real(kind=rb), parameter :: cldmin = 1.e-20_rb
2733 !
2734 ! Definitions
2735 !
2736 !     Explanation of the method for each value of INFLAG.  Values of
2737 !     0 or 1 for INFLAG do not distingish being liquid and ice clouds.
2738 !     INFLAG = 2 does distinguish between liquid and ice clouds, and
2739 !     requires further user input to specify the method to be used to
2740 !     compute the aborption due to each.
2741 !     INFLAG = 0:  For each cloudy layer, the cloud fraction and (gray)
2742 !                  optical depth are input.
2743 !     INFLAG = 1:  For each cloudy layer, the cloud fraction and cloud
2744 !                  water path (g/m2) are input.  The (gray) cloud optical
2745 !                  depth is computed as in CCM2.
2746 !     INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud
2747 !                  water path (g/m2), and cloud ice fraction are input.
2748 !       ICEFLAG = 0:  The ice effective radius (microns) is input and the
2749 !                     optical depths due to ice clouds are computed as in CCM3.
2750 !       ICEFLAG = 1:  The ice effective radius (microns) is input and the
2751 !                     optical depths due to ice clouds are computed as in
2752 !                     Ebert and Curry, JGR, 97, 3831-3836 (1992).  The
2753 !                     spectral regions in this work have been matched with
2754 !                     the spectral bands in RRTM to as great an extent
2755 !                     as possible:
2756 !                     E&C 1      IB = 5      RRTM bands 9-16
2757 !                     E&C 2      IB = 4      RRTM bands 6-8
2758 !                     E&C 3      IB = 3      RRTM bands 3-5
2759 !                     E&C 4      IB = 2      RRTM band 2
2760 !                     E&C 5      IB = 1      RRTM band 1
2761 !       ICEFLAG = 2:  The ice effective radius (microns) is input and the
2762 !                     optical properties due to ice clouds are computed from
2763 !                     the optical properties stored in the RT code,
2764 !                     STREAMER v3.0 (Reference: Key. J., streamer
2765 !                     User's Guide, Cooperative Institute for
2766 !                     Meteorological Satellite Studies, 2001, 96 pp.).
2767 !                     Valid range of values for re are between 5.0 and
2768 !                     131.0 micron.
2769 !       ICEFLAG = 3: The ice generalized effective size (dge) is input
2770 !                    and the optical properties, are calculated as in
2771 !                    Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
2772 !                    tables which were appropriately averaged for the
2773 !                    bands in RRTM_LW.  Linear interpolation is used to
2774 !                    get the coefficients from the stored tables.
2775 !                    Valid range of values for dge are between 5.0 and
2776 !                    140.0 micron.
2777 !       LIQFLAG = 0:  The optical depths due to water clouds are computed as
2778 !                     in CCM3.
2779 !       LIQFLAG = 1:  The water droplet effective radius (microns) is input
2780 !                     and the optical depths due to water clouds are computed
2781 !                     as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
2782 !                     The values for absorption coefficients appropriate for
2783 !                     the spectral bands in RRTM have been obtained for a
2784 !                     range of effective radii by an averaging procedure
2785 !                     based on the work of J. Pinto (private communication).
2786 !                     Linear interpolation is used to get the absorption
2787 !                     coefficients for the input effective radius.
2788 !-------------------------------------------------------------------------------
2789    data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/
2790 !
2791    hvrclc = '$Revision: 1.8 $'
2792 !
2793    ncbands = 1
2794 !
2795 ! This initialization is done in rrtmg_lw_subcol.F90.
2796 !      do lay = 1, nlayers
2797 !         do ig = 1, ngptlw
2798 !            taucmc(ig,lay) = 0.0_rb
2799 !         enddo
2800 !      enddo
2801 !
2802 ! Main layer loop
2803 !
2804    do lay = 1,nlayers
2805 !
2806      do ig = 1,ngptlw
2807        cwp = ciwpmc(ig,lay)+clwpmc(ig,lay)+cswpmc(ig,lay)
2808        if (cldfmc(ig,lay).ge.cldmin .and.                                      &
2809           (cwp.ge.cldmin .or. taucmc(ig,lay).ge.cldmin)) then
2810 !
2811 ! Ice clouds and water clouds combined.
2812 !
2813          if (inflag.eq.0) then
2814 !
2815 ! Cloud optical depth already defined in taucmc, return to main program
2816 !
2817            return
2818 !
2819          else if (inflag.eq.1) then
2820            stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
2821 !          cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
2822 !          taucmc(ig,lay) = abscld1 * cwp
2823 !
2824 ! Separate treatement of ice clouds and water clouds.
2825 !
2826          else if (inflag.ge.2) then
2827            radice = reicmc(lay)
2828 !
2829 ! Calculation of absorption coefficients due to ice clouds.
2830 !
2831            if ((ciwpmc(ig,lay)+cswpmc(ig,lay)).eq.0.0_rb) then
2832              abscoice(ig) = 0.0_rb
2833              abscosno(ig) = 0.0_rb
2834            else if (iceflag.eq.0) then
2835              if (radice.lt.10.0_rb) stop 'ICE RADIUS TOO SMALL'
2836              abscoice(ig) = absice0(1) + absice0(2)/radice
2837              abscosno(ig) = 0.0_rb
2838            else if (iceflag.eq.1) then
2839              if (radice.lt.13.0_rb .or. radice.gt.130._rb) stop                &
2840                'ICE RADIUS out OF BOUNDS'
2841              ncbands = 5
2842              ib = icb(ngb(ig))
2843              abscoice(ig) = absice1(1,ib)+absice1(2,ib)/radice
2844              abscosno(ig) = 0.0_rb
2845 !
2846 ! For iceflag=2 option, ice particle effective radius is limited
2847 ! to 5.0 to 131.0 microns
2848 !
2849            else if (iceflag.eq.2) then
2850              if (radice.lt.5.0_rb .or. radice.gt.131.0_rb) stop                &
2851                'ICE RADIUS out OF BOUNDS'
2852              ncbands = 16
2853              factor = (radice-2._rb)/3._rb
2854              index = int(factor)
2855              if (index.eq.43) index = 42
2856              fint = factor-real(index)
2857              ib = ngb(ig)
2858              abscoice(ig) = absice2(index,ib)+fint*                            &
2859                            (absice2(index+1,ib)-(absice2(index,ib)))
2860              abscosno(ig) = 0.0_rb
2861 !
2862 ! For iceflag=3 option, ice particle generalized effective size is limited
2863 ! to 5.0 to 140.0 microns
2864 !
2865            else if (iceflag .ge. 3) then
2866              if (radice.lt.5.0_rb .or. radice.gt.140.0_rb) stop                &
2867                'ICE GENERALIZED EFFECTIVE SIZE out OF BOUNDS'
2868              ncbands = 16
2869              factor = (radice-2._rb)/3._rb
2870              index = int(factor)
2871              if (index.eq.46) index = 45
2872              fint = factor-real(index)
2873              ib = ngb(ig)
2874              abscoice(ig) = absice3(index,ib)+fint*                            &
2875                            (absice3(index+1,ib)-(absice3(index,ib)))
2876              abscosno(ig) = 0.0_rb
2877            endif
2878 !
2879 ! Incorporate additional effects due to snow.
2880 !
2881            if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag.eq.5) then
2882              radsno = resnmc(lay)
2883              if (radsno.lt.5.0_rb .or. radsno.gt.140.0_rb) stop                &
2884                'ERROR: SNOW GENERALIZED EFFECTIVE SIZE out OF BOUNDS'
2885              ncbands = 16
2886              factor = (radsno-2._rb)/3._rb
2887              index = int(factor)
2888              if (index.eq.46) index = 45
2889              fint = factor-real(index)
2890              ib = ngb(ig)
2891              abscosno(ig) = absice3(index,ib)+fint*                            &
2892                            (absice3(index+1,ib) - (absice3(index,ib)))
2893            endif
2894 !
2895 ! Calculation of absorption coefficients due to water clouds.
2896 !
2897            if (clwpmc(ig,lay).eq.0.0_rb) then
2898              abscoliq(ig) = 0.0_rb
2899 !
2900            else if (liqflag.eq.0) then
2901              abscoliq(ig) = absliq0
2902 !
2903            else if (liqflag.eq.1) then
2904              radliq = relqmc(lay)
2905              if (radliq.lt.2.5_rb .or. radliq.gt.60._rb) stop                  &
2906                        'LIQUID EFFECTIVE RADIUS out OF BOUNDS'
2907              index = int(radliq-1.5_rb)
2908              if (index.eq.0) index = 1
2909              if (index.eq.58) index = 57
2910              fint = radliq-1.5_rb-real(index)
2911              ib = ngb(ig)
2912              abscoliq(ig) = absliq1(index,ib)+fint*                            &
2913                            (absliq1(index+1,ib)-(absliq1(index,ib)))
2914            endif
2915 !
2916            taucmc(ig,lay) = ciwpmc(ig,lay)*abscoice(ig) +                      &
2917                             clwpmc(ig,lay)*abscoliq(ig) +                      &
2918                             cswpmc(ig,lay)*abscosno(ig)
2919          endif
2920        endif
2921      enddo
2922    enddo
2923 !
2924    end subroutine cldprmc
2925 !-------------------------------------------------------------------------------
2926 !
2927 !
2928 !-------------------------------------------------------------------------------
2929    end module rrtmg_lw_cldprmc_k
2930 !-------------------------------------------------------------------------------
2931 !
2932 !
2933 !-------------------------------------------------------------------------------
2934    module rrtmg_lw_rtrnmc_k
2935 !-------------------------------------------------------------------------------
2936 !   --------------------------------------------------------------------------
2937 !  |                                                                          |
2938 !  |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
2939 !  |  This software may be used, copied, or redistributed as long as it is    |
2940 !  |  not sold and this copyright notice is reproduced on each copy made.     |
2941 !  |  This model is provided as is without any express or implied warranties. |
2942 !  |                       (http://www.rtweb.aer.com/)                        |
2943 !  |                                                                          |
2944 !   --------------------------------------------------------------------------
2945 !-------------------------------------------------------------------------------
2946    use parkind_k,  only : im => kind_im, rb => kind_rb
2947    use parrrtm_k,  only : mg, nbndlw, ngptlw
2948    use rrlw_con_k, only : fluxfac, heatfac
2949    use rrlw_wvn_k, only : delwave, ngb, ngs
2950    use rrlw_tbl_k, only : tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
2951    use rrlw_vsn_k, only : hvrrtc, hnamrtc
2952 !
2953    implicit none
2954 !
2955    real(kind=rb) :: wtdiff, rec_6
2956 !
2957 ! diffusivity angle adjustment coefficients
2958 !
2959    real(kind=rb), dimension(nbndlw) :: a0, a1, a2
2960 !
2961 ! This secant and weight corresponds to the standard diffusivity
2962 ! angle.  This initial value is redefined below for some bands.
2963 !
2964    data wtdiff /0.5_rb/
2965    data rec_6 /0.166667_rb/
2966 !
2967 ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
2968 ! and 1.80) as a function of total column water vapor.  The function
2969 ! has been defined to minimize flux and cooling rate errors in these bands
2970 ! over a wide range of precipitable water values.
2971 !
2972    data a0 / 1.66_rb,  1.55_rb,   1.58_rb,  1.66_rb,                           &
2973              1.54_rb,  1.454_rb,  1.89_rb,  1.33_rb,                           &
2974              1.668_rb, 1.66_rb,   1.66_rb,  1.66_rb,                           &
2975              1.66_rb,  1.66_rb,   1.66_rb,  1.66_rb /
2976    data a1 / 0.00_rb,  0.25_rb,   0.22_rb,  0.00_rb,                           &
2977              0.13_rb,  0.446_rb, -0.10_rb,  0.40_rb,                           &
2978             -0.006_rb, 0.00_rb,   0.00_rb,  0.00_rb,                           &
2979              0.00_rb,  0.00_rb,   0.00_rb,  0.00_rb /
2980    data a2 / 0.00_rb, -12.0_rb,  -11.7_rb,  0.00_rb,                           &
2981             -0.72_rb, -0.243_rb,  0.19_rb, -0.062_rb,                          &
2982              0.414_rb, 0.00_rb,   0.00_rb,  0.00_rb,                           &
2983              0.00_rb,  0.00_rb,   0.00_rb,  0.00_rb /
2984 !
2985    contains
2986 !-------------------------------------------------------------------------------
2987 !
2988 !
2989 !-------------------------------------------------------------------------------
2990    subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands,         &
2991                      cldfmc, taucmc, planklay, planklev, plankbnd,             &
2992                      pwvcm, fracs, taut,                                       &
2993                      totuflux, totdflux, fnet, htr,                            &
2994                      totuclfl, totdclfl, fnetc, htrc )
2995 !-------------------------------------------------------------------------------
2996 !
2997 !  Original version:   E. J. Mlawer, et al. RRTM_v3.0
2998 !  Revision for GCMs:  Michael J. Iacono; October, 2002
2999 !  Revision for F90:  Michael J. Iacono; June, 2006
3000 !
3001 !  This program calculates the upward fluxes, downward fluxes, and
3002 !  heating rates for an arbitrary clear or cloudy atmosphere.  The input
3003 !  to this program is the atmospheric profile, all Planck function
3004 !  information, and the cloud fraction by layer.  A variable diffusivity
3005 !  angle (SECDIFF) is used for the angle integration.  Bands 2-3 and 5-9
3006 !  use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
3007 !  the column water vapor, and other bands use a value of 1.66.  The Gaussian
3008 !  weight appropriate to this angle (WTDIFF=0.5) is applied here.  Note that
3009 !  use of the emissivity angle for the flux integration can cause errors of
3010 !  1 to 4 W/m2 within cloudy layers.
3011 !  Clouds are treated with the McICA stochastic approach and maximum-random
3012 !  cloud overlap.
3013 !
3014 !  input :
3015 !    nlayers         - total number of layers
3016 !    istart          - beginning band of calculation
3017 !    iend            - ending band of calculation
3018 !    iout            - output option flag
3019 !    pz(0:)          - level (interface) pressures (hPa, mb)
3020 !                      Dimensions: (0:nlayers)
3021 !    pwvcm           - precipitable water vapor (cm)
3022 !    semiss(:)       - lw surface emissivity
3023 !                      Dimensions: (nbndlw)
3024 !    planklay(:,:)
3025 !                      Dimensions: (nlayers,nbndlw)
3026 !    planklev(0:,:)
3027 !                      Dimensions: (0:nlayers,nbndlw)
3028 !    plankbnd(:)
3029 !                      Dimensions: (nbndlw)
3030 !    fracs(:,:)
3031 !                      Dimensions: (nlayers,ngptw)
3032 !    taut(:,:)       - gaseous + aerosol optical depths
3033 !                      Dimensions: (nlayers,ngptlw)
3034 !    ncbands         - number of cloud spectral bands
3035 !    cldfmc(:,:)     - layer cloud fraction [mcica]
3036 !                      Dimensions: (ngptlw,nlayers)
3037 !    taucmc(:,:)     - layer cloud optical depth [mcica]
3038 !                      Dimensions: (ngptlw,nlayers)
3039 !  output :
3040 !    totuflux(0:)    - upward longwave flux (w/m2)
3041 !                      Dimensions: (0:nlayers)
3042 !    totdflux(0:)    - downward longwave flux (w/m2)
3043 !                      Dimensions: (0:nlayers)
3044 !    fnet(0:)        - net longwave flux (w/m2)
3045 !                      Dimensions: (0:nlayers)
3046 !    htr(0:)         - longwave heating rate (k/day)
3047 !                      Dimensions: (0:nlayers)
3048 !    totuclfl(0:)    - clear sky upward longwave flux (w/m2)
3049 !                      Dimensions: (0:nlayers)
3050 !    totdclfl(0:)    - clear sky downward longwave flux (w/m2)
3051 !                      Dimensions: (0:nlayers)
3052 !    fnetc(0:)       - clear sky net longwave flux (w/m2)
3053 !                      Dimensions: (0:nlayers)
3054 !    htrc(0:)        - clear sky longwave heating rate (k/day)
3055 !                      Dimensions: (0:nlayers)
3056 !
3057 !  local variables :
3058 !    secdiff(nbndlw)                   - secant of diffusivity angle
3059 !    icldlyr(nlayers)                  - flag for cloud in layer
3060 !    ibnd, ib, iband, lay, lev, l, ig  - loop indices
3061 !    igc                               - g-point interval counter
3062 !    iclddn                            - flag for cloud in down path
3063 !    ittot, itgas, itr                 - lookup table indices
3064 !
3065 ! ------- Definitions -------
3066 !  input
3067 !    nlayers                    ! number of model layers
3068 !    ngptlw                     ! total number of g-point subintervals
3069 !    nbndlw                     ! number of longwave spectral bands
3070 !    ncbands                    ! number of spectral bands for clouds
3071 !    secdiff                    ! diffusivity angle
3072 !    wtdiff                     ! weight for radiance to flux conversion
3073 !    pavel                      ! layer pressures (mb)
3074 !    pz                         ! level (interface) pressures (mb)
3075 !    tavel                      ! layer temperatures (k)
3076 !    tz                         ! level (interface) temperatures(mb)
3077 !    tbound                     ! surface temperature (k)
3078 !    cldfrac                    ! layer cloud fraction
3079 !    taucloud                   ! layer cloud optical depth
3080 !    itr                        ! integer look-up table index
3081 !    icldlyr                    ! flag for cloudy layers
3082 !    iclddn                     ! flag for cloud in column at any layer
3083 !    semiss                     ! surface emissivities for each band
3084 !    reflect                    ! surface reflectance
3085 !    bpade                      ! 1/(pade constant)
3086 !    tau_tbl                    ! clear sky optical depth look-up table
3087 !    exp_tbl                    ! exponential look-up table for transmittance
3088 !    tfn_tbl                    ! tau transition function look-up table
3089 !
3090 !  local
3091 !    atrans                     ! gaseous absorptivity
3092 !    abscld                     ! cloud absorptivity
3093 !    atot                       ! combined gaseous and cloud absorptivity
3094 !    odclr                      ! clear sky (gaseous) optical depth
3095 !    odcld                      ! cloud optical depth
3096 !    odtot                      ! optical depth of gas and cloud
3097 !    tfacgas                    ! gas-only pade factor, used for planck fn
3098 !    tfactot                    ! gas and cloud pade factor, used for planck fn
3099 !    bbdgas                     ! gas-only planck function for downward rt
3100 !    bbugas                     ! gas-only planck function for upward rt
3101 !    bbdtot                     ! gas and cloud planck function for downward rt
3102 !    bbutot                     ! gas and cloud planck function for upward calc.
3103 !    gassrc                     ! source radiance due to gas only
3104 !    efclfrac                   ! effective cloud fraction
3105 !    radlu                      ! spectrally summed upward radiance
3106 !    radclru                    ! spectrally summed clear sky upward radiance
3107 !    urad                       ! upward radiance by layer
3108 !    clrurad                    ! clear sky upward radiance by layer
3109 !    radld                      ! spectrally summed downward radiance
3110 !    radclrd                    ! spectrally summed clear sky downward radiance
3111 !    drad                       ! downward radiance by layer
3112 !    clrdrad                    ! clear sky downward radiance by layer
3113 !
3114 !  output
3115 !    totuflux                   ! upward longwave flux (w/m2)
3116 !    totdflux                   ! downward longwave flux (w/m2)
3117 !    fnet                       ! net longwave flux (w/m2)
3118 !    htr                        ! longwave heating rate (k/day)
3119 !    totuclfl                   ! clear sky upward longwave flux (w/m2)
3120 !    totdclfl                   ! clear sky downward longwave flux (w/m2)
3121 !    fnetc                      ! clear sky net longwave flux (w/m2)
3122 !    htrc                       ! clear sky longwave heating rate (k/day)
3123 !
3124 !-------------------------------------------------------------------------------
3125 !
3126 ! Declarations
3127 !
3128 ! Input
3129 !
3130    integer(kind=im), intent(in   ) :: nlayers
3131    integer(kind=im), intent(in   ) :: istart
3132    integer(kind=im), intent(in   ) :: iend
3133    integer(kind=im), intent(in   ) :: iout
3134 !
3135 ! Atmosphere
3136 !
3137    real(kind=rb), dimension(0:)  , intent(in   ) :: pz
3138    real(kind=rb)                 , intent(in   ) :: pwvcm
3139    real(kind=rb), dimension(:)   , intent(in   ) :: semiss
3140    real(kind=rb), dimension(:,:) , intent(in   ) :: planklay
3141    real(kind=rb), dimension(0:,:), intent(in   ) :: planklev
3142    real(kind=rb), dimension(:)   , intent(in   ) :: plankbnd
3143    real(kind=rb), dimension(:,:) , intent(in   ) :: fracs
3144    real(kind=rb), dimension(:,:) , intent(in   ) :: taut
3145 !
3146 ! Clouds
3147 !
3148    integer(kind=im)             , intent(in   ) :: ncbands
3149    real(kind=rb), dimension(:,:), intent(in   ) :: cldfmc
3150    real(kind=rb), dimension(:,:), intent(in   ) :: taucmc
3151 !
3152 ! Output
3153 !
3154    real(kind=rb), dimension(0:), intent(  out) :: totuflux
3155    real(kind=rb), dimension(0:), intent(  out) :: totdflux
3156    real(kind=rb), dimension(0:), intent(  out) :: fnet
3157    real(kind=rb), dimension(0:), intent(  out) :: htr
3158    real(kind=rb), dimension(0:), intent(  out) :: totuclfl
3159    real(kind=rb), dimension(0:), intent(  out) :: totdclfl
3160    real(kind=rb), dimension(0:), intent(  out) :: fnetc
3161    real(kind=rb), dimension(0:), intent(  out) :: htrc
3162 !
3163 ! Local
3164 !
3165 ! Declarations for radiative transfer
3166 !
3167    real(kind=rb), dimension(nlayers,ngptlw) :: abscld
3168    real(kind=rb), dimension(nlayers)        :: atot
3169    real(kind=rb), dimension(nlayers)        :: atrans
3170    real(kind=rb), dimension(nlayers)        :: bbugas
3171    real(kind=rb), dimension(nlayers)        :: bbutot
3172    real(kind=rb), dimension(0:nlayers)      :: clrurad
3173    real(kind=rb), dimension(0:nlayers)      :: clrdrad
3174    real(kind=rb), dimension(nlayers,ngptlw) :: efclfrac
3175    real(kind=rb), dimension(0:nlayers)      :: uflux
3176    real(kind=rb), dimension(0:nlayers)      :: dflux
3177    real(kind=rb), dimension(0:nlayers)      :: urad
3178    real(kind=rb), dimension(0:nlayers)      :: drad
3179    real(kind=rb), dimension(0:nlayers)      :: uclfl
3180    real(kind=rb), dimension(0:nlayers)      :: dclfl
3181    real(kind=rb), dimension(nlayers,ngptlw) :: odcld
3182 !
3183    real(kind=rb), dimension(nbndlw)         :: secdiff
3184 !
3185    real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
3186    real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
3187    real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
3188    real(kind=rb) :: rad0, reflect, radlu, radclru
3189 !
3190    integer(kind=im), dimension(nlayers) :: icldlyr
3191    integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig
3192    integer(kind=im) :: igc
3193    integer(kind=im) :: iclddn
3194    integer(kind=im) :: ittot, itgas, itr
3195 !-------------------------------------------------------------------------------
3196 !
3197    hvrrtc = '$Revision: 1.3 $'
3198 !
3199    do ibnd = 1,nbndlw
3200      if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
3201        secdiff(ibnd) = 1.66_rb
3202      else
3203        secdiff(ibnd) = a0(ibnd)+a1(ibnd)*exp(a2(ibnd)*pwvcm)
3204        if (secdiff(ibnd).gt.1.80_rb) secdiff(ibnd) = 1.80_rb
3205        if (secdiff(ibnd).lt.1.50_rb) secdiff(ibnd) = 1.50_rb
3206      endif
3207    enddo
3208 !
3209    urad     = 0.0_rb
3210    drad     = 0.0_rb
3211    totuflux = 0.0_rb
3212    totdflux = 0.0_rb
3213    clrurad  = 0.0_rb
3214    clrdrad  = 0.0_rb
3215    totuclfl = 0.0_rb
3216    totdclfl = 0.0_rb
3217    icldlyr  = 0
3218 !
3219    do lay = 1,nlayers
3220 !
3221 ! Change to band loop?
3222 !
3223      do ig = 1,ngptlw
3224        if (cldfmc(ig,lay).eq.1._rb) then
3225          ib = ngb(ig)
3226          odcld(lay,ig) = secdiff(ib)*taucmc(ig,lay)
3227          transcld = exp(-odcld(lay,ig))
3228          abscld(lay,ig) = 1._rb-transcld
3229          efclfrac(lay,ig) = abscld(lay,ig)*cldfmc(ig,lay)
3230          icldlyr(lay) = 1
3231        else
3232          odcld(lay,ig) = 0.0_rb
3233          abscld(lay,ig) = 0.0_rb
3234          efclfrac(lay,ig) = 0.0_rb
3235        endif
3236      enddo
3237    enddo
3238 !
3239    igc = 1
3240 !
3241 ! Loop over frequency bands.
3242 !
3243    do iband = istart,iend
3244 !
3245 ! Reinitialize g-point counter for each band if output for each band
3246 ! is requested.
3247 !
3248      if (iout.gt.0 .and. iband.ge.2) igc = ngs(iband-1)+1
3249 !
3250 ! Loop over g-channels.
3251 !
3252      1000 continue
3253 !
3254 ! Radiative transfer starts here.
3255 !
3256      radld = 0._rb
3257      radclrd = 0._rb
3258      iclddn = 0
3259 !
3260 ! Downward radiative transfer loop.
3261 !
3262      do lev = nlayers,1,-1
3263        plfrac = fracs(lev,igc)
3264        blay = planklay(lev,iband)
3265        dplankup = planklev(lev,iband)-blay
3266        dplankdn = planklev(lev-1,iband)-blay
3267        odepth = secdiff(iband)*taut(lev,igc)
3268        if (odepth.lt.0.0_rb) odepth = 0.0_rb
3269 !
3270 !  Cloudy layer
3271 !
3272        if (icldlyr(lev).eq.1) then
3273          iclddn = 1
3274          odtot = odepth+odcld(lev,igc)
3275          if (odtot.lt.0.06_rb) then
3276            atrans(lev) = odepth-0.5_rb*odepth*odepth
3277            odepth_rec = rec_6*odepth
3278            gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3279 !
3280            atot(lev) =  odtot - 0.5_rb*odtot*odtot
3281            odtot_rec = rec_6*odtot
3282            bbdtot =  plfrac * (blay+dplankdn*odtot_rec)
3283            bbd = plfrac*(blay+dplankdn*odepth_rec)
3284            radld = radld-radld*(atrans(lev)+efclfrac(lev,igc)*                 &
3285                    (1.-atrans(lev)))+&
3286                    gassrc + cldfmc(igc,lev)*(bbdtot*atot(lev)-gassrc)
3287            drad(lev-1) = drad(lev-1)+radld
3288 !
3289            bbugas(lev) =  plfrac*(blay+dplankup*odepth_rec)
3290            bbutot(lev) =  plfrac*(blay+dplankup*odtot_rec)
3291 !
3292          else if (odepth.le.0.06_rb) then
3293            atrans(lev) = odepth-0.5_rb*odepth*odepth
3294            odepth_rec = rec_6*odepth
3295            gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
3296 !
3297            odtot = odepth+odcld(lev,igc)
3298            tblind = odtot/(bpade+odtot)
3299            ittot = tblint*tblind+0.5_rb
3300            tfactot = tfn_tbl(ittot)
3301            bbdtot = plfrac*(blay+tfactot*dplankdn)
3302            bbd = plfrac*(blay+dplankdn*odepth_rec)
3303            atot(lev) = 1.-exp_tbl(ittot)
3304 !
3305            radld = radld-radld*(atrans(lev)+                                   &
3306                    efclfrac(lev,igc)*(1._rb-atrans(lev)))+                     &
3307                    gassrc+cldfmc(igc,lev)*(bbdtot*atot(lev)-gassrc)
3308            drad(lev-1) = drad(lev-1)+radld
3309 !
3310            bbugas(lev) = plfrac*(blay+dplankup*odepth_rec)
3311            bbutot(lev) = plfrac*(blay+tfactot*dplankup)
3312 !
3313          else
3314 !
3315            tblind = odepth/(bpade+odepth)
3316            itgas = tblint*tblind+0.5_rb
3317            odepth = tau_tbl(itgas)
3318            atrans(lev) = 1._rb-exp_tbl(itgas)
3319            tfacgas = tfn_tbl(itgas)
3320            gassrc = atrans(lev)*plfrac*(blay+tfacgas*dplankdn)
3321 !
3322            odtot = odepth+odcld(lev,igc)
3323            tblind = odtot/(bpade+odtot)
3324            ittot = tblint*tblind+0.5_rb
3325            tfactot = tfn_tbl(ittot)
3326            bbdtot = plfrac*(blay+tfactot*dplankdn)
3327            bbd = plfrac*(blay+tfacgas*dplankdn)
3328            atot(lev) = 1._rb-exp_tbl(ittot)
3329 !
3330            radld = radld-radld*(atrans(lev)+                                   &
3331                    efclfrac(lev,igc)*(1._rb-atrans(lev)))+                     &
3332                    gassrc + cldfmc(igc,lev)*(bbdtot*atot(lev)-gassrc)
3333            drad(lev-1) = drad(lev-1) + radld
3334            bbugas(lev) = plfrac*(blay+tfacgas*dplankup)
3335            bbutot(lev) = plfrac*(blay+tfactot*dplankup)
3336          endif
3337 !
3338 ! Clear layer
3339 !
3340        else
3341          if (odepth.le.0.06_rb) then
3342            atrans(lev) = odepth-0.5_rb*odepth*odepth
3343            odepth = rec_6*odepth
3344            bbd = plfrac*(blay+dplankdn*odepth)
3345            bbugas(lev) = plfrac*(blay+dplankup*odepth)
3346          else
3347            tblind = odepth/(bpade+odepth)
3348            itr = tblint*tblind+0.5_rb
3349            transc = exp_tbl(itr)
3350            atrans(lev) = 1._rb-transc
3351            tausfac = tfn_tbl(itr)
3352            bbd = plfrac*(blay+tausfac*dplankdn)
3353            bbugas(lev) = plfrac*(blay+tausfac*dplankup)
3354          endif
3355          radld = radld + (bbd-radld)*atrans(lev)
3356          drad(lev-1) = drad(lev-1)+radld
3357        endif
3358 !
3359 ! Set clear sky stream to total sky stream as long as layers
3360 ! remain clear.  streams diverge when a cloud is reached (iclddn=1),
3361 ! and clear sky stream must be computed separately from that point.
3362 !
3363        if (iclddn.eq.1) then
3364          radclrd = radclrd+(bbd-radclrd)*atrans(lev)
3365          clrdrad(lev-1) = clrdrad(lev-1)+radclrd
3366        else
3367          radclrd = radld
3368          clrdrad(lev-1) = drad(lev-1)
3369        endif
3370      enddo
3371 !
3372 ! Spectral emissivity & reflectance
3373 ! Include the contribution of spectrally varying longwave emissivity
3374 ! and reflection from the surface to the upward radiative transfer.
3375 ! Note: Spectral and Lambertian reflection are identical for the
3376 ! diffusivity angle flux integration used here.
3377 !
3378      rad0 = fracs(1,igc)*plankbnd(iband)
3379 !
3380 ! Add in specular reflection of surface downward radiance.
3381 !
3382      reflect = 1._rb-semiss(iband)
3383      radlu = rad0+reflect*radld
3384      radclru = rad0+reflect*radclrd
3385 !
3386 ! Upward radiative transfer loop.
3387 !
3388      urad(0) = urad(0)+radlu
3389      clrurad(0) = clrurad(0)+radclru
3390 !
3391      do lev = 1,nlayers
3392 !
3393 ! Cloudy layer
3394 !
3395        if (icldlyr(lev).eq.1) then
3396          gassrc = bbugas(lev)*atrans(lev)
3397          radlu = radlu-radlu*(atrans(lev)+                                     &
3398                  efclfrac(lev,igc)*(1._rb-atrans(lev)))+                       &
3399                  gassrc+cldfmc(igc,lev)*(bbutot(lev)*atot(lev)-gassrc)
3400          urad(lev) = urad(lev)+radlu
3401 !
3402 ! Clear layer
3403 !
3404        else
3405          radlu = radlu+(bbugas(lev)-radlu)*atrans(lev)
3406          urad(lev) = urad(lev)+radlu
3407        endif
3408 !
3409 ! Set clear sky stream to total sky stream as long as all layers
3410 ! are clear (iclddn=0).  streams must be calculated separately at
3411 ! all layers when a cloud is present (ICLDDN=1), because surface
3412 ! reflectance is different for each stream.
3413 !
3414        if (iclddn.eq.1) then
3415          radclru = radclru+(bbugas(lev)-radclru)*atrans(lev)
3416          clrurad(lev) = clrurad(lev)+radclru
3417        else
3418          radclru = radlu
3419          clrurad(lev) = urad(lev)
3420        endif
3421      enddo
3422 !
3423 ! Increment g-point counter
3424 !
3425      igc = igc + 1
3426 !
3427 ! Return to continue radiative transfer for all g-channels in present band
3428 !
3429      if (igc.le.ngs(iband)) go to 1000
3430 !
3431 ! Process longwave output from band for total and clear streams.
3432 ! Calculate upward, downward, and net flux.
3433 !
3434      do lev = nlayers,0,-1
3435        uflux(lev) = urad(lev)*wtdiff
3436        dflux(lev) = drad(lev)*wtdiff
3437        urad(lev) = 0.0_rb
3438        drad(lev) = 0.0_rb
3439        totuflux(lev) = totuflux(lev)+uflux(lev)*delwave(iband)
3440        totdflux(lev) = totdflux(lev)+dflux(lev)*delwave(iband)
3441        uclfl(lev) = clrurad(lev)*wtdiff
3442        dclfl(lev) = clrdrad(lev)*wtdiff
3443        clrurad(lev) = 0.0_rb
3444        clrdrad(lev) = 0.0_rb
3445        totuclfl(lev) = totuclfl(lev)+uclfl(lev)*delwave(iband)
3446        totdclfl(lev) = totdclfl(lev)+dclfl(lev)*delwave(iband)
3447      enddo
3448 !
3449 ! End spectral band loop
3450 !
3451    enddo
3452 !
3453 ! Calculate fluxes at surface
3454 !
3455    totuflux(0) = totuflux(0)*fluxfac
3456    totdflux(0) = totdflux(0)*fluxfac
3457    fnet(0) = totuflux(0)-totdflux(0)
3458    totuclfl(0) = totuclfl(0)*fluxfac
3459    totdclfl(0) = totdclfl(0)*fluxfac
3460    fnetc(0) = totuclfl(0)-totdclfl(0)
3461 !
3462 ! Calculate fluxes at model levels
3463 !
3464    do lev = 1,nlayers
3465      totuflux(lev) = totuflux(lev)*fluxfac
3466      totdflux(lev) = totdflux(lev)*fluxfac
3467      fnet(lev) = totuflux(lev)-totdflux(lev)
3468      totuclfl(lev) = totuclfl(lev)*fluxfac
3469      totdclfl(lev) = totdclfl(lev)*fluxfac
3470      fnetc(lev) = totuclfl(lev)-totdclfl(lev)
3471      l = lev-1
3472 !
3473 ! Calculate heating rates at model layers
3474 !
3475      htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev))
3476      htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev))
3477    enddo
3478 !
3479 ! Set heating rate to zero in top layer
3480 !
3481    htr(nlayers) = 0.0_rb
3482    htrc(nlayers) = 0.0_rb
3483 !
3484    end subroutine rtrnmc
3485 !-------------------------------------------------------------------------------
3486 !
3487 !
3488 !-------------------------------------------------------------------------------
3489    end module rrtmg_lw_rtrnmc_k
3490 !-------------------------------------------------------------------------------
3491 !
3492 !
3493 !-------------------------------------------------------------------------------
3494    module rrtmg_lw_setcoef_k
3495 !-------------------------------------------------------------------------------
3496 !   --------------------------------------------------------------------------
3497 !  |                                                                          |
3498 !  |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
3499 !  |  This software may be used, copied, or redistributed as long as it is    |
3500 !  |  not sold and this copyright notice is reproduced on each copy made.     |
3501 !  |  This model is provided as is without any express or implied warranties. |
3502 !  |                       (http://www.rtweb.aer.com/)                        |
3503 !  |                                                                          |
3504 !   --------------------------------------------------------------------------
3505 !-------------------------------------------------------------------------------
3506    use parkind_k,  only : im => kind_im, rb => kind_rb
3507    use parrrtm_k,  only : nbndlw, mg, maxxsec, mxmol
3508    use rrlw_wvn_k, only : totplnk, totplk16
3509    use rrlw_ref_k
3510    use rrlw_vsn_k, only : hvrset, hnamset
3511 !
3512    implicit none
3513 !
3514    contains
3515 !-------------------------------------------------------------------------------
3516 !
3517 !
3518 !-------------------------------------------------------------------------------
3519    subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss,       &
3520                       coldry, wkl, wbroad,                                     &
3521                       laytrop, jp, jt, jt1, planklay, planklev, plankbnd,      &
3522                       colh2o, colco2, colo3, coln2o, colco, colch4, colo2,     &
3523                       colbrd, fac00, fac01, fac10, fac11,                      &
3524                       rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1,        &
3525                       rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1,      &
3526                       rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1,        &
3527                       selffac, selffrac, indself, forfac, forfrac, indfor,     &
3528                       minorfrac, scaleminor, scaleminorn2, indminor)
3529 !-------------------------------------------------------------------------------
3530 !
3531 !  Purpose:  For a given atmosphere, calculate the indices and
3532 !  fractions related to the pressure and temperature interpolations.
3533 !  Also calculate the values of the integrated Planck functions
3534 !  for each band at the level and layer temperatures.
3535 !
3536 !  input :
3537 !    nlayers         - total number of layers
3538 !    istart          - beginning band of calculation
3539 !    pavel(:)        - layer pressures (mb)
3540 !                      Dimensions: (nlayers)
3541 !    tavel(:)        - layer temperatures (K)
3542 !                      Dimensions: (nlayers)
3543 !    tz(0:)          - level (interface) temperatures (K)
3544 !                      Dimensions: (0:nlayers)
3545 !    tbound          - surface temperature (K)
3546 !    coldry(:)       - dry air column density (mol/cm2)
3547 !                      Dimensions: (nlayers)
3548 !    wbroad(:)       - broadening gas column density (mol/cm2)
3549 !                      Dimensions: (nlayers)
3550 !    wkl(:,:)        - molecular amounts (mol/cm-2)
3551 !                      Dimensions: (mxmol,nlayers)
3552 !    semiss(:)       - lw surface emissivity
3553 !                      Dimensions: (nbndlw)
3554 !  output :
3555 !    laytrop                    - tropopause layer index
3556 !    jp(nlayers)                -
3557 !    jt(nlayers)
3558 !    jt1(nlayers)
3559 !    planklay(nlayers,nbndlw)
3560 !    planklev(0:nlayers,nbndlw)
3561 !    plankbnd(nbndlw)
3562 !    colh2o(nlayers)            - column amount (h2o)
3563 !    colco2(nlayers)            - column amount (co2)
3564 !    colo3(nlayers)             - column amount (o3)
3565 !    coln2o(nlayers)            - column amount (n2o)
3566 !    colco(nlayers)             - column amount (co)
3567 !    colch4(nlayers)            - column amount (ch4)
3568 !    colo2(nlayers)             - column amount (o2)
3569 !    colbrd(nlayers)            - column amount (broadening gases)
3570 !
3571 !    indself(nlayers)
3572 !    indfor(nlayers)
3573 !    selffac(nlayers)
3574 !    selffrac(nlayers)
3575 !    forfac(nlayers)
3576 !    forfrac(nlayers)
3577 !    indminor(nlayers)
3578 !    minorfrac(nlayers)
3579 !    scaleminor(nlayers)
3580 !    scaleminorn2(nlayers)
3581 !    minorfrac(nlayers)
3582 !    scaleminor(nlayers)
3583 !    scaleminorn2(nlayers)
3584 !    fac00(nlayers), fac01(nlayers), fac10(nlayers), fac11(nlayers)
3585 !    rat_h2oco2(nlayers),rat_h2oco2_1(nlayers)
3586 !    rat_h2oo3(nlayers),rat_h2oo3_1(nlayers)
3587 !    rat_h2on2o(nlayers),rat_h2on2o_1(nlayers)
3588 !    rat_h2och4(nlayers),rat_h2och4_1(nlayers)
3589 !    rat_n2oco2(nlayers),rat_n2oco2_1(nlayers)
3590 !    rat_o3co2(nlayers),rat_o3co2_1(nlayers)
3591 !
3592 !  local varialbles :
3593 !-------------------------------------------------------------------------------
3594 !
3595 ! Input
3596 !
3597    integer(kind=im), intent(in   ) :: nlayers
3598    integer(kind=im), intent(in   ) :: istart
3599 !
3600    real(kind=rb), dimension(:)   , intent(in   ) :: pavel
3601    real(kind=rb), dimension(:)   , intent(in   ) :: tavel
3602    real(kind=rb), dimension(0:)  , intent(in   ) :: tz
3603    real(kind=rb)                 , intent(in   ) :: tbound
3604    real(kind=rb), dimension(:)   , intent(in   ) :: coldry
3605    real(kind=rb), dimension(:)   , intent(in   ) :: wbroad
3606    real(kind=rb), dimension(:,:) , intent(in   ) :: wkl
3607    real(kind=rb), dimension(:)   , intent(in   ) :: semiss
3608 !
3609 ! Output
3610 !
3611    integer(kind=im)              , intent(  out) :: laytrop
3612    integer(kind=im), dimension(:), intent(  out) :: jp
3613    integer(kind=im), dimension(:), intent(  out) :: jt
3614    integer(kind=im), dimension(:), intent(  out) :: jt1
3615    real(kind=rb), dimension(:,:) , intent(  out) :: planklay
3616    real(kind=rb), dimension(0:,:), intent(  out) :: planklev
3617    real(kind=rb), dimension(:)   , intent(  out) :: plankbnd
3618 !
3619    real(kind=rb), dimension(:), intent(  out) :: colh2o
3620    real(kind=rb), dimension(:), intent(  out) :: colco2
3621    real(kind=rb), dimension(:), intent(  out) :: colo3
3622    real(kind=rb), dimension(:), intent(  out) :: coln2o
3623    real(kind=rb), dimension(:), intent(  out) :: colco
3624    real(kind=rb), dimension(:), intent(  out) :: colch4
3625    real(kind=rb), dimension(:), intent(  out) :: colo2
3626    real(kind=rb), dimension(:), intent(  out) :: colbrd
3627 !
3628    integer(kind=im), dimension(:), intent(  out) :: indself
3629    integer(kind=im), dimension(:), intent(  out) :: indfor
3630    real(kind=rb), dimension(:)   , intent(  out) :: selffac
3631    real(kind=rb), dimension(:)   , intent(  out) :: selffrac
3632    real(kind=rb), dimension(:)   , intent(  out) :: forfac
3633    real(kind=rb), dimension(:)   , intent(  out) :: forfrac
3634 !
3635    integer(kind=im), dimension(:), intent(  out) :: indminor
3636    real(kind=rb), dimension(:)   , intent(  out) :: minorfrac
3637    real(kind=rb), dimension(:)   , intent(  out) :: scaleminor
3638    real(kind=rb), dimension(:)   , intent(  out) :: scaleminorn2
3639 !
3640    real(kind=rb), dimension(:)   , intent(  out) :: fac00, fac01, fac10, fac11
3641    real(kind=rb), dimension(:)   , intent(  out) :: rat_h2oco2, rat_h2oco2_1,  &
3642                                                       rat_h2oo3, rat_h2oo3_1,  &
3643                                                      rat_h2on2o,rat_h2on2o_1,  &
3644                                                      rat_h2och4,rat_h2och4_1,  &
3645                                                      rat_n2oco2,rat_n2oco2_1,  &
3646                                                        rat_o3co2,rat_o3co2_1
3647 !
3648 ! Local
3649 !
3650    integer(kind=im) :: indbound, indlev0
3651    integer(kind=im) :: lay, indlay, indlev, iband
3652    integer(kind=im) :: jp1
3653    real(kind=rb)    :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
3654    real(kind=rb)    :: dbdtlev, dbdtlay
3655    real(kind=rb)    :: plog, fp, ft, ft1, water, scalefac, factor, compfp
3656 !-------------------------------------------------------------------------------
3657 !
3658    hvrset = '$Revision: 1.3 $'
3659 !
3660    stpfac = 296._rb/1013._rb
3661 !
3662    indbound = tbound-159._rb
3663 !
3664    if (indbound.lt.1) then
3665      indbound = 1
3666    else if (indbound.gt.180) then
3667      indbound = 180
3668    endif
3669 !
3670    tbndfrac = tbound-159._rb-real(indbound)
3671    indlev0 = tz(0)-159._rb
3672 !
3673    if (indlev0.lt.1) then
3674      indlev0 = 1
3675    else if (indlev0.gt.180) then
3676      indlev0 = 180
3677    endif
3678 !
3679    t0frac = tz(0)-159._rb-real(indlev0)
3680    laytrop = 0
3681 !
3682 ! Begin layer loop
3683 ! Calculate the integrated Planck functions for each band at the
3684 ! surface, level, and layer temperatures.
3685 !
3686    do lay = 1,nlayers
3687      indlay = tavel(lay)-159._rb
3688      if (indlay.lt.1) then
3689        indlay = 1
3690      else if (indlay.gt.180) then
3691        indlay = 180
3692      endif
3693 !
3694      tlayfrac = tavel(lay)-159._rb-real(indlay)
3695      indlev = tz(lay)-159._rb
3696      if (indlev.lt.1) then
3697        indlev = 1
3698      else if (indlev.gt.180) then
3699        indlev = 180
3700      endif
3701      tlevfrac = tz(lay)-159._rb-real(indlev)
3702 !
3703 ! Begin spectral band loop
3704 !
3705      do iband = 1,15
3706        if (lay.eq.1) then
3707          dbdtlev = totplnk(indbound+1,iband)-totplnk(indbound,iband)
3708          plankbnd(iband) = semiss(iband)*                                      &
3709                           (totplnk(indbound,iband)+tbndfrac*dbdtlev)
3710          dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3711          planklev(0,iband) = totplnk(indlev0,iband)+t0frac*dbdtlev
3712        endif
3713        dbdtlev = totplnk(indlev+1,iband)-totplnk(indlev,iband)
3714        dbdtlay = totplnk(indlay+1,iband)-totplnk(indlay,iband)
3715        planklay(lay,iband) = totplnk(indlay,iband)+tlayfrac*dbdtlay
3716        planklev(lay,iband) = totplnk(indlev,iband)+tlevfrac*dbdtlev
3717      enddo
3718 !
3719 ! For band 16, if radiative transfer will be performed on just
3720 ! this band, use integrated Planck values up to 3250 cm-1.
3721 ! If radiative transfer will be performed across all 16 bands,
3722 ! then include in the integrated Planck values for this band
3723 ! contributions from 2600 cm-1 to infinity.
3724 !
3725      iband = 16
3726      if (istart.eq.16) then
3727        if (lay.eq.1) then
3728          dbdtlev = totplk16(indbound+1)-totplk16(indbound)
3729          plankbnd(iband) = semiss(iband)*                                      &
3730                           (totplk16(indbound)+tbndfrac*dbdtlev)
3731          dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3732          planklev(0,iband) = totplk16(indlev0)+t0frac*dbdtlev
3733        endif
3734        dbdtlev = totplk16(indlev+1)-totplk16(indlev)
3735        dbdtlay = totplk16(indlay+1)-totplk16(indlay)
3736        planklay(lay,iband) = totplk16(indlay)+tlayfrac*dbdtlay
3737        planklev(lay,iband) = totplk16(indlev)+tlevfrac*dbdtlev
3738      else
3739        if (lay.eq.1) then
3740          dbdtlev = totplnk(indbound+1,iband)-totplnk(indbound,iband)
3741          plankbnd(iband) = semiss(iband)*                                      &
3742                           (totplnk(indbound,iband)+tbndfrac*dbdtlev)
3743          dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
3744          planklev(0,iband) = totplnk(indlev0,iband)+t0frac*dbdtlev
3745        endif
3746        dbdtlev = totplnk(indlev+1,iband)-totplnk(indlev,iband)
3747        dbdtlay = totplnk(indlay+1,iband)-totplnk(indlay,iband)
3748        planklay(lay,iband) = totplnk(indlay,iband)+tlayfrac*dbdtlay
3749        planklev(lay,iband) = totplnk(indlev,iband)+tlevfrac*dbdtlev
3750      endif
3751 !
3752 ! Find the two reference pressures on either side of the
3753 ! layer pressure.  Store them in JP and JP1.  Store in FP the
3754 ! fraction of the difference (in ln(pressure)) between these
3755 ! two values that the layer pressure lies.
3756 !
3757      plog = log(pavel(lay))
3758 !    plog = dlog(pavel(lay))
3759      jp(lay) = int(36._rb - 5*(plog+0.04_rb))
3760 !
3761      if (jp(lay).lt.1) then
3762        jp(lay) = 1
3763      else if (jp(lay).gt.58) then
3764        jp(lay) = 58
3765      endif
3766 !
3767      jp1 = jp(lay)+1
3768      fp = 5._rb*(preflog(jp(lay))-plog)
3769 !
3770 ! Determine, for each reference pressure (JP and JP1), which
3771 ! reference temperature (these are different for each
3772 ! reference pressure) is nearest the layer temperature but does
3773 ! not exceed it.  Store these indices in JT and JT1, resp.
3774 ! Store in FT (resp. FT1) the fraction of the way between JT
3775 ! (JT1) and the next highest reference temperature that the
3776 ! layer temperature falls.
3777 !
3778      jt(lay) = int(3._rb+(tavel(lay)-tref(jp(lay)))/15._rb)
3779 !
3780      if (jt(lay).lt.1) then
3781        jt(lay) = 1
3782      else if (jt(lay).gt.4) then
3783        jt(lay) = 4
3784      endif
3785 !
3786      ft = ((tavel(lay)-tref(jp(lay)))/15._rb)-real(jt(lay)-3)
3787      jt1(lay) = int(3._rb+(tavel(lay)-tref(jp1))/15._rb)
3788 !
3789      if (jt1(lay).lt.1) then
3790        jt1(lay) = 1
3791      else if (jt1(lay).gt.4) then
3792        jt1(lay) = 4
3793      endif
3794 !
3795      ft1 = ((tavel(lay)-tref(jp1))/15._rb)-real(jt1(lay)-3)
3796      water = wkl(1,lay)/coldry(lay)
3797      scalefac = pavel(lay)*stpfac /tavel(lay)
3798 !
3799 ! If the pressure is less than ~100mb, perform a different
3800 ! set of species interpolations.
3801 !
3802      if (plog.le.4.56_rb) go to 5300
3803      laytrop =  laytrop+1
3804 !
3805      forfac(lay) = scalefac/(1.+water)
3806      factor = (332.0_rb-tavel(lay))/36.0_rb
3807      indfor(lay) = min(2, max(1,int(factor)))
3808      forfrac(lay) = factor-real(indfor(lay))
3809 !
3810 ! Set up factors needed to separately include the water vapor
3811 ! self-continuum in the calculation of absorption coefficient.
3812 !
3813      selffac(lay) = water*forfac(lay)
3814      factor = (tavel(lay)-188.0_rb)/7.2_rb
3815      indself(lay) = min(9, max(1,int(factor)-7))
3816      selffrac(lay) = factor-real(indself(lay)+ 7)
3817 !
3818 ! Set up factors needed to separately include the minor gases
3819 ! in the calculation of absorption coefficient
3820 !
3821      scaleminor(lay) = pavel(lay)/tavel(lay)
3822      scaleminorn2(lay) = (pavel(lay)/tavel(lay))                               &
3823                         *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3824      factor = (tavel(lay)-180.8_rb)/7.2_rb
3825      indminor(lay) = min(18,max(1,int(factor)))
3826      minorfrac(lay) = factor-real(indminor(lay))
3827 !
3828 ! Setup reference ratio to be used in calculation of binary
3829 ! species parameter in lower atmosphere.
3830 !
3831      rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3832      rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3833 !
3834      rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay))
3835      rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1)
3836 !
3837      rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay))
3838      rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1)
3839 !
3840      rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay))
3841      rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1)
3842 !
3843      rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay))
3844      rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3845 !
3846 ! Calculate needed column amounts.
3847 !
3848      colh2o(lay) = 1.e-20_rb*wkl(1,lay)
3849      colco2(lay) = 1.e-20_rb*wkl(2,lay)
3850      colo3(lay) = 1.e-20_rb*wkl(3,lay)
3851      coln2o(lay) = 1.e-20_rb*wkl(4,lay)
3852      colco(lay) = 1.e-20_rb*wkl(5,lay)
3853      colch4(lay) = 1.e-20_rb*wkl(6,lay)
3854      colo2(lay) = 1.e-20_rb*wkl(7,lay)
3855      if (colco2(lay).eq.0._rb) colco2(lay) = 1.e-32_rb*coldry(lay)
3856      if (colo3(lay).eq.0._rb)  colo3(lay)  = 1.e-32_rb*coldry(lay)
3857      if (coln2o(lay).eq.0._rb) coln2o(lay) = 1.e-32_rb*coldry(lay)
3858      if (colco(lay).eq.0._rb)  colco(lay)  = 1.e-32_rb*coldry(lay)
3859      if (colch4(lay).eq.0._rb) colch4(lay) = 1.e-32_rb*coldry(lay)
3860      colbrd(lay) = 1.e-20_rb*wbroad(lay)
3861      go to 5400
3862 !
3863 ! Above laytrop.
3864 !
3865      5300 continue
3866 !
3867      forfac(lay) = scalefac/(1.+water)
3868      factor = (tavel(lay)-188.0_rb)/36.0_rb
3869      indfor(lay) = 3
3870      forfrac(lay) = factor-1.0_rb
3871 !
3872 ! Set up factors needed to separately include the water vapor
3873 ! self-continuum in the calculation of absorption coefficient.
3874 !
3875      selffac(lay) = water*forfac(lay)
3876 !
3877 ! Set up factors needed to separately include the minor gases
3878 ! in the calculation of absorption coefficient
3879 !
3880      scaleminor(lay) = pavel(lay)/tavel(lay)
3881      scaleminorn2(lay) = (pavel(lay)/tavel(lay))                               &
3882                         *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
3883      factor = (tavel(lay)-180.8_rb)/7.2_rb
3884      indminor(lay) = min(18,max(1,int(factor)))
3885      minorfrac(lay) = factor-real(indminor(lay))
3886 !
3887 ! Setup reference ratio to be used in calculation of binary
3888 ! species parameter in upper atmosphere.
3889 !
3890      rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
3891      rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3892 !
3893      rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay))
3894      rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1)
3895 !
3896 ! Calculate needed column amounts.
3897 !
3898      colh2o(lay) = 1.e-20_rb*wkl(1,lay)
3899      colco2(lay) = 1.e-20_rb*wkl(2,lay)
3900      colo3(lay) = 1.e-20_rb*wkl(3,lay)
3901      coln2o(lay) = 1.e-20_rb*wkl(4,lay)
3902      colco(lay) = 1.e-20_rb*wkl(5,lay)
3903      colch4(lay) = 1.e-20_rb*wkl(6,lay)
3904      colo2(lay) = 1.e-20_rb*wkl(7,lay)
3905      if (colco2(lay).eq.0._rb) colco2(lay) = 1.e-32_rb*coldry(lay)
3906      if (colo3(lay).eq.0._rb)  colo3(lay)  = 1.e-32_rb*coldry(lay)
3907      if (coln2o(lay).eq.0._rb) coln2o(lay) = 1.e-32_rb*coldry(lay)
3908      if (colco(lay).eq.0._rb)  colco(lay)  = 1.e-32_rb*coldry(lay)
3909      if (colch4(lay).eq.0._rb) colch4(lay) = 1.e-32_rb*coldry(lay)
3910      colbrd(lay) = 1.e-20_rb*wbroad(lay)
3911      5400    continue
3912 !
3913 ! We have now isolated the layer ln pressure and temperature,
3914 ! between two reference pressures and two reference temperatures
3915 ! (for each reference pressure).  We multiply the pressure
3916 ! fraction FP with the appropriate temperature fractions to get
3917 ! the factors that will be needed for the interpolation that yields
3918 ! the optical depths (performed in routines TAUGBn for band n).`
3919 !
3920      compfp = 1.-fp
3921      fac10(lay) = compfp*ft
3922      fac00(lay) = compfp*(1._rb-ft)
3923      fac11(lay) = fp*ft1
3924      fac01(lay) = fp*(1._rb-ft1)
3925 !
3926 ! Rescale selffac and forfac for use in taumol
3927 !
3928      selffac(lay) = colh2o(lay)*selffac(lay)
3929      forfac(lay) = colh2o(lay)*forfac(lay)
3930 !
3931 ! End layer loop
3932 !
3933    enddo
3934 !
3935    end subroutine setcoef
3936 !-------------------------------------------------------------------------------
3937 !
3938 !
3939 !-------------------------------------------------------------------------------
3940    subroutine lwatmref
3941 !-------------------------------------------------------------------------------
3942 !
3943 !  These pressures are chosen such that the ln of the first pressure
3944 !  has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
3945 !  each subsequent ln(pressure) differs from the previous one by 0.2.
3946 !
3947 !-------------------------------------------------------------------------------
3948 !
3949    save
3950 !
3951    pref(:) = (/                                                                &
3952     1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb,&
3953     3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb,&
3954     1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb,&
3955     5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb,&
3956     1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb,&
3957     7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb,&
3958     2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb,&
3959     9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb,&
3960     3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb,&
3961     1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb,&
3962     4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb,&
3963     1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/)
3964    preflog(:) = (/                                                             &
3965     6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
3966     5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
3967     4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
3968     3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
3969     2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
3970     1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
3971     9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
3972    -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
3973    -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
3974    -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
3975    -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
3976    -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/)
3977 !
3978 ! These are the temperatures associated with the respective
3979 ! pressures for the mls standard atmosphere.
3980 !
3981    tref(:) = (/                                                                &
3982     2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
3983     2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
3984     2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
3985     2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
3986     2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
3987     2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
3988     2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
3989     2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
3990     2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
3991     2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
3992     2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
3993     1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/)
3994 !
3995    chi_mls(1,1:12) = (/                                                        &
3996     1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, &
3997     7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, &
3998     4.3082e-06_rb, 3.3319e-06_rb/)
3999    chi_mls(1,13:59) = (/                                                       &
4000     3.2039e-06_rb, 3.1619e-06_rb, 3.2524e-06_rb, 3.4226e-06_rb, 3.6288e-06_rb, &
4001     3.9148e-06_rb, 4.1488e-06_rb, 4.3081e-06_rb, 4.4420e-06_rb, 4.5778e-06_rb, &
4002     4.7087e-06_rb, 4.7943e-06_rb, 4.8697e-06_rb, 4.9260e-06_rb, 4.9669e-06_rb, &
4003     4.9963e-06_rb, 5.0527e-06_rb, 5.1266e-06_rb, 5.2503e-06_rb, 5.3571e-06_rb, &
4004     5.4509e-06_rb, 5.4830e-06_rb, 5.5000e-06_rb, 5.5000e-06_rb, 5.4536e-06_rb, &
4005     5.4047e-06_rb, 5.3558e-06_rb, 5.2533e-06_rb, 5.1436e-06_rb, 5.0340e-06_rb, &
4006     4.8766e-06_rb, 4.6979e-06_rb, 4.5191e-06_rb, 4.3360e-06_rb, 4.1442e-06_rb, &
4007     3.9523e-06_rb, 3.7605e-06_rb, 3.5722e-06_rb, 3.3855e-06_rb, 3.1988e-06_rb, &
4008     3.0121e-06_rb, 2.8262e-06_rb, 2.6407e-06_rb, 2.4552e-06_rb, 2.2696e-06_rb, &
4009     4.3360e-06_rb, 4.1442e-06_rb/)
4010    chi_mls(2,1:12) = (/                                                        &
4011     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4012     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4013     3.5500e-04_rb, 3.5500e-04_rb/)
4014    chi_mls(2,13:59) = (/                                                       &
4015     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4016     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4017     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4018     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4019     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4020     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4021     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4022     3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, 3.5500e-04_rb, &
4023     3.5500e-04_rb, 3.5471e-04_rb, 3.5427e-04_rb, 3.5384e-04_rb, 3.5340e-04_rb, &
4024     3.5500e-04_rb, 3.5500e-04_rb/)
4025    chi_mls(3,1:12) = (/                                                        &
4026     3.0170e-08_rb, 3.4725e-08_rb, 4.2477e-08_rb, 5.2759e-08_rb, 6.6944e-08_rb, &
4027     8.7130e-08_rb, 1.1391e-07_rb, 1.5677e-07_rb, 2.1788e-07_rb, 3.2443e-07_rb, &
4028     4.6594e-07_rb, 5.6806e-07_rb/)
4029    chi_mls(3,13:59) = (/                                                       &
4030     6.9607e-07_rb, 1.1186e-06_rb, 1.7618e-06_rb, 2.3269e-06_rb, 2.9577e-06_rb, &
4031     3.6593e-06_rb, 4.5950e-06_rb, 5.3189e-06_rb, 5.9618e-06_rb, 6.5113e-06_rb, &
4032     7.0635e-06_rb, 7.6917e-06_rb, 8.2577e-06_rb, 8.7082e-06_rb, 8.8325e-06_rb, &
4033     8.7149e-06_rb, 8.0943e-06_rb, 7.3307e-06_rb, 6.3101e-06_rb, 5.3672e-06_rb, &
4034     4.4829e-06_rb, 3.8391e-06_rb, 3.2827e-06_rb, 2.8235e-06_rb, 2.4906e-06_rb, &
4035     2.1645e-06_rb, 1.8385e-06_rb, 1.6618e-06_rb, 1.5052e-06_rb, 1.3485e-06_rb, &
4036     1.1972e-06_rb, 1.0482e-06_rb, 8.9926e-07_rb, 7.6343e-07_rb, 6.5381e-07_rb, &
4037     5.4419e-07_rb, 4.3456e-07_rb, 3.6421e-07_rb, 3.1194e-07_rb, 2.5967e-07_rb, &
4038     2.0740e-07_rb, 1.9146e-07_rb, 1.9364e-07_rb, 1.9582e-07_rb, 1.9800e-07_rb, &
4039     7.6343e-07_rb, 6.5381e-07_rb/)
4040    chi_mls(4,1:12) = (/                                                        &
4041     3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, 3.2000e-07_rb, &
4042     3.1965e-07_rb, 3.1532e-07_rb, 3.0383e-07_rb, 2.9422e-07_rb, 2.8495e-07_rb, &
4043     2.7671e-07_rb, 2.6471e-07_rb/)
4044    chi_mls(4,13:59) = (/                                                       &
4045     2.4285e-07_rb, 2.0955e-07_rb, 1.7195e-07_rb, 1.3749e-07_rb, 1.1332e-07_rb, &
4046     1.0035e-07_rb, 9.1281e-08_rb, 8.5463e-08_rb, 8.0363e-08_rb, 7.3372e-08_rb, &
4047     6.5975e-08_rb, 5.6039e-08_rb, 4.7090e-08_rb, 3.9977e-08_rb, 3.2979e-08_rb, &
4048     2.6064e-08_rb, 2.1066e-08_rb, 1.6592e-08_rb, 1.3017e-08_rb, 1.0090e-08_rb, &
4049     7.6249e-09_rb, 6.1159e-09_rb, 4.6672e-09_rb, 3.2857e-09_rb, 2.8484e-09_rb, &
4050     2.4620e-09_rb, 2.0756e-09_rb, 1.8551e-09_rb, 1.6568e-09_rb, 1.4584e-09_rb, &
4051     1.3195e-09_rb, 1.2072e-09_rb, 1.0948e-09_rb, 9.9780e-10_rb, 9.3126e-10_rb, &
4052     8.6472e-10_rb, 7.9818e-10_rb, 7.5138e-10_rb, 7.1367e-10_rb, 6.7596e-10_rb, &
4053     6.3825e-10_rb, 6.0981e-10_rb, 5.8600e-10_rb, 5.6218e-10_rb, 5.3837e-10_rb, &
4054     9.9780e-10_rb, 9.3126e-10_rb/)
4055    chi_mls(5,1:12) = (/                                                        &
4056     1.5000e-07_rb, 1.4306e-07_rb, 1.3474e-07_rb, 1.3061e-07_rb, 1.2793e-07_rb, &
4057     1.2038e-07_rb, 1.0798e-07_rb, 9.4238e-08_rb, 7.9488e-08_rb, 6.1386e-08_rb, &
4058     4.5563e-08_rb, 3.3475e-08_rb/)
4059    chi_mls(5,13:59) = (/                                                       &
4060     2.5118e-08_rb, 1.8671e-08_rb, 1.4349e-08_rb, 1.2501e-08_rb, 1.2407e-08_rb, &
4061     1.3472e-08_rb, 1.4900e-08_rb, 1.6079e-08_rb, 1.7156e-08_rb, 1.8616e-08_rb, &
4062     2.0106e-08_rb, 2.1654e-08_rb, 2.3096e-08_rb, 2.4340e-08_rb, 2.5643e-08_rb, &
4063     2.6990e-08_rb, 2.8456e-08_rb, 2.9854e-08_rb, 3.0943e-08_rb, 3.2023e-08_rb, &
4064     3.3101e-08_rb, 3.4260e-08_rb, 3.5360e-08_rb, 3.6397e-08_rb, 3.7310e-08_rb, &
4065     3.8217e-08_rb, 3.9123e-08_rb, 4.1303e-08_rb, 4.3652e-08_rb, 4.6002e-08_rb, &
4066     5.0289e-08_rb, 5.5446e-08_rb, 6.0603e-08_rb, 6.8946e-08_rb, 8.3652e-08_rb, &
4067     9.8357e-08_rb, 1.1306e-07_rb, 1.4766e-07_rb, 1.9142e-07_rb, 2.3518e-07_rb, &
4068     2.7894e-07_rb, 3.5001e-07_rb, 4.3469e-07_rb, 5.1938e-07_rb, 6.0407e-07_rb, &
4069     6.8946e-08_rb, 8.3652e-08_rb/)
4070    chi_mls(6,1:12) = (/                                                        &
4071     1.7000e-06_rb, 1.7000e-06_rb, 1.6999e-06_rb, 1.6904e-06_rb, 1.6671e-06_rb, &
4072     1.6351e-06_rb, 1.6098e-06_rb, 1.5590e-06_rb, 1.5120e-06_rb, 1.4741e-06_rb, &
4073     1.4385e-06_rb, 1.4002e-06_rb/)
4074    chi_mls(6,13:59) = (/                                                       &
4075     1.3573e-06_rb, 1.3130e-06_rb, 1.2512e-06_rb, 1.1668e-06_rb, 1.0553e-06_rb, &
4076     9.3281e-07_rb, 8.1217e-07_rb, 7.5239e-07_rb, 7.0728e-07_rb, 6.6722e-07_rb, &
4077     6.2733e-07_rb, 5.8604e-07_rb, 5.4769e-07_rb, 5.1480e-07_rb, 4.8206e-07_rb, &
4078     4.4943e-07_rb, 4.1702e-07_rb, 3.8460e-07_rb, 3.5200e-07_rb, 3.1926e-07_rb, &
4079     2.8646e-07_rb, 2.5498e-07_rb, 2.2474e-07_rb, 1.9588e-07_rb, 1.8295e-07_rb, &
4080     1.7089e-07_rb, 1.5882e-07_rb, 1.5536e-07_rb, 1.5304e-07_rb, 1.5072e-07_rb, &
4081     1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4082     1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4083     1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, 1.5000e-07_rb, &
4084     1.5000e-07_rb, 1.5000e-07_rb/)
4085    chi_mls(7,1:12) = (/                                                        &
4086     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4087     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4088     0.2090_rb, 0.2090_rb/)
4089    chi_mls(7,13:59) = (/                                                       &
4090     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4091     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4092     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4093     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4094     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4095     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4096     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4097     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4098     0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb, 0.2090_rb,                     &
4099     0.2090_rb, 0.2090_rb/)
4100 !
4101    end subroutine lwatmref
4102 !-------------------------------------------------------------------------------
4103 !
4104 !
4105 !-------------------------------------------------------------------------------
4106    subroutine lwavplank
4107 !-------------------------------------------------------------------------------
4108 !
4109    save
4110 !
4111    totplnk(1:50,  1) = (/                                                      &
4112    0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, &
4113    0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, &
4114    0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, &
4115    0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, &
4116    0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, &
4117    0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, &
4118    0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, &
4119    0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, &
4120    0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, &
4121    0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/)
4122    totplnk(51:100,  1) = (/                                                    &
4123    0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, &
4124    0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, &
4125    0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, &
4126    0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, &
4127    0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, &
4128    0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, &
4129    0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, &
4130    0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, &
4131    0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, &
4132    0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/)
4133    totplnk(101:150,  1) = (/                                                   &
4134    0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, &
4135    0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, &
4136    0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, &
4137    0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, &
4138    0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, &
4139    0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, &
4140    0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, &
4141    0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, &
4142    0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, &
4143    0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/)
4144    totplnk(151:181,  1) = (/                                                   &
4145    0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, &
4146    0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, &
4147    0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, &
4148    0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, &
4149    0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, &
4150    0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, &
4151    0.65247e-05_rb/)
4152    totplnk(1:50,  2) = (/                                                      &
4153    0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, &
4154    0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, &
4155    0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, &
4156    0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, &
4157    0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, &
4158    0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, &
4159    0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, &
4160    0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, &
4161    0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, &
4162    0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/)
4163    totplnk(51:100,  2) = (/                                                    &
4164    0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, &
4165    0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, &
4166    0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, &
4167    0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, &
4168    0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, &
4169    0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, &
4170    0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, &
4171    0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, &
4172    0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, &
4173    0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/)
4174    totplnk(101:150,  2) = (/                                                   &
4175    0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, &
4176    0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, &
4177    0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, &
4178    0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, &
4179    0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, &
4180    0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, &
4181    0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, &
4182    0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, &
4183    0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, &
4184    0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/)
4185    totplnk(151:181,  2) = (/                                                   &
4186    0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, &
4187    0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, &
4188    0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, &
4189    0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, &
4190    0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, &
4191    0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, &
4192    0.17998e-04_rb/)
4193    totplnk(1:50, 3) = (/                                                       &
4194    1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, &
4195    1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, &
4196    1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, &
4197    2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, &
4198    2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, &
4199    2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, &
4200    3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, &
4201    3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, &
4202    3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, &
4203    4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/)
4204    totplnk(51:100, 3) = (/                                                     &
4205    4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, &
4206    4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, &
4207    5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, &
4208    5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, &
4209    6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, &
4210    6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, &
4211    7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, &
4212    8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, &
4213    8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, &
4214    9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/)
4215    totplnk(101:150, 3) = (/                                                    &
4216    9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, &
4217    1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, &
4218    1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, &
4219    1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, &
4220    1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, &
4221    1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, &
4222    1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, &
4223    1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, &
4224    1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, &
4225    1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/)
4226    totplnk(151:181, 3) = (/                                                    &
4227    1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, &
4228    1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, &
4229    1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, &
4230    1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, &
4231    1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, &
4232    2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, &
4233    2.15414e-05_rb/)
4234    totplnk(1:50, 4) = (/                                                       &
4235    8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, &
4236    1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, &
4237    1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, &
4238    1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, &
4239    1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, &
4240    2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, &
4241    2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, &
4242    2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, &
4243    2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, &
4244    3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/)
4245    totplnk(51:100, 4) = (/                                                     &
4246    3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, &
4247    4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, &
4248    4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, &
4249    5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, &
4250    5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, &
4251    6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, &
4252    6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, &
4253    7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, &
4254    7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, &
4255    8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/)
4256    totplnk(101:150, 4) = (/                                                    &
4257    9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, &
4258    9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, &
4259    1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, &
4260    1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, &
4261    1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, &
4262    1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, &
4263    1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, &
4264    1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, &
4265    1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, &
4266    1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/)
4267    totplnk(151:181, 4) = (/                                                    &
4268    1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, &
4269    1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, &
4270    1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, &
4271    1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, &
4272    2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, &
4273    2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, &
4274    2.23158e-05_rb/)
4275    totplnk(1:50, 5) = (/                                                       &
4276    5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, &
4277    7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, &
4278    8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, &
4279    1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, &
4280    1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, &
4281    1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, &
4282    1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, &
4283    1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, &
4284    2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, &
4285    2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/)
4286    totplnk(51:100, 5) = (/                                                     &
4287    2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, &
4288    3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, &
4289    3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, &
4290    4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, &
4291    4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, &
4292    5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, &
4293    5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, &
4294    6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, &
4295    6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, &
4296    7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/)
4297    totplnk(101:150, 5) = (/                                                    &
4298    7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, &
4299    8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, &
4300    9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, &
4301    9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, &
4302    1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, &
4303    1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, &
4304    1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, &
4305    1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, &
4306    1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, &
4307    1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/)
4308    totplnk(151:181, 5) = (/                                                    &
4309    1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, &
4310    1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, &
4311    1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, &
4312    1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, &
4313    1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, &
4314    2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, &
4315    2.17931e-05_rb/)
4316    totplnk(1:50, 6) = (/                                                       &
4317    2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, &
4318    3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, &
4319    4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, &
4320    5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, &
4321    6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, &
4322    8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, &
4323    9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, &
4324    1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, &
4325    1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, &
4326    1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/)
4327    totplnk(51:100, 6) = (/                                                     &
4328    1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, &
4329    2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, &
4330    2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, &
4331    2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, &
4332    3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, &
4333    3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, &
4334    3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, &
4335    4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, &
4336    4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, &
4337    5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/)
4338    totplnk(101:150, 6) = (/                                                    &
4339    6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, &
4340    6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, &
4341    7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, &
4342    7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, &
4343    8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, &
4344    9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, &
4345    1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, &
4346    1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, &
4347    1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, &
4348    1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/)
4349    totplnk(151:181, 6) = (/                                                    &
4350    1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, &
4351    1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, &
4352    1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, &
4353    1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, &
4354    1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, &
4355    1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, &
4356    1.96471e-05_rb/)
4357    totplnk(1:50, 7) = (/                                                       &
4358    1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, &
4359    1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, &
4360    2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, &
4361    2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, &
4362    3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, &
4363    4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, &
4364    5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, &
4365    6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, &
4366    7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, &
4367    9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/)
4368    totplnk(51:100, 7) = (/                                                     &
4369    1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, &
4370    1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, &
4371    1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, &
4372    1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, &
4373    2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, &
4374    2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, &
4375    2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, &
4376    3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, &
4377    3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, &
4378    3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/)
4379    totplnk(101:150, 7) = (/                                                    &
4380    4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, &
4381    4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, &
4382    5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, &
4383    5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, &
4384    6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, &
4385    7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, &
4386    7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, &
4387    8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, &
4388    9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, &
4389    1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/)
4390    totplnk(151:181, 7) = (/                                                    &
4391    1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, &
4392    1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, &
4393    1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, &
4394    1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, &
4395    1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, &
4396    1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, &
4397    1.68640e-05_rb/)
4398    totplnk(1:50, 8) = (/                                                       &
4399    6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, &
4400    9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, &
4401    1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, &
4402    1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, &
4403    2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, &
4404    2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, &
4405    3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, &
4406    4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, &
4407    5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, &
4408    6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/)
4409    totplnk(51:100, 8) = (/                                                     &
4410    7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, &
4411    8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, &
4412    1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, &
4413    1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, &
4414    1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, &
4415    1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, &
4416    1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, &
4417    2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, &
4418    2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, &
4419    2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/)
4420    totplnk(101:150, 8) = (/                                                    &
4421    3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, &
4422    3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, &
4423    4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, &
4424    4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, &
4425    5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, &
4426    5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, &
4427    6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, &
4428    6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, &
4429    7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, &
4430    8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/)
4431    totplnk(151:181, 8) = (/                                                    &
4432    9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, &
4433    9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, &
4434    1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, &
4435    1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, &
4436    1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, &
4437    1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, &
4438    1.45267e-05_rb/)
4439    totplnk(1:50, 9) = (/                                                       &
4440    2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, &
4441    3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, &
4442    5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, &
4443    6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, &
4444    9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, &
4445    1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, &
4446    1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, &
4447    2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, &
4448    2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, &
4449    3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/)
4450    totplnk(51:100, 9) = (/                                                     &
4451    3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, &
4452    4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, &
4453    5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, &
4454    7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, &
4455    8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, &
4456    9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, &
4457    1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, &
4458    1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, &
4459    1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, &
4460    1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/)
4461    totplnk(101:150, 9) = (/                                                    &
4462    2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, &
4463    2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, &
4464    2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, &
4465    3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, &
4466    3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, &
4467    3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, &
4468    4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, &
4469    4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, &
4470    5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, &
4471    5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/)
4472    totplnk(151:181, 9) = (/                                                    &
4473    6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, &
4474    7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, &
4475    7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, &
4476    8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, &
4477    9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, &
4478    1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, &
4479    1.10781e-05_rb/)
4480    totplnk(1:50,10) = (/                                                       &
4481    8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, &
4482    1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, &
4483    1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, &
4484    2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, &
4485    3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, &
4486    5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, &
4487    6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, &
4488    8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, &
4489    1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, &
4490    1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/)
4491    totplnk(51:100,10) = (/                                                     &
4492    1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, &
4493    2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, &
4494    2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, &
4495    3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, &
4496    4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, &
4497    5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, &
4498    6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, &
4499    7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, &
4500    9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, &
4501    1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/)
4502    totplnk(101:150,10) = (/                                                    &
4503    1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, &
4504    1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, &
4505    1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, &
4506    1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, &
4507    2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, &
4508    2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, &
4509    2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, &
4510    3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, &
4511    3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, &
4512    4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/)
4513    totplnk(151:181,10) = (/                                                    &
4514    4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, &
4515    5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, &
4516    5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, &
4517    6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, &
4518    6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, &
4519    7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, &
4520    8.14138e-06_rb/)
4521    totplnk(1:50,11) = (/                                                       &
4522    2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, &
4523    3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, &
4524    5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, &
4525    8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, &
4526    1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, &
4527    1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, &
4528    2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, &
4529    3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, &
4530    4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, &
4531    5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/)
4532    totplnk(51:100,11) = (/                                                     &
4533    7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, &
4534    9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, &
4535    1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, &
4536    1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, &
4537    1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, &
4538    2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, &
4539    3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, &
4540    3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, &
4541    4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, &
4542    5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/)
4543    totplnk(101:150,11) = (/                                                    &
4544    6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, &
4545    7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, &
4546    8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, &
4547    1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, &
4548    1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, &
4549    1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, &
4550    1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, &
4551    1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, &
4552    2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, &
4553    2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/)
4554    totplnk(151:181,11) = (/                                                    &
4555    2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, &
4556    3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, &
4557    3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, &
4558    3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, &
4559    4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, &
4560    4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, &
4561    5.19332e-06_rb/)
4562    totplnk(1:50,12) = (/                                                       &
4563    2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, &
4564    4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, &
4565    7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, &
4566    1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, &
4567    1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, &
4568    2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, &
4569    4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, &
4570    5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, &
4571    8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, &
4572    1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/)
4573    totplnk(51:100,12) = (/                                                     &
4574    1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, &
4575    2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, &
4576    2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, &
4577    3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, &
4578    4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, &
4579    6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, &
4580    8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, &
4581    1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, &
4582    1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, &
4583    1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/)
4584    totplnk(101:150,12) = (/                                                    &
4585    1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, &
4586    2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, &
4587    2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, &
4588    3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, &
4589    4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, &
4590    5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, &
4591    5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, &
4592    6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, &
4593    8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, &
4594    9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/)
4595    totplnk(151:181,12) = (/                                                    &
4596    1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, &
4597    1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, &
4598    1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, &
4599    1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, &
4600    1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, &
4601    2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, &
4602    2.41619e-06_rb/)
4603    totplnk(1:50,13) = (/                                                       &
4604    4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, &
4605    8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, &
4606    1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, &
4607    2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, &
4608    3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, &
4609    6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, &
4610    9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, &
4611    1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, &
4612    2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, &
4613    3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/)
4614    totplnk(51:100,13) = (/                                                     &
4615    4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, &
4616    6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, &
4617    8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, &
4618    1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, &
4619    1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, &
4620    2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, &
4621    2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, &
4622    3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, &
4623    4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, &
4624    6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/)
4625    totplnk(101:150,13) = (/                                                    &
4626    7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, &
4627    9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, &
4628    1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, &
4629    1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, &
4630    1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, &
4631    2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, &
4632    2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, &
4633    3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, &
4634    3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, &
4635    4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/)
4636    totplnk(151:181,13) = (/                                                    &
4637    5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, &
4638    6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, &
4639    7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, &
4640    8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, &
4641    9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, &
4642    1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, &
4643    1.28049e-06_rb/)
4644    totplnk(1:50,14) = (/                                                       &
4645    1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, &
4646    2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, &
4647    4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, &
4648    8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, &
4649    1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, &
4650    2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, &
4651    3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, &
4652    5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, &
4653    8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, &
4654    1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/)
4655    totplnk(51:100,14) = (/                                                     &
4656    1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, &
4657    2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, &
4658    4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, &
4659    5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, &
4660    7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, &
4661    1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, &
4662    1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, &
4663    1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, &
4664    2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, &
4665    3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/)
4666    totplnk(101:150,14) = (/                                                    &
4667    4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, &
4668    5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, &
4669    6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, &
4670    8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, &
4671    1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, &
4672    1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, &
4673    1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, &
4674    1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, &
4675    2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, &
4676    2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/)
4677    totplnk(151:181,14) = (/                                                    &
4678    3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, &
4679    3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, &
4680    4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, &
4681    5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, &
4682    6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, &
4683    7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, &
4684    8.27050e-07_rb/)
4685    totplnk(1:50,15) = (/                                                       &
4686    3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, &
4687    7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, &
4688    1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, &
4689    2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, &
4690    4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, &
4691    7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, &
4692    1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, &
4693    2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, &
4694    3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, &
4695    5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/)
4696    totplnk(51:100,15) = (/                                                     &
4697    7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, &
4698    1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, &
4699    1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, &
4700    2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, &
4701    3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, &
4702    4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, &
4703    6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, &
4704    8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, &
4705    1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, &
4706    1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/)
4707    totplnk(101:150,15) = (/                                                    &
4708    1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, &
4709    2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, &
4710    3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, &
4711    4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, &
4712    5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, &
4713    6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, &
4714    8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, &
4715    1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, &
4716    1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, &
4717    1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/)
4718    totplnk(151:181,15) = (/                                                    &
4719    1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, &
4720    2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, &
4721    2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, &
4722    3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, &
4723    3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, &
4724    4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, &
4725    4.96535e-07_rb/)
4726    totplnk(1:50,16) = (/                                                       &
4727    0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, &
4728    0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, &
4729    0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, &
4730    0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, &
4731    0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, &
4732    0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, &
4733    0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, &
4734    0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, &
4735    0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, &
4736    0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/)
4737    totplnk(51:100,16) = (/                                                     &
4738    0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, &
4739    0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, &
4740    0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, &
4741    0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, &
4742    0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, &
4743    0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, &
4744    0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, &
4745    0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, &
4746    0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, &
4747    0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/)
4748    totplnk(101:150,16) = (/                                                    &
4749    0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, &
4750    0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, &
4751    0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, &
4752    0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, &
4753    0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, &
4754    0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, &
4755    0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, &
4756    0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, &
4757    0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, &
4758    0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/)
4759    totplnk(151:181,16) = (/                                                    &
4760    0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, &
4761    0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, &
4762    0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, &
4763    0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, &
4764    0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, &
4765    0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, &
4766    0.16823e-06_rb/)
4767    totplk16(1:50) = (/                                                         &
4768    0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, &
4769    0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, &
4770    0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, &
4771    0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, &
4772    0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, &
4773    0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, &
4774    0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, &
4775    0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, &
4776    0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, &
4777    0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/)
4778    totplk16(51:100) = (/                                                       &
4779    0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, &
4780    0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, &
4781    0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, &
4782    0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, &
4783    0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, &
4784    0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, &
4785    0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, &
4786    0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, &
4787    0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, &
4788    0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/)
4789    totplk16(101:150) = (/                                                      &
4790    0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, &
4791    0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, &
4792    0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, &
4793    0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, &
4794    0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, &
4795    0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, &
4796    0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, &
4797    0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, &
4798    0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, &
4799    0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/)
4800    totplk16(151:181) = (/                                                      &
4801    0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, &
4802    0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, &
4803    0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, &
4804    0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, &
4805    0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, &
4806    0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, &
4807    0.14841e-06_rb/)
4808 !
4809    end subroutine lwavplank
4810 !-------------------------------------------------------------------------------
4811 !
4812 !
4813 !-------------------------------------------------------------------------------
4814    end module rrtmg_lw_setcoef_k
4815 !-------------------------------------------------------------------------------
4816 !
4817 !
4818 !-------------------------------------------------------------------------------
4819    module rrtmg_lw_taumol_k
4820 !-------------------------------------------------------------------------------
4821 !   --------------------------------------------------------------------------
4822 !  |                                                                          |
4823 !  |  Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER).  |
4824 !  |  This software may be used, copied, or redistributed as long as it is    |
4825 !  |  not sold and this copyright notice is reproduced on each copy made.     |
4826 !  |  This model is provided as is without any express or implied warranties. |
4827 !  |                       (http://www.rtweb.aer.com/)                        |
4828 !  |                                                                          |
4829 !   --------------------------------------------------------------------------
4830 !-------------------------------------------------------------------------------
4831    use parkind_k,  only : im => kind_im, rb => kind_rb
4832    use parrrtm_k,  only : mg, nbndlw, maxxsec, ngptlw
4833    use rrlw_con_k, only : oneminus
4834    use rrlw_wvn_k, only : nspa, nspb
4835    use rrlw_vsn_k, only : hvrtau, hnamtau
4836 !
4837    implicit none
4838 !
4839    contains
4840 !-------------------------------------------------------------------------------
4841 !
4842 !
4843 !-------------------------------------------------------------------------------
4844    subroutine taumol(nlayers, pavel, wx, coldry,                               &
4845                      laytrop, jp, jt, jt1, planklay, planklev, plankbnd,       &
4846                      colh2o, colco2, colo3, coln2o, colco, colch4, colo2,      &
4847                      colbrd, fac00, fac01, fac10, fac11,                       &
4848                      rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1,         &
4849                      rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1,       &
4850                      rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1,         &
4851                      selffac, selffrac, indself, forfac, forfrac, indfor,      &
4852                      minorfrac, scaleminor, scaleminorn2, indminor,            &
4853                      fracs, taug)
4854 !-------------------------------------------------------------------------------
4855 !                                                                              *
4856 !                   Optical depths developed for the                           *
4857 !                                                                              *
4858 !                 RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
4859 !                                                                              *
4860 !                                                                              *
4861 !             ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
4862 !                         131 HARTWELL AVENUE                                  *
4863 !                         LEXINGTON, MA 02421                                  *
4864 !                                                                              *
4865 !                                                                              *
4866 !                            ELI J. MLAWER                                     *
4867 !                          JENNIFER DELAMERE                                   *
4868 !                          STEVEN J. TAUBMAN                                   *
4869 !                          SHEPARD A. CLOUGH                                   *
4870 !                                                                              *
4871 !                                                                              *
4872 !                                                                              *
4873 !                                                                              *
4874 !                        email:  mlawer@aer.com                                *
4875 !                        email:  jdelamer@aer.com                              *
4876 !                                                                              *
4877 !         The authors wish to acknowledge the contributions of the             *
4878 !         following people:  Karen Cady-Pereira, Patrick D. Brown,             *
4879 !         Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom.    *
4880 !                                                                              *
4881 ! ******************************************************************************
4882 !                                                                              *
4883 !   Revision for g-point reduction: Michael J. Iacono, AER, Inc.               *
4884 !                                                                              *
4885 ! ******************************************************************************
4886 !      TAUMOL                                                                  *
4887 !                                                                              *
4888 !      This file contains the subroutines TAUGBn (where n goes from            *
4889 !      1 to 16).  TAUGBn calculates the optical depths and Planck fractions    *
4890 !      per g-value and layer for band n.                                       *
4891 !                                                                              *
4892 !   Output:  optical depths (unitless)                                         *
4893 !            fractions needed to compute Planck functions at every layer       *
4894 !                and g-value                                                   *
4895 !                                                                              *
4896 !      COMMON /TAUGCOM/  TAUG(MXLAY,MG)                                        *
4897 !      COMMON /PLANKG/   FRACS(MXLAY,MG)                                       *
4898 !                                                                              *
4899 !   Input                                                                      *
4900 !                                                                              *
4901 !      COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)                  *
4902 !      COMMON /PRECISE/  ONEMINUS                                              *
4903 !      COMMON /PROFILE/  NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),                    *
4904 !      &                 PZ(0:MXLAY),TZ(0:MXLAY)                               *
4905 !      COMMON /PROFdata/ LAYTROP,                                              *
4906 !     &                  COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY),             *
4907 !     &                  COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY),             *
4908 !     &                  COLO2(MXLAY)
4909 !      COMMON /INTFAC/   FAC00(MXLAY),FAC01(MXLAY),                            *
4910 !     &                  FAC10(MXLAY),FAC11(MXLAY)                             *
4911 !      COMMON /INTIND/   JP(MXLAY),JT(MXLAY),JT1(MXLAY)                        *
4912 !      COMMON /SELF/     SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY)       *
4913 !                                                                              *
4914 !      Description:                                                            *
4915 !      NG(IBAND) - number of g-values in band IBAND                            *
4916 !      NSPA(IBAND) - for the lower atmosphere, the number of reference         *
4917 !                    atmospheres that are stored for band IBAND per            *
4918 !                    pressure level and temperature.  Each of these            *
4919 !                    atmospheres has different relative amounts of the         *
4920 !                    key species for the band (i.e. different binary           *
4921 !                    species parameters).                                      *
4922 !      NSPB(IBAND) - same for upper atmosphere                                 *
4923 !      ONEMINUS - since problems are caused in some cases by interpolation     *
4924 !                 parameters equal to or greater than 1, for these cases       *
4925 !                 these parameters are set to this value, slightly < 1.        *
4926 !      PAVEL - layer pressures (mb)                                            *
4927 !      TAVEL - layer temperatures (degrees K)                                  *
4928 !      PZ - level pressures (mb)                                               *
4929 !      TZ - level temperatures (degrees K)                                     *
4930 !      LAYTROP - layer at which switch is made from one combination of         *
4931 !                key species to another                                        *
4932 !      COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water         *
4933 !                vapor,carbon dioxide, ozone, nitrous ozide, methane,          *
4934 !                respectively (molecules/cm**2)                                *
4935 !      FACij(LAY) - for layer LAY, these are factors that are needed to        *
4936 !                   compute the interpolation factors that multiply the        *
4937 !                   appropriate reference k-values.  A value of 0 (1) for      *
4938 !                   i,j indicates that the corresponding factor multiplies     *
4939 !                   reference k-value for the lower (higher) of the two        *
4940 !                   appropriate temperatures, and altitudes, respectively.     *
4941 !      JP - the index of the lower (in altitude) of the two appropriate        *
4942 !           reference pressure levels needed for interpolation                 *
4943 !      JT, JT1 - the indices of the lower of the two appropriate reference     *
4944 !                temperatures needed for interpolation (for pressure           *
4945 !                levels JP and JP+1, respectively)                             *
4946 !      SELFFAC - scale factor needed for water vapor self-continuum, equals    *
4947 !                (water vapor density)/(atmospheric density at 296K and        *
4948 !                1013 mb)                                                      *
4949 !      SELFFRAC - factor needed for temperature interpolation of reference     *
4950 !                 water vapor self-continuum data                              *
4951 !      INDSELF - index of the lower of the two appropriate reference           *
4952 !                temperatures needed for the self-continuum interpolation      *
4953 !      FORFAC  - scale factor needed for water vapor foreign-continuum.        *
4954 !      FORFRAC - factor needed for temperature interpolation of reference      *
4955 !                 water vapor foreign-continuum data                           *
4956 !      INDFOR  - index of the lower of the two appropriate reference           *
4957 !                temperatures needed for the foreign-continuum interpolation   *
4958 !                                                                              *
4959 !   Data input                                                                 *
4960 !      COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
4961 !                  FORREF(4,MG), KA_M'MGAS', KB_M'MGAS'                        *
4962 !         (note:  n is the band number,'MGAS' is the species name of the minor *
4963 !          gas)                                                                *
4964 !                                                                              *
4965 !      Description:                                                            *
4966 !      KA - k-values for low reference atmospheres (key-species only)          *
4967 !           (units: cm**2/molecule)                                            *
4968 !      KB - k-values for high reference atmospheres (key-species only)         *
4969 !           (units: cm**2/molecule)                                            *
4970 !      KA_M'MGAS' - k-values for low reference atmosphere minor species        *
4971 !           (units: cm**2/molecule)                                            *
4972 !      KB_M'MGAS' - k-values for high reference atmosphere minor species       *
4973 !           (units: cm**2/molecule)                                            *
4974 !      SELFREF - k-values for water vapor self-continuum for reference         *
4975 !                atmospheres (used below LAYTROP)                              *
4976 !                (units: cm**2/molecule)                                       *
4977 !      FORREF  - k-values for water vapor foreign-continuum for reference      *
4978 !                atmospheres (used below/above LAYTROP)                        *
4979 !                (units: cm**2/molecule)                                       *
4980 !                                                                              *
4981 !      dimension ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG)                     *
4982 !      equivalence (KA,ABSA),(KB,ABSB)                                         *
4983 !-------------------------------------------------------------------------------
4984 !  input :
4985 !    layers                   - total number of layers
4986 !    pavel(nlayers)           - layer pressures (mb)
4987 !    wx(maxxsec,nlayers)      - cross-section amounts (mol/cm2)
4988 !    coldry(nlayers)          - column amount (dry air)
4989 !    laytrop                  - tropopause layer index
4990 !    jp(nlayers)
4991 !    jt(nlayers)
4992 !    jt1(nlayers)
4993 !    planklay(nlayers,nbndlw)
4994 !    planklev(nlayers,nbndlw)
4995 !    plankbnd(nbndlw)
4996 !    colh2o(nlayers)          - column amount (h2o)
4997 !    colco2(nlayers)          - column amount (co2)
4998 !    colo3(nlayers)           - column amount (o3)
4999 !    coln2o(nlayers)          - column amount (n2o)
5000 !    colco(nlayers)           - column amount (co)
5001 !    colch4(nlayers)          - column amount (ch4)
5002 !    colo2(nlayers)           - column amount (o2)
5003 !    colbrd(nlayers)          - column amount (broadening gases)
5004 !    indself(nlayers)
5005 !    indfor(nlayers)
5006 !    selffac(nlayers)
5007 !    selffrac(nlayers)
5008 !    forfac(nlayers)
5009 !    forfrac(nlayers)
5010 !    indminor(nlayers)
5011 !    minorfrac(nlayers)
5012 !    scaleminor(nlayers)
5013 !    scaleminorn2(nlayers)
5014 !    fac00(nlayers), fac01(nlayers), fac10(nlayers), fac11(nlayers)
5015 !    rat_h2oco2(nlayers), rat_h2oco2_1(nlayers)
5016 !    rat_h2oo3(nlayers),rat_h2oo3_1(nlayers)
5017 !    rat_h2on2o(nlayers),rat_h2on2o_1(nlayers)
5018 !    rat_h2och4(nlayers),rat_h2och4_1(nlayers)
5019 !    rat_n2oco2(nlayers),rat_n2oco2_1(nlayers)
5020 !    rat_o3co2(nlayers),rat_o3co2_1(nlayers)
5021 !
5022 !  output :
5023 !    fracs(nlayers,ngptlw)    - planck fractions
5024 !    taug(nlayers,ngptlw)     - gaseous optical depth
5025 !
5026 !-------------------------------------------------------------------------------
5027 !
5028 ! Input
5029 !
5030    integer(kind=im)              , intent(in   ) :: nlayers
5031    real(kind=rb), dimension(:)   , intent(in   ) :: pavel
5032    real(kind=rb), dimension(:,:) , intent(in   ) :: wx
5033    real(kind=rb), dimension(:)   , intent(in   ) :: coldry
5034 !
5035    integer(kind=im)              , intent(in   ) :: laytrop
5036    integer(kind=im), dimension(:), intent(in   ) :: jp
5037    integer(kind=im), dimension(:), intent(in   ) :: jt
5038    integer(kind=im), dimension(:), intent(in   ) :: jt1
5039    real(kind=rb), dimension(:,:) , intent(in   ) :: planklay
5040    real(kind=rb), dimension(0:,:), intent(in   ) :: planklev
5041    real(kind=rb), dimension(:)   , intent(in   ) :: plankbnd
5042 !
5043    real(kind=rb), dimension(:)   , intent(in   ) :: colh2o
5044    real(kind=rb), dimension(:)   , intent(in   ) :: colco2
5045    real(kind=rb), dimension(:)   , intent(in   ) :: colo3
5046    real(kind=rb), dimension(:)   , intent(in   ) :: coln2o
5047    real(kind=rb), dimension(:)   , intent(in   ) :: colco
5048    real(kind=rb), dimension(:)   , intent(in   ) :: colch4
5049    real(kind=rb), dimension(:)   , intent(in   ) :: colo2
5050    real(kind=rb), dimension(:)   , intent(in   ) :: colbrd
5051 !
5052    integer(kind=im), dimension(:), intent(in   ) :: indself
5053    integer(kind=im), dimension(:), intent(in   ) :: indfor
5054    real(kind=rb), dimension(:)   , intent(in   ) :: selffac
5055    real(kind=rb), dimension(:)   , intent(in   ) :: selffrac
5056    real(kind=rb), dimension(:)   , intent(in   ) :: forfac
5057    real(kind=rb), dimension(:)   , intent(in   ) :: forfrac
5058 !
5059    integer(kind=im), dimension(:), intent(in   ) :: indminor
5060    real(kind=rb), dimension(:)   , intent(in   ) :: minorfrac
5061    real(kind=rb), dimension(:)   , intent(in   ) :: scaleminor
5062    real(kind=rb), dimension(:)   , intent(in   ) :: scaleminorn2
5063    real(kind=rb), dimension(:)   , intent(in   ) :: fac00, fac01, fac10, fac11
5064    real(kind=rb), dimension(:)   , intent(in   ) :: rat_h2oco2, rat_h2oco2_1,  &
5065                                                       rat_h2oo3, rat_h2oo3_1,  &
5066                                                     rat_h2on2o, rat_h2on2o_1,  &
5067                                                     rat_h2och4, rat_h2och4_1,  &
5068                                                     rat_n2oco2, rat_n2oco2_1,  &
5069                                                       rat_o3co2, rat_o3co2_1
5070 !
5071 ! Output
5072 !
5073    real(kind=rb), dimension(:,:), intent(  out) :: fracs
5074    real(kind=rb), dimension(:,:), intent(  out) :: taug
5075 !-------------------------------------------------------------------------------
5076 !
5077    hvrtau = '$Revision: 1.7 $'
5078 !
5079 ! Calculate gaseous optical depth and planck fractions for each spectral band.
5080 !
5081    call taugb1
5082    call taugb2
5083    call taugb3
5084    call taugb4
5085    call taugb5
5086    call taugb6
5087    call taugb7
5088    call taugb8
5089    call taugb9
5090    call taugb10
5091    call taugb11
5092    call taugb12
5093    call taugb13
5094    call taugb14
5095    call taugb15
5096    call taugb16
5097 !
5098    contains
5099 !-------------------------------------------------------------------------------
5100 !
5101 !
5102 !-------------------------------------------------------------------------------
5103    subroutine taugb1
5104 !-------------------------------------------------------------------------------
5105 !
5106 !  ------- Modifications -------
5107 !  Written by Eli J. Mlawer, Atmospheric & Environmental Research.
5108 !  Revised by Michael J. Iacono, Atmospheric & Environmental Research.
5109 !
5110 !     band 1:  10-350 cm-1 (low key - h2o; low minor - n2)
5111 !                          (high key - h2o; high minor - n2)
5112 !
5113 !     note: previous versions of rrtm band 1:
5114 !           10-250 cm-1 (low - h2o; high - h2o)
5115 !
5116 !-------------------------------------------------------------------------------
5117    use parrrtm_k,   only : ng1
5118    use rrlw_kg01_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
5119                          ka_mn2, kb_mn2, selfref, forref
5120 !
5121 ! Local
5122 !
5123    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5124    real(kind=rb)    :: pp, corradj, scalen2, tauself, taufor, taun2
5125 !-------------------------------------------------------------------------------
5126 !
5127 ! Minor gas mapping levels:
5128 !     lower - n2, p = 142.5490 mbar, t = 215.70 k
5129 !     upper - n2, p = 142.5490 mbar, t = 215.70 k
5130 !
5131 ! Compute the optical depth by interpolating in ln(pressure) and
5132 ! temperature.  Below laytrop, the water vapor self-continuum and
5133 ! foreign continuum is interpolated (in temperature) separately.
5134 !
5135 ! Lower atmosphere loop
5136 !
5137    do lay = 1,laytrop
5138 !
5139      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1
5140      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1
5141      inds = indself(lay)
5142      indf = indfor(lay)
5143      indm = indminor(lay)
5144      pp = pavel(lay)
5145      corradj =  1.
5146      if (pp.lt.250._rb) then
5147        corradj = 1._rb-0.15_rb*(250._rb-pp)/154.4_rb
5148      endif
5149 !
5150      scalen2 = colbrd(lay) * scaleminorn2(lay)
5151      do ig = 1,ng1
5152        tauself = selffac(lay)*(selfref(inds,ig)+selffrac(lay)*                 &
5153                 (selfref(inds+1,ig)-selfref(inds,ig)))
5154        taufor = forfac(lay)*(forref(indf,ig)+forfrac(lay)*                     &
5155                (forref(indf+1,ig)- forref(indf,ig)))
5156        taun2 = scalen2*(ka_mn2(indm,ig)+                                       &
5157                minorfrac(lay)*(ka_mn2(indm+1,ig)-ka_mn2(indm,ig)))
5158        taug(lay,ig) = corradj*(colh2o(lay)*                                    &
5159                       (fac00(lay)*absa(ind0,ig)+                               &
5160                        fac10(lay)*absa(ind0+1,ig)+                             &
5161                        fac01(lay)*absa(ind1,ig)+                               &
5162                        fac11(lay)*absa(ind1+1,ig))                             &
5163                       +tauself+taufor+taun2)
5164        fracs(lay,ig) = fracrefa(ig)
5165      enddo
5166    enddo
5167 !
5168 ! Upper atmosphere loop
5169 !
5170    do lay = laytrop+1,nlayers
5171 !
5172      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1
5173      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1
5174      indf = indfor(lay)
5175      indm = indminor(lay)
5176      pp = pavel(lay)
5177      corradj =  1._rb-0.15_rb*(pp/95.6_rb)
5178 !
5179      scalen2 = colbrd(lay)*scaleminorn2(lay)
5180 !
5181      do ig = 1,ng1
5182        taufor = forfac(lay)*(forref(indf,ig)+                                  &
5183                 forfrac(lay)*(forref(indf+1,ig)-forref(indf,ig)))
5184        taun2 = scalen2*(kb_mn2(indm,ig)+                                       &
5185                minorfrac(lay)*(kb_mn2(indm+1,ig)-kb_mn2(indm,ig)))
5186        taug(lay,ig) = corradj*(colh2o(lay)*                                    &
5187                       (fac00(lay)*absb(ind0,ig)+                               &
5188                        fac10(lay)*absb(ind0+1,ig)+                             &
5189                        fac01(lay)*absb(ind1,ig)+                               &
5190                        fac11(lay)*absb(ind1+1,ig))                             &
5191                       +taufor + taun2)
5192        fracs(lay,ig) = fracrefb(ig)
5193      enddo
5194    enddo
5195 !
5196    end subroutine taugb1
5197 !-------------------------------------------------------------------------------
5198 !
5199 !
5200 !-------------------------------------------------------------------------------
5201    subroutine taugb2
5202 !-------------------------------------------------------------------------------
5203 !
5204 !  abstract : band 2,  350-500 cm-1 (low key - h2o; high key - h2o)
5205 !
5206 !  note: previous version of rrtm band 2:
5207 !        250 - 500 cm-1 (low - h2o; high - h2o)
5208 !
5209 !-------------------------------------------------------------------------------
5210    use parrrtm_k,   only : ng2, ngs1
5211    use rrlw_kg02_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
5212                          selfref, forref
5213 !
5214 ! Local
5215 !
5216    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5217    real(kind=rb)    :: pp, corradj, tauself, taufor
5218 !-------------------------------------------------------------------------------
5219 !
5220 ! Compute the optical depth by interpolating in ln(pressure) and
5221 ! temperature.  Below laytrop, the water vapor self-continuum and
5222 ! foreign continuum is interpolated (in temperature) separately.
5223 !
5224 ! Lower atmosphere loop
5225 !
5226    do lay = 1,laytrop
5227      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
5228      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
5229      inds = indself(lay)
5230      indf = indfor(lay)
5231      pp = pavel(lay)
5232      corradj = 1._rb-.05_rb*(pp-100._rb)/900._rb
5233      do ig = 1,ng2
5234        tauself = selffac(lay)*(selfref(inds,ig)+selffrac(lay)*                 &
5235                 (selfref(inds+1,ig)-selfref(inds,ig)))
5236        taufor =  forfac(lay)*(forref(indf,ig)+forfrac(lay)*                    &
5237                 (forref(indf+1,ig) - forref(indf,ig)))
5238        taug(lay,ngs1+ig) = corradj*(colh2o(lay)*                               &
5239                            (fac00(lay)*absa(ind0,ig)+                          &
5240                             fac10(lay)*absa(ind0+1,ig)+                        &
5241                             fac01(lay)*absa(ind1,ig)+                          &
5242                             fac11(lay)*absa(ind1+1,ig))                        &
5243                            +tauself+taufor)
5244        fracs(lay,ngs1+ig) = fracrefa(ig)
5245      enddo
5246    enddo
5247 !
5248 ! Upper atmosphere loop
5249 !
5250    do lay = laytrop+1,nlayers
5251      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
5252      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
5253      indf = indfor(lay)
5254      do ig = 1,ng2
5255        taufor = forfac(lay)*(forref(indf,ig)+                                  &
5256                 forfrac(lay)*(forref(indf+1,ig)-forref(indf,ig)))
5257        taug(lay,ngs1+ig) = colh2o(lay)*                                        &
5258                            (fac00(lay)*absb(ind0,ig)+                          &
5259                             fac10(lay)*absb(ind0+1,ig)+                        &
5260                             fac01(lay)*absb(ind1,ig)+                          &
5261                             fac11(lay)*absb(ind1+1,ig))                        &
5262                            +taufor
5263        fracs(lay,ngs1+ig) = fracrefb(ig)
5264      enddo
5265    enddo
5266 !
5267    end subroutine taugb2
5268 !-------------------------------------------------------------------------------
5269 !
5270 !
5271 !-------------------------------------------------------------------------------
5272    subroutine taugb3
5273 !-------------------------------------------------------------------------------
5274 !
5275 !  abstract : band 3,  500-630 cm-1 (low key - h2o,co2; low minor - n2o)
5276 !                                   (high key - h2o,co2; high minor - n2o)
5277 !
5278 !-------------------------------------------------------------------------------
5279    use parrrtm_k,   only : ng3, ngs2
5280    use rrlw_ref_k,  only : chi_mls
5281    use rrlw_kg03_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
5282                          ka_mn2o, kb_mn2o, selfref, forref
5283 !
5284 ! Local
5285 !
5286    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5287    integer(kind=im) :: js, js1, jmn2o, jpl
5288    real(kind=rb)    :: speccomb, specparm, specmult, fs
5289    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
5290    real(kind=rb)    :: speccomb_mn2o, specparm_mn2o, specmult_mn2o,            &
5291                        fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
5292    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
5293    real(kind=rb)    :: p, p4, fk0, fk1, fk2
5294    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
5295    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
5296    real(kind=rb)    :: tauself, taufor, n2om1, n2om2, absn2o
5297    real(kind=rb)    :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
5298    real(kind=rb)    :: tau_major, tau_major1
5299 !-------------------------------------------------------------------------------
5300 !
5301 ! Minor gas mapping levels:
5302 !     lower - n2o, p = 706.272 mbar, t = 278.94 k
5303 !     upper - n2o, p = 95.58 mbar, t = 215.7 k
5304 !
5305 !  P = 212.725 mb
5306 !
5307    refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
5308 !
5309 !  P = 95.58 mb
5310 !
5311    refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
5312 !
5313 !  P = 706.270mb
5314 !
5315    refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
5316 !
5317 !  P = 95.58 mb
5318 !
5319    refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
5320 !
5321 ! Compute the optical depth by interpolating in ln(pressure) and
5322 ! temperature, and appropriate species.  Below laytrop, the water vapor
5323 ! self-continuum and foreign continuum is interpolated (in temperature)
5324 ! separately.
5325 !
5326 ! Lower atmosphere loop
5327 !
5328    do lay = 1,laytrop
5329      speccomb = colh2o(lay)+rat_h2oco2(lay)*colco2(lay)
5330      specparm = colh2o(lay)/speccomb
5331      if (specparm.ge.oneminus) specparm = oneminus
5332      specmult = 8._rb*(specparm)
5333      js = 1+int(specmult)
5334      fs = mod(specmult,1.0_rb)
5335 !
5336      speccomb1 = colh2o(lay)+rat_h2oco2_1(lay)*colco2(lay)
5337      specparm1 = colh2o(lay)/speccomb1
5338      if (specparm1.ge.oneminus) specparm1 = oneminus
5339      specmult1 = 8._rb*(specparm1)
5340      js1 = 1+int(specmult1)
5341      fs1 = mod(specmult1,1.0_rb)
5342 !
5343      speccomb_mn2o = colh2o(lay)+refrat_m_a*colco2(lay)
5344      specparm_mn2o = colh2o(lay)/speccomb_mn2o
5345      if (specparm_mn2o.ge.oneminus) specparm_mn2o = oneminus
5346      specmult_mn2o = 8._rb*specparm_mn2o
5347      jmn2o = 1+int(specmult_mn2o)
5348      fmn2o = mod(specmult_mn2o,1.0_rb)
5349      fmn2omf = minorfrac(lay)*fmn2o
5350 !
5351 ! In atmospheres where the amount of N2O is too great to be considered
5352 ! a minor species, adjust the column amount of N2O by an empirical factor
5353 ! to obtain the proper contribution.
5354 !
5355      chi_n2o = coln2o(lay)/coldry(lay)
5356      ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
5357      if (ratn2o.gt.1.5_rb) then
5358        adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5359        adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5360      else
5361        adjcoln2o = coln2o(lay)
5362      endif
5363 !
5364      speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5365      specparm_planck = colh2o(lay)/speccomb_planck
5366      if (specparm_planck.ge.oneminus) specparm_planck=oneminus
5367      specmult_planck = 8._rb*specparm_planck
5368      jpl = 1+int(specmult_planck)
5369      fpl = mod(specmult_planck,1.0_rb)
5370 !
5371      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3)+js
5372      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3)+js1
5373      inds = indself(lay)
5374      indf = indfor(lay)
5375      indm = indminor(lay)
5376 !
5377      if (specparm.lt.0.125_rb) then
5378        p = fs-1
5379        p4 = p**4
5380        fk0 = p4
5381        fk1 = 1-p-2.0_rb*p4
5382        fk2 = p+p4
5383        fac000 = fk0*fac00(lay)
5384        fac100 = fk1*fac00(lay)
5385        fac200 = fk2*fac00(lay)
5386        fac010 = fk0*fac10(lay)
5387        fac110 = fk1*fac10(lay)
5388        fac210 = fk2*fac10(lay)
5389      else if (specparm.gt.0.875_rb) then
5390        p = -fs
5391        p4 = p**4
5392        fk0 = p4
5393        fk1 = 1-p-2.0_rb*p4
5394        fk2 = p+p4
5395        fac000 = fk0*fac00(lay)
5396        fac100 = fk1*fac00(lay)
5397        fac200 = fk2*fac00(lay)
5398        fac010 = fk0*fac10(lay)
5399        fac110 = fk1*fac10(lay)
5400        fac210 = fk2*fac10(lay)
5401      else
5402        fac000 = (1._rb-fs)*fac00(lay)
5403        fac010 = (1._rb-fs)*fac10(lay)
5404        fac100 = fs*fac00(lay)
5405        fac110 = fs*fac10(lay)
5406      endif
5407 !
5408      if (specparm1.lt.0.125_rb) then
5409        p = fs1-1
5410        p4 = p**4
5411        fk0 = p4
5412        fk1 = 1-p-2.0_rb*p4
5413        fk2 = p+p4
5414        fac001 = fk0*fac01(lay)
5415        fac101 = fk1*fac01(lay)
5416        fac201 = fk2*fac01(lay)
5417        fac011 = fk0*fac11(lay)
5418        fac111 = fk1*fac11(lay)
5419        fac211 = fk2*fac11(lay)
5420      else if (specparm1.gt.0.875_rb) then
5421        p = -fs1
5422        p4 = p**4
5423        fk0 = p4
5424        fk1 = 1-p-2.0_rb*p4
5425        fk2 = p+p4
5426        fac001 = fk0*fac01(lay)
5427        fac101 = fk1*fac01(lay)
5428        fac201 = fk2*fac01(lay)
5429        fac011 = fk0*fac11(lay)
5430        fac111 = fk1*fac11(lay)
5431        fac211 = fk2*fac11(lay)
5432      else
5433        fac001 = (1._rb-fs1)*fac01(lay)
5434        fac011 = (1._rb-fs1)*fac11(lay)
5435        fac101 = fs1*fac01(lay)
5436        fac111 = fs1*fac11(lay)
5437      endif
5438 !
5439      do ig = 1,ng3
5440        tauself = selffac(lay)*(selfref(inds,ig)+selffrac(lay)*                 &
5441                 (selfref(inds+1,ig)-selfref(inds,ig)))
5442        taufor = forfac(lay)*(forref(indf,ig)+forfrac(lay)*                     &
5443                (forref(indf+1,ig)-forref(indf,ig)))
5444        n2om1 = ka_mn2o(jmn2o,indm,ig)+fmn2o*                                   &
5445               (ka_mn2o(jmn2o+1,indm,ig)-ka_mn2o(jmn2o,indm,ig))
5446        n2om2 = ka_mn2o(jmn2o,indm+1,ig)+fmn2o*                                 &
5447               (ka_mn2o(jmn2o+1,indm+1,ig)-ka_mn2o(jmn2o,indm+1,ig))
5448        absn2o = n2om1 + minorfrac(lay)*(n2om2 - n2om1)
5449 !
5450        if (specparm.lt.0.125_rb) then
5451          tau_major = speccomb *                                                &
5452                      (fac000 * absa(ind0,ig) +                                 &
5453                       fac100 * absa(ind0+1,ig) +                               &
5454                       fac200 * absa(ind0+2,ig) +                               &
5455                       fac010 * absa(ind0+9,ig) +                               &
5456                       fac110 * absa(ind0+10,ig) +                              &
5457                       fac210 * absa(ind0+11,ig))
5458        else if (specparm.gt.0.875_rb) then
5459          tau_major = speccomb *                                                &
5460                      (fac200 * absa(ind0-1,ig) +                               &
5461                       fac100 * absa(ind0,ig) +                                 &
5462                       fac000 * absa(ind0+1,ig) +                               &
5463                       fac210 * absa(ind0+8,ig) +                               &
5464                       fac110 * absa(ind0+9,ig) +                               &
5465                       fac010 * absa(ind0+10,ig))
5466        else
5467          tau_major = speccomb *                                                &
5468                      (fac000 * absa(ind0,ig) +                                 &
5469                       fac100 * absa(ind0+1,ig) +                               &
5470                       fac010 * absa(ind0+9,ig) +                               &
5471                       fac110 * absa(ind0+10,ig))
5472        endif
5473 !
5474        if (specparm1.lt.0.125_rb) then
5475          tau_major1 = speccomb1 *                                              &
5476                       (fac001 * absa(ind1,ig) +                                &
5477                        fac101 * absa(ind1+1,ig) +                              &
5478                        fac201 * absa(ind1+2,ig) +                              &
5479                        fac011 * absa(ind1+9,ig) +                              &
5480                        fac111 * absa(ind1+10,ig) +                             &
5481                        fac211 * absa(ind1+11,ig))
5482        else if (specparm1.gt.0.875_rb) then
5483          tau_major1 = speccomb1 *                                              &
5484                       (fac201 * absa(ind1-1,ig) +                              &
5485                        fac101 * absa(ind1,ig) +                                &
5486                        fac001 * absa(ind1+1,ig) +                              &
5487                        fac211 * absa(ind1+8,ig) +                              &
5488                        fac111 * absa(ind1+9,ig) +                              &
5489                        fac011 * absa(ind1+10,ig))
5490        else
5491          tau_major1 = speccomb1 *                                              &
5492                       (fac001 * absa(ind1,ig) +                                &
5493                        fac101 * absa(ind1+1,ig) +                              &
5494                        fac011 * absa(ind1+9,ig) +                              &
5495                        fac111 * absa(ind1+10,ig))
5496        endif
5497 !
5498        taug(lay,ngs2+ig) = tau_major+tau_major1                                &
5499                          + tauself+taufor                                      &
5500                          + adjcoln2o*absn2o
5501        fracs(lay,ngs2+ig) = fracrefa(ig,jpl)+fpl*                              &
5502                            (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5503      enddo
5504    enddo
5505 !
5506 ! Upper atmosphere loop
5507 !
5508    do lay = laytrop+1,nlayers
5509      speccomb = colh2o(lay)+rat_h2oco2(lay)*colco2(lay)
5510      specparm = colh2o(lay)/speccomb
5511      if (specparm.ge.oneminus) specparm = oneminus
5512      specmult = 4._rb*(specparm)
5513      js = 1+int(specmult)
5514      fs = mod(specmult,1.0_rb)
5515 !
5516      speccomb1 = colh2o(lay)+rat_h2oco2_1(lay)*colco2(lay)
5517      specparm1 = colh2o(lay)/speccomb1
5518      if (specparm1.ge.oneminus) specparm1 = oneminus
5519      specmult1 = 4._rb*(specparm1)
5520      js1 = 1+int(specmult1)
5521      fs1 = mod(specmult1,1.0_rb)
5522 !
5523      fac000 = (1._rb-fs)*fac00(lay)
5524      fac010 = (1._rb-fs)*fac10(lay)
5525      fac100 = fs*fac00(lay)
5526      fac110 = fs*fac10(lay)
5527      fac001 = (1._rb-fs1)*fac01(lay)
5528      fac011 = (1._rb-fs1)*fac11(lay)
5529      fac101 = fs1*fac01(lay)
5530      fac111 = fs1*fac11(lay)
5531 !
5532      speccomb_mn2o = colh2o(lay)+refrat_m_b*colco2(lay)
5533      specparm_mn2o = colh2o(lay)/speccomb_mn2o
5534      if (specparm_mn2o.ge.oneminus) specparm_mn2o = oneminus
5535      specmult_mn2o = 4._rb*specparm_mn2o
5536      jmn2o = 1+int(specmult_mn2o)
5537      fmn2o = mod(specmult_mn2o,1.0_rb)
5538      fmn2omf = minorfrac(lay)*fmn2o
5539 !
5540 ! In atmospheres where the amount of N2O is too great to be considered
5541 ! a minor species, adjust the column amount of N2O by an empirical factor
5542 ! to obtain the proper contribution.
5543 !
5544      chi_n2o = coln2o(lay)/coldry(lay)
5545      ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1)
5546      if (ratn2o .gt. 1.5_rb) then
5547        adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
5548        adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
5549      else
5550        adjcoln2o = coln2o(lay)
5551      endif
5552 !
5553      speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay)
5554      specparm_planck = colh2o(lay)/speccomb_planck
5555      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
5556      specmult_planck = 4._rb*specparm_planck
5557      jpl = 1 + int(specmult_planck)
5558      fpl = mod(specmult_planck,1.0_rb)
5559 !
5560      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
5561      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1
5562      indf = indfor(lay)
5563      indm = indminor(lay)
5564 !
5565      do ig = 1,ng3
5566        taufor = forfac(lay)*(forref(indf,ig)+                                  &
5567                 forfrac(lay)*(forref(indf+1,ig) - forref(indf,ig)))
5568        n2om1 = kb_mn2o(jmn2o,indm,ig)+fmn2o*                                   &
5569               (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig))
5570        n2om2 = kb_mn2o(jmn2o,indm+1,ig)+fmn2o*                                 &
5571               (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig))
5572        absn2o = n2om1 + minorfrac(lay)*(n2om2 - n2om1)
5573        taug(lay,ngs2+ig) = speccomb *                                          &
5574                            (fac000 * absb(ind0,ig) +                           &
5575                             fac100 * absb(ind0+1,ig) +                         &
5576                             fac010 * absb(ind0+5,ig) +                         &
5577                             fac110 * absb(ind0+6,ig))                          &
5578                            +speccomb1 *                                        &
5579                             (fac001 * absb(ind1,ig) +                          &
5580                             fac101 * absb(ind1+1,ig) +                         &
5581                             fac011 * absb(ind1+5,ig) +                         &
5582                             fac111 * absb(ind1+6,ig))                          &
5583                            +taufor                                             &
5584                            +adjcoln2o*absn2o
5585        fracs(lay,ngs2+ig) = fracrefb(ig,jpl)+fpl*                              &
5586                            (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5587      enddo
5588    enddo
5589 !
5590    end subroutine taugb3
5591 !-------------------------------------------------------------------------------
5592 !
5593 !
5594 !-------------------------------------------------------------------------------
5595    subroutine taugb4
5596 !-------------------------------------------------------------------------------
5597 !
5598 !  abstract : band 4,  630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
5599 !
5600 !-------------------------------------------------------------------------------
5601    use parrrtm_k,   only : ng4, ngs3
5602    use rrlw_ref_k,  only : chi_mls
5603    use rrlw_kg04_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
5604                          selfref, forref
5605 !
5606 ! Local
5607 !
5608    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
5609    integer(kind=im) :: js, js1, jpl
5610    real(kind=rb)    :: speccomb, specparm, specmult, fs
5611    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
5612    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
5613    real(kind=rb)    :: p, p4, fk0, fk1, fk2
5614    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
5615    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
5616    real(kind=rb)    :: tauself, taufor
5617    real(kind=rb)    :: refrat_planck_a, refrat_planck_b
5618    real(kind=rb)    :: tau_major, tau_major1
5619 !-------------------------------------------------------------------------------
5620 !
5621 ! P =   142.5940 mb
5622 !
5623    refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
5624 !
5625 ! P = 95.58350 mb
5626 !
5627    refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
5628 !
5629 ! Compute the optical depth by interpolating in ln(pressure) and
5630 ! temperature, and appropriate species.  Below laytrop, the water
5631 ! vapor self-continuum and foreign continuum is interpolated (in temperature)
5632 ! separately.
5633 !
5634 ! Lower atmosphere loop
5635 !
5636    do lay = 1,laytrop
5637      speccomb = colh2o(lay)+rat_h2oco2(lay)*colco2(lay)
5638      specparm = colh2o(lay)/speccomb
5639      if (specparm.ge.oneminus) specparm = oneminus
5640      specmult = 8._rb*(specparm)
5641      js = 1+int(specmult)
5642      fs = mod(specmult,1.0_rb)
5643 !
5644      speccomb1 = colh2o(lay)+rat_h2oco2_1(lay)*colco2(lay)
5645      specparm1 = colh2o(lay)/speccomb1
5646      if (specparm1.ge.oneminus) specparm1 = oneminus
5647      specmult1 = 8._rb*(specparm1)
5648      js1 = 1+int(specmult1)
5649      fs1 = mod(specmult1,1.0_rb)
5650 !
5651      speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5652      specparm_planck = colh2o(lay)/speccomb_planck
5653      if (specparm_planck.ge.oneminus) specparm_planck=oneminus
5654      specmult_planck = 8._rb*specparm_planck
5655      jpl = 1+int(specmult_planck)
5656      fpl = mod(specmult_planck,1.0_rb)
5657 !
5658      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js
5659      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1
5660      inds = indself(lay)
5661      indf = indfor(lay)
5662 !
5663      if (specparm.lt.0.125_rb) then
5664        p = fs-1
5665        p4 = p**4
5666        fk0 = p4
5667        fk1 = 1-p-2.0_rb*p4
5668        fk2 = p+p4
5669        fac000 = fk0*fac00(lay)
5670        fac100 = fk1*fac00(lay)
5671        fac200 = fk2*fac00(lay)
5672        fac010 = fk0*fac10(lay)
5673        fac110 = fk1*fac10(lay)
5674        fac210 = fk2*fac10(lay)
5675      else if (specparm.gt.0.875_rb) then
5676        p = -fs
5677        p4 = p**4
5678        fk0 = p4
5679        fk1 = 1-p-2.0_rb*p4
5680        fk2 = p+p4
5681        fac000 = fk0*fac00(lay)
5682        fac100 = fk1*fac00(lay)
5683        fac200 = fk2*fac00(lay)
5684        fac010 = fk0*fac10(lay)
5685        fac110 = fk1*fac10(lay)
5686        fac210 = fk2*fac10(lay)
5687      else
5688        fac000 = (1._rb-fs)*fac00(lay)
5689        fac010 = (1._rb-fs)*fac10(lay)
5690        fac100 = fs*fac00(lay)
5691        fac110 = fs*fac10(lay)
5692      endif
5693 !
5694      if (specparm1.lt.0.125_rb) then
5695        p = fs1-1
5696        p4 = p**4
5697        fk0 = p4
5698        fk1 = 1-p-2.0_rb*p4
5699        fk2 = p+p4
5700        fac001 = fk0*fac01(lay)
5701        fac101 = fk1*fac01(lay)
5702        fac201 = fk2*fac01(lay)
5703        fac011 = fk0*fac11(lay)
5704        fac111 = fk1*fac11(lay)
5705        fac211 = fk2*fac11(lay)
5706      else if (specparm1.gt.0.875_rb) then
5707        p = -fs1
5708        p4 = p**4
5709        fk0 = p4
5710        fk1 = 1-p-2.0_rb*p4
5711        fk2 = p+p4
5712        fac001 = fk0*fac01(lay)
5713        fac101 = fk1*fac01(lay)
5714        fac201 = fk2*fac01(lay)
5715        fac011 = fk0*fac11(lay)
5716        fac111 = fk1*fac11(lay)
5717        fac211 = fk2*fac11(lay)
5718      else
5719        fac001 = (1._rb-fs1)*fac01(lay)
5720        fac011 = (1._rb-fs1)*fac11(lay)
5721        fac101 = fs1*fac01(lay)
5722        fac111 = fs1*fac11(lay)
5723      endif
5724 !
5725      do ig = 1,ng4
5726        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
5727                 (selfref(inds+1,ig) - selfref(inds,ig)))
5728        taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
5729                 (forref(indf+1,ig) - forref(indf,ig)))
5730 !
5731        if (specparm.lt.0.125_rb) then
5732          tau_major = speccomb *                                                &
5733                      (fac000 * absa(ind0,ig) +                                 &
5734                       fac100 * absa(ind0+1,ig) +                               &
5735                       fac200 * absa(ind0+2,ig) +                               &
5736                       fac010 * absa(ind0+9,ig) +                               &
5737                       fac110 * absa(ind0+10,ig) +                              &
5738                       fac210 * absa(ind0+11,ig))
5739        else if (specparm.gt.0.875_rb) then
5740          tau_major = speccomb *                                                &
5741                      (fac200 * absa(ind0-1,ig) +                               &
5742                       fac100 * absa(ind0,ig) +                                 &
5743                       fac000 * absa(ind0+1,ig) +                               &
5744                       fac210 * absa(ind0+8,ig) +                               &
5745                       fac110 * absa(ind0+9,ig) +                               &
5746                       fac010 * absa(ind0+10,ig))
5747        else
5748          tau_major = speccomb *                                                &
5749                      (fac000 * absa(ind0,ig) +                                 &
5750                       fac100 * absa(ind0+1,ig) +                               &
5751                       fac010 * absa(ind0+9,ig) +                               &
5752                       fac110 * absa(ind0+10,ig))
5753        endif
5754 !
5755        if (specparm1.lt.0.125_rb) then
5756          tau_major1 = speccomb1 *                                              &
5757                       (fac001 * absa(ind1,ig) +                                &
5758                        fac101 * absa(ind1+1,ig) +                              &
5759                        fac201 * absa(ind1+2,ig) +                              &
5760                        fac011 * absa(ind1+9,ig) +                              &
5761                        fac111 * absa(ind1+10,ig) +                             &
5762                        fac211 * absa(ind1+11,ig))
5763        else if (specparm1.gt.0.875_rb) then
5764          tau_major1 = speccomb1 *                                              &
5765                       (fac201 * absa(ind1-1,ig) +                              &
5766                        fac101 * absa(ind1,ig) +                                &
5767                        fac001 * absa(ind1+1,ig) +                              &
5768                        fac211 * absa(ind1+8,ig) +                              &
5769                        fac111 * absa(ind1+9,ig) +                              &
5770                        fac011 * absa(ind1+10,ig))
5771        else
5772          tau_major1 = speccomb1 *                                              &
5773                       (fac001 * absa(ind1,ig) +                                &
5774                        fac101 * absa(ind1+1,ig) +                              &
5775                        fac011 * absa(ind1+9,ig) +                              &
5776                        fac111 * absa(ind1+10,ig))
5777        endif
5778 !
5779        taug(lay,ngs3+ig) = tau_major+tau_major1                                &
5780                          + tauself + taufor
5781        fracs(lay,ngs3+ig) = fracrefa(ig,jpl)+fpl*                              &
5782                            (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
5783      enddo
5784    enddo
5785 !
5786 ! Upper atmosphere loop
5787 !
5788    do lay = laytrop+1,nlayers
5789      speccomb = colo3(lay)+rat_o3co2(lay)*colco2(lay)
5790      specparm = colo3(lay)/speccomb
5791      if (specparm.ge.oneminus) specparm = oneminus
5792      specmult = 4._rb*(specparm)
5793      js = 1+int(specmult)
5794      fs = mod(specmult,1.0_rb)
5795 !
5796      speccomb1 = colo3(lay)+rat_o3co2_1(lay)*colco2(lay)
5797      specparm1 = colo3(lay)/speccomb1
5798      if (specparm1.ge.oneminus) specparm1 = oneminus
5799      specmult1 = 4._rb*(specparm1)
5800      js1 = 1+int(specmult1)
5801      fs1 = mod(specmult1,1.0_rb)
5802 !
5803      fac000 = (1._rb-fs)*fac00(lay)
5804      fac010 = (1._rb-fs)*fac10(lay)
5805      fac100 = fs*fac00(lay)
5806      fac110 = fs*fac10(lay)
5807      fac001 = (1._rb-fs1)*fac01(lay)
5808      fac011 = (1._rb-fs1)*fac11(lay)
5809      fac101 = fs1*fac01(lay)
5810      fac111 = fs1*fac11(lay)
5811 !
5812      speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
5813      specparm_planck = colo3(lay)/speccomb_planck
5814      if (specparm_planck.ge.oneminus) specparm_planck=oneminus
5815      specmult_planck = 4._rb*specparm_planck
5816      jpl = 1+int(specmult_planck)
5817      fpl = mod(specmult_planck,1.0_rb)
5818 !
5819      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js
5820      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1
5821 !
5822      do ig = 1,ng4
5823        taug(lay,ngs3+ig) = speccomb *                                          &
5824                            (fac000 * absb(ind0,ig) +                           &
5825                             fac100 * absb(ind0+1,ig) +                         &
5826                             fac010 * absb(ind0+5,ig) +                         &
5827                             fac110 * absb(ind0+6,ig))                          &
5828                            +speccomb1 *                                        &
5829                            (fac001 * absb(ind1,ig ) +                          &
5830                             fac101 * absb(ind1+1,ig) +                         &
5831                             fac011 * absb(ind1+5,ig) +                         &
5832                             fac111 * absb(ind1+6,ig))
5833        fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl *                           &
5834                            (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
5835      enddo
5836 !
5837 ! Empirical modification to code to improve stratospheric cooling rates
5838 ! for co2.  Revised to apply weighting for g-point reduction in this band.
5839 !
5840      taug(lay,ngs3+8)  = taug(lay,ngs3+8)*0.92
5841      taug(lay,ngs3+9)  = taug(lay,ngs3+9)*0.88
5842      taug(lay,ngs3+10) = taug(lay,ngs3+10)*1.07
5843      taug(lay,ngs3+11) = taug(lay,ngs3+11)*1.1
5844      taug(lay,ngs3+12) = taug(lay,ngs3+12)*0.99
5845      taug(lay,ngs3+13) = taug(lay,ngs3+13)*0.88
5846      taug(lay,ngs3+14) = taug(lay,ngs3+14)*0.943
5847 !
5848    enddo
5849 !
5850    end subroutine taugb4
5851 !-------------------------------------------------------------------------------
5852 !
5853 !
5854 !-------------------------------------------------------------------------------
5855    subroutine taugb5
5856 !-------------------------------------------------------------------------------
5857 !
5858 !  abstract : band 5,  700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
5859 !                                   (high key - o3,co2)
5860 !
5861 !-------------------------------------------------------------------------------
5862    use parrrtm_k,   only : ng5, ngs4
5863    use rrlw_ref_k,  only : chi_mls
5864    use rrlw_kg05_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
5865                          ka_mo3, selfref, forref, ccl4
5866 !
5867 ! Local
5868 !
5869    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
5870    integer(kind=im) :: js, js1, jmo3, jpl
5871    real(kind=rb)    :: speccomb, specparm, specmult, fs
5872    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
5873    real(kind=rb)    :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
5874    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
5875    real(kind=rb)    :: p, p4, fk0, fk1, fk2
5876    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
5877    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
5878    real(kind=rb)    :: tauself, taufor, o3m1, o3m2, abso3
5879    real(kind=rb)    :: refrat_planck_a, refrat_planck_b, refrat_m_a
5880    real(kind=rb)    :: tau_major, tau_major1
5881 !-------------------------------------------------------------------------------
5882 !
5883 ! Minor gas mapping level :
5884 !     lower - o3, p = 317.34 mbar, t = 240.77 k
5885 !     lower - ccl4
5886 !
5887 ! Calculate reference ratio to be used in calculation of Planck
5888 ! fraction in lower/upper atmosphere.
5889 !
5890 ! P = 473.420 mb
5891 !
5892    refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
5893 !
5894 ! P = 0.2369 mb
5895 !
5896    refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
5897 !
5898 ! P = 317.3480
5899 !
5900    refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
5901 !
5902 ! Compute the optical depth by interpolating in ln(pressure) and
5903 ! temperature, and appropriate species.  Below laytrop, the
5904 ! water vapor self-continuum and foreign continuum is
5905 ! interpolated (in temperature) separately.
5906 !
5907 ! Lower atmosphere loop
5908 !
5909    do lay = 1,laytrop
5910      speccomb = colh2o(lay)+rat_h2oco2(lay)*colco2(lay)
5911      specparm = colh2o(lay)/speccomb
5912      if (specparm.ge.oneminus) specparm = oneminus
5913      specmult = 8._rb*(specparm)
5914      js = 1+int(specmult)
5915      fs = mod(specmult,1.0_rb)
5916 !
5917      speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
5918      specparm1 = colh2o(lay)/speccomb1
5919      if (specparm1 .ge. oneminus) specparm1 = oneminus
5920      specmult1 = 8._rb*(specparm1)
5921      js1 = 1 + int(specmult1)
5922      fs1 = mod(specmult1,1.0_rb)
5923 !
5924      speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay)
5925      specparm_mo3 = colh2o(lay)/speccomb_mo3
5926      if (specparm_mo3.ge.oneminus) specparm_mo3 = oneminus
5927      specmult_mo3 = 8._rb*specparm_mo3
5928      jmo3 = 1 + int(specmult_mo3)
5929      fmo3 = mod(specmult_mo3,1.0_rb)
5930 !
5931      speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
5932      specparm_planck = colh2o(lay)/speccomb_planck
5933      if (specparm_planck.ge.oneminus) specparm_planck=oneminus
5934      specmult_planck = 8._rb*specparm_planck
5935      jpl = 1 + int(specmult_planck)
5936      fpl = mod(specmult_planck,1.0_rb)
5937 !
5938      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js
5939      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1
5940      inds = indself(lay)
5941      indf = indfor(lay)
5942      indm = indminor(lay)
5943 !
5944      if (specparm.lt.0.125_rb) then
5945        p = fs - 1
5946        p4 = p**4
5947        fk0 = p4
5948        fk1 = 1 - p - 2.0_rb*p4
5949        fk2 = p + p4
5950        fac000 = fk0*fac00(lay)
5951        fac100 = fk1*fac00(lay)
5952        fac200 = fk2*fac00(lay)
5953        fac010 = fk0*fac10(lay)
5954        fac110 = fk1*fac10(lay)
5955        fac210 = fk2*fac10(lay)
5956      else if (specparm.gt.0.875_rb) then
5957        p = -fs
5958        p4 = p**4
5959        fk0 = p4
5960        fk1 = 1 - p - 2.0_rb*p4
5961        fk2 = p + p4
5962        fac000 = fk0*fac00(lay)
5963        fac100 = fk1*fac00(lay)
5964        fac200 = fk2*fac00(lay)
5965        fac010 = fk0*fac10(lay)
5966        fac110 = fk1*fac10(lay)
5967        fac210 = fk2*fac10(lay)
5968      else
5969        fac000 = (1._rb - fs) * fac00(lay)
5970        fac010 = (1._rb - fs) * fac10(lay)
5971        fac100 = fs * fac00(lay)
5972        fac110 = fs * fac10(lay)
5973      endif
5974 !
5975      if (specparm1.lt.0.125_rb) then
5976        p = fs1 - 1
5977        p4 = p**4
5978        fk0 = p4
5979        fk1 = 1 - p - 2.0_rb*p4
5980        fk2 = p + p4
5981        fac001 = fk0*fac01(lay)
5982        fac101 = fk1*fac01(lay)
5983        fac201 = fk2*fac01(lay)
5984        fac011 = fk0*fac11(lay)
5985        fac111 = fk1*fac11(lay)
5986        fac211 = fk2*fac11(lay)
5987      else if (specparm1.gt.0.875_rb) then
5988        p = -fs1
5989        p4 = p**4
5990        fk0 = p4
5991        fk1 = 1 - p - 2.0_rb*p4
5992        fk2 = p + p4
5993        fac001 = fk0*fac01(lay)
5994        fac101 = fk1*fac01(lay)
5995        fac201 = fk2*fac01(lay)
5996        fac011 = fk0*fac11(lay)
5997        fac111 = fk1*fac11(lay)
5998        fac211 = fk2*fac11(lay)
5999      else
6000        fac001 = (1._rb - fs1) * fac01(lay)
6001        fac011 = (1._rb - fs1) * fac11(lay)
6002        fac101 = fs1 * fac01(lay)
6003        fac111 = fs1 * fac11(lay)
6004      endif
6005 !
6006      do ig = 1,ng5
6007        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
6008                 (selfref(inds+1,ig) - selfref(inds,ig)))
6009        taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
6010                 (forref(indf+1,ig) - forref(indf,ig)))
6011        o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 *                                    &
6012              (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
6013        o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 *                                  &
6014              (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
6015        abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
6016 !
6017        if (specparm.lt.0.125_rb) then
6018          tau_major = speccomb *                                                &
6019                      (fac000 * absa(ind0,ig) +                                 &
6020                       fac100 * absa(ind0+1,ig) +                               &
6021                       fac200 * absa(ind0+2,ig) +                               &
6022                       fac010 * absa(ind0+9,ig) +                               &
6023                       fac110 * absa(ind0+10,ig) +                              &
6024                       fac210 * absa(ind0+11,ig))
6025        else if (specparm.gt.0.875_rb) then
6026          tau_major = speccomb *                                                &
6027                      (fac200 * absa(ind0-1,ig) +                               &
6028                       fac100 * absa(ind0,ig) +                                 &
6029                       fac000 * absa(ind0+1,ig) +                               &
6030                       fac210 * absa(ind0+8,ig) +                               &
6031                       fac110 * absa(ind0+9,ig) +                               &
6032                       fac010 * absa(ind0+10,ig))
6033        else
6034          tau_major = speccomb *                                                &
6035                      (fac000 * absa(ind0,ig) +                                 &
6036                       fac100 * absa(ind0+1,ig) +                               &
6037                       fac010 * absa(ind0+9,ig) +                               &
6038                       fac110 * absa(ind0+10,ig))
6039        endif
6040 !
6041        if (specparm1.lt.0.125_rb) then
6042          tau_major1 = speccomb1 *                                              &
6043                       (fac001 * absa(ind1,ig) +                                &
6044                        fac101 * absa(ind1+1,ig) +                              &
6045                        fac201 * absa(ind1+2,ig) +                              &
6046                        fac011 * absa(ind1+9,ig) +                              &
6047                        fac111 * absa(ind1+10,ig) +                             &
6048                        fac211 * absa(ind1+11,ig))
6049        else if (specparm1.gt.0.875_rb) then
6050          tau_major1 = speccomb1 *                                              &
6051                       (fac201 * absa(ind1-1,ig) +                              &
6052                        fac101 * absa(ind1,ig) +                                &
6053                        fac001 * absa(ind1+1,ig) +                              &
6054                        fac211 * absa(ind1+8,ig) +                              &
6055                        fac111 * absa(ind1+9,ig) +                              &
6056                        fac011 * absa(ind1+10,ig))
6057        else
6058          tau_major1 = speccomb1 *                                              &
6059                       (fac001 * absa(ind1,ig) +                                &
6060                        fac101 * absa(ind1+1,ig) +                              &
6061                        fac011 * absa(ind1+9,ig) +                              &
6062                        fac111 * absa(ind1+10,ig))
6063        endif
6064 !
6065        taug(lay,ngs4+ig) = tau_major + tau_major1                              &
6066                          + tauself + taufor                                    &
6067                          + abso3*colo3(lay)                                    &
6068                          + wx(1,lay) * ccl4(ig)
6069        fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl *                           &
6070                            (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6071      enddo
6072    enddo
6073 !
6074 ! Upper atmosphere loop
6075 !
6076    do lay = laytrop+1,nlayers
6077      speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
6078      specparm = colo3(lay)/speccomb
6079      if (specparm.ge.oneminus) specparm = oneminus
6080      specmult = 4._rb*(specparm)
6081      js = 1 + int(specmult)
6082      fs = mod(specmult,1.0_rb)
6083 !
6084      speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
6085      specparm1 = colo3(lay)/speccomb1
6086      if (specparm1.ge.oneminus) specparm1 = oneminus
6087      specmult1 = 4._rb*(specparm1)
6088      js1 = 1 + int(specmult1)
6089      fs1 = mod(specmult1,1.0_rb)
6090 !
6091      fac000 = (1._rb - fs) * fac00(lay)
6092      fac010 = (1._rb - fs) * fac10(lay)
6093      fac100 = fs * fac00(lay)
6094      fac110 = fs * fac10(lay)
6095      fac001 = (1._rb - fs1) * fac01(lay)
6096      fac011 = (1._rb - fs1) * fac11(lay)
6097      fac101 = fs1 * fac01(lay)
6098      fac111 = fs1 * fac11(lay)
6099 !
6100      speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
6101      specparm_planck = colo3(lay)/speccomb_planck
6102      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6103      specmult_planck = 4._rb*specparm_planck
6104      jpl = 1 + int(specmult_planck)
6105      fpl = mod(specmult_planck,1.0_rb)
6106 !
6107      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js
6108      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1
6109 !
6110      do ig = 1,ng5
6111        taug(lay,ngs4+ig) = speccomb *                                          &
6112                            (fac000 * absb(ind0,ig) +                           &
6113                             fac100 * absb(ind0+1,ig) +                         &
6114                             fac010 * absb(ind0+5,ig) +                         &
6115                             fac110 * absb(ind0+6,ig))                          &
6116                            +speccomb1 *                                        &
6117                            (fac001 * absb(ind1,ig) +                           &
6118                             fac101 * absb(ind1+1,ig) +                         &
6119                             fac011 * absb(ind1+5,ig) +                         &
6120                             fac111 * absb(ind1+6,ig))                          &
6121                            +wx(1,lay) * ccl4(ig)
6122        fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl *                           &
6123                            (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
6124      enddo
6125    enddo
6126 !
6127    end subroutine taugb5
6128 !-------------------------------------------------------------------------------
6129 !
6130 !
6131 !-------------------------------------------------------------------------------
6132    subroutine taugb6
6133 !-------------------------------------------------------------------------------
6134 !
6135 !  abstract : band 6, 820-980 cm-1 (low key - h2o; low minor - co2)
6136 !                                  (high key - nothing; high minor-cfc11, cfc12)
6137 !
6138 !-------------------------------------------------------------------------------
6139    use parrrtm_k,   only : ng6, ngs5
6140    use rrlw_ref_k,  only : chi_mls
6141    use rrlw_kg06_k, only : fracrefa, absa, ka, ka_mco2,                        &
6142                          selfref, forref, cfc11adj, cfc12
6143 !
6144 ! Local
6145 !
6146    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6147    real(kind=rb)    :: chi_co2, ratco2, adjfac, adjcolco2
6148    real(kind=rb)    :: tauself, taufor, absco2
6149 !-------------------------------------------------------------------------------
6150 !
6151 ! Minor gas mapping level:
6152 !     lower - co2, p = 706.2720 mb, t = 294.2 k
6153 !     upper - cfc11, cfc12
6154 !
6155 ! Compute the optical depth by interpolating in ln(pressure) and
6156 ! temperature. The water vapor self-continuum and foreign continuum
6157 ! is interpolated (in temperature) separately.
6158 !
6159 ! Lower atmosphere loop
6160 !
6161    do lay = 1,laytrop
6162 !
6163 ! In atmospheres where the amount of CO2 is too great to be considered
6164 ! a minor species, adjust the column amount of CO2 by an empirical factor
6165 ! to obtain the proper contribution.
6166 !
6167      chi_co2 = colco2(lay)/(coldry(lay))
6168      ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6169 !
6170      if (ratco2.gt.3.0_rb) then
6171        adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb
6172        adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6173      else
6174        adjcolco2 = colco2(lay)
6175      endif
6176 !
6177      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1
6178      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1
6179      inds = indself(lay)
6180      indf = indfor(lay)
6181      indm = indminor(lay)
6182 !
6183      do ig = 1,ng6
6184        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
6185                 (selfref(inds+1,ig) - selfref(inds,ig)))
6186        taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
6187                 (forref(indf+1,ig) - forref(indf,ig)))
6188        absco2 =  (ka_mco2(indm,ig) + minorfrac(lay) *                          &
6189                  (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6190        taug(lay,ngs5+ig) = colh2o(lay) *                                       &
6191                            (fac00(lay) * absa(ind0,ig) +                       &
6192                             fac10(lay) * absa(ind0+1,ig) +                     &
6193                             fac01(lay) * absa(ind1,ig) +                       &
6194                             fac11(lay) * absa(ind1+1,ig))                      &
6195                            +tauself + taufor                                   &
6196                            +adjcolco2 * absco2                                 &
6197                            +wx(2,lay) * cfc11adj(ig)                           &
6198                            +wx(3,lay) * cfc12(ig)
6199        fracs(lay,ngs5+ig) = fracrefa(ig)
6200      enddo
6201    enddo
6202 !
6203 ! Upper atmosphere loop
6204 ! Nothing important goes on above laytrop in this band.
6205 !
6206    do lay = laytrop+1,nlayers
6207      do ig = 1,ng6
6208        taug(lay,ngs5+ig) = 0.0_rb                                              &
6209                          + wx(2,lay) * cfc11adj(ig)                            &
6210                          + wx(3,lay) * cfc12(ig)
6211        fracs(lay,ngs5+ig) = fracrefa(ig)
6212      enddo
6213     enddo
6214 !
6215    end subroutine taugb6
6216 !-------------------------------------------------------------------------------
6217 !
6218 !
6219 !-------------------------------------------------------------------------------
6220    subroutine taugb7
6221 !-------------------------------------------------------------------------------
6222 !
6223 !  abstract : band 7,  980-1080 cm-1 (low key - h2o,o3; low minor - co2)
6224 !                                    (high key - o3; high minor - co2)
6225 !
6226 !-------------------------------------------------------------------------------
6227    use parrrtm_k,   only : ng7, ngs6
6228    use rrlw_ref_k,  only : chi_mls
6229    use rrlw_kg07_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
6230                          ka_mco2, kb_mco2, selfref, forref
6231 !
6232 ! Local
6233 !
6234    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6235    integer(kind=im) :: js, js1, jmco2, jpl
6236    real(kind=rb)    :: speccomb, specparm, specmult, fs
6237    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
6238    real(kind=rb)    :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
6239    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
6240    real(kind=rb)    :: p, p4, fk0, fk1, fk2
6241    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
6242    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
6243    real(kind=rb)    :: tauself, taufor, co2m1, co2m2, absco2
6244    real(kind=rb)    :: chi_co2, ratco2, adjfac, adjcolco2
6245    real(kind=rb)    :: refrat_planck_a, refrat_m_a
6246    real(kind=rb)    :: tau_major, tau_major1
6247 !-------------------------------------------------------------------------------
6248 !
6249 ! Minor gas mapping level :
6250 !     lower - co2, p = 706.2620 mbar, t= 278.94 k
6251 !     upper - co2, p = 12.9350 mbar, t = 234.01 k
6252 !
6253 ! Calculate reference ratio to be used in calculation of Planck
6254 ! fraction in lower atmosphere.
6255 !
6256 ! P = 706.2620 mb
6257 !
6258    refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
6259 !
6260 ! P = 706.2720 mb
6261 !
6262    refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
6263 !
6264 ! Compute the optical depth by interpolating in ln(pressure),
6265 ! temperature, and appropriate species.  Below laytrop, the water
6266 ! vapor self-continuum and foreign continuum is interpolated
6267 ! (in temperature) separately.
6268 !
6269 ! Lower atmosphere loop
6270 !
6271    do lay = 1,laytrop
6272      speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay)
6273      specparm = colh2o(lay)/speccomb
6274      if (specparm.ge.oneminus) specparm = oneminus
6275      specmult = 8._rb*(specparm)
6276      js = 1 + int(specmult)
6277      fs = mod(specmult,1.0_rb)
6278 !
6279      speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay)
6280      specparm1 = colh2o(lay)/speccomb1
6281      if (specparm1.ge.oneminus) specparm1 = oneminus
6282      specmult1 = 8._rb*(specparm1)
6283      js1 = 1 + int(specmult1)
6284      fs1 = mod(specmult1,1.0_rb)
6285 !
6286      speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay)
6287      specparm_mco2 = colh2o(lay)/speccomb_mco2
6288      if (specparm_mco2.ge.oneminus) specparm_mco2 = oneminus
6289      specmult_mco2 = 8._rb*specparm_mco2
6290 !
6291      jmco2 = 1+int(specmult_mco2)
6292      fmco2 = mod(specmult_mco2,1.0_rb)
6293 !
6294 !  In atmospheres where the amount of CO2 is too great to be considered
6295 !  a minor species, adjust the column amount of CO2 by an empirical factor
6296 !  to obtain the proper contribution.
6297 !
6298      chi_co2 = colco2(lay)/(coldry(lay))
6299      ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6300      if (ratco2.gt.3.0_rb) then
6301        adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb
6302        adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6303      else
6304        adjcolco2 = colco2(lay)
6305      endif
6306 !
6307      speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay)
6308      specparm_planck = colh2o(lay)/speccomb_planck
6309      if (specparm_planck.ge.oneminus) specparm_planck=oneminus
6310      specmult_planck = 8._rb*specparm_planck
6311      jpl = 1 + int(specmult_planck)
6312      fpl = mod(specmult_planck,1.0_rb)
6313 !
6314      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js
6315      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1
6316      inds = indself(lay)
6317      indf = indfor(lay)
6318      indm = indminor(lay)
6319 !
6320      if (specparm .lt. 0.125_rb) then
6321        p = fs - 1
6322        p4 = p**4
6323        fk0 = p4
6324        fk1 = 1 - p - 2.0_rb*p4
6325        fk2 = p + p4
6326        fac000 = fk0*fac00(lay)
6327        fac100 = fk1*fac00(lay)
6328        fac200 = fk2*fac00(lay)
6329        fac010 = fk0*fac10(lay)
6330        fac110 = fk1*fac10(lay)
6331        fac210 = fk2*fac10(lay)
6332      else if (specparm.gt.0.875_rb) then
6333        p = -fs
6334        p4 = p**4
6335        fk0 = p4
6336        fk1 = 1 - p - 2.0_rb*p4
6337        fk2 = p + p4
6338        fac000 = fk0*fac00(lay)
6339        fac100 = fk1*fac00(lay)
6340        fac200 = fk2*fac00(lay)
6341        fac010 = fk0*fac10(lay)
6342        fac110 = fk1*fac10(lay)
6343        fac210 = fk2*fac10(lay)
6344      else
6345        fac000 = (1._rb - fs) * fac00(lay)
6346        fac010 = (1._rb - fs) * fac10(lay)
6347        fac100 = fs * fac00(lay)
6348        fac110 = fs * fac10(lay)
6349      endif
6350 !
6351      if (specparm.lt.0.125_rb) then
6352        p = fs1 - 1
6353        p4 = p**4
6354        fk0 = p4
6355        fk1 = 1 - p - 2.0_rb*p4
6356        fk2 = p + p4
6357        fac001 = fk0*fac01(lay)
6358        fac101 = fk1*fac01(lay)
6359        fac201 = fk2*fac01(lay)
6360        fac011 = fk0*fac11(lay)
6361        fac111 = fk1*fac11(lay)
6362        fac211 = fk2*fac11(lay)
6363      else if (specparm1.gt.0.875_rb) then
6364        p = -fs1
6365        p4 = p**4
6366        fk0 = p4
6367        fk1 = 1 - p - 2.0_rb*p4
6368        fk2 = p + p4
6369        fac001 = fk0*fac01(lay)
6370        fac101 = fk1*fac01(lay)
6371        fac201 = fk2*fac01(lay)
6372        fac011 = fk0*fac11(lay)
6373        fac111 = fk1*fac11(lay)
6374        fac211 = fk2*fac11(lay)
6375      else
6376        fac001 = (1._rb - fs1) * fac01(lay)
6377        fac011 = (1._rb - fs1) * fac11(lay)
6378        fac101 = fs1 * fac01(lay)
6379        fac111 = fs1 * fac11(lay)
6380      endif
6381 !
6382      do ig = 1,ng7
6383        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
6384                 (selfref(inds+1,ig) - selfref(inds,ig)))
6385        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6386                (forref(indf+1,ig) - forref(indf,ig)))
6387        co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 *                                &
6388               (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
6389        co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 *                              &
6390               (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
6391        absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
6392 !
6393        if (specparm .lt. 0.125_rb) then
6394          tau_major = speccomb *                                                &
6395                      (fac000 * absa(ind0,ig) +                                 &
6396                       fac100 * absa(ind0+1,ig) +                               &
6397                       fac200 * absa(ind0+2,ig) +                               &
6398                       fac010 * absa(ind0+9,ig) +                               &
6399                       fac110 * absa(ind0+10,ig) +                              &
6400                       fac210 * absa(ind0+11,ig))
6401        else if (specparm.gt.0.875_rb) then
6402          tau_major = speccomb *                                                &
6403                      (fac200 * absa(ind0-1,ig) +                               &
6404                       fac100 * absa(ind0,ig) +                                 &
6405                       fac000 * absa(ind0+1,ig) +                               &
6406                       fac210 * absa(ind0+8,ig) +                               &
6407                       fac110 * absa(ind0+9,ig) +                               &
6408                       fac010 * absa(ind0+10,ig))
6409        else
6410          tau_major = speccomb *                                                &
6411                      (fac000 * absa(ind0,ig) +                                 &
6412                       fac100 * absa(ind0+1,ig) +                               &
6413                       fac010 * absa(ind0+9,ig) +                               &
6414                       fac110 * absa(ind0+10,ig))
6415        endif
6416 !
6417        if (specparm1.lt.0.125_rb) then
6418          tau_major1 = speccomb1 *                                              &
6419                       (fac001 * absa(ind1,ig) +                                &
6420                        fac101 * absa(ind1+1,ig) +                              &
6421                        fac201 * absa(ind1+2,ig) +                              &
6422                        fac011 * absa(ind1+9,ig) +                              &
6423                        fac111 * absa(ind1+10,ig) +                             &
6424                        fac211 * absa(ind1+11,ig))
6425        else if (specparm1.gt.0.875_rb) then
6426          tau_major1 = speccomb1 *                                              &
6427                       (fac201 * absa(ind1-1,ig) +                              &
6428                        fac101 * absa(ind1,ig) +                                &
6429                        fac001 * absa(ind1+1,ig) +                              &
6430                        fac211 * absa(ind1+8,ig) +                              &
6431                        fac111 * absa(ind1+9,ig) +                              &
6432                        fac011 * absa(ind1+10,ig))
6433        else
6434          tau_major1 = speccomb1 *                                              &
6435                       (fac001 * absa(ind1,ig) +                                &
6436                        fac101 * absa(ind1+1,ig) +                              &
6437                        fac011 * absa(ind1+9,ig) +                              &
6438                        fac111 * absa(ind1+10,ig))
6439        endif
6440 !
6441        taug(lay,ngs6+ig) = tau_major + tau_major1                              &
6442                          + tauself + taufor                                    &
6443                          + adjcolco2*absco2
6444        fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl *                           &
6445                            (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6446      enddo
6447    enddo
6448 !
6449 ! Upper atmosphere loop
6450 !
6451    do lay = laytrop+1,nlayers
6452 !
6453 !  In atmospheres where the amount of CO2 is too great to be considered
6454 !  a minor species, adjust the column amount of CO2 by an empirical factor
6455 !  to obtain the proper contribution.
6456 !
6457      chi_co2 = colco2(lay)/(coldry(lay))
6458      ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
6459      if (ratco2 .gt. 3.0_rb) then
6460        adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb
6461        adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6462      else
6463        adjcolco2 = colco2(lay)
6464      endif
6465 !
6466      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1
6467      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1
6468      indm = indminor(lay)
6469 !
6470      do ig = 1,ng7
6471        absco2 = kb_mco2(indm,ig) + minorfrac(lay) *                            &
6472                (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))
6473        taug(lay,ngs6+ig) = colo3(lay) *                                        &
6474                            (fac00(lay) * absb(ind0,ig) +                       &
6475                             fac10(lay) * absb(ind0+1,ig) +                     &
6476                             fac01(lay) * absb(ind1,ig) +                       &
6477                             fac11(lay) * absb(ind1+1,ig))                      &
6478                            +adjcolco2 * absco2
6479        fracs(lay,ngs6+ig) = fracrefb(ig)
6480      enddo
6481 !
6482 ! Empirical modification to code to improve stratospheric cooling rates
6483 ! for o3.  Revised to apply weighting for g-point reduction in this band.
6484 !
6485      taug(lay,ngs6+6)  = taug(lay,ngs6+6)*0.92_rb
6486      taug(lay,ngs6+7)  = taug(lay,ngs6+7)*0.88_rb
6487      taug(lay,ngs6+8)  = taug(lay,ngs6+8)*1.07_rb
6488      taug(lay,ngs6+9)  = taug(lay,ngs6+9)*1.1_rb
6489      taug(lay,ngs6+10) = taug(lay,ngs6+10)*0.99_rb
6490      taug(lay,ngs6+11) = taug(lay,ngs6+11)*0.855_rb
6491 !
6492    enddo
6493 !
6494    end subroutine taugb7
6495 !-------------------------------------------------------------------------------
6496 !
6497 !
6498 !-------------------------------------------------------------------------------
6499    subroutine taugb8
6500 !-------------------------------------------------------------------------------
6501 !
6502 !  abstract : band 8,  1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
6503 !                                     (high key - o3; high minor - co2, n2o)
6504 !
6505 !-------------------------------------------------------------------------------
6506    use parrrtm_k,   only : ng8, ngs7
6507    use rrlw_ref_k,  only : chi_mls
6508    use rrlw_kg08_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
6509                          ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o,           &
6510                          selfref, forref, cfc12, cfc22adj
6511 !
6512 ! Local
6513 !
6514    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6515    real(kind=rb)    :: tauself, taufor, absco2, abso3, absn2o
6516    real(kind=rb)    :: chi_co2, ratco2, adjfac, adjcolco2
6517 !-------------------------------------------------------------------------------
6518 !
6519 ! Minor gas mapping level:
6520 !     lower - co2, p = 1053.63 mb, t = 294.2 k
6521 !     lower - o3,  p = 317.348 mb, t = 240.77 k
6522 !     lower - n2o, p = 706.2720 mb, t= 278.94 k
6523 !     lower - cfc12,cfc11
6524 !     upper - co2, p = 35.1632 mb, t = 223.28 k
6525 !     upper - n2o, p = 8.716e-2 mb, t = 226.03 k
6526 !
6527 ! Compute the optical depth by interpolating in ln(pressure) and
6528 ! temperature, and appropriate species.  Below laytrop, the water vapor
6529 ! self-continuum and foreign continuum is interpolated (in temperature)
6530 ! separately.
6531 !
6532 ! Lower atmosphere loop
6533 !
6534    do lay = 1,laytrop
6535 !
6536 ! In atmospheres where the amount of CO2 is too great to be considered
6537 ! a minor species, adjust the column amount of CO2 by an empirical factor
6538 ! to obtain the proper contribution.
6539 !
6540      chi_co2 = colco2(lay)/(coldry(lay))
6541      ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6542      if (ratco2 .gt. 3.0_rb) then
6543        adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6544        adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
6545      else
6546        adjcolco2 = colco2(lay)
6547      endif
6548 !
6549      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
6550      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
6551      inds = indself(lay)
6552      indf = indfor(lay)
6553      indm = indminor(lay)
6554 !
6555      do ig = 1, ng8
6556        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
6557                                 (selfref(inds+1,ig) - selfref(inds,ig)))
6558        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6559                               (forref(indf+1,ig) - forref(indf,ig)))
6560        absco2 = (ka_mco2(indm,ig) + minorfrac(lay) *                           &
6561                 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
6562        abso3 = (ka_mo3(indm,ig) + minorfrac(lay) *                             &
6563                (ka_mo3(indm+1,ig) - ka_mo3(indm,ig)))
6564        absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) *                           &
6565                 (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig)))
6566        taug(lay,ngs7+ig) = colh2o(lay) *                                       &
6567                            (fac00(lay) * absa(ind0,ig) +                       &
6568                             fac10(lay) * absa(ind0+1,ig) +                     &
6569                             fac01(lay) * absa(ind1,ig) +                       &
6570                             fac11(lay) * absa(ind1+1,ig))                      &
6571                             + tauself + taufor                                 &
6572                             + adjcolco2 * absco2                               &
6573                             + colo3(lay) * abso3                               &
6574                             + coln2o(lay) * absn2o                             &
6575                             + wx(3,lay) * cfc12(ig)                            &
6576                             + wx(4,lay) * cfc22adj(ig)
6577        fracs(lay,ngs7+ig) = fracrefa(ig)
6578      enddo
6579    enddo
6580 !
6581 ! Upper atmosphere loop
6582 !
6583    do lay = laytrop+1, nlayers
6584 !
6585 ! In atmospheres where the amount of CO2 is too great to be considered
6586 ! a minor species, adjust the column amount of CO2 by an empirical factor
6587 ! to obtain the proper contribution.
6588 !
6589      chi_co2 = colco2(lay)/coldry(lay)
6590      ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
6591      if (ratco2 .gt. 3.0_rb) then
6592        adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
6593        adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb
6594      else
6595        adjcolco2 = colco2(lay)
6596      endif
6597 !
6598      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1
6599      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1
6600      indm = indminor(lay)
6601 !
6602      do ig = 1, ng8
6603        absco2 = (kb_mco2(indm,ig) + minorfrac(lay) *                           &
6604                 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)))
6605        absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) *                           &
6606                 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)))
6607        taug(lay,ngs7+ig) = colo3(lay)  *                                       &
6608                            (fac00(lay) * absb(ind0,ig) +                       &
6609                             fac10(lay) * absb(ind0+1,ig) +                     &
6610                             fac01(lay) * absb(ind1,ig) +                       &
6611                             fac11(lay) * absb(ind1+1,ig))                      &
6612                             + adjcolco2 * absco2                               &
6613                             + coln2o(lay)* absn2o                              &
6614                             + wx(3,lay) * cfc12(ig)                            &
6615                             + wx(4,lay) * cfc22adj(ig)
6616        fracs(lay,ngs7+ig) = fracrefb(ig)
6617      enddo
6618    enddo
6619 !
6620    end subroutine taugb8
6621 !-------------------------------------------------------------------------------
6622 !
6623 !
6624 !-------------------------------------------------------------------------------
6625    subroutine taugb9
6626 !-------------------------------------------------------------------------------
6627 !
6628 !  abstract : band 9,  1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
6629 !                                     (high key - ch4; high minor - n2o)
6630 !
6631 !-------------------------------------------------------------------------------
6632    use parrrtm_k,   only : ng9, ngs8
6633    use rrlw_ref_k,  only : chi_mls
6634    use rrlw_kg09_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
6635                          ka_mn2o, kb_mn2o, selfref, forref
6636 !
6637 ! Local
6638 !
6639    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6640    integer(kind=im) :: js, js1, jmn2o, jpl
6641    real(kind=rb)    :: speccomb, specparm, specmult, fs
6642    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
6643    real(kind=rb)    :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
6644    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
6645    real(kind=rb)    :: p, p4, fk0, fk1, fk2
6646    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
6647    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
6648    real(kind=rb)    :: tauself, taufor, n2om1, n2om2, absn2o
6649    real(kind=rb)    :: chi_n2o, ratn2o, adjfac, adjcoln2o
6650    real(kind=rb)    :: refrat_planck_a, refrat_m_a
6651    real(kind=rb)    :: tau_major, tau_major1
6652 !-------------------------------------------------------------------------------
6653 !
6654 ! Minor gas mapping level :
6655 !     lower - n2o, p = 706.272 mbar, t = 278.94 k
6656 !     upper - n2o, p = 95.58 mbar, t = 215.7 k
6657 !
6658 ! Calculate reference ratio to be used in calculation of Planck
6659 ! fraction in lower/upper atmosphere.
6660 !
6661 ! P = 212 mb
6662 !
6663    refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
6664 !
6665 ! P = 706.272 mb
6666 !
6667    refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
6668 !
6669 ! Compute the optical depth by interpolating in ln(pressure),
6670 ! temperature, and appropriate species.  Below laytrop, the water
6671 ! vapor self-continuum and foreign continuum is interpolated
6672 ! (in temperature) separately.
6673 !
6674 ! Lower atmosphere loop
6675 !
6676    do lay = 1,laytrop
6677 !
6678      speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
6679      specparm = colh2o(lay)/speccomb
6680      if (specparm .ge. oneminus) specparm = oneminus
6681      specmult = 8._rb*(specparm)
6682      js = 1 + int(specmult)
6683      fs = mod(specmult,1.0_rb)
6684 !
6685      speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
6686      specparm1 = colh2o(lay)/speccomb1
6687      if (specparm1 .ge. oneminus) specparm1 = oneminus
6688      specmult1 = 8._rb*(specparm1)
6689      js1 = 1 + int(specmult1)
6690      fs1 = mod(specmult1,1.0_rb)
6691 !
6692      speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay)
6693      specparm_mn2o = colh2o(lay)/speccomb_mn2o
6694      if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
6695      specmult_mn2o = 8._rb*specparm_mn2o
6696      jmn2o = 1 + int(specmult_mn2o)
6697      fmn2o = mod(specmult_mn2o,1.0_rb)
6698 !
6699 !  In atmospheres where the amount of N2O is too great to be considered
6700 !  a minor species, adjust the column amount of N2O by an empirical factor
6701 !  to obtain the proper contribution.
6702 !
6703      chi_n2o = coln2o(lay)/(coldry(lay))
6704      ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6705      if (ratn2o .gt. 1.5_rb) then
6706        adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6707        adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6708      else
6709        adjcoln2o = coln2o(lay)
6710      endif
6711 !
6712      speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
6713      specparm_planck = colh2o(lay)/speccomb_planck
6714      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
6715      specmult_planck = 8._rb*specparm_planck
6716      jpl = 1 + int(specmult_planck)
6717      fpl = mod(specmult_planck,1.0_rb)
6718 !
6719      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js
6720      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1
6721      inds = indself(lay)
6722      indf = indfor(lay)
6723      indm = indminor(lay)
6724 !
6725      if (specparm .lt. 0.125_rb) then
6726        p = fs - 1
6727        p4 = p**4
6728        fk0 = p4
6729        fk1 = 1 - p - 2.0_rb*p4
6730        fk2 = p + p4
6731        fac000 = fk0*fac00(lay)
6732        fac100 = fk1*fac00(lay)
6733        fac200 = fk2*fac00(lay)
6734        fac010 = fk0*fac10(lay)
6735        fac110 = fk1*fac10(lay)
6736        fac210 = fk2*fac10(lay)
6737      else if (specparm .gt. 0.875_rb) then
6738        p = -fs
6739        p4 = p**4
6740        fk0 = p4
6741        fk1 = 1 - p - 2.0_rb*p4
6742        fk2 = p + p4
6743        fac000 = fk0*fac00(lay)
6744        fac100 = fk1*fac00(lay)
6745        fac200 = fk2*fac00(lay)
6746        fac010 = fk0*fac10(lay)
6747        fac110 = fk1*fac10(lay)
6748        fac210 = fk2*fac10(lay)
6749      else
6750        fac000 = (1._rb - fs) * fac00(lay)
6751        fac010 = (1._rb - fs) * fac10(lay)
6752        fac100 = fs * fac00(lay)
6753        fac110 = fs * fac10(lay)
6754      endif
6755 !
6756      if (specparm1 .lt. 0.125_rb) then
6757        p = fs1 - 1
6758        p4 = p**4
6759        fk0 = p4
6760        fk1 = 1 - p - 2.0_rb*p4
6761        fk2 = p + p4
6762        fac001 = fk0*fac01(lay)
6763        fac101 = fk1*fac01(lay)
6764        fac201 = fk2*fac01(lay)
6765        fac011 = fk0*fac11(lay)
6766        fac111 = fk1*fac11(lay)
6767        fac211 = fk2*fac11(lay)
6768      else if (specparm1 .gt. 0.875_rb) then
6769        p = -fs1
6770        p4 = p**4
6771        fk0 = p4
6772        fk1 = 1 - p - 2.0_rb*p4
6773        fk2 = p + p4
6774        fac001 = fk0*fac01(lay)
6775        fac101 = fk1*fac01(lay)
6776        fac201 = fk2*fac01(lay)
6777        fac011 = fk0*fac11(lay)
6778        fac111 = fk1*fac11(lay)
6779        fac211 = fk2*fac11(lay)
6780      else
6781        fac001 = (1._rb - fs1) * fac01(lay)
6782        fac011 = (1._rb - fs1) * fac11(lay)
6783        fac101 = fs1 * fac01(lay)
6784        fac111 = fs1 * fac11(lay)
6785      endif
6786 !
6787      do ig = 1, ng9
6788        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
6789                                (selfref(inds+1,ig) - selfref(inds,ig)))
6790        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6791                               (forref(indf+1,ig) - forref(indf,ig)))
6792        n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o *                                &
6793               (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
6794        n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o *                              &
6795               (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
6796        absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
6797 !
6798        if (specparm .lt. 0.125_rb) then
6799          tau_major = speccomb *                                                &
6800                      (fac000 * absa(ind0,ig) +                                 &
6801                       fac100 * absa(ind0+1,ig) +                               &
6802                       fac200 * absa(ind0+2,ig) +                               &
6803                       fac010 * absa(ind0+9,ig) +                               &
6804                       fac110 * absa(ind0+10,ig) +                              &
6805                       fac210 * absa(ind0+11,ig))
6806        else if (specparm .gt. 0.875_rb) then
6807          tau_major = speccomb *                                                &
6808                      (fac200 * absa(ind0-1,ig) +                               &
6809                       fac100 * absa(ind0,ig) +                                 &
6810                       fac000 * absa(ind0+1,ig) +                               &
6811                       fac210 * absa(ind0+8,ig) +                               &
6812                       fac110 * absa(ind0+9,ig) +                               &
6813                       fac010 * absa(ind0+10,ig))
6814        else
6815          tau_major = speccomb *                                                &
6816                      (fac000 * absa(ind0,ig) +                                 &
6817                       fac100 * absa(ind0+1,ig) +                               &
6818                       fac010 * absa(ind0+9,ig) +                               &
6819                       fac110 * absa(ind0+10,ig))
6820        endif
6821 !
6822        if (specparm1 .lt. 0.125_rb) then
6823          tau_major1 = speccomb1 *                                              &
6824                       (fac001 * absa(ind1,ig) +                                &
6825                        fac101 * absa(ind1+1,ig) +                              &
6826                        fac201 * absa(ind1+2,ig) +                              &
6827                        fac011 * absa(ind1+9,ig) +                              &
6828                        fac111 * absa(ind1+10,ig) +                             &
6829                        fac211 * absa(ind1+11,ig))
6830        else if (specparm1 .gt. 0.875_rb) then
6831          tau_major1 = speccomb1 *                                              &
6832                       (fac201 * absa(ind1-1,ig) +                              &
6833                        fac101 * absa(ind1,ig) +                                &
6834                        fac001 * absa(ind1+1,ig) +                              &
6835                        fac211 * absa(ind1+8,ig) +                              &
6836                        fac111 * absa(ind1+9,ig) +                              &
6837                        fac011 * absa(ind1+10,ig))
6838        else
6839          tau_major1 = speccomb1 *                                              &
6840                       (fac001 * absa(ind1,ig) +                                &
6841                        fac101 * absa(ind1+1,ig) +                              &
6842                        fac011 * absa(ind1+9,ig) +                              &
6843                        fac111 * absa(ind1+10,ig))
6844        endif
6845        taug(lay,ngs8+ig) = tau_major + tau_major1                              &
6846                          + tauself + taufor                                    &
6847                          + adjcoln2o*absn2o
6848        fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl *                           &
6849                            (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
6850      enddo
6851    enddo
6852 !
6853 ! Upper atmosphere loop
6854 !
6855    do lay = laytrop+1,nlayers
6856 !
6857 ! In atmospheres where the amount of N2O is too great to be considered
6858 ! a minor species, adjust the column amount of N2O by an empirical factor
6859 ! to obtain the proper contribution.
6860 !
6861      chi_n2o = coln2o(lay)/(coldry(lay))
6862      ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
6863      if (ratn2o .gt. 1.5_rb) then
6864        adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
6865        adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
6866      else
6867        adjcoln2o = coln2o(lay)
6868      endif
6869 !
6870      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1
6871      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1
6872      indm = indminor(lay)
6873 !
6874      do ig = 1,ng9
6875        absn2o = kb_mn2o(indm,ig) + minorfrac(lay) *                            &
6876                (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))
6877        taug(lay,ngs8+ig) = colch4(lay) *                                       &
6878                            (fac00(lay) * absb(ind0,ig) +                       &
6879                             fac10(lay) * absb(ind0+1,ig) +                     &
6880                             fac01(lay) * absb(ind1,ig) +                       &
6881                             fac11(lay) * absb(ind1+1,ig))                      &
6882                             + adjcoln2o*absn2o
6883        fracs(lay,ngs8+ig) = fracrefb(ig)
6884      enddo
6885    enddo
6886 !
6887    end subroutine taugb9
6888 !-------------------------------------------------------------------------------
6889 !
6890 !
6891 !-------------------------------------------------------------------------------
6892    subroutine taugb10
6893 !-------------------------------------------------------------------------------
6894 !
6895 !  abstract : band 10,  1390-1480 cm-1 (low key - h2o; high key - h2o)
6896 !
6897 !-------------------------------------------------------------------------------
6898    use parrrtm_k,   only : ng10, ngs9
6899    use rrlw_kg10_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
6900                          selfref, forref
6901 !
6902 ! Local
6903 !
6904    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
6905    real(kind=rb)    :: tauself, taufor
6906 !-------------------------------------------------------------------------------
6907 !
6908 ! Compute the optical depth by interpolating in ln(pressure) and
6909 ! temperature.  Below laytrop, the water vapor self-continuum and
6910 ! foreign continuum is interpolated (in temperature) separately.
6911 !
6912 ! Lower atmosphere loop
6913 !
6914    do lay = 1,laytrop
6915      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1
6916      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1
6917      inds = indself(lay)
6918      indf = indfor(lay)
6919 !
6920      do ig = 1,ng10
6921        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
6922                 (selfref(inds+1,ig) - selfref(inds,ig)))
6923        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6924                (forref(indf+1,ig) - forref(indf,ig)))
6925        taug(lay,ngs9+ig) = colh2o(lay) *                                       &
6926                            (fac00(lay) * absa(ind0,ig) +                       &
6927                             fac10(lay) * absa(ind0+1,ig) +                     &
6928                             fac01(lay) * absa(ind1,ig) +                       &
6929                             fac11(lay) * absa(ind1+1,ig))                      &
6930                             + tauself + taufor
6931        fracs(lay,ngs9+ig) = fracrefa(ig)
6932      enddo
6933    enddo
6934 !
6935 ! Upper atmosphere loop
6936 !
6937    do lay = laytrop+1,nlayers
6938      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1
6939      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1
6940      indf = indfor(lay)
6941 !
6942      do ig = 1,ng10
6943        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6944                (forref(indf+1,ig) - forref(indf,ig)))
6945        taug(lay,ngs9+ig) = colh2o(lay) *                                       &
6946                            (fac00(lay) * absb(ind0,ig) +                       &
6947                            fac10(lay) * absb(ind0+1,ig) +                      &
6948                            fac01(lay) * absb(ind1,ig) +                        &
6949                            fac11(lay) * absb(ind1+1,ig))                       &
6950                            + taufor
6951        fracs(lay,ngs9+ig) = fracrefb(ig)
6952      enddo
6953    enddo
6954 !
6955    end subroutine taugb10
6956 !-------------------------------------------------------------------------------
6957 !
6958 !
6959 !-------------------------------------------------------------------------------
6960    subroutine taugb11
6961 !-------------------------------------------------------------------------------
6962 !
6963 !  abstract : band 11,  1480-1800 cm-1 (low - h2o; low minor - o2)
6964 !                                      (high key - h2o; high minor - o2)
6965 !
6966 !-------------------------------------------------------------------------------
6967    use parrrtm_k,   only : ng11, ngs10
6968    use rrlw_kg11_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
6969                             ka_mo2, kb_mo2, selfref, forref
6970 !
6971 ! Local
6972 !
6973    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
6974    real(kind=rb)    :: scaleo2, tauself, taufor, tauo2
6975 !-------------------------------------------------------------------------------
6976 !
6977 ! Minor gas mapping level :
6978 !     lower - o2, p = 706.2720 mbar, t = 278.94 k
6979 !     upper - o2, p = 4.758820 mbarm t = 250.85 k
6980 !
6981 ! Compute the optical depth by interpolating in ln(pressure) and
6982 ! temperature.  Below laytrop, the water vapor self-continuum and
6983 ! foreign continuum is interpolated (in temperature) separately.
6984 !
6985 ! Lower atmosphere loop
6986 !
6987    do lay = 1,laytrop
6988      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1
6989      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1
6990      inds = indself(lay)
6991      indf = indfor(lay)
6992      indm = indminor(lay)
6993      scaleo2 = colo2(lay)*scaleminor(lay)
6994      do ig = 1,ng11
6995        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
6996                 (selfref(inds+1,ig) - selfref(inds,ig)))
6997        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
6998                (forref(indf+1,ig) - forref(indf,ig)))
6999        tauo2 =  scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) *                  &
7000                (ka_mo2(indm+1,ig) - ka_mo2(indm,ig)))
7001        taug(lay,ngs10+ig) = colh2o(lay) *                                      &
7002                             (fac00(lay) * absa(ind0,ig) +                      &
7003                              fac10(lay) * absa(ind0+1,ig) +                    &
7004                              fac01(lay) * absa(ind1,ig) +                      &
7005                              fac11(lay) * absa(ind1+1,ig))                     &
7006                              + tauself + taufor                                &
7007                              + tauo2
7008        fracs(lay,ngs10+ig) = fracrefa(ig)
7009      enddo
7010    enddo
7011 !
7012 ! Upper atmosphere loop
7013 !
7014    do lay = laytrop+1,nlayers
7015      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1
7016      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1
7017      indf = indfor(lay)
7018      indm = indminor(lay)
7019      scaleo2 = colo2(lay)*scaleminor(lay)
7020      do ig = 1,ng11
7021        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
7022                (forref(indf+1,ig) - forref(indf,ig)))
7023        tauo2 =  scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) *                  &
7024                (kb_mo2(indm+1,ig) - kb_mo2(indm,ig)))
7025        taug(lay,ngs10+ig) = colh2o(lay) *                                      &
7026                             (fac00(lay) * absb(ind0,ig) +                      &
7027                              fac10(lay) * absb(ind0+1,ig) +                    &
7028                              fac01(lay) * absb(ind1,ig) +                      &
7029                              fac11(lay) * absb(ind1+1,ig))                     &
7030                              + taufor                                          &
7031                              + tauo2
7032        fracs(lay,ngs10+ig) = fracrefb(ig)
7033      enddo
7034    enddo
7035 !
7036    end subroutine taugb11
7037 !-------------------------------------------------------------------------------
7038 !
7039 !
7040 !-------------------------------------------------------------------------------
7041    subroutine taugb12
7042 !-------------------------------------------------------------------------------
7043 !
7044 !  abstract : band 12,  1800-2080 cm-1 (low - h2o,co2; high - nothing)
7045 !
7046 !-------------------------------------------------------------------------------
7047    use parrrtm_k,   only : ng12, ngs11
7048    use rrlw_ref_k,  only : chi_mls
7049    use rrlw_kg12_k, only : fracrefa, absa, ka,                                 &
7050                          selfref, forref
7051 !
7052 ! Local
7053 !
7054    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7055    integer(kind=im) :: js, js1, jpl
7056    real(kind=rb)    :: speccomb, specparm, specmult, fs
7057    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
7058    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
7059    real(kind=rb)    :: p, p4, fk0, fk1, fk2
7060    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
7061    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
7062    real(kind=rb)    :: tauself, taufor
7063    real(kind=rb)    :: refrat_planck_a
7064    real(kind=rb)    :: tau_major, tau_major1
7065 !-------------------------------------------------------------------------------
7066 !
7067 ! Calculate reference ratio to be used in calculation of Planck
7068 ! fraction in lower/upper atmosphere.
7069 !
7070 ! P =   174.164 mb
7071 !
7072    refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
7073 !
7074 ! Compute the optical depth by interpolating in ln(pressure),
7075 ! temperature, and appropriate species.  Below laytrop, the water
7076 ! vapor self-continuum adn foreign continuum is interpolated
7077 ! (in temperature) separately.
7078 !
7079 ! Lower atmosphere loop
7080 !
7081    do lay = 1,laytrop
7082 !
7083      speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
7084      specparm = colh2o(lay)/speccomb
7085      if (specparm .ge. oneminus) specparm = oneminus
7086      specmult = 8._rb*(specparm)
7087      js = 1 + int(specmult)
7088      fs = mod(specmult,1.0_rb)
7089 !
7090      speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
7091      specparm1 = colh2o(lay)/speccomb1
7092      if (specparm1 .ge. oneminus) specparm1 = oneminus
7093      specmult1 = 8._rb*(specparm1)
7094      js1 = 1 + int(specmult1)
7095      fs1 = mod(specmult1,1.0_rb)
7096 !
7097      speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
7098      specparm_planck = colh2o(lay)/speccomb_planck
7099      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7100      specmult_planck = 8._rb*specparm_planck
7101      jpl = 1 + int(specmult_planck)
7102      fpl = mod(specmult_planck,1.0_rb)
7103 !
7104      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js
7105      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1
7106      inds = indself(lay)
7107      indf = indfor(lay)
7108 !
7109      if (specparm .lt. 0.125_rb) then
7110        p = fs - 1
7111        p4 = p**4
7112        fk0 = p4
7113        fk1 = 1 - p - 2.0_rb*p4
7114        fk2 = p + p4
7115        fac000 = fk0*fac00(lay)
7116        fac100 = fk1*fac00(lay)
7117        fac200 = fk2*fac00(lay)
7118        fac010 = fk0*fac10(lay)
7119        fac110 = fk1*fac10(lay)
7120        fac210 = fk2*fac10(lay)
7121      else if (specparm .gt. 0.875_rb) then
7122        p = -fs
7123        p4 = p**4
7124        fk0 = p4
7125        fk1 = 1 - p - 2.0_rb*p4
7126        fk2 = p + p4
7127        fac000 = fk0*fac00(lay)
7128        fac100 = fk1*fac00(lay)
7129        fac200 = fk2*fac00(lay)
7130        fac010 = fk0*fac10(lay)
7131        fac110 = fk1*fac10(lay)
7132        fac210 = fk2*fac10(lay)
7133      else
7134        fac000 = (1._rb - fs) * fac00(lay)
7135        fac010 = (1._rb - fs) * fac10(lay)
7136        fac100 = fs * fac00(lay)
7137        fac110 = fs * fac10(lay)
7138      endif
7139 !
7140      if (specparm1 .lt. 0.125_rb) then
7141        p = fs1 - 1
7142        p4 = p**4
7143        fk0 = p4
7144        fk1 = 1 - p - 2.0_rb*p4
7145        fk2 = p + p4
7146        fac001 = fk0*fac01(lay)
7147        fac101 = fk1*fac01(lay)
7148        fac201 = fk2*fac01(lay)
7149        fac011 = fk0*fac11(lay)
7150        fac111 = fk1*fac11(lay)
7151        fac211 = fk2*fac11(lay)
7152      else if (specparm1 .gt. 0.875_rb) then
7153        p = -fs1
7154        p4 = p**4
7155        fk0 = p4
7156        fk1 = 1 - p - 2.0_rb*p4
7157        fk2 = p + p4
7158        fac001 = fk0*fac01(lay)
7159        fac101 = fk1*fac01(lay)
7160        fac201 = fk2*fac01(lay)
7161        fac011 = fk0*fac11(lay)
7162        fac111 = fk1*fac11(lay)
7163        fac211 = fk2*fac11(lay)
7164      else
7165        fac001 = (1._rb - fs1) * fac01(lay)
7166        fac011 = (1._rb - fs1) * fac11(lay)
7167        fac101 = fs1 * fac01(lay)
7168        fac111 = fs1 * fac11(lay)
7169      endif
7170 !
7171      do ig = 1,ng12
7172        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
7173                 (selfref(inds+1,ig) - selfref(inds,ig)))
7174        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
7175                (forref(indf+1,ig) - forref(indf,ig)))
7176 !
7177        if (specparm .lt. 0.125_rb) then
7178          tau_major = speccomb *                                                &
7179                      (fac000 * absa(ind0,ig) +                                 &
7180                       fac100 * absa(ind0+1,ig) +                               &
7181                       fac200 * absa(ind0+2,ig) +                               &
7182                       fac010 * absa(ind0+9,ig) +                               &
7183                       fac110 * absa(ind0+10,ig) +                              &
7184                       fac210 * absa(ind0+11,ig))
7185        else if (specparm .gt. 0.875_rb) then
7186          tau_major = speccomb *                                                &
7187                      (fac200 * absa(ind0-1,ig) +                               &
7188                       fac100 * absa(ind0,ig) +                                 &
7189                       fac000 * absa(ind0+1,ig) +                               &
7190                       fac210 * absa(ind0+8,ig) +                               &
7191                       fac110 * absa(ind0+9,ig) +                               &
7192                       fac010 * absa(ind0+10,ig))
7193        else
7194          tau_major = speccomb *                                                &
7195                      (fac000 * absa(ind0,ig) +                                 &
7196                       fac100 * absa(ind0+1,ig) +                               &
7197                       fac010 * absa(ind0+9,ig) +                               &
7198                       fac110 * absa(ind0+10,ig))
7199        endif
7200 !
7201        if (specparm1 .lt. 0.125_rb) then
7202          tau_major1 = speccomb1 *                                              &
7203                       (fac001 * absa(ind1,ig) +                                &
7204                        fac101 * absa(ind1+1,ig) +                              &
7205                        fac201 * absa(ind1+2,ig) +                              &
7206                        fac011 * absa(ind1+9,ig) +                              &
7207                        fac111 * absa(ind1+10,ig) +                             &
7208                        fac211 * absa(ind1+11,ig))
7209        else if (specparm1 .gt. 0.875_rb) then
7210          tau_major1 = speccomb1 *                                              &
7211                       (fac201 * absa(ind1-1,ig) +                              &
7212                        fac101 * absa(ind1,ig) +                                &
7213                        fac001 * absa(ind1+1,ig) +                              &
7214                        fac211 * absa(ind1+8,ig) +                              &
7215                        fac111 * absa(ind1+9,ig) +                              &
7216                        fac011 * absa(ind1+10,ig))
7217        else
7218          tau_major1 = speccomb1 *                                              &
7219                       (fac001 * absa(ind1,ig) +                                &
7220                        fac101 * absa(ind1+1,ig) +                              &
7221                        fac011 * absa(ind1+9,ig) +                              &
7222                        fac111 * absa(ind1+10,ig))
7223        endif
7224 !
7225        taug(lay,ngs11+ig) = tau_major + tau_major1                             &
7226                           + tauself + taufor
7227        fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl *                          &
7228                             (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7229      enddo
7230    enddo
7231 !
7232 ! Upper atmosphere loop
7233 !
7234       do lay = laytrop+1, nlayers
7235 !
7236          do ig = 1, ng12
7237             taug(lay,ngs11+ig) = 0.0_rb
7238             fracs(lay,ngs11+ig) = 0.0_rb
7239          enddo
7240       enddo
7241 !
7242    end subroutine taugb12
7243 !-------------------------------------------------------------------------------
7244 !
7245 !
7246 !-------------------------------------------------------------------------------
7247    subroutine taugb13
7248 !-------------------------------------------------------------------------------
7249 !
7250 !  abstract : band 13, 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
7251 !
7252 !-------------------------------------------------------------------------------
7253    use parrrtm_k,   only : ng13, ngs12
7254    use rrlw_ref_k,  only : chi_mls
7255    use rrlw_kg13_k, only : fracrefa, fracrefb, absa, ka,                       &
7256                          ka_mco2, ka_mco, kb_mo3, selfref, forref
7257 !
7258 ! Local
7259 !
7260    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7261    integer(kind=im) :: js, js1, jmco2, jmco, jpl
7262    real(kind=rb)    :: speccomb, specparm, specmult, fs
7263    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
7264    real(kind=rb)    :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
7265    real(kind=rb)    :: speccomb_mco, specparm_mco, specmult_mco, fmco
7266    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
7267    real(kind=rb)    :: p, p4, fk0, fk1, fk2
7268    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
7269    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
7270    real(kind=rb)    :: tauself, taufor, co2m1, co2m2, absco2
7271    real(kind=rb)    :: com1, com2, absco, abso3
7272    real(kind=rb)    :: chi_co2, ratco2, adjfac, adjcolco2
7273    real(kind=rb)    :: refrat_planck_a, refrat_m_a, refrat_m_a3
7274    real(kind=rb)    :: tau_major, tau_major1
7275 !-------------------------------------------------------------------------------
7276 !
7277 ! Minor gas mapping levels :
7278 !     lower - co2, p = 1053.63 mb, t = 294.2 k
7279 !     lower - co, p = 706 mb, t = 278.94 k
7280 !     upper - o3, p = 95.5835 mb, t = 215.7 k
7281 !
7282 ! Calculate reference ratio to be used in calculation of Planck
7283 ! fraction in lower/upper atmosphere.
7284 !
7285 ! P = 473.420 mb (Level 5)
7286 !
7287    refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
7288 !
7289 ! P = 1053. (Level 1)
7290 !
7291    refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
7292 !
7293 ! P = 706. (Level 3)
7294 !
7295    refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
7296 !
7297 ! Compute the optical depth by interpolating in ln(pressure),
7298 ! temperature, and appropriate species.  Below laytrop, the water
7299 ! vapor self-continuum and foreign continuum is interpolated
7300 ! (in temperature) separately.
7301 !
7302 ! Lower atmosphere loop
7303 !
7304    do lay = 1,laytrop
7305 !
7306      speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay)
7307      specparm = colh2o(lay)/speccomb
7308      if (specparm .ge. oneminus) specparm = oneminus
7309      specmult = 8._rb*(specparm)
7310      js = 1 + int(specmult)
7311      fs = mod(specmult,1.0_rb)
7312 !
7313      speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay)
7314      specparm1 = colh2o(lay)/speccomb1
7315      if (specparm1 .ge. oneminus) specparm1 = oneminus
7316      specmult1 = 8._rb*(specparm1)
7317      js1 = 1 + int(specmult1)
7318      fs1 = mod(specmult1,1.0_rb)
7319 !
7320      speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay)
7321      specparm_mco2 = colh2o(lay)/speccomb_mco2
7322      if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
7323      specmult_mco2 = 8._rb*specparm_mco2
7324      jmco2 = 1 + int(specmult_mco2)
7325      fmco2 = mod(specmult_mco2,1.0_rb)
7326 !
7327 ! In atmospheres where the amount of CO2 is too great to be considered
7328 ! a minor species, adjust the column amount of CO2 by an empirical factor
7329 ! to obtain the proper contribution.
7330 !
7331      chi_co2 = colco2(lay)/(coldry(lay))
7332      ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb
7333      if (ratco2 .gt. 3.0_rb) then
7334        adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb
7335        adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb
7336      else
7337        adjcolco2 = colco2(lay)
7338      endif
7339 !
7340      speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay)
7341      specparm_mco = colh2o(lay)/speccomb_mco
7342      if (specparm_mco .ge. oneminus) specparm_mco = oneminus
7343      specmult_mco = 8._rb*specparm_mco
7344      jmco = 1 + int(specmult_mco)
7345      fmco = mod(specmult_mco,1.0_rb)
7346 !
7347      speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay)
7348      specparm_planck = colh2o(lay)/speccomb_planck
7349      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7350      specmult_planck = 8._rb*specparm_planck
7351      jpl = 1 + int(specmult_planck)
7352      fpl = mod(specmult_planck,1.0_rb)
7353 !
7354      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js
7355      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1
7356      inds = indself(lay)
7357      indf = indfor(lay)
7358      indm = indminor(lay)
7359 !
7360      if (specparm .lt. 0.125_rb) then
7361        p = fs - 1
7362        p4 = p**4
7363        fk0 = p4
7364        fk1 = 1 - p - 2.0_rb*p4
7365        fk2 = p + p4
7366        fac000 = fk0*fac00(lay)
7367        fac100 = fk1*fac00(lay)
7368        fac200 = fk2*fac00(lay)
7369        fac010 = fk0*fac10(lay)
7370        fac110 = fk1*fac10(lay)
7371        fac210 = fk2*fac10(lay)
7372      else if (specparm .gt. 0.875_rb) then
7373        p = -fs
7374        p4 = p**4
7375        fk0 = p4
7376        fk1 = 1 - p - 2.0_rb*p4
7377        fk2 = p + p4
7378        fac000 = fk0*fac00(lay)
7379        fac100 = fk1*fac00(lay)
7380        fac200 = fk2*fac00(lay)
7381        fac010 = fk0*fac10(lay)
7382        fac110 = fk1*fac10(lay)
7383        fac210 = fk2*fac10(lay)
7384      else
7385        fac000 = (1._rb - fs) * fac00(lay)
7386        fac010 = (1._rb - fs) * fac10(lay)
7387        fac100 = fs * fac00(lay)
7388        fac110 = fs * fac10(lay)
7389      endif
7390 !
7391      if (specparm1 .lt. 0.125_rb) then
7392        p = fs1 - 1
7393        p4 = p**4
7394        fk0 = p4
7395        fk1 = 1 - p - 2.0_rb*p4
7396        fk2 = p + p4
7397        fac001 = fk0*fac01(lay)
7398        fac101 = fk1*fac01(lay)
7399        fac201 = fk2*fac01(lay)
7400        fac011 = fk0*fac11(lay)
7401        fac111 = fk1*fac11(lay)
7402        fac211 = fk2*fac11(lay)
7403      else if (specparm1 .gt. 0.875_rb) then
7404        p = -fs1
7405        p4 = p**4
7406        fk0 = p4
7407        fk1 = 1 - p - 2.0_rb*p4
7408        fk2 = p + p4
7409        fac001 = fk0*fac01(lay)
7410        fac101 = fk1*fac01(lay)
7411        fac201 = fk2*fac01(lay)
7412        fac011 = fk0*fac11(lay)
7413        fac111 = fk1*fac11(lay)
7414        fac211 = fk2*fac11(lay)
7415      else
7416        fac001 = (1._rb - fs1) * fac01(lay)
7417        fac011 = (1._rb - fs1) * fac11(lay)
7418        fac101 = fs1 * fac01(lay)
7419        fac111 = fs1 * fac11(lay)
7420      endif
7421 !
7422      do ig = 1, ng13
7423        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
7424                 (selfref(inds+1,ig) - selfref(inds,ig)))
7425        taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) *                &
7426                (forref(indf+1,ig) - forref(indf,ig)))
7427        co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 *                                &
7428               (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
7429        co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 *                              &
7430               (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
7431        absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
7432        com1 = ka_mco(jmco,indm,ig) + fmco *                                    &
7433              (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
7434        com2 = ka_mco(jmco,indm+1,ig) + fmco *                                  &
7435              (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
7436        absco = com1 + minorfrac(lay) * (com2 - com1)
7437 !
7438        if (specparm .lt. 0.125_rb) then
7439          tau_major = speccomb *                                                &
7440                      (fac000 * absa(ind0,ig) +                                 &
7441                       fac100 * absa(ind0+1,ig) +                               &
7442                       fac200 * absa(ind0+2,ig) +                               &
7443                       fac010 * absa(ind0+9,ig) +                               &
7444                       fac110 * absa(ind0+10,ig) +                              &
7445                       fac210 * absa(ind0+11,ig))
7446        else if (specparm .gt. 0.875_rb) then
7447          tau_major = speccomb *                                                &
7448                      (fac200 * absa(ind0-1,ig) +                               &
7449                       fac100 * absa(ind0,ig) +                                 &
7450                       fac000 * absa(ind0+1,ig) +                               &
7451                       fac210 * absa(ind0+8,ig) +                               &
7452                       fac110 * absa(ind0+9,ig) +                               &
7453                       fac010 * absa(ind0+10,ig))
7454        else
7455          tau_major = speccomb *                                                &
7456                      (fac000 * absa(ind0,ig) +                                 &
7457                       fac100 * absa(ind0+1,ig) +                               &
7458                       fac010 * absa(ind0+9,ig) +                               &
7459                       fac110 * absa(ind0+10,ig))
7460        endif
7461 !
7462        if (specparm1 .lt. 0.125_rb) then
7463          tau_major1 = speccomb1 *                                              &
7464                       (fac001 * absa(ind1,ig) +                                &
7465                        fac101 * absa(ind1+1,ig) +                              &
7466                        fac201 * absa(ind1+2,ig) +                              &
7467                        fac011 * absa(ind1+9,ig) +                              &
7468                        fac111 * absa(ind1+10,ig) +                             &
7469                        fac211 * absa(ind1+11,ig))
7470        else if (specparm1 .gt. 0.875_rb) then
7471          tau_major1 = speccomb1 *                                              &
7472                       (fac201 * absa(ind1-1,ig) +                              &
7473                        fac101 * absa(ind1,ig) +                                &
7474                        fac001 * absa(ind1+1,ig) +                              &
7475                        fac211 * absa(ind1+8,ig) +                              &
7476                        fac111 * absa(ind1+9,ig) +                              &
7477                        fac011 * absa(ind1+10,ig))
7478        else
7479          tau_major1 = speccomb1 *                                              &
7480                       (fac001 * absa(ind1,ig) +                                &
7481                        fac101 * absa(ind1+1,ig) +                              &
7482                        fac011 * absa(ind1+9,ig) +                              &
7483                        fac111 * absa(ind1+10,ig))
7484        endif
7485 !
7486        taug(lay,ngs12+ig) = tau_major + tau_major1                             &
7487                           + tauself + taufor                                   &
7488                           + adjcolco2*absco2                                   &
7489                           + colco(lay)*absco
7490        fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl *                          &
7491                             (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7492      enddo
7493    enddo
7494 !
7495 ! Upper atmosphere loop
7496 !
7497    do lay = laytrop+1,nlayers
7498      indm = indminor(lay)
7499      do ig = 1,ng13
7500        abso3 = kb_mo3(indm,ig) + minorfrac(lay) *                              &
7501               (kb_mo3(indm+1,ig) - kb_mo3(indm,ig))
7502        taug(lay,ngs12+ig) = colo3(lay)*abso3
7503        fracs(lay,ngs12+ig) = fracrefb(ig)
7504      enddo
7505    enddo
7506 !
7507    end subroutine taugb13
7508 !-------------------------------------------------------------------------------
7509 !
7510 !
7511 !-------------------------------------------------------------------------------
7512    subroutine taugb14
7513 !-------------------------------------------------------------------------------
7514 !
7515 !  abstract : band 14,  2250-2380 cm-1 (low - co2; high - co2)
7516 !
7517 !-------------------------------------------------------------------------------
7518    use parrrtm_k,   only : ng14, ngs13
7519    use rrlw_kg14_k, only : fracrefa, fracrefb, absa, ka, absb, kb,             &
7520                          selfref, forref
7521 !
7522 ! Local
7523 !
7524    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7525    real(kind=rb)    :: tauself, taufor
7526 !-------------------------------------------------------------------------------
7527 !
7528 ! Compute the optical depth by interpolating in ln(pressure) and
7529 ! temperature.  Below laytrop, the water vapor self-continuum
7530 ! and foreign continuum is interpolated (in temperature) separately.
7531 !
7532 ! Lower atmosphere loop
7533 !
7534    do lay = 1,laytrop
7535      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1
7536      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1
7537      inds = indself(lay)
7538      indf = indfor(lay)
7539      do ig = 1,ng14
7540        tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) *            &
7541                 (selfref(inds+1,ig) - selfref(inds,ig)))
7542        taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
7543                 (forref(indf+1,ig) - forref(indf,ig)))
7544        taug(lay,ngs13+ig) = colco2(lay) *                                      &
7545                             (fac00(lay) * absa(ind0,ig) +                      &
7546                              fac10(lay) * absa(ind0+1,ig) +                    &
7547                              fac01(lay) * absa(ind1,ig) +                      &
7548                              fac11(lay) * absa(ind1+1,ig))                     &
7549                              + tauself + taufor
7550        fracs(lay,ngs13+ig) = fracrefa(ig)
7551      enddo
7552    enddo
7553 !
7554 ! Upper atmosphere loop
7555 !
7556    do lay = laytrop+1,nlayers
7557      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1
7558      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1
7559      do ig = 1,ng14
7560        taug(lay,ngs13+ig) = colco2(lay) *                                      &
7561                             (fac00(lay) * absb(ind0,ig) +                      &
7562                              fac10(lay) * absb(ind0+1,ig) +                    &
7563                              fac01(lay) * absb(ind1,ig) +                      &
7564                              fac11(lay) * absb(ind1+1,ig))
7565        fracs(lay,ngs13+ig) = fracrefb(ig)
7566      enddo
7567    enddo
7568 !
7569    end subroutine taugb14
7570 !-------------------------------------------------------------------------------
7571 !
7572 !
7573 !-------------------------------------------------------------------------------
7574    subroutine taugb15
7575 !-------------------------------------------------------------------------------
7576 !
7577 !  abstract : band 15,  2380-2600 cm-1 (low - n2o,co2; low minor - n2)
7578 !                                      (high - nothing)
7579 !
7580 !-------------------------------------------------------------------------------
7581    use parrrtm_k,   only : ng15, ngs14
7582    use rrlw_ref_k,  only : chi_mls
7583    use rrlw_kg15_k, only : fracrefa, absa, ka, ka_mn2, selfref, forref
7584 !
7585 ! Local
7586 !
7587    integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
7588    integer(kind=im) :: js, js1, jmn2, jpl
7589    real(kind=rb)    :: speccomb, specparm, specmult, fs
7590    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
7591    real(kind=rb)    :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
7592    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
7593    real(kind=rb)    :: p, p4, fk0, fk1, fk2
7594    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
7595    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
7596    real(kind=rb)    :: scalen2, tauself, taufor, n2m1, n2m2, taun2
7597    real(kind=rb)    :: refrat_planck_a, refrat_m_a
7598    real(kind=rb)    :: tau_major, tau_major1
7599 !-------------------------------------------------------------------------------
7600 !
7601 ! Minor gas mapping level :
7602 !     Lower - Nitrogen Continuum, P = 1053., T = 294.
7603 !
7604 ! Calculate reference ratio to be used in calculation of Planck
7605 ! fraction in lower atmosphere.
7606 !
7607 ! P = 1053. mb (Level 1)
7608 !
7609    refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
7610 !
7611 ! P = 1053.
7612 !
7613    refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
7614 !
7615 ! Compute the optical depth by interpolating in ln(pressure),
7616 ! temperature, and appropriate species.  Below laytrop, the water
7617 ! vapor self-continuum and foreign continuum is interpolated
7618 ! (in temperature) separately.
7619 !
7620 ! Lower atmosphere loop
7621 !
7622    do lay = 1,laytrop
7623 !
7624      speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay)
7625      specparm = coln2o(lay)/speccomb
7626      if (specparm .ge. oneminus) specparm = oneminus
7627      specmult = 8._rb*(specparm)
7628      js = 1 + int(specmult)
7629      fs = mod(specmult,1.0_rb)
7630 !
7631      speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay)
7632      specparm1 = coln2o(lay)/speccomb1
7633      if (specparm1 .ge. oneminus) specparm1 = oneminus
7634      specmult1 = 8._rb*(specparm1)
7635      js1 = 1 + int(specmult1)
7636      fs1 = mod(specmult1,1.0_rb)
7637 !
7638      speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay)
7639      specparm_mn2 = coln2o(lay)/speccomb_mn2
7640      if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus
7641      specmult_mn2 = 8._rb*specparm_mn2
7642      jmn2 = 1 + int(specmult_mn2)
7643      fmn2 = mod(specmult_mn2,1.0_rb)
7644 !
7645      speccomb_planck = coln2o(lay) + refrat_planck_a*colco2(lay)
7646      specparm_planck = coln2o(lay)/speccomb_planck
7647      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7648      specmult_planck = 8._rb*specparm_planck
7649      jpl = 1 + int(specmult_planck)
7650      fpl = mod(specmult_planck,1.0_rb)
7651 !
7652      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js
7653      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1
7654      inds = indself(lay)
7655      indf = indfor(lay)
7656      indm = indminor(lay)
7657 !
7658      scalen2 = colbrd(lay)*scaleminor(lay)
7659 !
7660      if (specparm .lt. 0.125_rb) then
7661        p = fs - 1
7662        p4 = p**4
7663        fk0 = p4
7664        fk1 = 1 - p - 2.0_rb*p4
7665        fk2 = p + p4
7666        fac000 = fk0*fac00(lay)
7667        fac100 = fk1*fac00(lay)
7668        fac200 = fk2*fac00(lay)
7669        fac010 = fk0*fac10(lay)
7670        fac110 = fk1*fac10(lay)
7671        fac210 = fk2*fac10(lay)
7672      else if (specparm .gt. 0.875_rb) then
7673        p = -fs
7674        p4 = p**4
7675        fk0 = p4
7676        fk1 = 1 - p - 2.0_rb*p4
7677        fk2 = p + p4
7678        fac000 = fk0*fac00(lay)
7679        fac100 = fk1*fac00(lay)
7680        fac200 = fk2*fac00(lay)
7681        fac010 = fk0*fac10(lay)
7682        fac110 = fk1*fac10(lay)
7683        fac210 = fk2*fac10(lay)
7684      else
7685        fac000 = (1._rb - fs) * fac00(lay)
7686        fac010 = (1._rb - fs) * fac10(lay)
7687        fac100 = fs * fac00(lay)
7688        fac110 = fs * fac10(lay)
7689      endif
7690 !
7691      if (specparm1 .lt. 0.125_rb) then
7692        p = fs1 - 1
7693        p4 = p**4
7694        fk0 = p4
7695        fk1 = 1 - p - 2.0_rb*p4
7696        fk2 = p + p4
7697        fac001 = fk0*fac01(lay)
7698        fac101 = fk1*fac01(lay)
7699        fac201 = fk2*fac01(lay)
7700        fac011 = fk0*fac11(lay)
7701        fac111 = fk1*fac11(lay)
7702        fac211 = fk2*fac11(lay)
7703      else if (specparm1 .gt. 0.875_rb) then
7704        p = -fs1
7705        p4 = p**4
7706        fk0 = p4
7707        fk1 = 1 - p - 2.0_rb*p4
7708        fk2 = p + p4
7709        fac001 = fk0*fac01(lay)
7710        fac101 = fk1*fac01(lay)
7711        fac201 = fk2*fac01(lay)
7712        fac011 = fk0*fac11(lay)
7713        fac111 = fk1*fac11(lay)
7714        fac211 = fk2*fac11(lay)
7715      else
7716        fac001 = (1._rb - fs1) * fac01(lay)
7717        fac011 = (1._rb - fs1) * fac11(lay)
7718        fac101 = fs1 * fac01(lay)
7719        fac111 = fs1 * fac11(lay)
7720      endif
7721 !
7722      do ig = 1,ng15
7723        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
7724                                (selfref(inds+1,ig) - selfref(inds,ig)))
7725        taufor  = forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
7726                                (forref(indf+1,ig) - forref(indf,ig)))
7727        n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 *                                    &
7728              (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
7729        n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 *                                  &
7730              (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
7731        taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
7732 !
7733        if (specparm .lt. 0.125_rb) then
7734          tau_major = speccomb *                                                &
7735                      (fac000 * absa(ind0,ig) +                                 &
7736                       fac100 * absa(ind0+1,ig) +                               &
7737                       fac200 * absa(ind0+2,ig) +                               &
7738                       fac010 * absa(ind0+9,ig) +                               &
7739                       fac110 * absa(ind0+10,ig) +                              &
7740                       fac210 * absa(ind0+11,ig))
7741        else if (specparm .gt. 0.875_rb) then
7742          tau_major = speccomb *                                                &
7743                      (fac200 * absa(ind0-1,ig) +                               &
7744                       fac100 * absa(ind0,ig) +                                 &
7745                       fac000 * absa(ind0+1,ig) +                               &
7746                       fac210 * absa(ind0+8,ig) +                               &
7747                       fac110 * absa(ind0+9,ig) +                               &
7748                       fac010 * absa(ind0+10,ig))
7749        else
7750          tau_major = speccomb *                                                &
7751                      (fac000 * absa(ind0,ig) +                                 &
7752                       fac100 * absa(ind0+1,ig) +                               &
7753                       fac010 * absa(ind0+9,ig) +                               &
7754                       fac110 * absa(ind0+10,ig))
7755        endif
7756 !
7757        if (specparm1 .lt. 0.125_rb) then
7758          tau_major1 = speccomb1 *                                              &
7759                       (fac001 * absa(ind1,ig) +                                &
7760                        fac101 * absa(ind1+1,ig) +                              &
7761                        fac201 * absa(ind1+2,ig) +                              &
7762                        fac011 * absa(ind1+9,ig) +                              &
7763                        fac111 * absa(ind1+10,ig) +                             &
7764                        fac211 * absa(ind1+11,ig))
7765        else if (specparm1 .gt. 0.875_rb) then
7766          tau_major1 = speccomb1 *                                              &
7767                       (fac201 * absa(ind1-1,ig) +                              &
7768                        fac101 * absa(ind1,ig) +                                &
7769                        fac001 * absa(ind1+1,ig) +                              &
7770                        fac211 * absa(ind1+8,ig) +                              &
7771                        fac111 * absa(ind1+9,ig) +                              &
7772                        fac011 * absa(ind1+10,ig))
7773        else
7774          tau_major1 = speccomb1 *                                              &
7775                       (fac001 * absa(ind1,ig) +                                &
7776                        fac101 * absa(ind1+1,ig) +                              &
7777                        fac011 * absa(ind1+9,ig) +                              &
7778                        fac111 * absa(ind1+10,ig))
7779        endif
7780 !
7781        taug(lay,ngs14+ig) = tau_major + tau_major1                             &
7782                           + tauself + taufor                                   &
7783                           + taun2
7784        fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl *                          &
7785                             (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7786      enddo
7787    enddo
7788 !
7789 ! Upper atmosphere loop
7790 !
7791    do lay = laytrop+1,nlayers
7792      do ig = 1,ng15
7793        taug(lay,ngs14+ig)  = 0.0_rb
7794        fracs(lay,ngs14+ig) = 0.0_rb
7795      enddo
7796    enddo
7797 !
7798    end subroutine taugb15
7799 !-------------------------------------------------------------------------------
7800 !
7801 !
7802 !-------------------------------------------------------------------------------
7803    subroutine taugb16
7804 !-------------------------------------------------------------------------------
7805 !
7806 !  abstract : band 16,  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
7807 !
7808 !-------------------------------------------------------------------------------
7809    use parrrtm_k,   only : ng16, ngs15
7810    use rrlw_ref_k,  only : chi_mls
7811    use rrlw_kg16_k, only : fracrefa, fracrefb, absa, ka,                       &
7812                            absb, kb, selfref, forref
7813 !
7814 ! Local
7815 !
7816    integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
7817    integer(kind=im) :: js, js1, jpl
7818    real(kind=rb)    :: speccomb, specparm, specmult, fs
7819    real(kind=rb)    :: speccomb1, specparm1, specmult1, fs1
7820    real(kind=rb)    :: speccomb_planck, specparm_planck, specmult_planck, fpl
7821    real(kind=rb)    :: p, p4, fk0, fk1, fk2
7822    real(kind=rb)    :: fac000, fac100, fac200, fac010, fac110, fac210
7823    real(kind=rb)    :: fac001, fac101, fac201, fac011, fac111, fac211
7824    real(kind=rb)    :: tauself, taufor
7825    real(kind=rb)    :: refrat_planck_a
7826    real(kind=rb)    :: tau_major, tau_major1
7827 !-------------------------------------------------------------------------------
7828 !
7829 ! Calculate reference ratio to be used in calculation of Planck
7830 ! fraction in lower atmosphere.
7831 ! P = 387. mb (Level 6)
7832 !
7833    refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
7834 !
7835 ! Compute the optical depth by interpolating in ln(pressure),
7836 ! temperature,and appropriate species.  Below laytrop, the water
7837 ! vapor self-continuum and foreign continuum is interpolated
7838 ! (in temperature) separately.
7839 !
7840 ! Lower atmosphere loop
7841 !
7842    do lay = 1,laytrop
7843 !
7844      speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
7845      specparm = colh2o(lay)/speccomb
7846      if (specparm .ge. oneminus) specparm = oneminus
7847      specmult = 8._rb*(specparm)
7848      js = 1 + int(specmult)
7849      fs = mod(specmult,1.0_rb)
7850 !
7851      speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
7852      specparm1 = colh2o(lay)/speccomb1
7853      if (specparm1 .ge. oneminus) specparm1 = oneminus
7854      specmult1 = 8._rb*(specparm1)
7855      js1 = 1 + int(specmult1)
7856      fs1 = mod(specmult1,1.0_rb)
7857 !
7858      speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
7859      specparm_planck = colh2o(lay)/speccomb_planck
7860      if (specparm_planck .ge. oneminus) specparm_planck=oneminus
7861      specmult_planck = 8._rb*specparm_planck
7862      jpl = 1 + int(specmult_planck)
7863      fpl = mod(specmult_planck,1.0_rb)
7864 !
7865      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
7866      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1
7867      inds = indself(lay)
7868      indf = indfor(lay)
7869 !
7870      if (specparm .lt. 0.125_rb) then
7871        p = fs - 1
7872        p4 = p**4
7873        fk0 = p4
7874        fk1 = 1 - p - 2.0_rb*p4
7875        fk2 = p + p4
7876        fac000 = fk0*fac00(lay)
7877        fac100 = fk1*fac00(lay)
7878        fac200 = fk2*fac00(lay)
7879        fac010 = fk0*fac10(lay)
7880        fac110 = fk1*fac10(lay)
7881        fac210 = fk2*fac10(lay)
7882      else if (specparm .gt. 0.875_rb) then
7883        p = -fs
7884        p4 = p**4
7885        fk0 = p4
7886        fk1 = 1 - p - 2.0_rb*p4
7887        fk2 = p + p4
7888        fac000 = fk0*fac00(lay)
7889        fac100 = fk1*fac00(lay)
7890        fac200 = fk2*fac00(lay)
7891        fac010 = fk0*fac10(lay)
7892        fac110 = fk1*fac10(lay)
7893        fac210 = fk2*fac10(lay)
7894      else
7895        fac000 = (1._rb - fs) * fac00(lay)
7896        fac010 = (1._rb - fs) * fac10(lay)
7897        fac100 = fs * fac00(lay)
7898        fac110 = fs * fac10(lay)
7899      endif
7900 !
7901      if (specparm1 .lt. 0.125_rb) then
7902        p = fs1 - 1
7903        p4 = p**4
7904        fk0 = p4
7905        fk1 = 1 - p - 2.0_rb*p4
7906        fk2 = p + p4
7907        fac001 = fk0*fac01(lay)
7908        fac101 = fk1*fac01(lay)
7909        fac201 = fk2*fac01(lay)
7910        fac011 = fk0*fac11(lay)
7911        fac111 = fk1*fac11(lay)
7912        fac211 = fk2*fac11(lay)
7913      else if (specparm1 .gt. 0.875_rb) then
7914        p = -fs1
7915        p4 = p**4
7916        fk0 = p4
7917        fk1 = 1 - p - 2.0_rb*p4
7918        fk2 = p + p4
7919        fac001 = fk0*fac01(lay)
7920        fac101 = fk1*fac01(lay)
7921        fac201 = fk2*fac01(lay)
7922        fac011 = fk0*fac11(lay)
7923        fac111 = fk1*fac11(lay)
7924        fac211 = fk2*fac11(lay)
7925      else
7926        fac001 = (1._rb - fs1) * fac01(lay)
7927        fac011 = (1._rb - fs1) * fac11(lay)
7928        fac101 = fs1 * fac01(lay)
7929        fac111 = fs1 * fac11(lay)
7930      endif
7931 !
7932      do ig = 1,ng16
7933        tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) *             &
7934                 (selfref(inds+1,ig) - selfref(inds,ig)))
7935        taufor  = forfac(lay) * (forref(indf,ig) + forfrac(lay) *               &
7936                 (forref(indf+1,ig) - forref(indf,ig)))
7937 !
7938        if (specparm .lt. 0.125_rb) then
7939          tau_major = speccomb *                                                &
7940                      (fac000 * absa(ind0,ig) +                                 &
7941                       fac100 * absa(ind0+1,ig) +                               &
7942                       fac200 * absa(ind0+2,ig) +                               &
7943                       fac010 * absa(ind0+9,ig) +                               &
7944                       fac110 * absa(ind0+10,ig) +                              &
7945                       fac210 * absa(ind0+11,ig))
7946        else if (specparm .gt. 0.875_rb) then
7947          tau_major = speccomb *                                                &
7948                      (fac200 * absa(ind0-1,ig) +                               &
7949                       fac100 * absa(ind0,ig) +                                 &
7950                       fac000 * absa(ind0+1,ig) +                               &
7951                       fac210 * absa(ind0+8,ig) +                               &
7952                       fac110 * absa(ind0+9,ig) +                               &
7953                       fac010 * absa(ind0+10,ig))
7954        else
7955          tau_major = speccomb *                                                &
7956                      (fac000 * absa(ind0,ig) +                                 &
7957                       fac100 * absa(ind0+1,ig) +                               &
7958                       fac010 * absa(ind0+9,ig) +                               &
7959                       fac110 * absa(ind0+10,ig))
7960        endif
7961 !
7962        if (specparm1 .lt. 0.125_rb) then
7963          tau_major1 = speccomb1 *                                              &
7964                       (fac001 * absa(ind1,ig) +                                &
7965                        fac101 * absa(ind1+1,ig) +                              &
7966                        fac201 * absa(ind1+2,ig) +                              &
7967                        fac011 * absa(ind1+9,ig) +                              &
7968                        fac111 * absa(ind1+10,ig) +                             &
7969                        fac211 * absa(ind1+11,ig))
7970        else if (specparm1 .gt. 0.875_rb) then
7971          tau_major1 = speccomb1 *                                              &
7972                       (fac201 * absa(ind1-1,ig) +                              &
7973                        fac101 * absa(ind1,ig) +                                &
7974                        fac001 * absa(ind1+1,ig) +                              &
7975                        fac211 * absa(ind1+8,ig) +                              &
7976                        fac111 * absa(ind1+9,ig) +                              &
7977                        fac011 * absa(ind1+10,ig))
7978        else
7979          tau_major1 = speccomb1 *                                              &
7980                       (fac001 * absa(ind1,ig) +                                &
7981                        fac101 * absa(ind1+1,ig) +                              &
7982                        fac011 * absa(ind1+9,ig) +                              &
7983                        fac111 * absa(ind1+10,ig))
7984        endif
7985 !
7986        taug(lay,ngs15+ig) = tau_major + tau_major1                             &
7987                           + tauself + taufor
7988        fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl *                          &
7989                             (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
7990      enddo
7991    enddo
7992 !
7993 ! Upper atmosphere loop
7994 !
7995    do lay = laytrop+1,nlayers
7996      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
7997      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
7998      do ig = 1,ng16
7999        taug(lay,ngs15+ig) = colch4(lay) *                                      &
8000                             (fac00(lay) * absb(ind0,ig) +                      &
8001                              fac10(lay) * absb(ind0+1,ig) +                    &
8002                              fac01(lay) * absb(ind1,ig) +                      &
8003                              fac11(lay) * absb(ind1+1,ig))
8004        fracs(lay,ngs15+ig) = fracrefb(ig)
8005      enddo
8006    enddo
8007 !
8008    end subroutine taugb16
8009 !-------------------------------------------------------------------------------
8010 !
8011 !
8012 !-------------------------------------------------------------------------------
8013    end subroutine taumol
8014 !-------------------------------------------------------------------------------
8015 !
8016 !
8017 !-------------------------------------------------------------------------------
8018    end module rrtmg_lw_taumol_k
8019 !-------------------------------------------------------------------------------
8020 !
8021 !
8022 !-------------------------------------------------------------------------------
8023 !
8024 ! path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
8025 ! author:    $Author: trn $
8026 ! revision:  $Revision: 1.3 $
8027 ! created:   $Date: 2009/04/16 19:54:22 $
8028 !
8029 !-------------------------------------------------------------------------------
8030 !
8031 !
8032 !-------------------------------------------------------------------------------
8033    module rrtmg_lw_init_k
8034 !-------------------------------------------------------------------------------
8035 !
8036 !  abstract : rrtmg_lw_init (Steven Cavallo: added for buffer layer adjustment)
8037 !
8038 !  --------------------------------------------------------------------------
8039 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
8040 ! |  This software may be used, copied, or redistributed as long as it is    |
8041 ! |  not sold and this copyright notice is reproduced on each copy made.     |
8042 ! |  This model is provided as is without any express or implied warranties. |
8043 ! |                       (http://www.rtweb.aer.com/)                        |
8044 !  --------------------------------------------------------------------------
8045 !
8046 !-------------------------------------------------------------------------------
8047    use parkind_k,          only : im => kind_im, rb => kind_rb
8048    use rrlw_wvn_k
8049    use rrtmg_lw_setcoef_k, only : lwatmref, lwavplank
8050 !
8051    implicit none
8052 !
8053    integer, save    :: nlayers
8054 !
8055    contains
8056 !-------------------------------------------------------------------------------
8057 !
8058 !
8059 !-------------------------------------------------------------------------------
8060    subroutine rrtmg_lw_ini (cpdair)
8061 !-------------------------------------------------------------------------------
8062 !
8063 !  abstract :
8064 !  This subroutine performs calculations necessary for the initialization
8065 !  of the longwave model.  Lookup tables are computed for use in the LW
8066 !  radiative transfer, and input absorption coefficient data for each
8067 !  spectral band are reduced from 256 g-point intervals to 140.
8068 !
8069 !  history log :
8070 !    1998-07-01  Michael J. Iacono  original version
8071 !    1998-09-01                     first revision for GCMs
8072 !    2002-09-01                     second revision for RRTM_V3.0
8073 !
8074 !  input :
8075 !    cpdair - Specific heat capacity of dry air at constant pressure at 273 K
8076 !             (J kg-1 K-1)
8077 !
8078 !  local variable :
8079 !    expeps - Smallest value for exponential table
8080 !
8081 !-------------------------------------------------------------------------------
8082    use parrrtm_k,  only : mg, nbndlw, ngptlw
8083    use rrlw_tbl_k, only : ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
8084    use rrlw_vsn_k, only : hvrini, hnamini
8085 !
8086    real(kind=rb), intent(in   ) :: cpdair
8087 !
8088 ! Local
8089 !
8090    integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr
8091    integer(kind=im) :: igcsm, iprsm
8092    real(kind=rb)    :: wtsum, wtsm(mg)
8093    real(kind=rb)    :: tfn
8094    real(kind=rb), parameter :: expeps = 1.e-20
8095 !-------------------------------------------------------------------------------
8096 !
8097 ! ------- Definitions -------
8098 ! Arrays for 10000-point look-up tables:
8099 ! tau_tbl Clear-sky optical depth (used in cloudy radiative transfer)
8100 ! exp_tbl Exponential lookup table for ransmittance
8101 ! tfn_tbl Tau transition function; i.e. the transition of the Planck
8102 !         function from that for the mean layer temperature to that for
8103 !         the layer boundary temperature as a function of optical depth.
8104 !         The "linear in tau" method is used to make the table.
8105 ! pade    Pade approximation constant (= 0.278)
8106 ! bpade   Inverse of the Pade approximation constant
8107 !
8108    hvrini = '$Revision: 1.3 $'
8109 !
8110 ! Initialize model data
8111 !
8112    call lwdatinit(cpdair)
8113    call lwcmbdat               ! g-point interval reduction data
8114    call lwcldpr                ! cloud optical properties
8115    call lwatmref               ! reference MLS profile
8116    call lwavplank              ! Planck function
8117 !
8118 ! Moved to module_ra_rrtmg_lw for WRF
8119 !
8120 !  call lw_kgb01               ! molecular absorption coefficients
8121 !  call lw_kgb02
8122 !  call lw_kgb03
8123 !  call lw_kgb04
8124 !  call lw_kgb05
8125 !  call lw_kgb06
8126 !  call lw_kgb07
8127 !  call lw_kgb08
8128 !  call lw_kgb09
8129 !  call lw_kgb10
8130 !  call lw_kgb11
8131 !  call lw_kgb12
8132 !  call lw_kgb13
8133 !  call lw_kgb14
8134 !  call lw_kgb15
8135 !  call lw_kgb16
8136 !
8137 ! Compute lookup tables for transmittance, tau transition function,
8138 ! and clear sky tau (for the cloudy sky radiative transfer).  Tau is
8139 ! computed as a function of the tau transition function, transmittance
8140 ! is calculated as a function of tau, and the tau transition function
8141 ! is calculated using the linear in tau formulation at values of tau
8142 ! above 0.01.  TF is approximated as tau/6 for tau < 0.01.  All tables
8143 ! are computed at intervals of 0.001.  The inverse of the constant used
8144 ! in the Pade approximation to the tau transition function is set to b.
8145 !
8146    tau_tbl(0) = 0.0_rb
8147    tau_tbl(ntbl) = 1.e10_rb
8148    exp_tbl(0) = 1.0_rb
8149    exp_tbl(ntbl) = expeps
8150    tfn_tbl(0) = 0.0_rb
8151    tfn_tbl(ntbl) = 1.0_rb
8152    bpade = 1.0_rb / pade
8153 !
8154    do itr = 1,ntbl-1
8155      tfn = real(itr) / real(ntbl)
8156      tau_tbl(itr) = bpade * tfn / (1._rb - tfn)
8157      exp_tbl(itr) = exp(-tau_tbl(itr))
8158      if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
8159      if (tau_tbl(itr) .lt. 0.06_rb) then
8160        tfn_tbl(itr) = tau_tbl(itr)/6._rb
8161      else
8162        tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))                        &
8163                                   -(exp_tbl(itr)/(1.-exp_tbl(itr))))
8164      endif
8165    enddo
8166 !
8167 ! Perform g-point reduction from 16 per band (256 total points) to
8168 ! a band dependant number (140 total points) for all absorption
8169 ! coefficient input data and Planck fraction input data.
8170 ! Compute relative weighting for new g-point combinations.
8171 !
8172    igcsm = 0
8173    do ibnd = 1,nbndlw
8174      iprsm = 0
8175      if (ngc(ibnd).lt.mg) then
8176        do igc = 1,ngc(ibnd)
8177          igcsm = igcsm + 1
8178          wtsum = 0._rb
8179          do ipr = 1,ngn(igcsm)
8180            iprsm = iprsm + 1
8181            wtsum = wtsum + wt(iprsm)
8182          enddo
8183          wtsm(igc) = wtsum
8184        enddo
8185 !
8186        do ig = 1,ng(ibnd)
8187          ind = (ibnd-1)*mg + ig
8188          rwgt(ind) = wt(ig)/wtsm(ngm(ind))
8189        enddo
8190      else
8191        do ig = 1,ng(ibnd)
8192          igcsm = igcsm + 1
8193          ind = (ibnd-1)*mg + ig
8194          rwgt(ind) = 1.0_rb
8195        enddo
8196      endif
8197    enddo
8198 !
8199 ! Reduce g-points for absorption coefficient data in each LW spectral band.
8200 !
8201    call cmbgb1
8202    call cmbgb2
8203    call cmbgb3
8204    call cmbgb4
8205    call cmbgb5
8206    call cmbgb6
8207    call cmbgb7
8208    call cmbgb8
8209    call cmbgb9
8210    call cmbgb10
8211    call cmbgb11
8212    call cmbgb12
8213    call cmbgb13
8214    call cmbgb14
8215    call cmbgb15
8216    call cmbgb16
8217 !
8218    end subroutine rrtmg_lw_ini
8219 !-------------------------------------------------------------------------------
8220 !
8221 !
8222 !-------------------------------------------------------------------------------
8223    subroutine lwdatinit (cpdair)
8224 !-------------------------------------------------------------------------------
8225 !
8226 !  abstract : lwdatinit
8227 !
8228 !  input :
8229 !    cpdair - Specific heat capacity of dry air at constant pressure at 273 K
8230 !             (J kg-1 K-1)
8231 !
8232 !-------------------------------------------------------------------------------
8233    use parrrtm_k,  only : maxxsec, maxinpx
8234    use rrlw_con_k, only : heatfac, grav, planck, boltz,                        &
8235                         clight, avogad, alosmt, gascon, radcn1, radcn2,        &
8236                         sbcnst, secdy
8237    use rrlw_vsn_k
8238 !
8239    save
8240 !
8241    real(kind=rb), intent(in   ) :: cpdair
8242 !-------------------------------------------------------------------------------
8243 !
8244 ! Longwave spectral band limits (wavenumbers)
8245 !
8246    wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb,       &
8247                    980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,       &
8248                   2080._rb,2250._rb,2380._rb,2600._rb/)
8249    wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb,       &
8250                   1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb,       &
8251                   2250._rb,2380._rb,2600._rb,3250._rb/)
8252    delwave(:)  = (/340._rb, 150._rb, 130._rb,  70._rb, 120._rb, 160._rb,       &
8253                    100._rb, 100._rb, 210._rb,  90._rb, 320._rb, 280._rb,       &
8254                    170._rb, 130._rb, 220._rb, 650._rb/)
8255 !
8256 ! Spectral band information
8257 !
8258    ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
8259    nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
8260    nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
8261 !
8262 ! nxmol     - number of cross-sections input by user
8263 ! ixindx(i) - index of cross-section molecule corresponding to Ith
8264 !             cross-section specified by user
8265 !             = 0 -- not allowed in rrtm
8266 !             = 1 -- ccl4
8267 !             = 2 -- cfc11
8268 !             = 3 -- cfc12
8269 !             = 4 -- cfc22
8270 !
8271    nxmol = 4
8272    ixindx(1) = 1
8273    ixindx(2) = 2
8274    ixindx(3) = 3
8275    ixindx(4) = 4
8276    ixindx(5:maxinpx) = 0
8277 !
8278 ! Fundamental physical constants from NIST 2002
8279 !
8280    grav = 9.8066_rb                        ! Acceleration of gravity
8281                                            ! (m s-2)
8282    planck = 6.62606876e-27_rb              ! Planck constant
8283                                            ! (ergs s; g cm2 s-1)
8284    boltz = 1.3806503e-16_rb                ! Boltzmann constant
8285                                            ! (ergs K-1; g cm2 s-2 K-1)
8286    clight = 2.99792458e+10_rb              ! Speed of light in a vacuum
8287                                            ! (cm s-1)
8288    avogad = 6.02214199e+23_rb              ! Avogadro constant
8289                                            ! (mol-1)
8290    alosmt = 2.6867775e+19_rb               ! Loschmidt constant
8291                                            ! (cm-3)
8292    gascon = 8.31447200e+07_rb              ! Molar gas constant
8293                                            ! (ergs mol-1 K-1)
8294    radcn1 = 1.191042722e-12_rb             ! First radiation constant
8295                                            ! (W cm2 sr-1)
8296    radcn2 = 1.4387752_rb                   ! Second radiation constant
8297                                            ! (cm K)
8298    sbcnst = 5.670400e-04_rb                ! Stefan-Boltzmann constant
8299                                            ! (W cm-2 K-4)
8300    secdy = 8.6400e4_rb                     ! Number of seconds per day
8301                                            ! (s d-1)
8302 !
8303 ! units are generally cgs
8304 !
8305 ! The first and second radiation constants are taken from NIST.
8306 ! They were previously obtained from the relations:
8307 !      radcn1 = 2.*planck*clight*clight*1.e-07
8308 !      radcn2 = planck*clight/boltz
8309 !
8310 ! Heatfac is the factor by which delta-flux / delta-pressure is
8311 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
8312 ! the heating rate in units of degrees/day.  It is equal to:
8313 ! Original value:
8314 !       (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8315 !       Here, cpdair (1.004) is in units of J g-1 K-1, and the
8316 !       constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8317 !    =  (9.8066)(86400)(1e-5)/(1.004)
8318 ! heatfac = 8.4391_rb
8319 !
8320 ! Modified value for consistency with CAM3:
8321 !       (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
8322 !       Here, cpdair (1.00464) is in units of J g-1 K-1, and the
8323 !       constant (1.e-5) converts mb to Pa and g-1 to kg-1.
8324 !    =  (9.80616)(86400)(1e-5)/(1.00464)
8325 ! heatfac = 8.43339130434_rb
8326 !
8327 ! Calculated value:
8328 !    (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
8329 !       Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
8330 !       converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
8331 !
8332    heatfac = grav * secdy / (cpdair * 1.e2_rb)
8333 !
8334    end subroutine lwdatinit
8335 !-------------------------------------------------------------------------------
8336 !
8337 !
8338 !-------------------------------------------------------------------------------
8339    subroutine lwcmbdat
8340 !-------------------------------------------------------------------------------
8341 !
8342 !  abstract :
8343 !  Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
8344 !  This mapping from 256 to 140 points has been carefully selected to
8345 !  minimize the effect on the resulting fluxes and cooling rates, and
8346 !  caution should be used if the mapping is modified.  The full 256
8347 !  g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
8348 !
8349 !  data :
8350 !    ngptlw  The total number of new g-points
8351 !    ngc     The number of new g-points in each band
8352 !    ngs     The cumulative sum of new g-points for each band
8353 !    ngm     The index of each new g-point relative to the original
8354 !            16 g-points for each band.
8355 !    ngn     The number of original g-points that are combined to make
8356 !            each new g-point in each band.
8357 !    ngb     The band index for each new g-point.
8358 !    wt      RRTM weights for 16 g-points.
8359 !
8360 !-------------------------------------------------------------------------------
8361 !
8362    save
8363 !
8364 ! ------- Data statements -------
8365 !
8366    ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
8367    ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
8368    ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10,                      & ! band 1
8369               1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12,                 & ! band 2
8370               1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,                & ! band 3
8371               1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14,                & ! band 4
8372               1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,                & ! band 5
8373               1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,                       & ! band 6
8374               1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12,                  & ! band 7
8375               1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,                       & ! band 8
8376               1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12,                 & ! band 9
8377               1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6,                       & ! band 10
8378               1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8,                       & ! band 11
8379               1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8,                       & ! band 12
8380               1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4,                       & ! band 13
8381               1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,                       & ! band 14
8382               1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,                       & ! band 15
8383               1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/)                        ! band 16
8384    ngn(:) = (/1,1,2,2,2,2,2,2,1,1,                                   & ! band 1
8385               1,1,1,1,1,1,1,1,2,2,2,2,                               & ! band 2
8386               1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,                       & ! band 3
8387               1,1,1,1,1,1,1,1,1,1,1,1,1,3,                           & ! band 4
8388               1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,                       & ! band 5
8389               2,2,2,2,2,2,2,2,                                       & ! band 6
8390               2,2,1,1,1,1,1,1,1,1,2,2,                               & ! band 7
8391               2,2,2,2,2,2,2,2,                                       & ! band 8
8392               1,1,1,1,1,1,1,1,2,2,2,2,                               & ! band 9
8393               2,2,2,2,4,4,                                           & ! band 10
8394               1,1,2,2,2,2,3,3,                                       & ! band 11
8395               1,1,1,1,2,2,4,4,                                       & ! band 12
8396               3,3,4,6,                                               & ! band 13
8397               8,8,                                                   & ! band 14
8398               8,8,                                                   & ! band 15
8399               4,12/)                                                   ! band 16
8400    ngb(:) = (/1,1,1,1,1,1,1,1,1,1,                                   & ! band 1
8401               2,2,2,2,2,2,2,2,2,2,2,2,                               & ! band 2
8402               3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,                       & ! band 3
8403               4,4,4,4,4,4,4,4,4,4,4,4,4,4,                           & ! band 4
8404               5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,                       & ! band 5
8405               6,6,6,6,6,6,6,6,                                       & ! band 6
8406               7,7,7,7,7,7,7,7,7,7,7,7,                               & ! band 7
8407               8,8,8,8,8,8,8,8,                                       & ! band 8
8408               9,9,9,9,9,9,9,9,9,9,9,9,                               & ! band 9
8409               10,10,10,10,10,10,                                     & ! band 10
8410               11,11,11,11,11,11,11,11,                               & ! band 11
8411               12,12,12,12,12,12,12,12,                               & ! band 12
8412               13,13,13,13,                                           & ! band 13
8413               14,14,                                                 & ! band 14
8414               15,15,                                                 & ! band 15
8415               16,16/)                                                  ! band 16
8416    wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb,               &
8417               0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb,               &
8418               0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb,               &
8419               0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb,               &
8420               0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb,               &
8421               0.0000750000_rb/)
8422 !
8423    end subroutine lwcmbdat
8424 !-------------------------------------------------------------------------------
8425 !
8426 !
8427 !-------------------------------------------------------------------------------
8428    subroutine cmbgb1
8429 !-------------------------------------------------------------------------------
8430 !
8431 !  abstract :
8432 !  The subroutines CMBGB1->CMBGB16 input the absorption coefficient
8433 !  data for each band, which are defined for 16 g-points and 16 spectral
8434 !  bands. The data are combined with appropriate weighting following the
8435 !  g-point mapping arrays specified in RRTMINIT.  Plank fraction data
8436 !  in arrays FRACREFA and FRACREFB are combined without weighting.  All
8437 !  g-point reduced data are put into new arrays for use in RRTM.
8438 !
8439 !  band 1:  10-350 cm-1 (low key - h2o; low minor - n2)
8440 !                       (high key - h2o; high minor - n2)
8441 !  note: previous versions of rrtm band 1:
8442 !        10-250 cm-1 (low - h2o; high - h2o)
8443 !
8444 !  history log :
8445 !    1998-07-01  MJIacono  original version
8446 !    1998-09-01  MJIacono  revision for GCMs
8447 !    2002-09-01  MJIacono  revision for RRTMG
8448 !    2006-06-01  MJIacono  revision for F90 reformatting
8449 !
8450 !-------------------------------------------------------------------------------
8451    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng1
8452    use rrlw_kg01_k, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2,   &
8453                          selfrefo, forrefo,                                    &
8454                          fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2,kb_mn2,&
8455                          selfref, forref
8456 !
8457 ! Local
8458 !
8459    integer(kind=im) :: jt, jp, igc, ipr, iprsm
8460    real(kind=rb)    :: sumk, sumk1, sumk2, sumf1, sumf2
8461 !-------------------------------------------------------------------------------
8462 !
8463    do jt = 1,5
8464      do jp = 1,13
8465        iprsm = 0
8466        do igc = 1,ngc(1)
8467          sumk = 0.
8468          do ipr = 1,ngn(igc)
8469            iprsm = iprsm + 1
8470            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
8471          enddo
8472          ka(jt,jp,igc) = sumk
8473        enddo
8474      enddo
8475 !
8476      do jp = 13,59
8477        iprsm = 0
8478        do igc = 1,ngc(1)
8479          sumk = 0.
8480          do ipr = 1,ngn(igc)
8481            iprsm = iprsm + 1
8482            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
8483          enddo
8484          kb(jt,jp,igc) = sumk
8485        enddo
8486      enddo
8487    enddo
8488 !
8489    do jt = 1,10
8490      iprsm = 0
8491      do igc = 1,ngc(1)
8492        sumk = 0.
8493        do ipr = 1,ngn(igc)
8494          iprsm = iprsm + 1
8495          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
8496        enddo
8497        selfref(jt,igc) = sumk
8498      enddo
8499    enddo
8500 !
8501    do jt = 1,4
8502      iprsm = 0
8503      do igc = 1,ngc(1)
8504        sumk = 0.
8505        do ipr = 1,ngn(igc)
8506          iprsm = iprsm + 1
8507          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
8508        enddo
8509        forref(jt,igc) = sumk
8510      enddo
8511    enddo
8512 !
8513    do jt = 1,19
8514      iprsm = 0
8515      do igc = 1,ngc(1)
8516        sumk1 = 0.
8517        sumk2 = 0.
8518        do ipr = 1,ngn(igc)
8519          iprsm = iprsm + 1
8520          sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
8521          sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
8522        enddo
8523        ka_mn2(jt,igc) = sumk1
8524        kb_mn2(jt,igc) = sumk2
8525      enddo
8526    enddo
8527 !
8528    iprsm = 0
8529    do igc = 1,ngc(1)
8530      sumf1 = 0.
8531      sumf2 = 0.
8532      do ipr = 1,ngn(igc)
8533        iprsm = iprsm + 1
8534        sumf1 = sumf1+ fracrefao(iprsm)
8535        sumf2 = sumf2+ fracrefbo(iprsm)
8536      enddo
8537      fracrefa(igc) = sumf1
8538      fracrefb(igc) = sumf2
8539    enddo
8540 !
8541    end subroutine cmbgb1
8542 !-------------------------------------------------------------------------------
8543 !
8544 !
8545 !-------------------------------------------------------------------------------
8546    subroutine cmbgb2
8547 !-------------------------------------------------------------------------------
8548 !
8549 !  abstract :
8550 !  band 2:  350-500 cm-1 (low key - h2o; high key - h2o)
8551 !
8552 !  note: previous version of rrtm band 2:
8553 !        250 - 500 cm-1 (low - h2o; high - h2o)
8554 !
8555 !-------------------------------------------------------------------------------
8556    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng2
8557    use rrlw_kg02_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo,  &
8558                          fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8559 !
8560 ! Local
8561 !
8562    integer(kind=im) :: jt, jp, igc, ipr, iprsm
8563    real(kind=rb)    :: sumk, sumf1, sumf2
8564 !-------------------------------------------------------------------------------
8565 !
8566    do jt = 1,5
8567      do jp = 1,13
8568        iprsm = 0
8569        do igc = 1,ngc(2)
8570          sumk = 0.
8571          do ipr = 1,ngn(ngs(1)+igc)
8572            iprsm = iprsm + 1
8573            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
8574          enddo
8575          ka(jt,jp,igc) = sumk
8576        enddo
8577      enddo
8578 !
8579      do jp = 13,59
8580        iprsm = 0
8581        do igc = 1,ngc(2)
8582          sumk = 0.
8583          do ipr = 1,ngn(ngs(1)+igc)
8584            iprsm = iprsm + 1
8585            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
8586          enddo
8587          kb(jt,jp,igc) = sumk
8588        enddo
8589      enddo
8590    enddo
8591 !
8592    do jt = 1,10
8593      iprsm = 0
8594      do igc = 1,ngc(2)
8595        sumk = 0.
8596        do ipr = 1,ngn(ngs(1)+igc)
8597          iprsm = iprsm + 1
8598          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
8599        enddo
8600        selfref(jt,igc) = sumk
8601      enddo
8602    enddo
8603 !
8604    do jt = 1,4
8605      iprsm = 0
8606      do igc = 1,ngc(2)
8607        sumk = 0.
8608        do ipr = 1,ngn(ngs(1)+igc)
8609          iprsm = iprsm + 1
8610          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
8611        enddo
8612        forref(jt,igc) = sumk
8613      enddo
8614    enddo
8615 !
8616    iprsm = 0
8617    do igc = 1,ngc(2)
8618      sumf1 = 0.
8619      sumf2 = 0.
8620      do ipr = 1,ngn(ngs(1)+igc)
8621        iprsm = iprsm + 1
8622        sumf1 = sumf1+ fracrefao(iprsm)
8623        sumf2 = sumf2+ fracrefbo(iprsm)
8624      enddo
8625      fracrefa(igc) = sumf1
8626      fracrefb(igc) = sumf2
8627    enddo
8628 !
8629    end subroutine cmbgb2
8630 !-------------------------------------------------------------------------------
8631 !
8632 !
8633 !-------------------------------------------------------------------------------
8634    subroutine cmbgb3
8635 !-------------------------------------------------------------------------------
8636 !
8637 !  abstract :
8638 !  band 3:  500-630 cm-1 (low key - h2o,co2; low minor - n2o)
8639 !                        (high key - h2o,co2; high minor - n2o)
8640 !
8641 !  old band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
8642 !
8643 !-------------------------------------------------------------------------------
8644    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng3
8645    use rrlw_kg03_k, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
8646                          selfrefo, forrefo,                                    &
8647                          fracrefa, fracrefb, absa, ka, absb,kb,ka_mn2o,kb_mn2o,&
8648                          selfref, forref
8649 !
8650 ! Local
8651 !
8652    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8653    real(kind=rb)    :: sumk, sumf
8654 !-------------------------------------------------------------------------------
8655 !
8656    do jn = 1,9
8657      do jt = 1,5
8658        do jp = 1,13
8659          iprsm = 0
8660          do igc = 1,ngc(3)
8661           sumk = 0.
8662            do ipr = 1,ngn(ngs(2)+igc)
8663              iprsm = iprsm + 1
8664              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8665            enddo
8666            ka(jn,jt,jp,igc) = sumk
8667          enddo
8668        enddo
8669      enddo
8670    enddo
8671 !
8672    do jn = 1,5
8673      do jt = 1,5
8674        do jp = 13,59
8675          iprsm = 0
8676          do igc = 1,ngc(3)
8677            sumk = 0.
8678            do ipr = 1,ngn(ngs(2)+igc)
8679              iprsm = iprsm + 1
8680              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
8681            enddo
8682            kb(jn,jt,jp,igc) = sumk
8683          enddo
8684        enddo
8685      enddo
8686    enddo
8687 !
8688    do jn = 1,9
8689      do jt = 1,19
8690        iprsm = 0
8691        do igc = 1,ngc(3)
8692          sumk = 0.
8693          do ipr = 1,ngn(ngs(2)+igc)
8694            iprsm = iprsm + 1
8695            sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8696          enddo
8697          ka_mn2o(jn,jt,igc) = sumk
8698        enddo
8699      enddo
8700    enddo
8701 !
8702    do jn = 1,5
8703      do jt = 1,19
8704        iprsm = 0
8705        do igc = 1,ngc(3)
8706          sumk = 0.
8707          do ipr = 1,ngn(ngs(2)+igc)
8708            iprsm = iprsm + 1
8709            sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
8710          enddo
8711          kb_mn2o(jn,jt,igc) = sumk
8712        enddo
8713      enddo
8714    enddo
8715 !
8716    do jt = 1,10
8717      iprsm = 0
8718      do igc = 1,ngc(3)
8719        sumk = 0.
8720        do ipr = 1,ngn(ngs(2)+igc)
8721          iprsm = iprsm + 1
8722          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
8723        enddo
8724        selfref(jt,igc) = sumk
8725      enddo
8726    enddo
8727 !
8728    do jt = 1,4
8729      iprsm = 0
8730      do igc = 1,ngc(3)
8731        sumk = 0.
8732        do ipr = 1,ngn(ngs(2)+igc)
8733          iprsm = iprsm + 1
8734          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
8735        enddo
8736        forref(jt,igc) = sumk
8737      enddo
8738    enddo
8739 !
8740    do jp = 1,9
8741      iprsm = 0
8742      do igc = 1,ngc(3)
8743        sumf = 0.
8744        do ipr = 1,ngn(ngs(2)+igc)
8745          iprsm = iprsm + 1
8746          sumf = sumf + fracrefao(iprsm,jp)
8747        enddo
8748        fracrefa(igc,jp) = sumf
8749      enddo
8750    enddo
8751 !
8752    do jp = 1,5
8753      iprsm = 0
8754      do igc = 1,ngc(3)
8755        sumf = 0.
8756        do ipr = 1,ngn(ngs(2)+igc)
8757          iprsm = iprsm + 1
8758          sumf = sumf + fracrefbo(iprsm,jp)
8759        enddo
8760        fracrefb(igc,jp) = sumf
8761      enddo
8762    enddo
8763 !
8764    end subroutine cmbgb3
8765 !-------------------------------------------------------------------------------
8766 !
8767 !
8768 !-------------------------------------------------------------------------------
8769    subroutine cmbgb4
8770 !-------------------------------------------------------------------------------
8771 !
8772 !  abstract :
8773 !  band 4:  630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
8774 !
8775 !  old band 4:  630-700 cm-1 (low - h2o,co2; high - o3,co2)
8776 !
8777 !-------------------------------------------------------------------------------
8778    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng4
8779    use rrlw_kg04_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo,  &
8780                          fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
8781 !
8782 ! Local
8783 !
8784    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8785    real(kind=rb)    :: sumk, sumf
8786 !-------------------------------------------------------------------------------
8787 !
8788    do jn = 1,9
8789      do jt = 1,5
8790        do jp = 1,13
8791          iprsm = 0
8792          do igc = 1,ngc(4)
8793           sumk = 0.
8794            do ipr = 1,ngn(ngs(3)+igc)
8795              iprsm = iprsm + 1
8796              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8797            enddo
8798            ka(jn,jt,jp,igc) = sumk
8799          enddo
8800        enddo
8801      enddo
8802    enddo
8803 !
8804    do jn = 1,5
8805      do jt = 1,5
8806        do jp = 13,59
8807          iprsm = 0
8808          do igc = 1,ngc(4)
8809            sumk = 0.
8810            do ipr = 1,ngn(ngs(3)+igc)
8811              iprsm = iprsm + 1
8812              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
8813            enddo
8814            kb(jn,jt,jp,igc) = sumk
8815          enddo
8816        enddo
8817      enddo
8818    enddo
8819 !
8820    do jt = 1,10
8821      iprsm = 0
8822      do igc = 1,ngc(4)
8823        sumk = 0.
8824        do ipr = 1,ngn(ngs(3)+igc)
8825          iprsm = iprsm + 1
8826          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
8827        enddo
8828        selfref(jt,igc) = sumk
8829      enddo
8830    enddo
8831 !
8832    do jt = 1,4
8833      iprsm = 0
8834      do igc = 1,ngc(4)
8835        sumk = 0.
8836        do ipr = 1,ngn(ngs(3)+igc)
8837          iprsm = iprsm + 1
8838          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
8839        enddo
8840        forref(jt,igc) = sumk
8841      enddo
8842    enddo
8843 !
8844    do jp = 1,9
8845      iprsm = 0
8846      do igc = 1,ngc(4)
8847        sumf = 0.
8848        do ipr = 1,ngn(ngs(3)+igc)
8849          iprsm = iprsm + 1
8850          sumf = sumf + fracrefao(iprsm,jp)
8851        enddo
8852        fracrefa(igc,jp) = sumf
8853      enddo
8854    enddo
8855 !
8856    do jp = 1,5
8857      iprsm = 0
8858      do igc = 1,ngc(4)
8859        sumf = 0.
8860        do ipr = 1,ngn(ngs(3)+igc)
8861          iprsm = iprsm + 1
8862          sumf = sumf + fracrefbo(iprsm,jp)
8863        enddo
8864        fracrefb(igc,jp) = sumf
8865      enddo
8866    enddo
8867 !
8868    end subroutine cmbgb4
8869 !-------------------------------------------------------------------------------
8870 !
8871 !
8872 !-------------------------------------------------------------------------------
8873    subroutine cmbgb5
8874 !-------------------------------------------------------------------------------
8875 !
8876 !  abstract :
8877 !  band 5:  700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
8878 !                        (high key - o3,co2)
8879 !
8880 !  old band 5:  700-820 cm-1 (low - h2o,co2; high - o3,co2)
8881 !
8882 !-------------------------------------------------------------------------------
8883    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng5
8884    use rrlw_kg05_k, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o,     &
8885                          selfrefo, forrefo,                                    &
8886                          fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
8887                          selfref, forref
8888 !
8889 ! Local
8890 !
8891       integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
8892       real(kind=rb)    :: sumk, sumf
8893 !-------------------------------------------------------------------------------
8894 !
8895    do jn = 1,9
8896      do jt = 1,5
8897        do jp = 1,13
8898          iprsm = 0
8899          do igc = 1,ngc(5)
8900            sumk = 0.
8901            do ipr = 1,ngn(ngs(4)+igc)
8902              iprsm = iprsm + 1
8903              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8904            enddo
8905            ka(jn,jt,jp,igc) = sumk
8906          enddo
8907        enddo
8908      enddo
8909    enddo
8910 !
8911    do jn = 1,5
8912      do jt = 1,5
8913        do jp = 13,59
8914          iprsm = 0
8915          do igc = 1,ngc(5)
8916            sumk = 0.
8917            do ipr = 1,ngn(ngs(4)+igc)
8918              iprsm = iprsm + 1
8919              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
8920            enddo
8921            kb(jn,jt,jp,igc) = sumk
8922          enddo
8923        enddo
8924      enddo
8925    enddo
8926 !
8927    do jn = 1,9
8928      do jt = 1,19
8929        iprsm = 0
8930        do igc = 1,ngc(5)
8931         sumk = 0.
8932          do ipr = 1,ngn(ngs(4)+igc)
8933            iprsm = iprsm + 1
8934            sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
8935          enddo
8936          ka_mo3(jn,jt,igc) = sumk
8937        enddo
8938      enddo
8939    enddo
8940 !
8941    do jt = 1,10
8942      iprsm = 0
8943      do igc = 1,ngc(5)
8944        sumk = 0.
8945        do ipr = 1,ngn(ngs(4)+igc)
8946          iprsm = iprsm + 1
8947          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
8948        enddo
8949        selfref(jt,igc) = sumk
8950      enddo
8951    enddo
8952 !
8953    do jt = 1,4
8954      iprsm = 0
8955      do igc = 1,ngc(5)
8956        sumk = 0.
8957        do ipr = 1,ngn(ngs(4)+igc)
8958          iprsm = iprsm + 1
8959          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
8960        enddo
8961        forref(jt,igc) = sumk
8962      enddo
8963    enddo
8964 !
8965    do jp = 1,9
8966      iprsm = 0
8967      do igc = 1,ngc(5)
8968        sumf = 0.
8969        do ipr = 1,ngn(ngs(4)+igc)
8970          iprsm = iprsm + 1
8971          sumf = sumf + fracrefao(iprsm,jp)
8972        enddo
8973        fracrefa(igc,jp) = sumf
8974      enddo
8975    enddo
8976 !
8977    do jp = 1,5
8978      iprsm = 0
8979      do igc = 1,ngc(5)
8980        sumf = 0.
8981        do ipr = 1,ngn(ngs(4)+igc)
8982          iprsm = iprsm + 1
8983          sumf = sumf + fracrefbo(iprsm,jp)
8984        enddo
8985        fracrefb(igc,jp) = sumf
8986      enddo
8987    enddo
8988 !
8989    iprsm = 0
8990    do igc = 1,ngc(5)
8991      sumk = 0.
8992      do ipr = 1,ngn(ngs(4)+igc)
8993        iprsm = iprsm + 1
8994        sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
8995      enddo
8996      ccl4(igc) = sumk
8997    enddo
8998 !
8999    end subroutine cmbgb5
9000 !-------------------------------------------------------------------------------
9001 !
9002 !
9003 !-------------------------------------------------------------------------------
9004    subroutine cmbgb6
9005 !-------------------------------------------------------------------------------
9006 !
9007 !  abstract :
9008 !  band 6:  820-980 cm-1 (low key - h2o; low minor - co2)
9009 !                        (high key - nothing; high minor - cfc11, cfc12)
9010 !
9011 !  old band 6:  820-980 cm-1 (low - h2o; high - nothing)
9012 !
9013 !-------------------------------------------------------------------------------
9014    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng6
9015    use rrlw_kg06_k, only : fracrefao, kao, kao_mco2, cfc11adjo, cfc12o,        &
9016                          selfrefo, forrefo,                                    &
9017                          fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12,         &
9018                          selfref, forref
9019 !
9020 ! Local
9021 !
9022    integer(kind=im) :: jt, jp, igc, ipr, iprsm
9023    real(kind=rb)    :: sumk, sumf, sumk1, sumk2
9024 !-------------------------------------------------------------------------------
9025 !
9026    do jt = 1,5
9027      do jp = 1,13
9028        iprsm = 0
9029        do igc = 1,ngc(6)
9030          sumk = 0.
9031          do ipr = 1,ngn(ngs(5)+igc)
9032            iprsm = iprsm + 1
9033            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
9034          enddo
9035          ka(jt,jp,igc) = sumk
9036        enddo
9037      enddo
9038    enddo
9039 !
9040    do jt = 1,19
9041      iprsm = 0
9042      do igc = 1,ngc(6)
9043        sumk = 0.
9044        do ipr = 1,ngn(ngs(5)+igc)
9045          iprsm = iprsm + 1
9046          sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
9047        enddo
9048        ka_mco2(jt,igc) = sumk
9049      enddo
9050    enddo
9051 !
9052    do jt = 1,10
9053      iprsm = 0
9054      do igc = 1,ngc(6)
9055        sumk = 0.
9056        do ipr = 1,ngn(ngs(5)+igc)
9057          iprsm = iprsm + 1
9058          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
9059        enddo
9060        selfref(jt,igc) = sumk
9061      enddo
9062    enddo
9063 !
9064    do jt = 1,4
9065      iprsm = 0
9066      do igc = 1,ngc(6)
9067        sumk = 0.
9068        do ipr = 1,ngn(ngs(5)+igc)
9069          iprsm = iprsm + 1
9070          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
9071        enddo
9072        forref(jt,igc) = sumk
9073      enddo
9074    enddo
9075 !
9076    iprsm = 0
9077    do igc = 1,ngc(6)
9078      sumf = 0.
9079      sumk1 = 0.
9080      sumk2 = 0.
9081      do ipr = 1,ngn(ngs(5)+igc)
9082        iprsm = iprsm + 1
9083        sumf = sumf + fracrefao(iprsm)
9084        sumk1 = sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
9085        sumk2 = sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
9086      enddo
9087      fracrefa(igc) = sumf
9088      cfc11adj(igc) = sumk1
9089      cfc12(igc) = sumk2
9090    enddo
9091 !
9092    end subroutine cmbgb6
9093 !-------------------------------------------------------------------------------
9094 !
9095 !
9096 !-------------------------------------------------------------------------------
9097    subroutine cmbgb7
9098 !-------------------------------------------------------------------------------
9099 !
9100 !  abstract :
9101 !  band 7:  980-1080 cm-1 (low key - h2o,o3; low minor - co2)
9102 !                         (high key - o3; high minor - co2)
9103 !
9104 !  old band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
9105 !
9106 !-------------------------------------------------------------------------------
9107    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng7
9108    use rrlw_kg07_k, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
9109                          selfrefo, forrefo,                                    &
9110                          fracrefa, fracrefb, absa, ka, absb,kb,ka_mco2,kb_mco2,&
9111                          selfref, forref
9112 !
9113 ! Local
9114 !
9115    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9116    real(kind=rb)    :: sumk, sumf
9117 !-------------------------------------------------------------------------------
9118 !
9119    do jn = 1,9
9120      do jt = 1,5
9121        do jp = 1,13
9122          iprsm = 0
9123          do igc = 1,ngc(7)
9124            sumk = 0.
9125            do ipr = 1,ngn(ngs(6)+igc)
9126              iprsm = iprsm + 1
9127              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
9128            enddo
9129            ka(jn,jt,jp,igc) = sumk
9130          enddo
9131        enddo
9132      enddo
9133    enddo
9134 !
9135    do jt = 1,5
9136      do jp = 13,59
9137        iprsm = 0
9138        do igc = 1,ngc(7)
9139          sumk = 0.
9140          do ipr = 1,ngn(ngs(6)+igc)
9141            iprsm = iprsm + 1
9142            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
9143          enddo
9144          kb(jt,jp,igc) = sumk
9145        enddo
9146      enddo
9147    enddo
9148 !
9149    do jn = 1,9
9150      do jt = 1,19
9151        iprsm = 0
9152        do igc = 1,ngc(7)
9153          sumk = 0.
9154          do ipr = 1,ngn(ngs(6)+igc)
9155            iprsm = iprsm + 1
9156            sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
9157          enddo
9158          ka_mco2(jn,jt,igc) = sumk
9159        enddo
9160      enddo
9161    enddo
9162 !
9163    do jt = 1,19
9164      iprsm = 0
9165      do igc = 1,ngc(7)
9166        sumk = 0.
9167        do ipr = 1,ngn(ngs(6)+igc)
9168          iprsm = iprsm + 1
9169          sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
9170        enddo
9171        kb_mco2(jt,igc) = sumk
9172      enddo
9173    enddo
9174 !
9175    do jt = 1,10
9176      iprsm = 0
9177      do igc = 1,ngc(7)
9178        sumk = 0.
9179        do ipr = 1,ngn(ngs(6)+igc)
9180          iprsm = iprsm + 1
9181          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
9182        enddo
9183        selfref(jt,igc) = sumk
9184      enddo
9185    enddo
9186 !
9187    do jt = 1,4
9188      iprsm = 0
9189      do igc = 1,ngc(7)
9190        sumk = 0.
9191        do ipr = 1,ngn(ngs(6)+igc)
9192          iprsm = iprsm + 1
9193          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
9194        enddo
9195        forref(jt,igc) = sumk
9196      enddo
9197    enddo
9198 !
9199    do jp = 1,9
9200      iprsm = 0
9201      do igc = 1,ngc(7)
9202        sumf = 0.
9203        do ipr = 1,ngn(ngs(6)+igc)
9204          iprsm = iprsm + 1
9205          sumf = sumf + fracrefao(iprsm,jp)
9206        enddo
9207        fracrefa(igc,jp) = sumf
9208      enddo
9209    enddo
9210 !
9211    iprsm = 0
9212    do igc = 1,ngc(7)
9213      sumf = 0.
9214      do ipr = 1,ngn(ngs(6)+igc)
9215        iprsm = iprsm + 1
9216        sumf = sumf + fracrefbo(iprsm)
9217      enddo
9218      fracrefb(igc) = sumf
9219    enddo
9220 !
9221    end subroutine cmbgb7
9222 !-------------------------------------------------------------------------------
9223 !
9224 !
9225 !-------------------------------------------------------------------------------
9226    subroutine cmbgb8
9227 !-------------------------------------------------------------------------------
9228 !
9229 !  abstract :
9230 !  band 8:  1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
9231 !                          (high key - o3; high minor - co2, n2o)
9232 !
9233 !  old band 8:  1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
9234 !
9235 !-------------------------------------------------------------------------------
9236    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng8
9237    use rrlw_kg08_k, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o,      &
9238                          kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo,  &
9239                          cfc12o, cfc22adjo,                                    &
9240                          fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o,       &
9241                          ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref,  &
9242                          cfc12, cfc22adj
9243 !
9244 ! Local
9245 !
9246    integer(kind=im) :: jt, jp, igc, ipr, iprsm
9247    real(kind=rb)    :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
9248 !-------------------------------------------------------------------------------
9249 !
9250    do jt = 1,5
9251      do jp = 1,13
9252        iprsm = 0
9253        do igc = 1,ngc(8)
9254          sumk = 0.
9255          do ipr = 1,ngn(ngs(7)+igc)
9256            iprsm = iprsm + 1
9257            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
9258          enddo
9259          ka(jt,jp,igc) = sumk
9260        enddo
9261      enddo
9262    enddo
9263 !
9264    do jt = 1,5
9265      do jp = 13,59
9266        iprsm = 0
9267        do igc = 1,ngc(8)
9268          sumk = 0.
9269          do ipr = 1,ngn(ngs(7)+igc)
9270            iprsm = iprsm + 1
9271            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
9272          enddo
9273          kb(jt,jp,igc) = sumk
9274        enddo
9275      enddo
9276    enddo
9277 !
9278    do jt = 1,10
9279      iprsm = 0
9280      do igc = 1,ngc(8)
9281        sumk = 0.
9282        do ipr = 1,ngn(ngs(7)+igc)
9283          iprsm = iprsm + 1
9284          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
9285        enddo
9286        selfref(jt,igc) = sumk
9287      enddo
9288    enddo
9289 !
9290    do jt = 1,4
9291      iprsm = 0
9292      do igc = 1,ngc(8)
9293        sumk = 0.
9294        do ipr = 1,ngn(ngs(7)+igc)
9295          iprsm = iprsm + 1
9296          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
9297        enddo
9298        forref(jt,igc) = sumk
9299      enddo
9300    enddo
9301 !
9302    do jt = 1,19
9303      iprsm = 0
9304      do igc = 1,ngc(8)
9305        sumk1 = 0.
9306        sumk2 = 0.
9307        sumk3 = 0.
9308        sumk4 = 0.
9309        sumk5 = 0.
9310        do ipr = 1,ngn(ngs(7)+igc)
9311          iprsm = iprsm + 1
9312          sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
9313          sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
9314          sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
9315          sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
9316          sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
9317        enddo
9318        ka_mco2(jt,igc) = sumk1
9319        kb_mco2(jt,igc) = sumk2
9320        ka_mo3(jt,igc) = sumk3
9321        ka_mn2o(jt,igc) = sumk4
9322        kb_mn2o(jt,igc) = sumk5
9323      enddo
9324    enddo
9325 !
9326    iprsm = 0
9327    do igc = 1,ngc(8)
9328      sumf1 = 0.
9329      sumf2 = 0.
9330      sumk1 = 0.
9331      sumk2 = 0.
9332      do ipr = 1,ngn(ngs(7)+igc)
9333        iprsm = iprsm + 1
9334        sumf1 = sumf1+ fracrefao(iprsm)
9335        sumf2 = sumf2+ fracrefbo(iprsm)
9336        sumk1 = sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
9337        sumk2 = sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
9338      enddo
9339      fracrefa(igc) = sumf1
9340      fracrefb(igc) = sumf2
9341      cfc12(igc) = sumk1
9342      cfc22adj(igc) = sumk2
9343    enddo
9344 !
9345    end subroutine cmbgb8
9346 !-------------------------------------------------------------------------------
9347 !
9348 !
9349 !-------------------------------------------------------------------------------
9350    subroutine cmbgb9
9351 !-------------------------------------------------------------------------------
9352 !
9353 !  abstract :
9354 !  band 9:  1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
9355 !                          (high key - ch4; high minor - n2o)!
9356 !
9357 !  old band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
9358 !
9359 !-------------------------------------------------------------------------------
9360    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng9
9361    use rrlw_kg09_k, only : fracrefao, fracrefbo, kao, kao_mn2o,                &
9362                          kbo, kbo_mn2o, selfrefo, forrefo,                     &
9363                          fracrefa, fracrefb, absa, ka, ka_mn2o,                &
9364                          absb, kb, kb_mn2o, selfref, forref
9365 !
9366 ! Local
9367 !
9368    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9369    real(kind=rb)    :: sumk, sumf
9370 !-------------------------------------------------------------------------------
9371 !
9372    do jn = 1,9
9373      do jt = 1,5
9374        do jp = 1,13
9375          iprsm = 0
9376          do igc = 1,ngc(9)
9377            sumk = 0.
9378            do ipr = 1,ngn(ngs(8)+igc)
9379              iprsm = iprsm + 1
9380              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
9381            enddo
9382            ka(jn,jt,jp,igc) = sumk
9383          enddo
9384        enddo
9385      enddo
9386    enddo
9387 !
9388    do jt = 1,5
9389      do jp = 13,59
9390        iprsm = 0
9391        do igc = 1,ngc(9)
9392          sumk = 0.
9393          do ipr = 1,ngn(ngs(8)+igc)
9394            iprsm = iprsm + 1
9395            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
9396          enddo
9397          kb(jt,jp,igc) = sumk
9398        enddo
9399      enddo
9400    enddo
9401 !
9402    do jn = 1,9
9403      do jt = 1,19
9404        iprsm = 0
9405        do igc = 1,ngc(9)
9406          sumk = 0.
9407          do ipr = 1,ngn(ngs(8)+igc)
9408            iprsm = iprsm + 1
9409            sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
9410          enddo
9411          ka_mn2o(jn,jt,igc) = sumk
9412        enddo
9413      enddo
9414    enddo
9415 !
9416    do jt = 1,19
9417      iprsm = 0
9418      do igc = 1,ngc(9)
9419        sumk = 0.
9420        do ipr = 1,ngn(ngs(8)+igc)
9421          iprsm = iprsm + 1
9422          sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
9423        enddo
9424        kb_mn2o(jt,igc) = sumk
9425      enddo
9426    enddo
9427 !
9428    do jt = 1,10
9429      iprsm = 0
9430      do igc = 1,ngc(9)
9431        sumk = 0.
9432        do ipr = 1,ngn(ngs(8)+igc)
9433          iprsm = iprsm + 1
9434          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
9435        enddo
9436        selfref(jt,igc) = sumk
9437      enddo
9438    enddo
9439 !
9440    do jt = 1,4
9441      iprsm = 0
9442      do igc = 1,ngc(9)
9443        sumk = 0.
9444        do ipr = 1,ngn(ngs(8)+igc)
9445          iprsm = iprsm + 1
9446          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
9447        enddo
9448        forref(jt,igc) = sumk
9449      enddo
9450    enddo
9451 !
9452    do jp = 1,9
9453      iprsm = 0
9454      do igc = 1,ngc(9)
9455        sumf = 0.
9456        do ipr = 1,ngn(ngs(8)+igc)
9457          iprsm = iprsm + 1
9458          sumf = sumf + fracrefao(iprsm,jp)
9459        enddo
9460        fracrefa(igc,jp) = sumf
9461      enddo
9462    enddo
9463 !
9464    iprsm = 0
9465    do igc = 1,ngc(9)
9466      sumf = 0.
9467      do ipr = 1,ngn(ngs(8)+igc)
9468        iprsm = iprsm + 1
9469        sumf = sumf + fracrefbo(iprsm)
9470      enddo
9471      fracrefb(igc) = sumf
9472    enddo
9473 !
9474    end subroutine cmbgb9
9475 !-------------------------------------------------------------------------------
9476 !
9477 !
9478 !-------------------------------------------------------------------------------
9479    subroutine cmbgb10
9480 !-------------------------------------------------------------------------------
9481 !
9482 !  abstract :
9483 !  band 10:  1390-1480 cm-1 (low key - h2o; high key - h2o)
9484 !
9485 !  old band 10:  1390-1480 cm-1 (low - h2o; high - h2o)
9486 !
9487 !-------------------------------------------------------------------------------
9488    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng10
9489    use rrlw_kg10_k, only : fracrefao, fracrefbo, kao, kbo,                     &
9490                          selfrefo, forrefo,                                    &
9491                          fracrefa, fracrefb, absa, ka, absb, kb,               &
9492                          selfref, forref
9493 !
9494 ! Local
9495 !
9496    integer(kind=im) :: jt, jp, igc, ipr, iprsm
9497    real(kind=rb)    :: sumk, sumf1, sumf2
9498 !-------------------------------------------------------------------------------
9499 !
9500    do jt = 1,5
9501      do jp = 1,13
9502        iprsm = 0
9503        do igc = 1,ngc(10)
9504          sumk = 0.
9505          do ipr = 1,ngn(ngs(9)+igc)
9506            iprsm = iprsm + 1
9507            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
9508          enddo
9509          ka(jt,jp,igc) = sumk
9510        enddo
9511      enddo
9512    enddo
9513 !
9514    do jt = 1,5
9515      do jp = 13,59
9516        iprsm = 0
9517        do igc = 1,ngc(10)
9518          sumk = 0.
9519          do ipr = 1,ngn(ngs(9)+igc)
9520            iprsm = iprsm + 1
9521            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
9522          enddo
9523          kb(jt,jp,igc) = sumk
9524        enddo
9525      enddo
9526    enddo
9527 !
9528    do jt = 1,10
9529      iprsm = 0
9530      do igc = 1,ngc(10)
9531        sumk = 0.
9532        do ipr = 1,ngn(ngs(9)+igc)
9533          iprsm = iprsm + 1
9534          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
9535        enddo
9536        selfref(jt,igc) = sumk
9537      enddo
9538    enddo
9539 !
9540    do jt = 1,4
9541      iprsm = 0
9542      do igc = 1,ngc(10)
9543        sumk = 0.
9544        do ipr = 1,ngn(ngs(9)+igc)
9545          iprsm = iprsm + 1
9546          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
9547        enddo
9548        forref(jt,igc) = sumk
9549      enddo
9550    enddo
9551 !
9552    iprsm = 0
9553    do igc = 1,ngc(10)
9554      sumf1 = 0.
9555      sumf2 = 0.
9556      do ipr = 1,ngn(ngs(9)+igc)
9557        iprsm = iprsm + 1
9558        sumf1 = sumf1+ fracrefao(iprsm)
9559        sumf2 = sumf2+ fracrefbo(iprsm)
9560      enddo
9561      fracrefa(igc) = sumf1
9562      fracrefb(igc) = sumf2
9563    enddo
9564 !
9565    end subroutine cmbgb10
9566 !-------------------------------------------------------------------------------
9567 !
9568 !
9569 !-------------------------------------------------------------------------------
9570    subroutine cmbgb11
9571 !-------------------------------------------------------------------------------
9572 !
9573 !  abstract :
9574 !  band 11:  1480-1800 cm-1 (low - h2o; low minor - o2)
9575 !                           (high key - h2o; high minor - o2)
9576 !
9577 !  old band 11:  1480-1800 cm-1 (low - h2o; low minor - o2)
9578 !                               (high key - h2o; high minor - o2)
9579 !
9580 !-------------------------------------------------------------------------------
9581    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng11
9582    use rrlw_kg11_k, only : fracrefao, fracrefbo, kao, kao_mo2,                 &
9583                          kbo, kbo_mo2, selfrefo, forrefo,                      &
9584                          fracrefa, fracrefb, absa, ka, ka_mo2,                 &
9585                          absb, kb, kb_mo2, selfref, forref
9586 !
9587 ! Local
9588 !
9589    integer(kind=im) :: jt, jp, igc, ipr, iprsm
9590    real(kind=rb)    :: sumk, sumk1, sumk2, sumf1, sumf2
9591 !-------------------------------------------------------------------------------
9592 !
9593    do jt = 1,5
9594      do jp = 1,13
9595        iprsm = 0
9596        do igc = 1,ngc(11)
9597          sumk = 0.
9598          do ipr = 1,ngn(ngs(10)+igc)
9599            iprsm = iprsm + 1
9600            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
9601          enddo
9602          ka(jt,jp,igc) = sumk
9603        enddo
9604      enddo
9605    enddo
9606 !
9607    do jt = 1,5
9608      do jp = 13,59
9609        iprsm = 0
9610        do igc = 1,ngc(11)
9611          sumk = 0.
9612          do ipr = 1,ngn(ngs(10)+igc)
9613            iprsm = iprsm + 1
9614            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
9615          enddo
9616          kb(jt,jp,igc) = sumk
9617        enddo
9618      enddo
9619    enddo
9620 !
9621    do jt = 1,19
9622      iprsm = 0
9623      do igc = 1,ngc(11)
9624        sumk1 = 0.
9625        sumk2 = 0.
9626        do ipr = 1,ngn(ngs(10)+igc)
9627          iprsm = iprsm + 1
9628          sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
9629          sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
9630        enddo
9631        ka_mo2(jt,igc) = sumk1
9632        kb_mo2(jt,igc) = sumk2
9633      enddo
9634    enddo
9635 !
9636    do jt = 1,10
9637      iprsm = 0
9638      do igc = 1,ngc(11)
9639        sumk = 0.
9640        do ipr = 1,ngn(ngs(10)+igc)
9641          iprsm = iprsm + 1
9642          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
9643        enddo
9644        selfref(jt,igc) = sumk
9645      enddo
9646    enddo
9647 !
9648    do jt = 1,4
9649      iprsm = 0
9650      do igc = 1,ngc(11)
9651        sumk = 0.
9652        do ipr = 1,ngn(ngs(10)+igc)
9653          iprsm = iprsm + 1
9654          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
9655        enddo
9656        forref(jt,igc) = sumk
9657      enddo
9658    enddo
9659 !
9660    iprsm = 0
9661    do igc = 1,ngc(11)
9662      sumf1 = 0.
9663      sumf2 = 0.
9664      do ipr = 1,ngn(ngs(10)+igc)
9665        iprsm = iprsm + 1
9666        sumf1 = sumf1+ fracrefao(iprsm)
9667        sumf2 = sumf2+ fracrefbo(iprsm)
9668      enddo
9669      fracrefa(igc) = sumf1
9670      fracrefb(igc) = sumf2
9671    enddo
9672 !
9673    end subroutine cmbgb11
9674 !-------------------------------------------------------------------------------
9675 !
9676 !
9677 !-------------------------------------------------------------------------------
9678    subroutine cmbgb12
9679 !-------------------------------------------------------------------------------
9680 !
9681 !  abstract :
9682 !  band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
9683 !
9684 !  old band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
9685 !
9686 !-------------------------------------------------------------------------------
9687    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng12
9688    use rrlw_kg12_k, only : fracrefao, kao, selfrefo, forrefo,                  &
9689                          fracrefa, absa, ka, selfref, forref
9690 !
9691 ! Local
9692 !
9693    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9694    real(kind=rb)    :: sumk, sumf
9695 !-------------------------------------------------------------------------------
9696 !
9697    do jn = 1,9
9698      do jt = 1,5
9699        do jp = 1,13
9700          iprsm = 0
9701          do igc = 1,ngc(12)
9702            sumk = 0.
9703            do ipr = 1,ngn(ngs(11)+igc)
9704              iprsm = iprsm + 1
9705              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
9706            enddo
9707            ka(jn,jt,jp,igc) = sumk
9708          enddo
9709        enddo
9710      enddo
9711    enddo
9712 !
9713    do jt = 1,10
9714      iprsm = 0
9715      do igc = 1,ngc(12)
9716        sumk = 0.
9717        do ipr = 1,ngn(ngs(11)+igc)
9718          iprsm = iprsm + 1
9719          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
9720        enddo
9721        selfref(jt,igc) = sumk
9722      enddo
9723    enddo
9724 !
9725    do jt = 1,4
9726      iprsm = 0
9727      do igc = 1,ngc(12)
9728        sumk = 0.
9729        do ipr = 1,ngn(ngs(11)+igc)
9730          iprsm = iprsm + 1
9731          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
9732        enddo
9733        forref(jt,igc) = sumk
9734      enddo
9735    enddo
9736 !
9737    do jp = 1,9
9738      iprsm = 0
9739      do igc = 1,ngc(12)
9740        sumf = 0.
9741        do ipr = 1,ngn(ngs(11)+igc)
9742          iprsm = iprsm + 1
9743          sumf = sumf + fracrefao(iprsm,jp)
9744        enddo
9745        fracrefa(igc,jp) = sumf
9746      enddo
9747    enddo
9748 !
9749    end subroutine cmbgb12
9750 !-------------------------------------------------------------------------------
9751 !
9752 !
9753 !-------------------------------------------------------------------------------
9754    subroutine cmbgb13
9755 !-------------------------------------------------------------------------------
9756 !
9757 !  abstract :
9758 !  band 13:  2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
9759 !
9760 !  old band 13:  2080-2250 cm-1 (low - h2o,n2o; high - nothing)
9761 !
9762 !-------------------------------------------------------------------------------
9763    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng13
9764    use rrlw_kg13_k, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco,       &
9765                          kbo_mo3, selfrefo, forrefo,                           &
9766                          fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco,        &
9767                          kb_mo3, selfref, forref
9768 !
9769 ! Local
9770 !
9771    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9772    real(kind=rb)    :: sumk, sumk1, sumk2, sumf
9773 !-------------------------------------------------------------------------------
9774 !
9775    do jn = 1,9
9776      do jt = 1,5
9777        do jp = 1,13
9778          iprsm = 0
9779          do igc = 1,ngc(13)
9780            sumk = 0.
9781            do ipr = 1,ngn(ngs(12)+igc)
9782              iprsm = iprsm + 1
9783              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
9784            enddo
9785            ka(jn,jt,jp,igc) = sumk
9786          enddo
9787        enddo
9788      enddo
9789    enddo
9790 !
9791    do jn = 1,9
9792      do jt = 1,19
9793        iprsm = 0
9794        do igc = 1,ngc(13)
9795          sumk1 = 0.
9796          sumk2 = 0.
9797          do ipr = 1,ngn(ngs(12)+igc)
9798            iprsm = iprsm + 1
9799            sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
9800            sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
9801          enddo
9802          ka_mco2(jn,jt,igc) = sumk1
9803          ka_mco(jn,jt,igc) = sumk2
9804        enddo
9805      enddo
9806    enddo
9807 !
9808    do jt = 1,19
9809      iprsm = 0
9810      do igc = 1,ngc(13)
9811        sumk = 0.
9812        do ipr = 1,ngn(ngs(12)+igc)
9813          iprsm = iprsm + 1
9814          sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
9815        enddo
9816        kb_mo3(jt,igc) = sumk
9817      enddo
9818    enddo
9819 !
9820    do jt = 1,10
9821      iprsm = 0
9822      do igc = 1,ngc(13)
9823        sumk = 0.
9824        do ipr = 1,ngn(ngs(12)+igc)
9825          iprsm = iprsm + 1
9826          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
9827        enddo
9828        selfref(jt,igc) = sumk
9829      enddo
9830    enddo
9831 !
9832    do jt = 1,4
9833      iprsm = 0
9834      do igc = 1,ngc(13)
9835        sumk = 0.
9836        do ipr = 1,ngn(ngs(12)+igc)
9837          iprsm = iprsm + 1
9838          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
9839        enddo
9840        forref(jt,igc) = sumk
9841      enddo
9842    enddo
9843 !
9844    iprsm = 0
9845    do igc = 1,ngc(13)
9846      sumf = 0.
9847      do ipr = 1,ngn(ngs(12)+igc)
9848        iprsm = iprsm + 1
9849        sumf = sumf + fracrefbo(iprsm)
9850      enddo
9851      fracrefb(igc) = sumf
9852    enddo
9853 !
9854    do jp = 1,9
9855      iprsm = 0
9856      do igc = 1,ngc(13)
9857        sumf = 0.
9858        do ipr = 1,ngn(ngs(12)+igc)
9859          iprsm = iprsm + 1
9860          sumf = sumf + fracrefao(iprsm,jp)
9861        enddo
9862        fracrefa(igc,jp) = sumf
9863      enddo
9864    enddo
9865 !
9866    end subroutine cmbgb13
9867 !-------------------------------------------------------------------------------
9868 !
9869 !
9870 !-------------------------------------------------------------------------------
9871    subroutine cmbgb14
9872 !-------------------------------------------------------------------------------
9873 !
9874 !  abstract :
9875 !  band 14:  2250-2380 cm-1 (low - co2; high - co2)
9876 !
9877 !  old band 14:  2250-2380 cm-1 (low - co2; high - co2)
9878 !
9879 !-------------------------------------------------------------------------------
9880    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng14
9881    use rrlw_kg14_k, only : fracrefao, fracrefbo, kao, kbo,                     &
9882                          selfrefo, forrefo,                                    &
9883                          fracrefa, fracrefb, absa, ka, absb, kb,               &
9884                          selfref, forref
9885 !
9886 ! Local
9887 !
9888    integer(kind=im) :: jt, jp, igc, ipr, iprsm
9889    real(kind=rb)    :: sumk, sumf1, sumf2
9890 !-------------------------------------------------------------------------------
9891 !
9892    do jt = 1,5
9893      do jp = 1,13
9894        iprsm = 0
9895        do igc = 1,ngc(14)
9896          sumk = 0.
9897          do ipr = 1,ngn(ngs(13)+igc)
9898            iprsm = iprsm + 1
9899            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
9900          enddo
9901          ka(jt,jp,igc) = sumk
9902        enddo
9903      enddo
9904    enddo
9905 !
9906    do jt = 1,5
9907      do jp = 13,59
9908        iprsm = 0
9909        do igc = 1,ngc(14)
9910          sumk = 0.
9911          do ipr = 1,ngn(ngs(13)+igc)
9912            iprsm = iprsm + 1
9913            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
9914          enddo
9915          kb(jt,jp,igc) = sumk
9916        enddo
9917      enddo
9918    enddo
9919 !
9920    do jt = 1,10
9921      iprsm = 0
9922      do igc = 1,ngc(14)
9923        sumk = 0.
9924        do ipr = 1,ngn(ngs(13)+igc)
9925          iprsm = iprsm + 1
9926          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
9927        enddo
9928        selfref(jt,igc) = sumk
9929      enddo
9930    enddo
9931 !
9932    do jt = 1,4
9933      iprsm = 0
9934      do igc = 1,ngc(14)
9935        sumk = 0.
9936        do ipr = 1,ngn(ngs(13)+igc)
9937          iprsm = iprsm + 1
9938          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
9939        enddo
9940        forref(jt,igc) = sumk
9941      enddo
9942    enddo
9943 !
9944    iprsm = 0
9945    do igc = 1,ngc(14)
9946      sumf1 = 0.
9947      sumf2 = 0.
9948      do ipr = 1,ngn(ngs(13)+igc)
9949        iprsm = iprsm + 1
9950        sumf1 = sumf1+ fracrefao(iprsm)
9951        sumf2 = sumf2+ fracrefbo(iprsm)
9952      enddo
9953      fracrefa(igc) = sumf1
9954      fracrefb(igc) = sumf2
9955    enddo
9956 !
9957    end subroutine cmbgb14
9958 !-------------------------------------------------------------------------------
9959 !
9960 !
9961 !-------------------------------------------------------------------------------
9962    subroutine cmbgb15
9963 !-------------------------------------------------------------------------------
9964 !
9965 !  abstract :
9966 !  band 15:  2380-2600 cm-1 (low - n2o,co2; low minor - n2)
9967 !                           (high - nothing)
9968 !
9969 !  old band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
9970 !
9971 !-------------------------------------------------------------------------------
9972    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng15
9973    use rrlw_kg15_k, only : fracrefao, kao, kao_mn2, selfrefo, forrefo,         &
9974                          fracrefa, absa, ka, ka_mn2, selfref, forref
9975 !
9976 ! Local
9977 !
9978    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
9979    real(kind=rb)    :: sumk, sumf
9980 !-------------------------------------------------------------------------------
9981 !
9982    do jn = 1,9
9983      do jt = 1,5
9984        do jp = 1,13
9985          iprsm = 0
9986          do igc = 1,ngc(15)
9987            sumk = 0.
9988            do ipr = 1,ngn(ngs(14)+igc)
9989              iprsm = iprsm + 1
9990              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
9991            enddo
9992            ka(jn,jt,jp,igc) = sumk
9993          enddo
9994        enddo
9995      enddo
9996    enddo
9997 !
9998    do jn = 1,9
9999      do jt = 1,19
10000        iprsm = 0
10001        do igc = 1,ngc(15)
10002          sumk = 0.
10003          do ipr = 1,ngn(ngs(14)+igc)
10004            iprsm = iprsm + 1
10005            sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
10006          enddo
10007          ka_mn2(jn,jt,igc) = sumk
10008        enddo
10009      enddo
10010    enddo
10011 !
10012    do jt = 1,10
10013      iprsm = 0
10014      do igc = 1,ngc(15)
10015        sumk = 0.
10016        do ipr = 1,ngn(ngs(14)+igc)
10017          iprsm = iprsm + 1
10018          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
10019        enddo
10020        selfref(jt,igc) = sumk
10021      enddo
10022    enddo
10023 !
10024    do jt = 1,4
10025      iprsm = 0
10026      do igc = 1,ngc(15)
10027        sumk = 0.
10028        do ipr = 1,ngn(ngs(14)+igc)
10029          iprsm = iprsm + 1
10030          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
10031        enddo
10032        forref(jt,igc) = sumk
10033      enddo
10034    enddo
10035 !
10036    do jp = 1,9
10037      iprsm = 0
10038      do igc = 1,ngc(15)
10039        sumf = 0.
10040        do ipr = 1,ngn(ngs(14)+igc)
10041          iprsm = iprsm + 1
10042          sumf = sumf + fracrefao(iprsm,jp)
10043        enddo
10044        fracrefa(igc,jp) = sumf
10045      enddo
10046    enddo
10047 !
10048    end subroutine cmbgb15
10049 !-------------------------------------------------------------------------------
10050 !
10051 !
10052 !-------------------------------------------------------------------------------
10053    subroutine cmbgb16
10054 !-------------------------------------------------------------------------------
10055 !
10056 !  abstract :
10057 !  band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
10058 !
10059 !  old band 16:  2600-3000 cm-1 (low - h2o,ch4; high - nothing)
10060 !
10061 !-------------------------------------------------------------------------------
10062    use parrrtm_k,   only : mg, nbndlw, ngptlw, ng16
10063    use rrlw_kg16_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo,  &
10064                         fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
10065 !
10066 ! Local
10067 !
10068    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
10069    real(kind=rb)    :: sumk, sumf
10070 !-------------------------------------------------------------------------------
10071 !
10072    do jn = 1,9
10073      do jt = 1,5
10074        do jp = 1,13
10075          iprsm = 0
10076          do igc = 1,ngc(16)
10077            sumk = 0.
10078            do ipr = 1,ngn(ngs(15)+igc)
10079              iprsm = iprsm + 1
10080              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
10081            enddo
10082            ka(jn,jt,jp,igc) = sumk
10083          enddo
10084        enddo
10085      enddo
10086    enddo
10087 !
10088    do jt = 1,5
10089      do jp = 13,59
10090        iprsm = 0
10091        do igc = 1,ngc(16)
10092          sumk = 0.
10093          do ipr = 1,ngn(ngs(15)+igc)
10094            iprsm = iprsm + 1
10095            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
10096          enddo
10097          kb(jt,jp,igc) = sumk
10098        enddo
10099      enddo
10100    enddo
10101 !
10102    do jt = 1,10
10103      iprsm = 0
10104      do igc = 1,ngc(16)
10105        sumk = 0.
10106        do ipr = 1,ngn(ngs(15)+igc)
10107          iprsm = iprsm + 1
10108          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
10109        enddo
10110        selfref(jt,igc) = sumk
10111      enddo
10112    enddo
10113 !
10114    do jt = 1,4
10115      iprsm = 0
10116      do igc = 1,ngc(16)
10117        sumk = 0.
10118        do ipr = 1,ngn(ngs(15)+igc)
10119          iprsm = iprsm + 1
10120          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
10121        enddo
10122        forref(jt,igc) = sumk
10123      enddo
10124    enddo
10125 !
10126    iprsm = 0
10127    do igc = 1,ngc(16)
10128      sumf = 0.
10129      do ipr = 1,ngn(ngs(15)+igc)
10130        iprsm = iprsm + 1
10131        sumf = sumf + fracrefbo(iprsm)
10132      enddo
10133      fracrefb(igc) = sumf
10134    enddo
10135 !
10136    do jp = 1,9
10137      iprsm = 0
10138      do igc = 1,ngc(16)
10139        sumf = 0.
10140        do ipr = 1,ngn(ngs(15)+igc)
10141          iprsm = iprsm + 1
10142          sumf = sumf + fracrefao(iprsm,jp)
10143        enddo
10144        fracrefa(igc,jp) = sumf
10145      enddo
10146    enddo
10147 !
10148    end subroutine cmbgb16
10149 !-------------------------------------------------------------------------------
10150 !
10151 !
10152 !-------------------------------------------------------------------------------
10153    subroutine lwcldpr
10154 !-------------------------------------------------------------------------------
10155    use rrlw_cld_k, only : abscld1, absliq0, absliq1,                           &
10156                         absice0, absice1, absice2, absice3
10157 !
10158    save
10159 !
10160 ! abscldn is the liquid water absorption coefficient (m2/g).
10161 ! For inflag = 1.
10162 !
10163    abscld1 = 0.0602410_rb
10164 !
10165 ! Everything below is for inflag = 2.
10166 !
10167 ! absicen(j,ib) are the parameters needed to compute the liquid water
10168 ! absorption coefficient in spectral region ib for iceflag=n.  The units
10169 ! of absicen(1,ib) are m2/g and absicen(2,ib) has units (microns (m2/g)).
10170 ! For iceflag = 0.
10171 !
10172    absice0(:)= (/0.005_rb,  1.0_rb/)
10173 !
10174 ! For iceflag = 1.
10175 !
10176    absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/)
10177    absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /)
10178 !
10179 ! For iceflag = 2.  In each band, the absorption
10180 ! coefficients are listed for a range of effective radii from 5.0
10181 ! to 131.0 microns in increments of 3.0 microns.
10182 ! Spherical Ice Particle Parameterization
10183 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10184 !
10185 ! band 1
10186 !
10187    absice2(:,1) = (/                                                           &
10188    7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,            &
10189    4.272663e-02_rb,3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,            &
10190    3.057511e-02_rb,2.855800e-02_rb,2.678022e-02_rb,2.519712e-02_rb,            &
10191    2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb,2.024194e-02_rb,            &
10192    1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb,            &
10193    1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,            &
10194    1.342462e-02_rb,1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,            &
10195    1.139297e-02_rb,1.094524e-02_rb,1.051794e-02_rb,1.010956e-02_rb,            &
10196    9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb,8.640223e-03_rb,            &
10197    8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb,            &
10198    7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/)
10199 !
10200 ! band 2
10201 !
10202    absice2(:,2) = (/                                                           &
10203    2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,            &
10204    2.443225e-02_rb,2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,            &
10205    2.139548e-02_rb,2.071840e-02_rb,2.006702e-02_rb,1.943856e-02_rb,            &
10206    1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb,1.711099e-02_rb,            &
10207    1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb,            &
10208    1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,            &
10209    1.260355e-02_rb,1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,            &
10210    1.081072e-02_rb,1.037731e-02_rb,9.949167e-03_rb,9.526021e-03_rb,            &
10211    9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb,7.878558e-03_rb,            &
10212    7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb,            &
10213    5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/)
10214 !
10215 ! band 3
10216 !
10217    absice2(:,3) = (/                                                           &
10218    1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,            &
10219    4.898681e-02_rb,4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,            &
10220    3.308299e-02_rb,3.057561e-02_rb,2.839325e-02_rb,2.647040e-02_rb,            &
10221    2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb,2.056430e-02_rb,            &
10222    1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb,            &
10223    1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,            &
10224    1.265364e-02_rb,1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,            &
10225    1.032445e-02_rb,9.811791e-03_rb,9.322587e-03_rb,8.855053e-03_rb,            &
10226    8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb,7.171949e-03_rb,            &
10227    6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb,            &
10228    5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/)
10229 !
10230 ! band 4
10231 !
10232    absice2(:,4) = (/                                                           &
10233    1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,            &
10234    5.738174e-02_rb,4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,            &
10235    3.391734e-02_rb,3.068690e-02_rb,2.798301e-02_rb,2.568480e-02_rb,            &
10236    2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb,1.912777e-02_rb,            &
10237    1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb,            &
10238    1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,            &
10239    1.156669e-02_rb,1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,            &
10240    9.614854e-03_rb,9.202335e-03_rb,8.814470e-03_rb,8.449077e-03_rb,            &
10241    8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb,7.176671e-03_rb,            &
10242    6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb,            &
10243    5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/)
10244 !
10245 ! band 5
10246 !
10247    absice2(:,5) = (/                                                           &
10248    2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,            &
10249    5.941273e-02_rb,4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,            &
10250    3.337910e-02_rb,2.994978e-02_rb,2.711556e-02_rb,2.473461e-02_rb,            &
10251    2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb,1.810267e-02_rb,            &
10252    1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb,            &
10253    1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,            &
10254    1.082583e-02_rb,1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,            &
10255    9.031157e-03_rb,8.657217e-03_rb,8.307449e-03_rb,7.979609e-03_rb,            &
10256    7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb,6.851298e-03_rb,            &
10257    6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb,            &
10258    5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/)
10259 !
10260 ! band 6
10261 !
10262    absice2(:,6) = (/                                                           &
10263    1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,            &
10264    5.399997e-02_rb,4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,            &
10265    3.300218e-02_rb,3.000586e-02_rb,2.747148e-02_rb,2.529633e-02_rb,            &
10266    2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb,1.896487e-02_rb,            &
10267    1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb,            &
10268    1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,            &
10269    1.135657e-02_rb,1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,            &
10270    9.318505e-03_rb,8.882815e-03_rb,8.471458e-03_rb,8.082364e-03_rb,            &
10271    7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb,6.714725e-03_rb,            &
10272    6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb,            &
10273    5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/)
10274 !
10275 ! band 7
10276 !
10277    absice2(:,7) = (/                                                           &
10278    7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,            &
10279    4.225986e-02_rb,3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,            &
10280    3.045798e-02_rb,2.845343e-02_rb,2.667231e-02_rb,2.507353e-02_rb,            &
10281    2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb,1.997617e-02_rb,            &
10282    1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb,            &
10283    1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,            &
10284    1.264164e-02_rb,1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,            &
10285    1.035218e-02_rb,9.839297e-03_rb,9.346733e-03_rb,8.873057e-03_rb,            &
10286    8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb,7.143210e-03_rb,            &
10287    6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb,            &
10288    5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/)
10289 !
10290 ! band 8
10291 !
10292    absice2(:,8) = (/                                                           &
10293    9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,            &
10294    4.305946e-02_rb,3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,            &
10295    2.929794e-02_rb,2.712627e-02_rb,2.523856e-02_rb,2.357810e-02_rb,            &
10296    2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb,1.850310e-02_rb,            &
10297    1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb,            &
10298    1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,            &
10299    1.180456e-02_rb,1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,            &
10300    9.864433e-03_rb,9.439878e-03_rb,9.035637e-03_rb,8.650140e-03_rb,            &
10301    8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb,7.269505e-03_rb,            &
10302    6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb,            &
10303    5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/)
10304 !
10305 ! band 9
10306 !
10307    absice2(:,9) = (/                                                           &
10308    1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,            &
10309    4.635049e-02_rb,4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,            &
10310    2.888498e-02_rb,2.640843e-02_rb,2.431904e-02_rb,2.253038e-02_rb,            &
10311    2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb,1.735426e-02_rb,            &
10312    1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb,            &
10313    1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,            &
10314    1.121797e-02_rb,1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,            &
10315    9.595509e-03_rb,9.250088e-03_rb,8.924447e-03_rb,8.616876e-03_rb,            &
10316    8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb,7.539388e-03_rb,            &
10317    7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb,            &
10318    6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/)
10319 !
10320 ! band 10
10321 !
10322    absice2(:,10) = (/                                                          &
10323    1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,            &
10324    4.887582e-02_rb,4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,            &
10325    2.898717e-02_rb,2.631256e-02_rb,2.408925e-02_rb,2.221156e-02_rb,            &
10326    2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb,1.692456e-02_rb,            &
10327    1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb,            &
10328    1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,            &
10329    1.099230e-02_rb,1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,            &
10330    9.498395e-03_rb,9.185047e-03_rb,8.891237e-03_rb,8.615185e-03_rb,            &
10331    8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb,7.659759e-03_rb,            &
10332    7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb,            &
10333    6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/)
10334 !
10335 ! band 11
10336 !
10337    absice2(:,11) = (/                                                          &
10338    1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,            &
10339    4.828355e-02_rb,4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,            &
10340    2.824593e-02_rb,2.560156e-02_rb,2.341503e-02_rb,2.157740e-02_rb,            &
10341    2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb,1.645421e-02_rb,            &
10342    1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb,            &
10343    1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,            &
10344    1.082096e-02_rb,1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,            &
10345    9.428223e-03_rb,9.137756e-03_rb,8.865964e-03_rb,8.611115e-03_rb,            &
10346    8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb,7.733187e-03_rb,            &
10347    7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb,            &
10348    6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/)
10349 !
10350 ! band 12
10351 !
10352    absice2(:,12) = (/                                                          &
10353    9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,            &
10354    3.418456e-02_rb,2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,            &
10355    2.153915e-02_rb,1.980791e-02_rb,1.836689e-02_rb,1.714979e-02_rb,            &
10356    1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb,1.373468e-02_rb,            &
10357    1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb,            &
10358    1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,            &
10359    9.976896e-03_rb,9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,            &
10360    9.058902e-03_rb,8.868710e-03_rb,8.691240e-03_rb,8.525312e-03_rb,            &
10361    8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb,7.957917e-03_rb,            &
10362    7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb,            &
10363    7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/)
10364 !
10365 ! band 13
10366 !
10367    absice2(:,13) = (/                                                          &
10368    1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,            &
10369    4.096790e-02_rb,3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,            &
10370    2.412102e-02_rb,2.195132e-02_rb,2.017124e-02_rb,1.868641e-02_rb,            &
10371    1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb,1.461388e-02_rb,            &
10372    1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb,            &
10373    1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,            &
10374    1.030126e-02_rb,1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,            &
10375    9.276155e-03_rb,9.065205e-03_rb,8.868808e-03_rb,8.685571e-03_rb,            &
10376    8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb,8.061776e-03_rb,            &
10377    7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb,            &
10378    7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/)
10379 !
10380 ! band 14
10381 !
10382    absice2(:,14) = (/                                                          &
10383    1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,            &
10384    3.888637e-02_rb,3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,            &
10385    2.330224e-02_rb,2.126754e-02_rb,1.959258e-02_rb,1.819130e-02_rb,            &
10386    1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb,1.432666e-02_rb,            &
10387    1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb,            &
10388    1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,            &
10389    1.019440e-02_rb,9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,            &
10390    9.205005e-03_rb,9.001022e-03_rb,8.810992e-03_rb,8.633588e-03_rb,            &
10391    8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb,8.028878e-03_rb,            &
10392    7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb,            &
10393    7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/)
10394 !
10395 ! band 15
10396 !
10397    absice2(:,15) = (/                                                          &
10398    8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,            &
10399    3.119623e-02_rb,2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,            &
10400    1.986526e-02_rb,1.830306e-02_rb,1.699991e-02_rb,1.589698e-02_rb,            &
10401    1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb,1.278883e-02_rb,            &
10402    1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb,            &
10403    1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,            &
10404    9.337044e-03_rb,9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,            &
10405    8.486341e-03_rb,8.309594e-03_rb,8.144500e-03_rb,7.989986e-03_rb,            &
10406    7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb,7.460376e-03_rb,            &
10407    7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb,            &
10408    6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/)
10409 !
10410 ! band 16
10411 !
10412    absice2(:,16) = (/                                                          &
10413    1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,            &
10414    4.063891e-02_rb,3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,            &
10415    2.390631e-02_rb,2.169972e-02_rb,1.987596e-02_rb,1.834393e-02_rb,            &
10416    1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb,1.407780e-02_rb,            &
10417    1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb,            &
10418    1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,            &
10419    9.402477e-03_rb,9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,            &
10420    8.251146e-03_rb,8.011373e-03_rb,7.787140e-03_rb,7.577002e-03_rb,            &
10421    7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb,6.854061e-03_rb,            &
10422    6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb,            &
10423    6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/)
10424 !
10425 ! iceflag = 3; Fu parameterization. Particle size 5 - 140 micron in
10426 ! increments of 3 microns.
10427 ! units = m2/g
10428 ! Hexagonal Ice Particle Parameterization
10429 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
10430 !
10431 ! band 1
10432 !
10433    absice3(:,1) = (/                                                           &
10434    3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,            &
10435    6.012598e-02_rb,5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,            &
10436    4.040585e-02_rb,3.697334e-02_rb,3.403027e-02_rb,3.149979e-02_rb,            &
10437    2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb,2.433888e-02_rb,            &
10438    2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb,            &
10439    1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,            &
10440    1.693346e-02_rb,1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,            &
10441    1.524933e-02_rb,1.489399e-02_rb,1.455580e-02_rb,1.423098e-02_rb,            &
10442    1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb,1.300156e-02_rb,            &
10443    1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb,            &
10444    1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,            &
10445    9.998198e-03_rb,9.602126e-03_rb/)
10446 !
10447 ! band 2
10448 !
10449    absice3(:,2) = (/                                                           &
10450    3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,            &
10451    2.700722e-02_rb,2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,            &
10452    2.209096e-02_rb,2.104882e-02_rb,2.010547e-02_rb,1.925003e-02_rb,            &
10453    1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb,1.649769e-02_rb,            &
10454    1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb,            &
10455    1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,            &
10456    1.243346e-02_rb,1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,            &
10457    1.107487e-02_rb,1.075861e-02_rb,1.044975e-02_rb,1.014753e-02_rb,            &
10458    9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb,8.992020e-03_rb,            &
10459    8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb,            &
10460    7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,            &
10461    6.584504e-03_rb,6.326424e-03_rb/)
10462 !
10463 ! band 3
10464 !
10465    absice3(:,3) = (/                                                           &
10466    6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,            &
10467    5.986953e-02_rb,5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,            &
10468    4.024411e-02_rb,3.711404e-02_rb,3.440426e-02_rb,3.203200e-02_rb,            &
10469    2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb,2.486516e-02_rb,            &
10470    2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb,            &
10471    1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,            &
10472    1.566773e-02_rb,1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,            &
10473    1.309865e-02_rb,1.254634e-02_rb,1.202456e-02_rb,1.153114e-02_rb,            &
10474    1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb,9.804381e-03_rb,            &
10475    9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb,            &
10476    8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,            &
10477    7.008697e-03_rb,6.769036e-03_rb/)
10478 !
10479 ! band 4
10480 !
10481    absice3(:,4) = (/                                                           &
10482    1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,            &
10483    7.591185e-02_rb,6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,            &
10484    4.607610e-02_rb,4.181475e-02_rb,3.822697e-02_rb,3.516432e-02_rb,            &
10485    3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb,2.637607e-02_rb,            &
10486    2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb,            &
10487    1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,            &
10488    1.622280e-02_rb,1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,            &
10489    1.362880e-02_rb,1.308460e-02_rb,1.257468e-02_rb,1.209611e-02_rb,            &
10490    1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb,1.044725e-02_rb,            &
10491    1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb,            &
10492    8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,            &
10493    7.842755e-03_rb,7.621418e-03_rb/)
10494 !
10495 ! band 5
10496 !
10497    absice3(:,5) = (/                                                           &
10498    2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,            &
10499    8.562949e-02_rb,7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,            &
10500    4.927787e-02_rb,4.430246e-02_rb,4.017061e-02_rb,3.669072e-02_rb,            &
10501    3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb,2.700471e-02_rb,            &
10502    2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb,            &
10503    2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,            &
10504    1.656300e-02_rb,1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,            &
10505    1.403419e-02_rb,1.350689e-02_rb,1.301260e-02_rb,1.254781e-02_rb,            &
10506    1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb,1.092675e-02_rb,            &
10507    1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb,            &
10508    9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,            &
10509    8.153590e-03_rb,7.890412e-03_rb/)
10510 !
10511 ! band 6
10512 !
10513    absice3(:,6) = (/                                                           &
10514    1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,            &
10515    7.104263e-02_rb,6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,            &
10516    4.317918e-02_rb,3.913795e-02_rb,3.574916e-02_rb,3.287437e-02_rb,            &
10517    3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb,2.479206e-02_rb,            &
10518    2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb,            &
10519    1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,            &
10520    1.598545e-02_rb,1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,            &
10521    1.382150e-02_rb,1.336499e-02_rb,1.293447e-02_rb,1.252685e-02_rb,            &
10522    1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb,1.107508e-02_rb,            &
10523    1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb,            &
10524    9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,            &
10525    8.390301e-03_rb,8.114723e-03_rb/)
10526 !
10527 ! band 7
10528 !
10529    absice3(:,7) = (/                                                           &
10530    1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,            &
10531    4.676925e-02_rb,4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,            &
10532    3.342843e-02_rb,3.115052e-02_rb,2.915776e-02_rb,2.739935e-02_rb,            &
10533    2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb,2.201687e-02_rb,            &
10534    2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb,            &
10535    1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,            &
10536    1.489742e-02_rb,1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,            &
10537    1.281068e-02_rb,1.235084e-02_rb,1.191172e-02_rb,1.149171e-02_rb,            &
10538    1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb,9.976220e-03_rb,            &
10539    9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb,            &
10540    8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,            &
10541    7.279706e-03_rb,7.026186e-03_rb/)
10542 !
10543 ! band 8
10544 !
10545    absice3(:,8) = (/                                                           &
10546    6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,            &
10547    4.836902e-02_rb,4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,            &
10548    3.416508e-02_rb,3.186003e-02_rb,2.984290e-02_rb,2.805671e-02_rb,            &
10549    2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb,2.250808e-02_rb,            &
10550    2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb,            &
10551    1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,            &
10552    1.491793e-02_rb,1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,            &
10553    1.268430e-02_rb,1.219799e-02_rb,1.173682e-02_rb,1.129925e-02_rb,            &
10554    1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb,9.759543e-03_rb,            &
10555    9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb,            &
10556    8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,            &
10557    7.270238e-03_rb,7.060305e-03_rb/)
10558 !
10559 ! band 9
10560 !
10561    absice3(:,9) = (/                                                           &
10562    1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,            &
10563    5.381029e-02_rb,4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,            &
10564    3.601540e-02_rb,3.335878e-02_rb,3.107493e-02_rb,2.908247e-02_rb,            &
10565    2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb,2.305852e-02_rb,            &
10566    2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb,            &
10567    1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,            &
10568    1.520924e-02_rb,1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,            &
10569    1.300293e-02_rb,1.253153e-02_rb,1.208808e-02_rb,1.167094e-02_rb,            &
10570    1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb,1.023786e-02_rb,            &
10571    9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb,            &
10572    8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,            &
10573    8.121463e-03_rb,7.964013e-03_rb/)
10574 !
10575 ! band 10
10576 !
10577    absice3(:,10) = (/                                                          &
10578    1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,            &
10579    6.063739e-02_rb,5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,            &
10580    3.871892e-02_rb,3.559206e-02_rb,3.293893e-02_rb,3.065226e-02_rb,            &
10581    2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb,2.391150e-02_rb,            &
10582    2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb,            &
10583    1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,            &
10584    1.556456e-02_rb,1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,            &
10585    1.331719e-02_rb,1.284339e-02_rb,1.239992e-02_rb,1.198486e-02_rb,            &
10586    1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb,1.057679e-02_rb,            &
10587    1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb,            &
10588    9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,            &
10589    8.582314e-03_rb,8.442725e-03_rb/)
10590 !
10591 ! band 11
10592 !
10593    absice3(:,11) = (/                                                          &
10594    1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,            &
10595    6.108333e-02_rb,5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,            &
10596    3.836768e-02_rb,3.518576e-02_rb,3.250063e-02_rb,3.019825e-02_rb,            &
10597    2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb,2.348414e-02_rb,            &
10598    2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb,            &
10599    1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,            &
10600    1.534084e-02_rb,1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,            &
10601    1.317597e-02_rb,1.272004e-02_rb,1.229321e-02_rb,1.189350e-02_rb,            &
10602    1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb,1.053338e-02_rb,            &
10603    1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb,            &
10604    9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,            &
10605    8.565568e-03_rb,8.422115e-03_rb/)
10606 !
10607 ! band 12
10608 !
10609    absice3(:,12) = (/                                                          &
10610    9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,            &
10611    3.741843e-02_rb,3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,            &
10612    2.651789e-02_rb,2.490518e-02_rb,2.351273e-02_rb,2.229056e-02_rb,            &
10613    2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb,1.852546e-02_rb,            &
10614    1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb,            &
10615    1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,            &
10616    1.333549e-02_rb,1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,            &
10617    1.178265e-02_rb,1.144337e-02_rb,1.112148e-02_rb,1.081609e-02_rb,            &
10618    1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb,9.745130e-03_rb,            &
10619    9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb,            &
10620    8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,            &
10621    8.078032e-03_rb,7.947730e-03_rb/)
10622 !
10623 ! band 13
10624 !
10625    absice3(:,13) = (/                                                          &
10626    1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,            &
10627    5.214952e-02_rb,4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,            &
10628    3.419343e-02_rb,3.165356e-02_rb,2.949251e-02_rb,2.762222e-02_rb,            &
10629    2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb,2.203516e-02_rb,            &
10630    2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb,            &
10631    1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,            &
10632    1.485411e-02_rb,1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,            &
10633    1.285996e-02_rb,1.243746e-02_rb,1.204183e-02_rb,1.167164e-02_rb,            &
10634    1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb,1.042258e-02_rb,            &
10635    1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb,            &
10636    9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,            &
10637    8.753555e-03_rb,8.652951e-03_rb/)
10638 !
10639 ! band 14
10640 !
10641    absice3(:,14) = (/                                                          &
10642    1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,            &
10643    5.168730e-02_rb,4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,            &
10644    3.390714e-02_rb,3.139438e-02_rb,2.925702e-02_rb,2.740783e-02_rb,            &
10645    2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb,2.188910e-02_rb,            &
10646    2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb,            &
10647    1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,            &
10648    1.481712e-02_rb,1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,            &
10649    1.286068e-02_rb,1.244689e-02_rb,1.205973e-02_rb,1.169780e-02_rb,            &
10650    1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb,1.048004e-02_rb,            &
10651    1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb,            &
10652    9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,            &
10653    8.878039e-03_rb,8.785184e-03_rb/)
10654 !
10655 ! band 15
10656 !
10657    absice3(:,15) = (/                                                          &
10658    1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,            &
10659    4.006116e-02_rb,3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,            &
10660    2.791920e-02_rb,2.615617e-02_rb,2.464023e-02_rb,2.331426e-02_rb,            &
10661    2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb,1.925493e-02_rb,            &
10662    1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb,            &
10663    1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,            &
10664    1.373841e-02_rb,1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,            &
10665    1.212700e-02_rb,1.178015e-02_rb,1.145348e-02_rb,1.114612e-02_rb,            &
10666    1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb,1.009564e-02_rb,            &
10667    9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb,            &
10668    9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,            &
10669    8.649907e-03_rb,8.560232e-03_rb/)
10670 !
10671 ! band 16
10672 !
10673    absice3(:,16) = (/                                                          &
10674    1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,            &
10675    5.369850e-02_rb,4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,            &
10676    3.342069e-02_rb,3.065831e-02_rb,2.834557e-02_rb,2.637680e-02_rb,            &
10677    2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb,2.071701e-02_rb,            &
10678    1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb,            &
10679    1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,            &
10680    1.400433e-02_rb,1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,            &
10681    1.222688e-02_rb,1.185044e-02_rb,1.149683e-02_rb,1.116436e-02_rb,            &
10682    1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb,1.001831e-02_rb,            &
10683    9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb,            &
10684    8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,            &
10685    8.262543e-03_rb,8.123136e-03_rb/)
10686 !
10687 ! For liqflag = 0.
10688 !
10689    absliq0 = 0.0903614_rb
10690 !
10691 ! For liqflag = 1.  In each band, the absorption
10692 ! coefficients are listed for a range of effective radii from 2.5
10693 ! to 59.5 microns in increments of 1.0 micron.
10694 !
10695 ! band  1
10696 !
10697    absliq1(:, 1) = (/                                                          &
10698    1.64047e-03_rb,6.90533e-02_rb,7.72017e-02_rb,7.78054e-02_rb,7.69523e-02_rb, &
10699    7.58058e-02_rb,7.46400e-02_rb,7.35123e-02_rb,7.24162e-02_rb,7.13225e-02_rb, &
10700    6.99145e-02_rb,6.66409e-02_rb,6.36582e-02_rb,6.09425e-02_rb,5.84593e-02_rb, &
10701    5.61743e-02_rb,5.40571e-02_rb,5.20812e-02_rb,5.02245e-02_rb,4.84680e-02_rb, &
10702    4.67959e-02_rb,4.51944e-02_rb,4.36516e-02_rb,4.21570e-02_rb,4.07015e-02_rb, &
10703    3.92766e-02_rb,3.78747e-02_rb,3.64886e-02_rb,3.53632e-02_rb,3.41992e-02_rb, &
10704    3.31016e-02_rb,3.20643e-02_rb,3.10817e-02_rb,3.01490e-02_rb,2.92620e-02_rb, &
10705    2.84171e-02_rb,2.76108e-02_rb,2.68404e-02_rb,2.61031e-02_rb,2.53966e-02_rb, &
10706    2.47189e-02_rb,2.40678e-02_rb,2.34418e-02_rb,2.28392e-02_rb,2.22586e-02_rb, &
10707    2.16986e-02_rb,2.11580e-02_rb,2.06356e-02_rb,2.01305e-02_rb,1.96417e-02_rb, &
10708    1.91682e-02_rb,1.87094e-02_rb,1.82643e-02_rb,1.78324e-02_rb,1.74129e-02_rb, &
10709    1.70052e-02_rb,1.66088e-02_rb,1.62231e-02_rb/)
10710 !
10711 ! band  2
10712 !
10713    absliq1(:, 2) = (/                                                          &
10714    2.19486e-01_rb,1.80687e-01_rb,1.59150e-01_rb,1.44731e-01_rb,1.33703e-01_rb, &
10715    1.24355e-01_rb,1.15756e-01_rb,1.07318e-01_rb,9.86119e-02_rb,8.92739e-02_rb, &
10716    8.34911e-02_rb,7.70773e-02_rb,7.15240e-02_rb,6.66615e-02_rb,6.23641e-02_rb, &
10717    5.85359e-02_rb,5.51020e-02_rb,5.20032e-02_rb,4.91916e-02_rb,4.66283e-02_rb, &
10718    4.42813e-02_rb,4.21236e-02_rb,4.01330e-02_rb,3.82905e-02_rb,3.65797e-02_rb, &
10719    3.49869e-02_rb,3.35002e-02_rb,3.21090e-02_rb,3.08957e-02_rb,2.97601e-02_rb, &
10720    2.86966e-02_rb,2.76984e-02_rb,2.67599e-02_rb,2.58758e-02_rb,2.50416e-02_rb, &
10721    2.42532e-02_rb,2.35070e-02_rb,2.27997e-02_rb,2.21284e-02_rb,2.14904e-02_rb, &
10722    2.08834e-02_rb,2.03051e-02_rb,1.97536e-02_rb,1.92271e-02_rb,1.87239e-02_rb, &
10723    1.82425e-02_rb,1.77816e-02_rb,1.73399e-02_rb,1.69162e-02_rb,1.65094e-02_rb, &
10724    1.61187e-02_rb,1.57430e-02_rb,1.53815e-02_rb,1.50334e-02_rb,1.46981e-02_rb, &
10725    1.43748e-02_rb,1.40628e-02_rb,1.37617e-02_rb/)
10726 !
10727 ! band  3
10728 !
10729    absliq1(:, 3) = (/                                                          &
10730    2.95174e-01_rb,2.34765e-01_rb,1.98038e-01_rb,1.72114e-01_rb,1.52083e-01_rb, &
10731    1.35654e-01_rb,1.21613e-01_rb,1.09252e-01_rb,9.81263e-02_rb,8.79448e-02_rb, &
10732    8.12566e-02_rb,7.44563e-02_rb,6.86374e-02_rb,6.36042e-02_rb,5.92094e-02_rb, &
10733    5.53402e-02_rb,5.19087e-02_rb,4.88455e-02_rb,4.60951e-02_rb,4.36124e-02_rb, &
10734    4.13607e-02_rb,3.93096e-02_rb,3.74338e-02_rb,3.57119e-02_rb,3.41261e-02_rb, &
10735    3.26610e-02_rb,3.13036e-02_rb,3.00425e-02_rb,2.88497e-02_rb,2.78077e-02_rb, &
10736    2.68317e-02_rb,2.59158e-02_rb,2.50545e-02_rb,2.42430e-02_rb,2.34772e-02_rb, &
10737    2.27533e-02_rb,2.20679e-02_rb,2.14181e-02_rb,2.08011e-02_rb,2.02145e-02_rb, &
10738    1.96561e-02_rb,1.91239e-02_rb,1.86161e-02_rb,1.81311e-02_rb,1.76673e-02_rb, &
10739    1.72234e-02_rb,1.67981e-02_rb,1.63903e-02_rb,1.59989e-02_rb,1.56230e-02_rb, &
10740    1.52615e-02_rb,1.49138e-02_rb,1.45791e-02_rb,1.42565e-02_rb,1.39455e-02_rb, &
10741    1.36455e-02_rb,1.33559e-02_rb,1.30761e-02_rb/)
10742 !
10743 ! band  4
10744 !
10745    absliq1(:, 4) = (/                                                          &
10746    3.00925e-01_rb,2.36949e-01_rb,1.96947e-01_rb,1.68692e-01_rb,1.47190e-01_rb, &
10747    1.29986e-01_rb,1.15719e-01_rb,1.03568e-01_rb,9.30028e-02_rb,8.36658e-02_rb, &
10748    7.71075e-02_rb,7.07002e-02_rb,6.52284e-02_rb,6.05024e-02_rb,5.63801e-02_rb, &
10749    5.27534e-02_rb,4.95384e-02_rb,4.66690e-02_rb,4.40925e-02_rb,4.17664e-02_rb, &
10750    3.96559e-02_rb,3.77326e-02_rb,3.59727e-02_rb,3.43561e-02_rb,3.28662e-02_rb, &
10751    3.14885e-02_rb,3.02110e-02_rb,2.90231e-02_rb,2.78948e-02_rb,2.69109e-02_rb, &
10752    2.59884e-02_rb,2.51217e-02_rb,2.43058e-02_rb,2.35364e-02_rb,2.28096e-02_rb, &
10753    2.21218e-02_rb,2.14700e-02_rb,2.08515e-02_rb,2.02636e-02_rb,1.97041e-02_rb, &
10754    1.91711e-02_rb,1.86625e-02_rb,1.81769e-02_rb,1.77126e-02_rb,1.72683e-02_rb, &
10755    1.68426e-02_rb,1.64344e-02_rb,1.60427e-02_rb,1.56664e-02_rb,1.53046e-02_rb, &
10756    1.49565e-02_rb,1.46214e-02_rb,1.42985e-02_rb,1.39871e-02_rb,1.36866e-02_rb, &
10757    1.33965e-02_rb,1.31162e-02_rb,1.28453e-02_rb/)
10758 !
10759 ! band  5
10760 !
10761    absliq1(:, 5) = (/                                                          &
10762    2.64691e-01_rb,2.12018e-01_rb,1.78009e-01_rb,1.53539e-01_rb,1.34721e-01_rb, &
10763    1.19580e-01_rb,1.06996e-01_rb,9.62772e-02_rb,8.69710e-02_rb,7.87670e-02_rb, &
10764    7.29272e-02_rb,6.70920e-02_rb,6.20977e-02_rb,5.77732e-02_rb,5.39910e-02_rb, &
10765    5.06538e-02_rb,4.76866e-02_rb,4.50301e-02_rb,4.26374e-02_rb,4.04704e-02_rb, &
10766    3.84981e-02_rb,3.66948e-02_rb,3.50394e-02_rb,3.35141e-02_rb,3.21038e-02_rb, &
10767    3.07957e-02_rb,2.95788e-02_rb,2.84438e-02_rb,2.73790e-02_rb,2.64390e-02_rb, &
10768    2.55565e-02_rb,2.47263e-02_rb,2.39437e-02_rb,2.32047e-02_rb,2.25056e-02_rb, &
10769    2.18433e-02_rb,2.12149e-02_rb,2.06177e-02_rb,2.00495e-02_rb,1.95081e-02_rb, &
10770    1.89917e-02_rb,1.84984e-02_rb,1.80269e-02_rb,1.75755e-02_rb,1.71431e-02_rb, &
10771    1.67283e-02_rb,1.63303e-02_rb,1.59478e-02_rb,1.55801e-02_rb,1.52262e-02_rb, &
10772    1.48853e-02_rb,1.45568e-02_rb,1.42400e-02_rb,1.39342e-02_rb,1.36388e-02_rb, &
10773    1.33533e-02_rb,1.30773e-02_rb,1.28102e-02_rb/)
10774 !
10775 ! band  6
10776 !
10777    absliq1(:, 6) = (/                                                          &
10778    8.81182e-02_rb,1.06745e-01_rb,9.79753e-02_rb,8.99625e-02_rb,8.35200e-02_rb, &
10779    7.81899e-02_rb,7.35939e-02_rb,6.94696e-02_rb,6.56266e-02_rb,6.19148e-02_rb, &
10780    5.83355e-02_rb,5.49306e-02_rb,5.19642e-02_rb,4.93325e-02_rb,4.69659e-02_rb, &
10781    4.48148e-02_rb,4.28431e-02_rb,4.10231e-02_rb,3.93332e-02_rb,3.77563e-02_rb, &
10782    3.62785e-02_rb,3.48882e-02_rb,3.35758e-02_rb,3.23333e-02_rb,3.11536e-02_rb, &
10783    3.00310e-02_rb,2.89601e-02_rb,2.79365e-02_rb,2.70502e-02_rb,2.62618e-02_rb, &
10784    2.55025e-02_rb,2.47728e-02_rb,2.40726e-02_rb,2.34013e-02_rb,2.27583e-02_rb, &
10785    2.21422e-02_rb,2.15522e-02_rb,2.09869e-02_rb,2.04453e-02_rb,1.99260e-02_rb, &
10786    1.94280e-02_rb,1.89501e-02_rb,1.84913e-02_rb,1.80506e-02_rb,1.76270e-02_rb, &
10787    1.72196e-02_rb,1.68276e-02_rb,1.64500e-02_rb,1.60863e-02_rb,1.57357e-02_rb, &
10788    1.53975e-02_rb,1.50710e-02_rb,1.47558e-02_rb,1.44511e-02_rb,1.41566e-02_rb, &
10789    1.38717e-02_rb,1.35960e-02_rb,1.33290e-02_rb/)
10790 ! band  7
10791 !
10792    absliq1(:, 7) = (/                                                          &
10793    4.32174e-02_rb,7.36078e-02_rb,6.98340e-02_rb,6.65231e-02_rb,6.41948e-02_rb, &
10794    6.23551e-02_rb,6.06638e-02_rb,5.88680e-02_rb,5.67124e-02_rb,5.38629e-02_rb, &
10795    4.99579e-02_rb,4.86289e-02_rb,4.70120e-02_rb,4.52854e-02_rb,4.35466e-02_rb, &
10796    4.18480e-02_rb,4.02169e-02_rb,3.86658e-02_rb,3.71992e-02_rb,3.58168e-02_rb, &
10797    3.45155e-02_rb,3.32912e-02_rb,3.21390e-02_rb,3.10538e-02_rb,3.00307e-02_rb, &
10798    2.90651e-02_rb,2.81524e-02_rb,2.72885e-02_rb,2.62821e-02_rb,2.55744e-02_rb, &
10799    2.48799e-02_rb,2.42029e-02_rb,2.35460e-02_rb,2.29108e-02_rb,2.22981e-02_rb, &
10800    2.17079e-02_rb,2.11402e-02_rb,2.05945e-02_rb,2.00701e-02_rb,1.95663e-02_rb, &
10801    1.90824e-02_rb,1.86174e-02_rb,1.81706e-02_rb,1.77411e-02_rb,1.73281e-02_rb, &
10802    1.69307e-02_rb,1.65483e-02_rb,1.61801e-02_rb,1.58254e-02_rb,1.54835e-02_rb, &
10803    1.51538e-02_rb,1.48358e-02_rb,1.45288e-02_rb,1.42322e-02_rb,1.39457e-02_rb, &
10804    1.36687e-02_rb,1.34008e-02_rb,1.31416e-02_rb/)
10805 !
10806 ! band  8
10807 !
10808    absliq1(:, 8) = (/                                                          &
10809    1.41881e-01_rb,7.15419e-02_rb,6.30335e-02_rb,6.11132e-02_rb,6.01931e-02_rb, &
10810    5.92420e-02_rb,5.78968e-02_rb,5.58876e-02_rb,5.28923e-02_rb,4.84462e-02_rb, &
10811    4.60839e-02_rb,4.56013e-02_rb,4.45410e-02_rb,4.31866e-02_rb,4.17026e-02_rb, &
10812    4.01850e-02_rb,3.86892e-02_rb,3.72461e-02_rb,3.58722e-02_rb,3.45749e-02_rb, &
10813    3.33564e-02_rb,3.22155e-02_rb,3.11494e-02_rb,3.01541e-02_rb,2.92253e-02_rb, &
10814    2.83584e-02_rb,2.75488e-02_rb,2.67925e-02_rb,2.57692e-02_rb,2.50704e-02_rb, &
10815    2.43918e-02_rb,2.37350e-02_rb,2.31005e-02_rb,2.24888e-02_rb,2.18996e-02_rb, &
10816    2.13325e-02_rb,2.07870e-02_rb,2.02623e-02_rb,1.97577e-02_rb,1.92724e-02_rb, &
10817    1.88056e-02_rb,1.83564e-02_rb,1.79241e-02_rb,1.75079e-02_rb,1.71070e-02_rb, &
10818    1.67207e-02_rb,1.63482e-02_rb,1.59890e-02_rb,1.56424e-02_rb,1.53077e-02_rb, &
10819    1.49845e-02_rb,1.46722e-02_rb,1.43702e-02_rb,1.40782e-02_rb,1.37955e-02_rb, &
10820    1.35219e-02_rb,1.32569e-02_rb,1.30000e-02_rb/)
10821 !
10822 ! band  9
10823 !
10824    absliq1(:, 9) = (/                                                          &
10825    6.72726e-02_rb,6.61013e-02_rb,6.47866e-02_rb,6.33780e-02_rb,6.18985e-02_rb, &
10826    6.03335e-02_rb,5.86136e-02_rb,5.65876e-02_rb,5.39839e-02_rb,5.03536e-02_rb, &
10827    4.71608e-02_rb,4.63630e-02_rb,4.50313e-02_rb,4.34526e-02_rb,4.17876e-02_rb, &
10828    4.01261e-02_rb,3.85171e-02_rb,3.69860e-02_rb,3.55442e-02_rb,3.41954e-02_rb, &
10829    3.29384e-02_rb,3.17693e-02_rb,3.06832e-02_rb,2.96745e-02_rb,2.87374e-02_rb, &
10830    2.78662e-02_rb,2.70557e-02_rb,2.63008e-02_rb,2.52450e-02_rb,2.45424e-02_rb, &
10831    2.38656e-02_rb,2.32144e-02_rb,2.25885e-02_rb,2.19873e-02_rb,2.14099e-02_rb, &
10832    2.08554e-02_rb,2.03230e-02_rb,1.98116e-02_rb,1.93203e-02_rb,1.88482e-02_rb, &
10833    1.83944e-02_rb,1.79578e-02_rb,1.75378e-02_rb,1.71335e-02_rb,1.67440e-02_rb, &
10834    1.63687e-02_rb,1.60069e-02_rb,1.56579e-02_rb,1.53210e-02_rb,1.49958e-02_rb, &
10835    1.46815e-02_rb,1.43778e-02_rb,1.40841e-02_rb,1.37999e-02_rb,1.35249e-02_rb, &
10836    1.32585e-02_rb,1.30004e-02_rb,1.27502e-02_rb/)
10837 !
10838 ! band 10
10839 !
10840    absliq1(:,10) = (/                                                          &
10841    7.97040e-02_rb,7.63844e-02_rb,7.36499e-02_rb,7.13525e-02_rb,6.93043e-02_rb, &
10842    6.72807e-02_rb,6.50227e-02_rb,6.22395e-02_rb,5.86093e-02_rb,5.37815e-02_rb, &
10843    5.14682e-02_rb,4.97214e-02_rb,4.77392e-02_rb,4.56961e-02_rb,4.36858e-02_rb, &
10844    4.17569e-02_rb,3.99328e-02_rb,3.82224e-02_rb,3.66265e-02_rb,3.51416e-02_rb, &
10845    3.37617e-02_rb,3.24798e-02_rb,3.12887e-02_rb,3.01812e-02_rb,2.91505e-02_rb, &
10846    2.81900e-02_rb,2.72939e-02_rb,2.64568e-02_rb,2.54165e-02_rb,2.46832e-02_rb, &
10847    2.39783e-02_rb,2.33017e-02_rb,2.26531e-02_rb,2.20314e-02_rb,2.14359e-02_rb, &
10848    2.08653e-02_rb,2.03187e-02_rb,1.97947e-02_rb,1.92924e-02_rb,1.88106e-02_rb, &
10849    1.83483e-02_rb,1.79043e-02_rb,1.74778e-02_rb,1.70678e-02_rb,1.66735e-02_rb, &
10850    1.62941e-02_rb,1.59286e-02_rb,1.55766e-02_rb,1.52371e-02_rb,1.49097e-02_rb, &
10851    1.45937e-02_rb,1.42885e-02_rb,1.39936e-02_rb,1.37085e-02_rb,1.34327e-02_rb, &
10852    1.31659e-02_rb,1.29075e-02_rb,1.26571e-02_rb/)
10853 !
10854 ! band 11
10855 !
10856    absliq1(:,11) = (/                                                          &
10857    1.49438e-01_rb,1.33535e-01_rb,1.21542e-01_rb,1.11743e-01_rb,1.03263e-01_rb, &
10858    9.55774e-02_rb,8.83382e-02_rb,8.12943e-02_rb,7.42533e-02_rb,6.70609e-02_rb, &
10859    6.38761e-02_rb,5.97788e-02_rb,5.59841e-02_rb,5.25318e-02_rb,4.94132e-02_rb, &
10860    4.66014e-02_rb,4.40644e-02_rb,4.17706e-02_rb,3.96910e-02_rb,3.77998e-02_rb, &
10861    3.60742e-02_rb,3.44947e-02_rb,3.30442e-02_rb,3.17079e-02_rb,3.04730e-02_rb, &
10862    2.93283e-02_rb,2.82642e-02_rb,2.72720e-02_rb,2.61789e-02_rb,2.53277e-02_rb, &
10863    2.45237e-02_rb,2.37635e-02_rb,2.30438e-02_rb,2.23615e-02_rb,2.17140e-02_rb, &
10864    2.10987e-02_rb,2.05133e-02_rb,1.99557e-02_rb,1.94241e-02_rb,1.89166e-02_rb, &
10865    1.84317e-02_rb,1.79679e-02_rb,1.75238e-02_rb,1.70983e-02_rb,1.66901e-02_rb, &
10866    1.62983e-02_rb,1.59219e-02_rb,1.55599e-02_rb,1.52115e-02_rb,1.48761e-02_rb, &
10867    1.45528e-02_rb,1.42411e-02_rb,1.39402e-02_rb,1.36497e-02_rb,1.33690e-02_rb, &
10868    1.30976e-02_rb,1.28351e-02_rb,1.25810e-02_rb/)
10869 !
10870 ! band 12
10871 !
10872    absliq1(:,12) = (/                                                          &
10873    3.71985e-02_rb,3.88586e-02_rb,3.99070e-02_rb,4.04351e-02_rb,4.04610e-02_rb, &
10874    3.99834e-02_rb,3.89953e-02_rb,3.74886e-02_rb,3.54551e-02_rb,3.28870e-02_rb, &
10875    3.32576e-02_rb,3.22444e-02_rb,3.12384e-02_rb,3.02584e-02_rb,2.93146e-02_rb, &
10876    2.84120e-02_rb,2.75525e-02_rb,2.67361e-02_rb,2.59618e-02_rb,2.52280e-02_rb, &
10877    2.45327e-02_rb,2.38736e-02_rb,2.32487e-02_rb,2.26558e-02_rb,2.20929e-02_rb, &
10878    2.15579e-02_rb,2.10491e-02_rb,2.05648e-02_rb,1.99749e-02_rb,1.95704e-02_rb, &
10879    1.91731e-02_rb,1.87839e-02_rb,1.84032e-02_rb,1.80315e-02_rb,1.76689e-02_rb, &
10880    1.73155e-02_rb,1.69712e-02_rb,1.66362e-02_rb,1.63101e-02_rb,1.59928e-02_rb, &
10881    1.56842e-02_rb,1.53840e-02_rb,1.50920e-02_rb,1.48080e-02_rb,1.45318e-02_rb, &
10882    1.42631e-02_rb,1.40016e-02_rb,1.37472e-02_rb,1.34996e-02_rb,1.32586e-02_rb, &
10883    1.30239e-02_rb,1.27954e-02_rb,1.25728e-02_rb,1.23559e-02_rb,1.21445e-02_rb, &
10884    1.19385e-02_rb,1.17376e-02_rb,1.15417e-02_rb/)
10885 !
10886 ! band 13
10887 !
10888    absliq1(:,13) = (/                                                          &
10889    3.11868e-02_rb,4.48357e-02_rb,4.90224e-02_rb,4.96406e-02_rb,4.86806e-02_rb, &
10890    4.69610e-02_rb,4.48630e-02_rb,4.25795e-02_rb,4.02138e-02_rb,3.78236e-02_rb, &
10891    3.74266e-02_rb,3.60384e-02_rb,3.47074e-02_rb,3.34434e-02_rb,3.22499e-02_rb, &
10892    3.11264e-02_rb,3.00704e-02_rb,2.90784e-02_rb,2.81463e-02_rb,2.72702e-02_rb, &
10893    2.64460e-02_rb,2.56698e-02_rb,2.49381e-02_rb,2.42475e-02_rb,2.35948e-02_rb, &
10894    2.29774e-02_rb,2.23925e-02_rb,2.18379e-02_rb,2.11793e-02_rb,2.07076e-02_rb, &
10895    2.02470e-02_rb,1.97981e-02_rb,1.93613e-02_rb,1.89367e-02_rb,1.85243e-02_rb, &
10896    1.81240e-02_rb,1.77356e-02_rb,1.73588e-02_rb,1.69935e-02_rb,1.66392e-02_rb, &
10897    1.62956e-02_rb,1.59624e-02_rb,1.56393e-02_rb,1.53259e-02_rb,1.50219e-02_rb, &
10898    1.47268e-02_rb,1.44404e-02_rb,1.41624e-02_rb,1.38925e-02_rb,1.36302e-02_rb, &
10899    1.33755e-02_rb,1.31278e-02_rb,1.28871e-02_rb,1.26530e-02_rb,1.24253e-02_rb, &
10900    1.22038e-02_rb,1.19881e-02_rb,1.17782e-02_rb/)
10901 !
10902 ! band 14
10903 !
10904    absliq1(:,14) = (/                                                          &
10905    1.58988e-02_rb,3.50652e-02_rb,4.00851e-02_rb,4.07270e-02_rb,3.98101e-02_rb, &
10906    3.83306e-02_rb,3.66829e-02_rb,3.50327e-02_rb,3.34497e-02_rb,3.19609e-02_rb, &
10907    3.13712e-02_rb,3.03348e-02_rb,2.93415e-02_rb,2.83973e-02_rb,2.75037e-02_rb, &
10908    2.66604e-02_rb,2.58654e-02_rb,2.51161e-02_rb,2.44100e-02_rb,2.37440e-02_rb, &
10909    2.31154e-02_rb,2.25215e-02_rb,2.19599e-02_rb,2.14282e-02_rb,2.09242e-02_rb, &
10910    2.04459e-02_rb,1.99915e-02_rb,1.95594e-02_rb,1.90254e-02_rb,1.86598e-02_rb, &
10911    1.82996e-02_rb,1.79455e-02_rb,1.75983e-02_rb,1.72584e-02_rb,1.69260e-02_rb, &
10912    1.66013e-02_rb,1.62843e-02_rb,1.59752e-02_rb,1.56737e-02_rb,1.53799e-02_rb, &
10913    1.50936e-02_rb,1.48146e-02_rb,1.45429e-02_rb,1.42782e-02_rb,1.40203e-02_rb, &
10914    1.37691e-02_rb,1.35243e-02_rb,1.32858e-02_rb,1.30534e-02_rb,1.28270e-02_rb, &
10915    1.26062e-02_rb,1.23909e-02_rb,1.21810e-02_rb,1.19763e-02_rb,1.17766e-02_rb, &
10916    1.15817e-02_rb,1.13915e-02_rb,1.12058e-02_rb/)
10917 !
10918 ! band 15
10919 !
10920    absliq1(:,15) = (/                                                          &
10921    5.02079e-03_rb,2.17615e-02_rb,2.55449e-02_rb,2.59484e-02_rb,2.53650e-02_rb, &
10922    2.45281e-02_rb,2.36843e-02_rb,2.29159e-02_rb,2.22451e-02_rb,2.16716e-02_rb, &
10923    2.11451e-02_rb,2.05817e-02_rb,2.00454e-02_rb,1.95372e-02_rb,1.90567e-02_rb, &
10924    1.86028e-02_rb,1.81742e-02_rb,1.77693e-02_rb,1.73866e-02_rb,1.70244e-02_rb, &
10925    1.66815e-02_rb,1.63563e-02_rb,1.60477e-02_rb,1.57544e-02_rb,1.54755e-02_rb, &
10926    1.52097e-02_rb,1.49564e-02_rb,1.47146e-02_rb,1.43684e-02_rb,1.41728e-02_rb, &
10927    1.39762e-02_rb,1.37797e-02_rb,1.35838e-02_rb,1.33891e-02_rb,1.31961e-02_rb, &
10928    1.30051e-02_rb,1.28164e-02_rb,1.26302e-02_rb,1.24466e-02_rb,1.22659e-02_rb, &
10929    1.20881e-02_rb,1.19131e-02_rb,1.17412e-02_rb,1.15723e-02_rb,1.14063e-02_rb, &
10930    1.12434e-02_rb,1.10834e-02_rb,1.09264e-02_rb,1.07722e-02_rb,1.06210e-02_rb, &
10931    1.04725e-02_rb,1.03269e-02_rb,1.01839e-02_rb,1.00436e-02_rb,9.90593e-03_rb, &
10932    9.77080e-03_rb,9.63818e-03_rb,9.50800e-03_rb/)
10933 !
10934 ! band 16
10935 !
10936    absliq1(:,16) = (/                                                          &
10937    5.64971e-02_rb,9.04736e-02_rb,8.11726e-02_rb,7.05450e-02_rb,6.20052e-02_rb, &
10938    5.54286e-02_rb,5.03503e-02_rb,4.63791e-02_rb,4.32290e-02_rb,4.06959e-02_rb, &
10939    3.74690e-02_rb,3.52964e-02_rb,3.33799e-02_rb,3.16774e-02_rb,3.01550e-02_rb, &
10940    2.87856e-02_rb,2.75474e-02_rb,2.64223e-02_rb,2.53953e-02_rb,2.44542e-02_rb, &
10941    2.35885e-02_rb,2.27894e-02_rb,2.20494e-02_rb,2.13622e-02_rb,2.07222e-02_rb, &
10942    2.01246e-02_rb,1.95654e-02_rb,1.90408e-02_rb,1.84398e-02_rb,1.80021e-02_rb, &
10943    1.75816e-02_rb,1.71775e-02_rb,1.67889e-02_rb,1.64152e-02_rb,1.60554e-02_rb, &
10944    1.57089e-02_rb,1.53751e-02_rb,1.50531e-02_rb,1.47426e-02_rb,1.44428e-02_rb, &
10945    1.41532e-02_rb,1.38734e-02_rb,1.36028e-02_rb,1.33410e-02_rb,1.30875e-02_rb, &
10946    1.28420e-02_rb,1.26041e-02_rb,1.23735e-02_rb,1.21497e-02_rb,1.19325e-02_rb, &
10947    1.17216e-02_rb,1.15168e-02_rb,1.13177e-02_rb,1.11241e-02_rb,1.09358e-02_rb, &
10948    1.07525e-02_rb,1.05741e-02_rb,1.04003e-02_rb/)
10949 !
10950    end subroutine lwcldpr
10951 !-------------------------------------------------------------------------------
10952 !
10953 !
10954 !-------------------------------------------------------------------------------
10955    end module rrtmg_lw_init_k
10956 !-------------------------------------------------------------------------------
10957 !
10958 !
10959 !-------------------------------------------------------------------------------
10960 !
10961 ! path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
10962 ! author:    $Author: trn $
10963 ! revision:  $Revision: 1.3 $
10964 ! created:   $Date: 2009/04/16 19:54:22 $
10965 !
10966 !-------------------------------------------------------------------------------
10967 !
10968 !
10969 !-------------------------------------------------------------------------------
10970    module rrtmg_lw_rad_k
10971 !-------------------------------------------------------------------------------
10972 !
10973 !  abstract :
10974 !
10975 !  --------------------------------------------------------------------------
10976 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
10977 ! |  This software may be used, copied, or redistributed as long as it is    |
10978 ! |  not sold and this copyright notice is reproduced on each copy made.     |
10979 ! |  This model is provided as is without any express or implied warranties. |
10980 ! |                       (http://www.rtweb.aer.com/)                        |
10981 !  --------------------------------------------------------------------------
10982 !
10983 ! ****************************************************************************
10984 ! *                                                                          *
10985 ! *                              RRTMG_LW                                    *
10986 ! *                                                                          *
10987 ! *                                                                          *
10988 ! *                                                                          *
10989 ! *                   a rapid radiative transfer model                       *
10990 ! *                       for the longwave region                            *
10991 ! *             for application to general circulation models                *
10992 ! *                                                                          *
10993 ! *                                                                          *
10994 ! *            Atmospheric and Environmental Research, Inc.                  *
10995 ! *                        131 Hartwell Avenue                               *
10996 ! *                        Lexington, MA 02421                               *
10997 ! *                                                                          *
10998 ! *                                                                          *
10999 ! *                           Eli J. Mlawer                                  *
11000 ! *                        Jennifer S. Delamere                              *
11001 ! *                         Michael J. Iacono                                *
11002 ! *                         Shepard A. Clough                                *
11003 ! *                                                                          *
11004 ! *                                                                          *
11005 ! *                                                                          *
11006 ! *                                                                          *
11007 ! *                                                                          *
11008 ! *                                                                          *
11009 ! *                       email:  miacono@aer.com                            *
11010 ! *                       email:  emlawer@aer.com                            *
11011 ! *                       email:  jdelamer@aer.com                           *
11012 ! *                                                                          *
11013 ! *        The authors wish to acknowledge the contributions of the          *
11014 ! *        following people:  Steven J. Taubman, Karen Cady-Pereira,         *
11015 ! *        Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom.  *
11016 ! *                                                                          *
11017 ! ****************************************************************************
11018 !
11019 !-------------------------------------------------------------------------------
11020    use parkind_k,             only : im => kind_im, rb => kind_rb
11021    use rrlw_vsn_k
11022    use mcica_subcol_gen_k,    only : mcica_subcol
11023    use rrtmg_lw_cldprmc_k,    only : cldprmc
11024 !
11025 ! *** Move the required call to rrtmg_lw_ini below and the following
11026 ! use association to the GCM initialization area ***
11027 !
11028 !  use rrtmg_lw_init,       only : rrtmg_lw_ini
11029    use rrtmg_lw_rtrnmc_k,     only : rtrnmc
11030    use rrtmg_lw_setcoef_k,    only : setcoef
11031    use rrtmg_lw_taumol_k,     only : taumol
11032 !
11033    implicit none
11034 !
11035 ! public interfaces/functions/subroutines
11036 !
11037    public :: rrtmg_lw, inatm
11038 !
11039    contains
11040 !-------------------------------------------------------------------------------
11041 !
11042 !
11043 !-------------------------------------------------------------------------------
11044 ! public subroutines
11045 !-------------------------------------------------------------------------------
11046    subroutine rrtmg_lw                                                         &
11047             (ncol    ,nlay    ,icld    ,                                       &
11048              play    ,plev    ,tlay    ,tlev    ,tsfc    ,                     &
11049              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr  ,o2vmr ,              &
11050              cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis    ,                     &
11051              inflglw ,iceflglw,liqflglw,cldfmcl ,                              &
11052              taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl ,                     &
11053              cswpmcl, resnmcl,                                                 &
11054              tauaer  ,                                                         &
11055              uflx    ,dflx    ,hr      ,uflxc   ,dflxc,  hrc)
11056 !-------------------------------------------------------------------------------
11057 !
11058 !  abstract :
11059 !  This program is the driver subroutine for RRTMG_LW, the AER LW radiation
11060 !  model for application to GCMs, that has been adapted from RRTM_LW for
11061 !  improved efficiency.
11062 !
11063 !  .not.: The call to RRTMG_LW_INI should be moved to the GCM initialization
11064 !  area, since this has to be called only once.
11065 !
11066 !  This routine:
11067 !    a) calls INATM to read in the atmospheric profile from GCM;
11068 !       all layering in RRTMG is ordered from surface to toa.
11069 !    b) calls CLDPRMC to set cloud optical depth for McICA based
11070 !       on input cloud properties
11071 !    c) calls SETCOEF to calculate various quantities needed for
11072 !       the radiative transfer algorithm
11073 !    d) calls TAUMOL to calculate gaseous optical depths for each
11074 !       of the 16 spectral bands
11075 !    e) calls RTRNMC (for both clear and cloudy profiles) to perform the
11076 !       radiative transfer calculation using McICA, the Monte-Carlo
11077 !       Independent Column Approximation, to represent sub-grid scale
11078 !       cloud variability
11079 !    f) passes the necessary fluxes and cooling rates back to GCM
11080 !
11081 !  Two modes of operation are possible:
11082 !    The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
11083 !    McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM.
11084 !
11085 !    1) Standard, single forward model calculation (imca = 0)
11086 !    2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
11087 !       JC, 2003) method is applied to the forward model calculation (imca = 1)
11088 !
11089 !  This call to RRTMG_LW must be preceeded by a call to the module
11090 !    mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
11091 !    which will provide the cloud physical or cloud optical properties
11092 !    on the RRTMG quadrature point (ngpt) dimension.
11093 !    Two random number generators are available for use when imca = 1.
11094 !    This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
11095 !    1) KISSVEC (irnd = 0)
11096 !    2) Mersenne-Twister (irnd = 1)
11097 !
11098 !  Two methods of cloud property input are possible:
11099 !    Cloud properties can be input in one of two ways (controlled by input
11100 !    flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
11101 !    and subroutine rrtmg_lw_cldprop.f90 for further details):
11102 !
11103 !    1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
11104 !    2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);
11105 !       cloud optical properties are calculated by cldprop or cldprmc based
11106 !       on input settings of iceflglw and liqflglw.  Ice particle size provided
11107 !       must be appropriately defined for the ice parameterization selected.
11108 !
11109 !  One method of aerosol property input is possible:
11110 !    Aerosol properties can be input in only one way (controlled by input
11111 !    flag iaer; see text file rrtmg_lw_instructions for further details):
11112 !
11113 !    1) Input aerosol optical depth directly by layer & spectral band (iaer=10);
11114 !       band average optical depth at the mid-point of each spectral band.
11115 !       RRTMG_LW currently treats only aerosol absorption;
11116 !       scattering capability is not presently available.
11117 !
11118 !  ------- Modifications -------
11119 !
11120 !  This version of RRTMG_LW has been modified from RRTM_LW to use a reduced
11121 !  set of g-points for application to GCMs.
11122 !
11123 !  history log :
11124 !    1999        M. J. Iacono, AER, Inc.  Original version (derived from
11125 !                                         RRTM_LW), reduction of g-points,
11126 !                                         other revisions for use with GCMs
11127 !    2004-05-01  M. J. Iacono, AER, Inc.  Adapted for use with NCAR/CAM
11128 !    2005-11-01  M. J. Iacono, AER, Inc.  Revised to add McICA capability
11129 !    2007-02-01  M. J. Iacono, AER, Inc.  Conversion to F90 formatting for
11130 !                                         consistency with rrtmg_sw
11131 !    2007-08-01  M. J. Iacono, AER, Inc.  Modifications to formatting to use
11132 !                                         assumed-shape arrays
11133 !    2008-04-01  M. J. Iacono, AER, Inc.  Modified to add lw aerosol absorption
11134 !
11135 !  input :
11136 !    ncol     - Number of horizontal columns
11137 !    nlay     - Number of model layers
11138 !    icld     - Cloud overlap method (0: Clear only, 1: Random
11139 !                                     2: Maxiumu/random, 4: Maximum)
11140 !    play     - Layer     pressures (hPa, mb) (ncol,nlay)
11141 !    plev     - Interface pressures (hPa, mb) (ncol,nlay+1)
11142 !    tlay     - Layer     temperature (K) (ncol,nlay)
11143 !    tlev     - Interface temperature (K) (ncol,nlay+1)
11144 !    tsfc     - Surface   temperature (K) (ncol)
11145 !    h2ovmr   - H2O     volume mixing ratio (ncol,nlay)
11146 !    o3vmr    - O3      volume mixing ratio (ncol,nlay)
11147 !    co2vmr   - CO2     volume mixing ratio (ncol,nlay)
11148 !    ch4vmr   - Methane volume mixing ratio (ncol,nlay)
11149 !    n2ovmr   - Nitrous oxide volume mixing ratio (ncol,nlay)
11150 !    o2vmr    - Oxygen  volume mixing ratio (ncol,nlay)
11151 !    cfc11vmr - CFC11   volume mixing ratio (ncol,nlay)
11152 !    cfc12vmr - CFC12   volume mixing ratio (ncol,nlay)
11153 !    cfc22vmr - CFC22   volume mixing ratio (ncol,nlay)
11154 !    ccl4vmr  - CCL4    volume mixing ratio (ncol,nlay)
11155 !    emis     - Surface emissivity (ncol,nbndlw)
11156 !
11157 !    inflglw  - Flag for cloud optical properties
11158 !    iceflglw - Flag for ice particle specification
11159 !    liqflglw - Flag for liquid droplet specification
11160 !
11161 !    cldfmcl  - Cloud fraction (ngptlw,ncol,nlay)
11162 !    ciwpmcl  - In-cloud    ice water path (g/m2) (ngptlw,ncol,nlay)
11163 !    clwpmcl  - In-cloud liquid water path (g/m2) (ngptlw,ncol,nlay)
11164 !    cswpmcl  - In-cloud   snow water path (g/m2) (ngptlw,ncol,nlay)
11165 !    reicmcl  - Cloud ice particle effective size (microns) (ncol,nlay)
11166 !    relqmcl  - Cloud water drop effective radius (microns) (ncol,nlay)
11167 !    resnmcl  - Snow effective radius (microns) (ncol,nlay)
11168 !    taucmcl  - In-cloud optical depth (ngptlw,ncol,nlay)
11169 !    ssacmcl  - In-cloud single scattering albedo (ngptlw,ncol,nlay)
11170 !               for future expansion (lw scattering not yet available)
11171 !    asmcmcl  - In-cloud asymmetry parameter (ngptlw,ncol,nlay)
11172 !               for future expansion (lw scattering not yet available)
11173 !    tauaer   - aerosol optical depth at mid-point of LW spectral bands
11174 !                (ncol,nlay,nbndlw)
11175 !    ssaaer   - aerosol single scattering albedo (ncol,nlay,nbndlw)
11176 !               for future expansion (lw aerosols/scattering not yet available)
11177 !    asmaer   - aerosol asymmetry parameter (ncol,nlay,nbndlw)
11178 !               for future expansion (lw aerosols/scattering not yet available)
11179 !
11180 !  output :
11181 !    uflx     - Total sky longwave   upward flux (W/m2) (ncol,nlay+1)
11182 !    dflx     - Total sky longwave downward flux (W/m2) (ncol,nlay+1)
11183 !    hr       - Total sky longwave radiative heating rate (K/d) (ncol,nlay)
11184 !    uflxc    - Clear sky longwave   upward flux (W/m2) (ncol,nlay+1)
11185 !    dflxc    - Clear sky longwave downward flux (W/m2) (ncol,nlay+1)
11186 !    hrc      - Clear sky longwave radiative heating rate (K/d) (ncol,nlay)
11187 !
11188 !  local variable :
11189 !    nlayers  - total number of layers
11190 !    istart   - beginning band of calculation
11191 !    iend     - ending band of calculation
11192 !    iout     - output option flag (inactive)
11193 !    iaer     - aerosol option flag
11194 !    iplon    - column loop index
11195 !    imca     - flag for mcica [0=off, 1=on]
11196 !    ims      - value for changing mcica permute seed
11197 !    k        - layer loop index
11198 !    ig       - g-point loop index
11199 !
11200 !    pavel    - layer pressures (mb)
11201 !    tavel    - layer temperatures (K)
11202 !    pz       - level (interface) pressures (hPa, mb)
11203 !    tz       - level (interface) temperatures (K)
11204 !    tbound   - surface temperature (K)
11205 !    coldry   - dry air column density (mol/cm2)
11206 !    wbrodl   - broadening gas column density (mol/cm2)
11207 !    wkl      - molecular amounts (mol/cm-2)
11208 !    wx       - cross-section amounts (mol/cm-2)
11209 !    pwvcm    - precipitable water vapor (cm)
11210 !    semiss   - lw surface emissivity
11211 !    taug     - gaseous optical depths
11212 !    taut     - gaseous + aerosol optical depths
11213 !    taua     - aerosol optical depth
11214 !    ssaa     - aerosol single scattering albedo
11215 !               for future expansion (lw aerosols/scattering not yet available)
11216 !    asma     - aerosol asymmetry parameter
11217 !               for future expansion (lw aerosols/scattering not yet available)
11218 !
11219 !    laytrop  - tropopause layer index
11220 !    jp       - lookup table index
11221 !    jt       - lookup table index
11222 !    jt1      - lookup table index
11223 !    colh2o   - column amount (h2o)
11224 !    colco2   - column amount (co2)
11225 !    colo3    - column amount (o3)
11226 !    coln2o   - column amount (n2o)
11227 !    colco    - column amount (co)
11228 !    colch4   - column amount (ch4)
11229 !    colo2    - column amount (o2)
11230 !    colbrd   - column amount (broadening gases)
11231 !
11232 !    ncbands  - number of cloud spectral bands
11233 !    inflag   - flag for cloud property method
11234 !    iceflag  - flag for ice cloud properties
11235 !    liqflag  - flag for liquid cloud properties
11236 !
11237 !    cldfmc   - cloud fraction [mcica]
11238 !    ciwpmc   - in-cloud ice water path [mcica]
11239 !    clwpmc   - in-cloud liquid water path [mcica]
11240 !    cswpmc   - in-cloud snow path [mcica]
11241 !    relqmc   - liquid particle effective radius (microns)
11242 !    reicmc   - ice particle effective size (microns)
11243 !    resnmc   - snow particle effective size (microns)
11244 !    taucmc   - in-cloud optical depth [mcica]
11245 !    ssacmc   - in-cloud single scattering albedo [mcica]
11246 !               for future expansion (lw scattering not yet available)
11247 !    asmcmc   - in-cloud asymmetry parameter [mcica]
11248 !               for future expansion (lw scattering not yet available)
11249 !
11250 !    totuflux - upward longwave flux (w/m2)
11251 !    totdflux - downward longwave flux (w/m2)
11252 !    fnet     - net longwave flux (w/m2)
11253 !    htr      - longwave heating rate (k/day)
11254 !    totuclfl - clear sky upward longwave flux (w/m2)
11255 !    totdclfl - clear sky downward longwave flux (w/m2)
11256 !    fnetc    - clear sky net longwave flux (w/m2)
11257 !    htrc     - lear sky longwave heating rate (k/day)
11258 !
11259 !-------------------------------------------------------------------------------
11260    use parrrtm_k,  only : nbndlw, ngptlw, maxxsec, mxmol
11261    use rrlw_con_k, only : fluxfac, heatfac, oneminus, pi
11262    use rrlw_wvn_k, only : ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
11263 !
11264 ! ----- Input -----
11265 !
11266    integer(kind=im),                intent(in   ) :: ncol
11267    integer(kind=im),                intent(in   ) :: nlay
11268    integer(kind=im),                intent(inout) :: icld
11269 !
11270    real(kind=rb), dimension(:,:),   intent(in   ) :: play
11271    real(kind=rb), dimension(:,:),   intent(in   ) :: plev    ! nlay+1
11272    real(kind=rb), dimension(:,:),   intent(in   ) :: tlay
11273    real(kind=rb), dimension(:,:),   intent(in   ) :: tlev    ! nlay+1
11274    real(kind=rb), dimension(:),     intent(in   ) :: tsfc
11275    real(kind=rb), dimension(:,:),   intent(in   ) :: h2ovmr
11276    real(kind=rb), dimension(:,:),   intent(in   ) :: o3vmr
11277    real(kind=rb), dimension(:,:),   intent(in   ) :: co2vmr
11278    real(kind=rb), dimension(:,:),   intent(in   ) :: ch4vmr
11279    real(kind=rb), dimension(:,:),   intent(in   ) :: n2ovmr
11280    real(kind=rb), dimension(:,:),   intent(in   ) :: o2vmr
11281    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc11vmr
11282    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc12vmr
11283    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc22vmr
11284    real(kind=rb), dimension(:,:),   intent(in   ) :: ccl4vmr
11285    real(kind=rb), dimension(:,:),   intent(in   ) :: emis    ! nbndlw
11286 !
11287    integer(kind=im),                intent(in   ) :: inflglw
11288    integer(kind=im),                intent(in   ) :: iceflglw
11289    integer(kind=im),                intent(in   ) :: liqflglw
11290 !
11291    real(kind=rb), dimension(:,:,:), intent(in   ) :: cldfmcl
11292    real(kind=rb), dimension(:,:,:), intent(in   ) :: ciwpmcl
11293    real(kind=rb), dimension(:,:,:), intent(in   ) :: clwpmcl
11294    real(kind=rb), dimension(:,:,:), intent(in   ) :: cswpmcl
11295    real(kind=rb), dimension(:,:),   intent(in   ) :: reicmcl
11296    real(kind=rb), dimension(:,:),   intent(in   ) :: relqmcl
11297    real(kind=rb), dimension(:,:),   intent(in   ) :: resnmcl
11298    real(kind=rb), dimension(:,:,:), intent(in   ) :: taucmcl
11299 !  real(kind=rb), dimension(:,:,:), intent(in   ) :: ssacmcl
11300 !  real(kind=rb), dimension(:,:,:), intent(in   ) :: asmcmcl
11301    real(kind=rb), dimension(:,:,:), intent(in   ) :: tauaer
11302 !  real(kind=rb), dimension(:,:,:), intent(in   ) :: ssaaer
11303 !  real(kind=rb), dimension(:,:,:), intent(in   ) :: asmaer
11304 !
11305 ! ----- Output -----
11306 !
11307    real(kind=rb), dimension(:,:),   intent(  out) :: uflx    ! nlay+1
11308    real(kind=rb), dimension(:,:),   intent(  out) :: dflx    ! nlay+1
11309    real(kind=rb), dimension(:,:),   intent(  out) :: hr
11310    real(kind=rb), dimension(:,:),   intent(  out) :: uflxc   ! nlay+1
11311    real(kind=rb), dimension(:,:),   intent(  out) :: dflxc   ! nlay+1
11312    real(kind=rb), dimension(:,:),   intent(  out) :: hrc
11313 !
11314 ! ----- Local -----
11315 !
11316 ! Control
11317 !
11318    integer(kind=im)                               :: nlayers
11319    integer(kind=im)                               :: istart
11320    integer(kind=im)                               :: iend
11321    integer(kind=im)                               :: iout
11322    integer(kind=im)                               :: iaer
11323    integer(kind=im)                               :: iplon
11324    integer(kind=im)                               :: imca
11325    integer(kind=im)                               :: ims
11326    integer(kind=im)                               :: k
11327    integer(kind=im)                               :: ig
11328 !
11329 ! Atmosphere
11330 !
11331    real(kind=rb),    dimension(nlay+1)            :: pavel
11332    real(kind=rb),    dimension(nlay+1)            :: tavel
11333    real(kind=rb),    dimension(0:nlay+1)          :: pz
11334    real(kind=rb),    dimension(0:nlay+1)          :: tz
11335    real(kind=rb)                                  :: tbound
11336    real(kind=rb),    dimension(nlay+1)            :: coldry
11337    real(kind=rb),    dimension(nlay+1)            :: wbrodl
11338    real(kind=rb),    dimension(mxmol,nlay+1)      :: wkl
11339    real(kind=rb),    dimension(maxxsec,nlay+1)    :: wx
11340    real(kind=rb)                                  :: pwvcm
11341    real(kind=rb),    dimension(nbndlw)            :: semiss
11342    real(kind=rb),    dimension(nlay+1,ngptlw)     :: fracs
11343    real(kind=rb),    dimension(nlay+1,ngptlw)     :: taug
11344    real(kind=rb),    dimension(nlay+1,ngptlw)     :: taut
11345    real(kind=rb),    dimension(nlay+1,nbndlw)     :: taua
11346 !  real(kind=rb),    dimension(nlay+1,nbndlw)     :: ssaa
11347 !  real(kind=rb),    dimension(nlay+1,nbndlw)     :: asma
11348 !
11349 ! Atmosphere - setcoef
11350 !
11351    integer(kind=im)                               :: laytrop
11352    integer(kind=im), dimension(nlay+1)            :: jp
11353    integer(kind=im), dimension(nlay+1)            :: jt
11354    integer(kind=im), dimension(nlay+1)            :: jt1
11355    real(kind=rb),    dimension(nlay+1,nbndlw)     :: planklay
11356    real(kind=rb),    dimension(0:nlay+1,nbndlw)   :: planklev
11357    real(kind=rb),    dimension(nbndlw)            :: plankbnd
11358 !
11359    real(kind=rb),    dimension(nlay+1)            :: colh2o
11360    real(kind=rb),    dimension(nlay+1)            :: colco2
11361    real(kind=rb),    dimension(nlay+1)            :: colo3
11362    real(kind=rb),    dimension(nlay+1)            :: coln2o
11363    real(kind=rb),    dimension(nlay+1)            :: colco
11364    real(kind=rb),    dimension(nlay+1)            :: colch4
11365    real(kind=rb),    dimension(nlay+1)            :: colo2
11366    real(kind=rb),    dimension(nlay+1)            :: colbrd
11367 !
11368    integer(kind=im), dimension(nlay+1)            :: indself
11369    integer(kind=im), dimension(nlay+1)            :: indfor
11370    real(kind=rb),    dimension(nlay+1)            :: selffac
11371    real(kind=rb),    dimension(nlay+1)            :: selffrac
11372    real(kind=rb),    dimension(nlay+1)            :: forfac
11373    real(kind=rb),    dimension(nlay+1)            :: forfrac
11374 !
11375    integer(kind=im), dimension(nlay+1)            :: indminor
11376    real(kind=rb),    dimension(nlay+1)            :: minorfrac
11377    real(kind=rb),    dimension(nlay+1)            :: scaleminor
11378    real(kind=rb),    dimension(nlay+1)            :: scaleminorn2
11379 !
11380    real(kind=rb),    dimension(nlay+1)            :: fac00, fac01, fac10, fac11
11381    real(kind=rb),    dimension(nlay+1)            :: rat_h2oco2, rat_h2oco2_1, &
11382                                                      rat_h2oo3,  rat_h2oo3_1,  &
11383                                                      rat_h2on2o, rat_h2on2o_1, &
11384                                                      rat_h2och4, rat_h2och4_1, &
11385                                                      rat_n2oco2, rat_n2oco2_1, &
11386                                                      rat_o3co2,  rat_o3co2_1
11387 !
11388 ! Atmosphere/clouds - cldprop
11389 !
11390    integer(kind=im)                               :: ncbands
11391    integer(kind=im)                               :: inflag
11392    integer(kind=im)                               :: iceflag
11393    integer(kind=im)                               :: liqflag
11394 !
11395 ! Atmosphere/clouds - cldprmc [mcica]
11396 !
11397    real(kind=rb),    dimension(ngptlw,nlay+1)     :: cldfmc
11398    real(kind=rb),    dimension(ngptlw,nlay+1)     :: ciwpmc
11399    real(kind=rb),    dimension(ngptlw,nlay+1)     :: clwpmc
11400    real(kind=rb),    dimension(ngptlw,nlay+1)     :: cswpmc
11401    real(kind=rb),    dimension(nlay+1)            :: relqmc
11402    real(kind=rb),    dimension(nlay+1)            :: reicmc
11403    real(kind=rb),    dimension(nlay+1)            :: resnmc
11404    real(kind=rb),    dimension(ngptlw,nlay+1)     :: taucmc
11405 !  real(kind=rb),    dimension(ngptlw,nlay+1)     :: ssacmc
11406 !  real(kind=rb),    dimension(ngptlw,nlay+1)     :: asmcmc
11407 !
11408 ! Output
11409 !
11410    real(kind=rb),    dimension(0:nlay+1)          :: totuflux
11411    real(kind=rb),    dimension(0:nlay+1)          :: totdflux
11412    real(kind=rb),    dimension(0:nlay+1)          :: fnet
11413    real(kind=rb),    dimension(0:nlay+1)          :: htr
11414    real(kind=rb),    dimension(0:nlay+1)          :: totuclfl
11415    real(kind=rb),    dimension(0:nlay+1)          :: totdclfl
11416    real(kind=rb),    dimension(0:nlay+1)          :: fnetc
11417    real(kind=rb),    dimension(0:nlay+1)          :: htrc
11418 !-------------------------------------------------------------------------------
11419 !
11420 ! Initializations
11421 !
11422    oneminus = 1._rb - 1.e-6_rb
11423    pi = 2._rb * asin(1._rb)
11424    fluxfac = pi * 2.e4_rb                  ! orig:   fluxfac = pi * 2.d4
11425    istart = 1
11426    iend = 16
11427    iout = 0
11428    ims = 1
11429 !
11430 ! Set imca to select calculation type:
11431 ! imca = 0, use standard forward model calculation
11432 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
11433 !
11434 ! *** This version uses McICA (imca = 1) ***
11435 !
11436 ! Set icld to select of clear or cloud calculation and cloud overlap method
11437 ! icld = 0, clear only
11438 ! icld = 1, with clouds using random cloud overlap
11439 ! icld = 2, with clouds using maximum/random cloud overlap
11440 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
11441 !
11442    if (icld.lt.0.or.icld.gt.3) icld = 2
11443 !
11444 ! Set iaer to select aerosol option
11445 ! iaer = 0, no aerosols
11446 ! icld = 10, input total aerosol optical depth (tauaer) directly
11447 !
11448    iaer = 10
11449 !
11450 ! Call model and data initialization, compute lookup tables, perform
11451 ! reduction of g-points from 256 to 140 for input absorption coefficient
11452 ! data and other arrays.
11453 !
11454 ! In a GCM this call should be placed in the model initialization
11455 ! area, since this has to be called only once.
11456 !
11457 !  call rrtmg_lw_ini(cpdair)
11458 !
11459 ! This is the main longitude/column loop within RRTMG.
11460 !
11461    do iplon = 1,ncol
11462 !
11463 ! Prepare atmospheric profile from GCM for use in RRTMG, and define
11464 ! other input parameters.
11465 !
11466      call inatm (iplon, nlay, icld, iaer,                                      &
11467           play, plev, tlay, tlev, tsfc, h2ovmr,                                &
11468           o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr,            &
11469           cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw,                &
11470           cldfmcl, taucmcl,                                                    &
11471           ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer,                          &
11472           cswpmcl, resnmcl,                                                    &
11473           nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry,               &
11474           wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag,                    &
11475           cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc,                      &
11476           cswpmc, resnmc,                                                      &
11477           taua)
11478 !
11479 ! For cloudy atmosphere, use cldprop to set cloud optical properties based on
11480 ! input cloud physical properties.  Select method based on choices described
11481 ! in cldprop.  Cloud fraction, water path, liquid droplet and ice particle
11482 ! effective radius must be passed into cldprop.  Cloud fraction and cloud
11483 ! optical depth are transferred to rrtmg_lw arrays in cldprop.
11484 !
11485      call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc,           &
11486                   clwpmc, reicmc, relqmc,                                      &
11487                   cswpmc, resnmc,                                              &
11488                   ncbands, taucmc)
11489 !
11490 ! Calculate information needed by the radiative transfer routine
11491 ! that is specific to this atmosphere, especially some of the
11492 ! coefficients and indices needed to compute the optical depths
11493 ! by interpolating data from stored reference atmospheres.
11494 !
11495      call setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss,           &
11496                   coldry, wkl, wbrodl,                                         &
11497                   laytrop, jp, jt, jt1, planklay, planklev, plankbnd,          &
11498                   colh2o, colco2, colo3, coln2o, colco, colch4, colo2,         &
11499                   colbrd, fac00, fac01, fac10, fac11,                          &
11500                   rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1,            &
11501                   rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1,          &
11502                   rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1,            &
11503                   selffac, selffrac, indself, forfac, forfrac, indfor,         &
11504                   minorfrac, scaleminor, scaleminorn2, indminor)
11505 !
11506 ! Calculate the gaseous optical depths and Planck fractions for
11507 ! each longwave spectral band.
11508 !
11509      call taumol(nlayers, pavel, wx, coldry,                                   &
11510                  laytrop, jp, jt, jt1, planklay, planklev, plankbnd,           &
11511                  colh2o, colco2, colo3, coln2o, colco, colch4, colo2,          &
11512                  colbrd, fac00, fac01, fac10, fac11,                           &
11513                  rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1,             &
11514                  rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1,           &
11515                  rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1,             &
11516                  selffac, selffrac, indself, forfac, forfrac, indfor,          &
11517                  minorfrac, scaleminor, scaleminorn2, indminor,                &
11518                  fracs, taug)
11519 !
11520 ! Combine gaseous and aerosol optical depths, if aerosol active
11521 !
11522      if (iaer .eq. 0) then
11523        do k = 1,nlayers
11524          do ig = 1,ngptlw
11525            taut(k,ig) = taug(k,ig)
11526          enddo
11527        enddo
11528      else if (iaer .eq. 10) then
11529        do k = 1,nlayers
11530          do ig = 1,ngptlw
11531            taut(k,ig) = taug(k,ig) + taua(k,ngb(ig))
11532          enddo
11533        enddo
11534      endif
11535 !
11536 ! Call the radiative transfer routine.
11537 ! Either routine can be called to do clear sky calculation.  If clouds
11538 ! are present, then select routine based on cloud overlap assumption
11539 ! to be used.  Clear sky calculation is done simultaneously.
11540 ! For McICA, RTRNMC is called for clear and cloudy calculations.
11541 !
11542      call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands,             &
11543                  cldfmc, taucmc, planklay, planklev, plankbnd,                 &
11544                  pwvcm, fracs, taut,                                           &
11545                  totuflux, totdflux, fnet, htr,                                &
11546                  totuclfl, totdclfl, fnetc, htrc )
11547 !
11548 ! Transfer up and down fluxes and heating rate to output arrays.
11549 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
11550 !
11551      do k = 0,nlayers
11552        uflx(iplon,k+1) = totuflux(k)
11553        dflx(iplon,k+1) = totdflux(k)
11554        uflxc(iplon,k+1) = totuclfl(k)
11555        dflxc(iplon,k+1) = totdclfl(k)
11556      enddo
11557 !
11558      do k = 0,nlayers-1
11559        hr(iplon,k+1) = htr(k)
11560        hrc(iplon,k+1) = htrc(k)
11561      enddo
11562    enddo
11563 !
11564    end subroutine rrtmg_lw
11565 !-------------------------------------------------------------------------------
11566 !
11567 !
11568 !-------------------------------------------------------------------------------
11569    subroutine inatm (iplon, nlay, icld, iaer,                                  &
11570               play, plev, tlay, tlev, tsfc, h2ovmr,                            &
11571               o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr,        &
11572               cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw,            &
11573               cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer,    &
11574               cswpmcl, resnmcl,                                                &
11575               nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry,           &
11576               wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag,                &
11577               cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc,                  &
11578               cswpmc, resnmc,                                                  &
11579               taua)
11580 !-------------------------------------------------------------------------------
11581 !
11582 !  abstract :
11583 !  Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
11584 !  Set other RRTMG_LW input parameters.
11585 !
11586 !  input :
11587 !    iplon    - Column loop index
11588 !    nlay     - Number of model layers
11589 !    icld     - Cloud overlap method (0: Clear only, 1: Random
11590 !                                     2: Maxiumu/random, 4: Maximum)
11591 !    iaer     - Aerosol option flag
11592 !
11593 !    play     - Layer     pressures (hPa, mb) (ncol,nlay)
11594 !    plev     - Interface pressures (hPa, mb) (ncol,nlay+1)
11595 !    tlay     - Layer     temperature (K) (ncol,nlay)
11596 !    tlev     - Interface temperature (K) (ncol,nlay+1)
11597 !    tsfc     - Surface   temperature (K) (ncol)
11598 !    h2ovmr   - H2O     volume mixing ratio (ncol,nlay)
11599 !    o3vmr    - O3      volume mixing ratio (ncol,nlay)
11600 !    co2vmr   - CO2     volume mixing ratio (ncol,nlay)
11601 !    ch4vmr   - Methane volume mixing ratio (ncol,nlay)
11602 !    n2ovmr   - Nitrous oxide volume mixing ratio (ncol,nlay)
11603 !    o2vmr    - Oxygen  volume mixing ratio (ncol,nlay)
11604 !    cfc11vmr - CFC11   volume mixing ratio (ncol,nlay)
11605 !    cfc12vmr - CFC12   volume mixing ratio (ncol,nlay)
11606 !    cfc22vmr - CFC22   volume mixing ratio (ncol,nlay)
11607 !    ccl4vmr  - CCL4    volume mixing ratio (ncol,nlay)
11608 !    emis     - Surface emissivity (ncol,nbndlw)
11609 !
11610 !    inflglw  - Flag for cloud optical properties
11611 !    iceflglw - Flag for ice particle specification
11612 !    liqflglw - Flag for liquid droplet specification
11613 !
11614 !    cldfmcl  - Cloud fraction (ngptlw,ncol,nlay)
11615 !    ciwpmcl  - In-cloud    ice water path (g/m2) (ngptlw,ncol,nlay)
11616 !    clwpmcl  - In-cloud liquid water path (g/m2) (ngptlw,ncol,nlay)
11617 !    cswpmcl  - In-cloud   snow water path (g/m2) (ngptlw,ncol,nlay)
11618 !    reicmcl  - Cloud ice particle effective size (microns) (ncol,nlay)
11619 !    relqmcl  - Cloud water drop effective radius (microns) (ncol,nlay)
11620 !    resnmcl  - Snow effective radius (microns) (ncol,nlay)
11621 !    taucmcl  - In-cloud optical depth (ngptlw,ncol,nlay)
11622 !    tauaer   - aerosol  optical depth (ncol,nlay,nbndlw)
11623 !
11624 !  output :
11625 !    nlayers  - number of layers
11626 !    pavel    - layer pressures (mb)
11627 !    tavel    - layer temperatures (K)
11628 !    pz       - level (interface) pressures (hPa, mb)
11629 !    tz       - level (interface) temperatures (K)
11630 !    tbound   - surface temperature (K)
11631 !    coldry   - dry air column density (mol/cm2)
11632 !    wbrodl   - broadening gas column density (mol/cm2)
11633 !    wkl      - molecular amounts (mol/cm-2)
11634 !    wx       - cross-section amounts (mol/cm-2)
11635 !    pwvcm    - precipitable water vapor (cm)
11636 !    semiss   - lw surface emissivity
11637 !
11638 !    inflag   - flag for cloud property method
11639 !    iceflag  - flag for ice cloud properties
11640 !    liqflag  - flag for liquid cloud properties
11641 !    cldfmc   - cloud fraction [mcica]
11642 !    ciwpmc   - in-cloud ice water path [mcica]
11643 !    clwpmc   - in-cloud liquid water path [mcica]
11644 !    cswpmc   - in-cloud snow path [mcica]
11645 !    relqmc   - liquid particle effective radius (microns)
11646 !    reicmc   - ice particle effective size (microns)
11647 !    resnmc   - snow particle effective size (microns)
11648 !    taucmc   - in-cloud optical depth [mcica]
11649 !    taua     - aerosol optical depth
11650 !
11651 !  local variable :
11652 !    amd      - Effective molecular weight of dry air (g/mol)
11653 !    amw      - Molecular weight of water vapor (g/mol)
11654 !    amc      - Molecular weight of carbon dioxide (g/mol)
11655 !    amo      - Molecular weight of ozone (g/mol)
11656 !    amo2     - Molecular weight of oxygen (g/mol)
11657 !    amch4    - Molecular weight of methane (g/mol)
11658 !    amn2o    - Molecular weight of nitrous oxide (g/mol)
11659 !    amc11    - Molecular weight of CFC11 (g/mol) - CCL3F
11660 !    amc12    - Molecular weight of CFC12 (g/mol) - CCL2F2
11661 !    amc22    - Molecular weight of CFC22 (g/mol) - CHCLF2
11662 !    amc14    - Molecular weight of CCL4  (g/mol) - CCL4
11663 !
11664 !    amdw     - Molecular weight of dry air / water vapor
11665 !    amdc     - Molecular weight of dry air / carbon dioxide
11666 !    amdo     - Molecular weight of dry air / ozone
11667 !    amdm     - Molecular weight of dry air / methane
11668 !    amdn     - Molecular weight of dry air / nitrous oxide
11669 !    amdo2    - Molecular weight of dry air / oxygen
11670 !    amdc1    - Molecular weight of dry air / CFC11
11671 !    amdc2    - Molecular weight of dry air / CFC12
11672 !
11673 !-------------------------------------------------------------------------------
11674    use parrrtm_k,  only : nbndlw, ngptlw, nmol, maxxsec, mxmol
11675    use rrlw_con_k, only : fluxfac, heatfac, oneminus, pi, grav, avogad
11676    use rrlw_wvn_k, only : ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
11677 !
11678 ! ----- Input -----
11679 !
11680    integer(kind=im),                intent(in   ) :: iplon
11681    integer(kind=im),                intent(in   ) :: nlay
11682    integer(kind=im),                intent(in   ) :: icld
11683    integer(kind=im),                intent(in   ) :: iaer
11684 !
11685    real(kind=rb), dimension(:,:),   intent(in   ) :: play
11686    real(kind=rb), dimension(:,:),   intent(in   ) :: plev    ! nlay+1
11687    real(kind=rb), dimension(:,:),   intent(in   ) :: tlay
11688    real(kind=rb), dimension(:,:),   intent(in   ) :: tlev    ! nlay+1
11689    real(kind=rb), dimension(:),     intent(in   ) :: tsfc
11690    real(kind=rb), dimension(:,:),   intent(in   ) :: h2ovmr
11691    real(kind=rb), dimension(:,:),   intent(in   ) :: o3vmr
11692    real(kind=rb), dimension(:,:),   intent(in   ) :: co2vmr
11693    real(kind=rb), dimension(:,:),   intent(in   ) :: ch4vmr
11694    real(kind=rb), dimension(:,:),   intent(in   ) :: n2ovmr
11695    real(kind=rb), dimension(:,:),   intent(in   ) :: o2vmr
11696    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc11vmr
11697    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc12vmr
11698    real(kind=rb), dimension(:,:),   intent(in   ) :: cfc22vmr
11699    real(kind=rb), dimension(:,:),   intent(in   ) :: ccl4vmr
11700    real(kind=rb), dimension(:,:),   intent(in   ) :: emis    ! nbndlw
11701 !
11702    integer(kind=im),                intent(in   ) :: inflglw
11703    integer(kind=im),                intent(in   ) :: iceflglw
11704    integer(kind=im),                intent(in   ) :: liqflglw
11705 !
11706    real(kind=rb), dimension(:,:,:), intent(in   ) :: cldfmcl
11707    real(kind=rb), dimension(:,:,:), intent(in   ) :: ciwpmcl
11708    real(kind=rb), dimension(:,:,:), intent(in   ) :: clwpmcl
11709    real(kind=rb), dimension(:,:,:), intent(in   ) :: cswpmcl
11710    real(kind=rb), dimension(:,:),   intent(in   ) :: reicmcl
11711    real(kind=rb), dimension(:,:),   intent(in   ) :: relqmcl
11712    real(kind=rb), dimension(:,:),   intent(in   ) :: resnmcl
11713    real(kind=rb), dimension(:,:,:), intent(in   ) :: taucmcl
11714    real(kind=rb), dimension(:,:,:), intent(in   ) :: tauaer
11715 !
11716 ! ----- Output -----
11717 !
11718 ! Atmosphere
11719 !
11720    integer(kind=im),                intent(  out) :: nlayers
11721    real(kind=rb), dimension(:),     intent(  out) :: pavel
11722    real(kind=rb), dimension(:),     intent(  out) :: tavel
11723    real(kind=rb), dimension(0:),    intent(  out) :: pz
11724    real(kind=rb), dimension(0:),    intent(  out) :: tz
11725    real(kind=rb),                   intent(  out) :: tbound
11726    real(kind=rb), dimension(:),     intent(  out) :: coldry
11727    real(kind=rb), dimension(:),     intent(  out) :: wbrodl
11728    real(kind=rb), dimension(:,:),   intent(  out) :: wkl
11729    real(kind=rb), dimension(:,:),   intent(  out) :: wx
11730    real(kind=rb),                   intent(  out) :: pwvcm
11731    real(kind=rb), dimension(:),     intent(  out) :: semiss
11732 !
11733 ! Atmosphere/clouds - cldprop
11734 !
11735    integer(kind=im),                intent(  out) :: inflag
11736    integer(kind=im),                intent(  out) :: iceflag
11737    integer(kind=im),                intent(  out) :: liqflag
11738    real(kind=rb), dimension(:,:),   intent(  out) :: cldfmc
11739    real(kind=rb), dimension(:,:),   intent(  out) :: ciwpmc
11740    real(kind=rb), dimension(:,:),   intent(  out) :: clwpmc
11741    real(kind=rb), dimension(:,:),   intent(  out) :: cswpmc
11742    real(kind=rb), dimension(:),     intent(  out) :: relqmc
11743    real(kind=rb), dimension(:),     intent(  out) :: reicmc
11744    real(kind=rb), dimension(:),     intent(  out) :: resnmc
11745    real(kind=rb), dimension(:,:),   intent(  out) :: taucmc
11746    real(kind=rb), dimension(:,:),   intent(  out) :: taua
11747 !
11748 ! ----- Local -----
11749 !
11750    real(kind=rb), parameter :: amd = 28.9660_rb
11751    real(kind=rb), parameter :: amw = 18.0160_rb
11752 !  real(kind=rb), parameter :: amc = 44.0098_rb
11753 !  real(kind=rb), parameter :: amo = 47.9998_rb
11754 !  real(kind=rb), parameter :: amo2 = 31.9999_rb
11755 !  real(kind=rb), parameter :: amch4 = 16.0430_rb
11756 !  real(kind=rb), parameter :: amn2o = 44.0128_rb
11757 !  real(kind=rb), parameter :: amc11 = 137.3684_rb
11758 !  real(kind=rb), parameter :: amc12 = 120.9138_rb
11759 !  real(kind=rb), parameter :: amc22 = 86.4688_rb
11760 !  real(kind=rb), parameter :: amcl4 = 153.823_rb
11761 !
11762 ! Set molecular weight ratios (for converting mmr to vmr)
11763 ! e.g. h2ovmr = h2ommr * amdw)
11764 !
11765    real(kind=rb), parameter :: amdw = 1.607793_rb
11766    real(kind=rb), parameter :: amdc = 0.658114_rb
11767    real(kind=rb), parameter :: amdo = 0.603428_rb
11768    real(kind=rb), parameter :: amdm = 1.805423_rb
11769    real(kind=rb), parameter :: amdn = 0.658090_rb
11770    real(kind=rb), parameter :: amdo2 = 0.905140_rb
11771    real(kind=rb), parameter :: amdc1 = 0.210852_rb
11772    real(kind=rb), parameter :: amdc2 = 0.239546_rb
11773 !
11774    integer(kind=im)         :: isp, l, ix, n, imol, ib, ig   ! Loop indices
11775    real(kind=rb)            :: amm, amttl, wvttl, wvsh, summol
11776 !-------------------------------------------------------------------------------
11777 !
11778 ! Add one to nlayers here to include extra model layer at top of atmosphere
11779 !
11780    nlayers = nlay
11781 !
11782 ! Initialize all molecular amounts and cloud properties to zero here,
11783 ! then pass input amounts into RRTM arrays below.
11784 !
11785    wkl    = 0.0_rb ; wx     = 0.0_rb ; cldfmc = 0.0_rb
11786    taucmc = 0.0_rb ; ciwpmc = 0.0_rb ; clwpmc = 0.0_rb
11787    cswpmc = 0.0_rb
11788    reicmc = 0.0_rb ; relqmc = 0.0_rb
11789    resnmc = 0.0_rb
11790    taua   = 0.0_rb ; amttl  = 0.0_rb ; wvttl  = 0.0_rb
11791 !
11792 ! Set surface temperature.
11793 !
11794    tbound = tsfc(iplon)
11795 !
11796 ! Install input GCM arrays into RRTMG_LW arrays for pressure, temperature,
11797 ! and molecular amounts.
11798 ! Pressures are input in mb, or are converted to mb here.
11799 ! Molecular amounts are input in volume mixing ratio, or are converted from
11800 ! mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
11801 ! here. These are then converted to molecular amount (molec/cm2) below.
11802 ! The dry air column COLDRY (in molec/cm2) is calculated from the level
11803 ! pressures, pz (in mb), based on the hydrostatic equation and includes a
11804 ! correction to account for h2o in the layer.  The molecular weight of moist
11805 ! air (amm) is calculated for each layer.
11806 ! Note: In RRTMG, layer indexing goes from bottom to top, and coding below
11807 ! assumes GCM input fields are also bottom to top. Input layer indexing
11808 ! from GCM fields should be reversed here if necessary.
11809 !
11810    pz(0) = plev(iplon,1)
11811    tz(0) = tlev(iplon,1)
11812 !
11813    do l = 1,nlayers
11814      pavel(l) = play(iplon,l)
11815      tavel(l) = tlay(iplon,l)
11816      pz(l) = plev(iplon,l+1)
11817      tz(l) = tlev(iplon,l+1)
11818 !
11819 ! For h2o input in vmr:
11820 !
11821      wkl(1,l) = h2ovmr(iplon,l)
11822 !
11823 ! For h2o input in mmr:
11824 !
11825 !    wkl(1,l) = h2o(iplon,l)*amdw
11826 !
11827 ! For h2o input in specific humidity;
11828 !
11829 !    wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
11830 !
11831      wkl(2,l) = co2vmr(iplon,l)
11832      wkl(3,l) = o3vmr(iplon,l)
11833      wkl(4,l) = n2ovmr(iplon,l)
11834      wkl(6,l) = ch4vmr(iplon,l)
11835      wkl(7,l) = o2vmr(iplon,l)
11836      amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
11837      coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad /                          &
11838                  (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
11839    enddo
11840 !
11841 ! Set cross section molecule amounts from input; convert to vmr if necessary
11842 !
11843    do l = 1,nlayers
11844      wx(1,l) = ccl4vmr(iplon,l)
11845      wx(2,l) = cfc11vmr(iplon,l)
11846      wx(3,l) = cfc12vmr(iplon,l)
11847      wx(4,l) = cfc22vmr(iplon,l)
11848    enddo
11849 !
11850 ! The following section can be used to set values for an additional layer (from
11851 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
11852 ! Temperature and molecular amounts in the extra model layer are set to
11853 ! their values in the top GCM model layer, though these can be modified
11854 ! here if necessary.
11855 ! If this feature is utilized, increase nlayers by one above, limit the two
11856 ! loops above to (nlayers-1), and set the top most (extra) layer values here.
11857 !
11858 !  pavel(nlayers) = 0.5_rb * pz(nlayers-1)
11859 !  tavel(nlayers) = tavel(nlayers-1)
11860 !  pz(nlayers) = 1.e-4_rb
11861 !  tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
11862 !  tz(nlayers) = tz(nlayers-1)
11863 !  wkl(1,nlayers) = wkl(1,nlayers-1)
11864 !  wkl(2,nlayers) = wkl(2,nlayers-1)
11865 !  wkl(3,nlayers) = wkl(3,nlayers-1)
11866 !  wkl(4,nlayers) = wkl(4,nlayers-1)
11867 !  wkl(6,nlayers) = wkl(6,nlayers-1)
11868 !  wkl(7,nlayers) = wkl(7,nlayers-1)
11869 !  amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
11870 !  coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad /                      &
11871 !                    (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
11872 !  wx(1,nlayers) = wx(1,nlayers-1)
11873 !  wx(2,nlayers) = wx(2,nlayers-1)
11874 !  wx(3,nlayers) = wx(3,nlayers-1)
11875 !  wx(4,nlayers) = wx(4,nlayers-1)
11876 !
11877 ! At this point all molecular amounts in wkl and wx are in volume mixing ratio;
11878 ! convert to molec/cm2 based on coldry for use in rrtm.  also, compute
11879 ! precipitable water vapor for diffusivity angle adjustments in rtrn and rtrnmr.
11880 !
11881    do l = 1,nlayers
11882      summol = 0.0_rb
11883      do imol = 2,nmol
11884        summol = summol + wkl(imol,l)
11885      enddo
11886 !
11887      wbrodl(l) = coldry(l) * (1._rb - summol)
11888      do imol = 1,nmol
11889        wkl(imol,l) = coldry(l) * wkl(imol,l)
11890      enddo
11891 !
11892      amttl = amttl + coldry(l)+wkl(1,l)
11893      wvttl = wvttl + wkl(1,l)
11894      do ix = 1,maxxsec
11895        if (ixindx(ix) .ne. 0) then
11896          wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb
11897        endif
11898      enddo
11899    enddo
11900 !
11901    wvsh = (amw * wvttl) / (amd * amttl)
11902    pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav)
11903 !
11904 ! Set spectral surface emissivity for each longwave band.
11905 !
11906    do n = 1,nbndlw
11907      semiss(n) = emis(iplon,n)
11908 !    semiss(n) = 1.0_rb
11909    enddo
11910 !
11911 ! Transfer aerosol optical properties to RRTM variable;
11912 ! modify to reverse layer indexing here if necessary.
11913 !
11914    if (iaer .ge. 1) then
11915      do l = 1,nlayers
11916        do ib = 1,nbndlw
11917          taua(l,ib) = tauaer(iplon,l,ib)
11918        enddo
11919      enddo
11920    endif
11921 !
11922 ! Transfer cloud fraction and cloud optical properties to RRTM variables,
11923 ! modify to reverse layer indexing here if necessary.
11924 !
11925    if (icld .ge. 1) then
11926      inflag = inflglw
11927      iceflag = iceflglw
11928      liqflag = liqflglw
11929 !
11930 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
11931 ! For GCM input, incoming reicmcl is defined based on selected ice
11932 ! parameterization (inflglw)
11933 !
11934      do l = 1,nlayers
11935        do ig = 1,ngptlw
11936          cldfmc(ig,l) = cldfmcl(ig,iplon,l)
11937          taucmc(ig,l) = taucmcl(ig,iplon,l)
11938          ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
11939          clwpmc(ig,l) = clwpmcl(ig,iplon,l)
11940          cswpmc(ig,l) = cswpmcl(ig,iplon,l)
11941        enddo
11942        reicmc(l) = reicmcl(iplon,l)
11943        relqmc(l) = relqmcl(iplon,l)
11944        resnmc(l) = resnmcl(iplon,l)
11945      enddo
11946 !
11947 ! If an extra layer is being used in RRTMG,
11948 ! set all cloud properties to zero in the extra layer.
11949 !
11950 !    cldfmc(:,nlayers) = 0.0_rb
11951 !    taucmc(:,nlayers) = 0.0_rb
11952 !    ciwpmc(:,nlayers) = 0.0_rb
11953 !    clwpmc(:,nlayers) = 0.0_rb
11954 !    reicmc(nlayers) = 0.0_rb
11955 !    relqmc(nlayers) = 0.0_rb
11956 !    taua(nlayers,:) = 0.0_rb
11957 !
11958    endif
11959 !
11960    end subroutine inatm
11961 !-------------------------------------------------------------------------------
11962 !
11963 !
11964 !-------------------------------------------------------------------------------
11965    end module rrtmg_lw_rad_k
11966 !-------------------------------------------------------------------------------
11967 !
11968 !
11969 !-------------------------------------------------------------------------------
11970    module module_ra_rrtmg_lwk
11971 !-------------------------------------------------------------------------------
11972 !   use rad_effective_radius,   only : effectRad_wdm, cldf_to_qcqi
11973 !  use comio
11974    use parrrtm_k,                only : nbndlw, ngptlw
11975    use rrtmg_lw_init_k,          only : rrtmg_lw_ini
11976    use rrtmg_lw_rad_k,           only : rrtmg_lw
11977    use mcica_subcol_gen_k,       only : mcica_subcol
11978 !
11979    real retab(95)
11980    data retab /                                                                &
11981          5.92779, 6.26422, 6.61973, 6.99539, 7.39234,                          &
11982          7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930,                 &
11983          10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319,                 &
11984          15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955,                 &
11985          20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125,                 &
11986          27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943,                 &
11987          31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601,                 &
11988          34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078,                 &
11989          38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635,                 &
11990          42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221,                 &
11991          50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898,                 &
11992          65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833,                 &
11993          93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424,                 &
11994          124.954, 130.630, 136.457, 142.446, 148.608, 154.956,                 &
11995          161.503, 168.262, 175.248, 182.473, 189.952, 197.699,                 &
11996          205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
11997 !
11998    save retab
11999 !
12000 ! For buffer layer adjustment.  Steven Cavallo, Dec 2010.
12001 !
12002    real, parameter    :: qmin=0., cp=1.0046e+3, t0c=2.7315e+2, rd=2.8705e+2
12003    integer, save   :: nlayers
12004    real, parameter :: deltap = 4.  ! Pressure interval for buffer layer in mb
12005 !-------------------------------------------------------------------------------
12006    contains
12007 !-------------------------------------------------------------------------------
12008 !-------------------------------------------------------------------------------
12009    subroutine inirad (o3prof, plev, kts, kte)
12010 !-------------------------------------------------------------------------------
12011 !
12012 !  abstract : compute ozone mixing ratio distribution
12013 !
12014 !-------------------------------------------------------------------------------
12015 !
12016    implicit none
12017 !
12018    integer,                      intent(in   ) :: kts, kte
12019    real, dimension( kts:kte+1 ), intent(inout) :: o3prof
12020    real, dimension( kts:kte+2 ), intent(in   ) :: plev
12021 !
12022 ! local var
12023 !
12024    integer :: k
12025 !-------------------------------------------------------------------------------
12026 !
12027    do k = kts,kte+1
12028      o3prof(k) = 0.
12029    enddo
12030 !
12031    call o3data(o3prof, plev, kts, kte)
12032 !
12033    end subroutine inirad
12034 !-------------------------------------------------------------------------------
12035 !
12036 !
12037 !-------------------------------------------------------------------------------
12038    subroutine o3data (o3prof, plev, kts, kte)
12039 !-------------------------------------------------------------------------------
12040 !
12041    implicit none
12042 !
12043    integer,                      intent(in   ) :: kts, kte
12044    real, dimension( kts:kte+1 ), intent(inout) :: o3prof
12045    real, dimension( kts:kte+2 ), intent(in   ) :: plev
12046 !
12047 ! local var
12048 !
12049    integer ::  k, jj
12050    real, dimension(kts:kte+2) :: prlevh
12051    real, dimension(32)        :: ppwrkh
12052    real, dimension(31)        :: o3wrk, ppwrk, o3sum, ppsum,                   &
12053                                  o3win, ppwin, o3ann, ppann
12054    real    ::  pb1, pb2, pt1, pt2
12055 !
12056    data o3sum  /5.297e-8,5.852e-8,6.579e-8,7.505e-8,                           &
12057                 8.577e-8,9.895e-8,1.175e-7,1.399e-7,1.677e-7,2.003e-7,         &
12058                 2.571e-7,3.325e-7,4.438e-7,6.255e-7,8.168e-7,1.036e-6,         &
12059                 1.366e-6,1.855e-6,2.514e-6,3.240e-6,4.033e-6,4.854e-6,         &
12060                 5.517e-6,6.089e-6,6.689e-6,1.106e-5,1.462e-5,1.321e-5,         &
12061                 9.856e-6,5.960e-6,5.960e-6/
12062 !
12063    data ppsum  /955.890,850.532,754.599,667.742,589.841,                       &
12064                 519.421,455.480,398.085,347.171,301.735,261.310,225.360,       &
12065                 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123,       &
12066                 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122,        &
12067                 9.277,  4.660,  2.421,  1.294,  0.647/
12068 !
12069    data o3win  /4.629e-8,4.686e-8,5.017e-8,5.613e-8,                           &
12070                 6.871e-8,8.751e-8,1.138e-7,1.516e-7,2.161e-7,3.264e-7,         &
12071                 4.968e-7,7.338e-7,1.017e-6,1.308e-6,1.625e-6,2.011e-6,         &
12072                 2.516e-6,3.130e-6,3.840e-6,4.703e-6,5.486e-6,6.289e-6,         &
12073                 6.993e-6,7.494e-6,8.197e-6,9.632e-6,1.113e-5,1.146e-5,         &
12074                 9.389e-6,6.135e-6,6.135e-6/
12075 !
12076    data ppwin  /955.747,841.783,740.199,649.538,568.404,                       &
12077                 495.815,431.069,373.464,322.354,277.190,237.635,203.433,       &
12078                 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940,       &
12079                 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423,        &
12080                 7.583,  3.620,  1.807,  0.938,  0.469/
12081 !-------------------------------------------------------------------------------
12082 !
12083    do k = 1,31
12084      ppann(k) = ppsum(k)
12085    enddo
12086 !
12087    o3ann(1) = 0.5*(o3sum(1)+o3win(1))
12088 !
12089    do k = 2,31
12090      o3ann(k) = o3win(k-1)+(o3win(k)-o3win(k-1))/(ppwin(k)-ppwin(k-1))*        &
12091                (ppsum(k)-ppwin(k-1))
12092    enddo
12093 !
12094    do k = 2,31
12095      o3ann(k) = 0.5*(o3ann(k)+o3sum(k))
12096    enddo
12097 !
12098    do k = 1,31
12099      o3wrk(k) = o3ann(k)
12100      ppwrk(k) = ppann(k)
12101    enddo
12102 !
12103 ! calculate half pressure levels for model.and.data levels
12104 !
12105 ! plev is total P at model levels, from bottom to top
12106 ! plev is in mb
12107 !
12108    do k = kts,kte+2
12109      prlevh(k) = plev(k)
12110    enddo
12111 !
12112    ppwrkh(1) = 1100.
12113    do k = 2,31
12114      ppwrkh(k) = (ppwrk(k)+ppwrk(k-1))/2.
12115    enddo
12116 !
12117    ppwrkh(32) = 0.
12118    do k = kts,kte+1
12119      do 25 jj = 1,31
12120        if ((-(prlevh(k)-ppwrkh(jj))).ge.0.) then
12121          pb1 = 0.
12122        else
12123          pb1 = prlevh(k)-ppwrkh(jj)
12124        endif
12125 !
12126        if ((-(prlevh(k)-ppwrkh(jj+1))).ge.0.) then
12127          pb2 = 0.
12128        else
12129          pb2 = prlevh(k)-ppwrkh(jj+1)
12130        endif
12131 !
12132        if ((-(prlevh(k+1)-ppwrkh(jj))).ge.0.) then
12133          pt1 = 0.
12134        else
12135          pt1 = prlevh(k+1)-ppwrkh(jj)
12136        endif
12137 !
12138        if ((-(prlevh(k+1)-ppwrkh(jj+1))).ge.0.) then
12139          pt2 = 0.
12140        else
12141          pt2 = prlevh(k+1)-ppwrkh(jj+1)
12142        endif
12143 !
12144        o3prof(k) = o3prof(k)+(pb2-pb1-pt2+pt1)*o3wrk(jj)
12145   25 continue
12146      o3prof(k) = o3prof(k)/(prlevh(k)-prlevh(k+1))
12147    enddo
12148 !
12149    end subroutine o3data
12150 !-------------------------------------------------------------------------------
12151 !
12152 !
12153 !-------------------------------------------------------------------------------
12154    subroutine rrtmg_lwinit_k(                                                  &
12155                        allowed_to_read ,                                       &
12156                        ids, ide, jds, jde, kds, kde,                           &
12157                        ims, ime, jms, jme, kms, kme,                           &
12158                        its, ite, jts, jte, kts, kte                 )
12159 !-------------------------------------------------------------------------------
12160 !
12161    implicit none
12162 !
12163    logical , intent(in   )           :: allowed_to_read
12164    integer , intent(in   )           :: ids, ide, jds, jde, kds, kde,          &
12165                                         ims, ime, jms, jme, kms, kme,          &
12166                                         its, ite, jts, jte, kts, kte
12167 !-------------------------------------------------------------------------------
12168 !
12169    nlayers = kte  ! changed, shbaek
12170 !
12171 ! Read in absorption coefficients and other data
12172 !
12173    if (allowed_to_read) then
12174      call rrtmg_lwlookuptable
12175    endif
12176 !
12177 ! Perform g-point reduction and other initializations
12178 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
12179 !
12180    call rrtmg_lw_ini(cp)
12181 !
12182    end subroutine rrtmg_lwinit_k
12183 !-------------------------------------------------------------------------------
12184 !
12185 !
12186 !-------------------------------------------------------------------------------
12187    subroutine rrtmg_lwlookuptable
12188 !-------------------------------------------------------------------------------
12189 !
12190    implicit none
12191 !
12192 ! Local
12193 !
12194    integer                 :: i
12195    logical                 :: opened
12196    logical , external      :: wrf_dm_on_monitor
12197 !
12198    character*80            :: errmess
12199    integer                 :: rrtmg_unit
12200 !-------------------------------------------------------------------------------
12201 !
12202
12203    if (wrf_dm_on_monitor()) then
12204      do i = 10,99
12205        inquire ( i , opened = opened )
12206        if ( .not. opened ) then
12207          rrtmg_unit = i
12208          goto 2010
12209        endif
12210      enddo
12211      rrtmg_unit = -1
12212 2010 continue
12213    endif
12214 !
12215
12216
12217      CALL wrf_dm_bcast_bytes ( rrtmg_unit , 4 )
12218       IF ( rrtmg_unit < 0 ) THEN
12219         CALL wrf_error_fatal ( 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// &
12220                                'find unused fortran unit to read in lookup table.' )
12221       ENDIF
12222
12223
12224    if ( wrf_dm_on_monitor() ) then
12225      open(rrtmg_unit,file='RRTMG_LW_DATA',                                     &
12226              form='unformatted',status='old',err=9009)
12227    endif
12228 !
12229    call lw_kgb01(rrtmg_unit)
12230    call lw_kgb02(rrtmg_unit)
12231    call lw_kgb03(rrtmg_unit)
12232    call lw_kgb04(rrtmg_unit)
12233    call lw_kgb05(rrtmg_unit)
12234    call lw_kgb06(rrtmg_unit)
12235    call lw_kgb07(rrtmg_unit)
12236    call lw_kgb08(rrtmg_unit)
12237    call lw_kgb09(rrtmg_unit)
12238    call lw_kgb10(rrtmg_unit)
12239    call lw_kgb11(rrtmg_unit)
12240    call lw_kgb12(rrtmg_unit)
12241    call lw_kgb13(rrtmg_unit)
12242    call lw_kgb14(rrtmg_unit)
12243    call lw_kgb15(rrtmg_unit)
12244    call lw_kgb16(rrtmg_unit)
12245 !
12246    if ( wrf_dm_on_monitor() ) close (rrtmg_unit)
12247 !
12248    return
12249 9009 continue
12250    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_'// &
12251                                'DATA on unit ',rrtmg_unit
12252 !
12253    end subroutine rrtmg_lwlookuptable
12254 !-------------------------------------------------------------------------------
12255 !
12256 !
12257 !-------------------------------------------------------------------------------
12258 !
12259 !  RRTMG Longwave Radiative Transfer Model
12260 !  Atmospheric and Environmental Research, Inc., Cambridge, MA
12261 !
12262 !  Original version:   E. J. Mlawer, et al.
12263 !  Revision for GCMs:  Michael J. Iacono; October, 2002
12264 !  Revision for F90 formatting:  Michael J. Iacono; June 2006
12265 !
12266 !  This file contains 16 READ statements that include the
12267 !  absorption coefficients and other data for each of the 16 longwave
12268 !  spectral bands used in RRTMG_LW.  Here, the data are defined for 16
12269 !  g-points, or sub-intervals, per band.  These data are combined and
12270 !  weighted using a mapping procedure in module RRTMG_LW_INIT to reduce
12271 !  the total number of g-points from 256 to 140 for use in the GCM.
12272 !
12273 !-------------------------------------------------------------------------------
12274    subroutine lw_kgb01(rrtmg_unit)
12275 !-------------------------------------------------------------------------------
12276 !
12277 !  abstract :
12278 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12279 !  and upper atmosphere.
12280 !  Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
12281 !
12282 !  The array KAO contains absorption coefs at the 16 chosen g-values
12283 !  for a range of pressure levels > ~100mb and temperatures.  The first
12284 !  index in the array, JT, which runs from 1 to 5, corresponds to
12285 !  different temperatures.  More specifically, JT = 3 means that the
12286 !  data are for the corresponding TREF for this  pressure level,
12287 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12288 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
12289 !  index, JP, runs from 1 to 13 and refers to the corresponding
12290 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12291 !  The third index, IG, goes from 1 to 16, and tells us which
12292 !  g-interval the absorption coefficients are for.
12293 !
12294 !  The array KBO contains absorption coefs at the 16 chosen g-values
12295 !  for a range of pressure levels < ~100mb and temperatures. The first
12296 !  index in the array, JT, which runs from 1 to 5, corresponds to
12297 !  different temperatures.  More specifically, JT = 3 means that the
12298 !  data are for the reference temperature TREF for this pressure
12299 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12300 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12301 !  The second index, JP, runs from 13 to 59 and refers to the JPth
12302 !  reference pressure level (see taumol.f for the value of these
12303 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
12304 !  and tells us which g-interval the absorption coefficients are for.
12305 !
12306 !  The arrays kao_mn2 and kbo_mn2 contain the coefficients of the
12307 !  nitrogen continuum for the upper and lower atmosphere.
12308 !  Minor gas mapping levels:
12309 !  Lower - n2: P = 142.5490 mbar, T = 215.70 K
12310 !  Upper - n2: P = 142.5490 mbar, T = 215.70 K
12311 !
12312 !  The array FORREFO contains the coefficient of the water vapor
12313 !  foreign-continuum (including the energy term).  The first
12314 !  index refers to reference temperature (296,260,224,260) and
12315 !  pressure (970,475,219,3 mbar) levels.  The second index
12316 !  runs over the g-channel (1 to 16).
12317 !
12318 !  The array SELFREFO contains the coefficient of the water vapor
12319 !  self-continuum (including the energy term).  The first index
12320 !  refers to temperature in 7.2 degree increments.  For instance,
12321 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12322 !  etc.  The second index runs over the g-channel (1 to 16).
12323 !
12324 !-------------------------------------------------------------------------------
12325    use rrlw_kg01_k, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2,   &
12326                          absa, absb, selfrefo, forrefo
12327 !
12328    implicit none
12329 !
12330    save
12331 !
12332 ! Input
12333 !
12334    integer, intent(in   ) :: rrtmg_unit
12335 !
12336 ! Local
12337 !
12338    character*80       :: errmess
12339    logical, external  :: wrf_dm_on_monitor
12340 !-------------------------------------------------------------------------------
12341 !
12342    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12343         fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
12344    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12345    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12346    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12347    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12348    call wrf_dm_bcast_bytes ( kao_mn2 , size ( kao_mn2 ) * 4 )
12349    call wrf_dm_bcast_bytes ( kbo_mn2 , size ( kbo_mn2 ) * 4 )
12350    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12351    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12352 !
12353    return
12354 9010 continue
12355    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12356                                'DATA on unit ',rrtmg_unit
12357 !
12358    end subroutine lw_kgb01
12359 !-------------------------------------------------------------------------------
12360 !
12361 !
12362 !-------------------------------------------------------------------------------
12363    subroutine lw_kgb02(rrtmg_unit)
12364 !-------------------------------------------------------------------------------
12365 !
12366 !  abstract :
12367 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12368 !  and upper atmosphere.
12369 !  Planck fraction mapping levels:
12370 !  Lower: P = 1053.630 mbar, T = 294.2 K
12371 !  Upper: P = 3.206e-2 mb, T = 197.92 K
12372 !
12373 !  The array KAO contains absorption coefs at the 16 chosen g-values
12374 !  for a range of pressure levels > ~100mb and temperatures.  The first
12375 !  index in the array, JT, which runs from 1 to 5, corresponds to
12376 !  different temperatures.  More specifically, JT = 3 means that the
12377 !  data are for the corresponding TREF for this  pressure level,
12378 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12379 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
12380 !  index, JP, runs from 1 to 13 and refers to the corresponding
12381 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12382 !  The third index, IG, goes from 1 to 16, and tells us which
12383 !  g-interval the absorption coefficients are for.
12384 !
12385 !  The array KBO contains absorption coefs at the 16 chosen g-values
12386 !  for a range of pressure levels < ~100mb and temperatures. The first
12387 !  index in the array, JT, which runs from 1 to 5, corresponds to
12388 !  different temperatures.  More specifically, JT = 3 means that the
12389 !  data are for the reference temperature TREF for this pressure
12390 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12391 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12392 !  The second index, JP, runs from 13 to 59 and refers to the JPth
12393 !  reference pressure level (see taumol.f for the value of these
12394 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
12395 !  and tells us which g-interval the absorption coefficients are for.
12396 !
12397 !  The array FORREFO contains the coefficient of the water vapor
12398 !  foreign-continuum (including the energy term).  The first
12399 !  index refers to reference temperature (296,260,224,260) and
12400 !  pressure (970,475,219,3 mbar) levels.  The second index
12401 !  runs over the g-channel (1 to 16).
12402 !
12403 !  The array SELFREFO contains the coefficient of the water vapor
12404 !  self-continuum (including the energy term).  The first index
12405 !  refers to temperature in 7.2 degree increments.  For instance,
12406 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12407 !  etc.  The second index runs over the g-channel (1 to 16).
12408 !
12409 !-------------------------------------------------------------------------------
12410    use rrlw_kg02_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12411 !
12412    implicit none
12413 !
12414    save
12415 !
12416 ! Input
12417 !
12418    integer, intent(in   ) :: rrtmg_unit
12419 !
12420 ! Local
12421 !
12422    character*80       :: errmess
12423    logical, external  :: wrf_dm_on_monitor
12424 !-------------------------------------------------------------------------------
12425 !
12426    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12427         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12428    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12429    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12430    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12431    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12432    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12433    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12434 !
12435    return
12436 9010 continue
12437    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12438                                'DATA on unit ',rrtmg_unit
12439 !
12440    end subroutine lw_kgb02
12441 !-------------------------------------------------------------------------------
12442 !
12443 !
12444 !-------------------------------------------------------------------------------
12445    subroutine lw_kgb03(rrtmg_unit)
12446 !-------------------------------------------------------------------------------
12447 !
12448 !  abstract :
12449 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12450 !  and upper atmosphere.
12451 !  Planck fraction mapping levels:
12452 !  Lower: P = 212.7250 mbar, T = 223.06 K
12453 !  Upper: P = 95.8 mbar, T = 215.7 k
12454 !
12455 !  The array KAO contains absorption coefs for each of the 16 g-intervals
12456 !  for a range of pressure levels > ~100mb, temperatures, and ratios
12457 !  of water vapor to CO2.  The first index in the array, JS, runs
12458 !  from 1 to 10, and corresponds to different gas column amount ratios,
12459 !  as expressed through the binary species parameter eta, defined as
12460 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12461 !  ratio of the reference MLS column amount value of gas 1
12462 !  to that of gas2.
12463 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12464 !  to different temperatures.  More specifically, JT = 3 means that the
12465 !  data are for the reference temperature TREF for this  pressure
12466 !  level, JT = 2 refers to the temperature
12467 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12468 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12469 !  to the reference pressure level (e.g. JP = 1 is for a
12470 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
12471 !  and tells us which g-interval the absorption coefficients are for.
12472 !
12473 !  The array KBO contains absorption coefs at the 16 chosen g-values
12474 !  for a range of pressure levels < ~100mb and temperatures. The first
12475 !  index in the array, JT, which runs from 1 to 5, corresponds to
12476 !  different temperatures.  More specifically, JT = 3 means that the
12477 !  data are for the reference temperature TREF for this pressure
12478 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12479 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12480 !  The second index, JP, runs from 13 to 59 and refers to the JPth
12481 !  reference pressure level (see taumol.f for the value of these
12482 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
12483 !  and tells us which g-interval the absorption coefficients are for.
12484 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12485 !  to different temperatures.  More specifically, JT = 3 means that the
12486 !  data are for the reference temperature TREF for this  pressure
12487 !  level, JT = 2 refers to the temperature
12488 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12489 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12490 !  to the reference pressure level (e.g. JP = 1 is for a
12491 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
12492 !  and tells us which g-interval the absorption coefficients are for.
12493 !
12494 !  The array KAO_Mxx contains the absorption coefficient for
12495 !  a minor species at the 16 chosen g-values for a reference pressure
12496 !  level below 100~ mb.   The first index in the array, JS, runs
12497 !  from 1 to 10, and corresponds to different gas column amount ratios,
12498 !  as expressed through the binary species parameter eta, defined as
12499 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12500 !  ratio of the reference MLS column amount value of gas 1
12501 !  to that of gas2.  The second index refers to temperature
12502 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12503 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12504 !  runs over the g-channel (1 to 16).
12505 !
12506 !  The array KBO_Mxx contains the absorption coefficient for
12507 !  a minor species at the 16 chosen g-values for a reference pressure
12508 !  level above 100~ mb.   The first index in the array, JS, runs
12509 !  from 1 to 10, and corresponds to different gas column amounts ratios,
12510 !  as expressed through the binary species parameter eta, defined as
12511 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12512 !  ratio of the reference MLS column amount value of gas 1 to
12513 !  that of gas2.  The second index refers to temperature
12514 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12515 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12516 !  runs over the g-channel (1 to 16).
12517 !
12518 !  The array FORREFO contains the coefficient of the water vapor
12519 !  foreign-continuum (including the energy term).  The first
12520 !  index refers to reference temperature (296,260,224,260) and
12521 !  pressure (970,475,219,3 mbar) levels.  The second index
12522 !  runs over the g-channel (1 to 16).
12523 !
12524 !  The array SELFREFO contains the coefficient of the water vapor
12525 !  self-continuum (including the energy term).  The first index
12526 !  refers to temperature in 7.2 degree increments.  For instance,
12527 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12528 !  etc.  The second index runs over the g-channel (1 to 16).
12529 !
12530 !-------------------------------------------------------------------------------
12531    use rrlw_kg03_k, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o,           &
12532                          kbo_mn2o, selfrefo, forrefo
12533 !
12534    implicit none
12535 !
12536    save
12537 !
12538 ! Input
12539 !
12540    integer, intent(in   ) :: rrtmg_unit
12541 !
12542 ! Local
12543 !
12544    character*80       :: errmess
12545    logical, external  :: wrf_dm_on_monitor
12546 !-------------------------------------------------------------------------------
12547 !
12548    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12549         fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
12550    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12551    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12552    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12553    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12554    call wrf_dm_bcast_bytes ( kao_mn2o , size ( kao_mn2o ) * 4 )
12555    call wrf_dm_bcast_bytes ( kbo_mn2o , size ( kbo_mn2o ) * 4 )
12556    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12557    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12558 !
12559    return
12560 9010 continue
12561    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12562                                'DATA on unit ',rrtmg_unit
12563 !
12564    end subroutine lw_kgb03
12565 !-------------------------------------------------------------------------------
12566 !
12567 !
12568 !-------------------------------------------------------------------------------
12569    subroutine lw_kgb04(rrtmg_unit)
12570 !-------------------------------------------------------------------------------
12571 !
12572 !  abstract :
12573 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12574 !  and upper atmosphere.
12575 !  Planck fraction mapping levels:
12576 !  Lower : P = 142.5940 mbar, T = 215.70 K
12577 !  Upper : P = 95.58350 mb, T = 215.70 K
12578 !
12579 !  The array KAO contains absorption coefs for each of the 16 g-intervals
12580 !  for a range of pressure levels > ~100mb, temperatures, and ratios
12581 !  of water vapor to CO2.  The first index in the array, JS, runs
12582 !  from 1 to 10, and corresponds to different gas column amount ratios,
12583 !  as expressed through the binary species parameter eta, defined as
12584 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12585 !  ratio of the reference MLS column amount value of gas 1
12586 !  to that of gas2.
12587 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12588 !  to different temperatures.  More specifically, JT = 3 means that the
12589 !  data are for the reference temperature TREF for this  pressure
12590 !  level, JT = 2 refers to the temperature
12591 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12592 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12593 !  to the reference pressure level (e.g. JP = 1 is for a
12594 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
12595 !  and tells us which g-interval the absorption coefficients are for.
12596 !
12597 !  The array KBO contains absorption coefs for each of the 16 g-intervals
12598 !  for a range of pressure levels  < ~100mb, temperatures, and ratios
12599 !  of H2O to CO2.  The first index in the array, JS, runs
12600 !  from 1 to 10, and corresponds to different gas column amount ratios,
12601 !  as expressed through the binary species parameter eta, defined as
12602 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12603 !  ratio of the reference MLS column amount value of gas 1
12604 !  to that of gas2.  The second index, JT, which
12605 !  runs from 1 to 5, corresponds to different temperatures.  More
12606 !  specifically, JT = 3 means that the data are for the corresponding
12607 !  reference temperature TREF for this  pressure level, JT = 2 refers
12608 !  to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12609 !  JT = 5 is for TREF+30.  The third index, JP, runs from 13 to 59 and
12610 !  refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12611 !  for a pressure of 95.5835 mb).  The fourth index, IG, goes from 1 to
12612 !  16, and tells us which g-interval the absorption coefficients are for.
12613 !
12614 !  The array FORREFO contains the coefficient of the water vapor
12615 !  foreign-continuum (including the energy term).  The first
12616 !  index refers to reference temperature (296,260,224,260) and
12617 !  pressure (970,475,219,3 mbar) levels.  The second index
12618 !  runs over the g-channel (1 to 16).
12619 !
12620 !  The array SELFREFO contains the coefficient of the water vapor
12621 !  self-continuum (including the energy term).  The first index
12622 !  refers to temperature in 7.2 degree increments.  For instance,
12623 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12624 !  etc.  The second index runs over the g-channel (1 to 16).
12625 !
12626 !-------------------------------------------------------------------------------
12627    use rrlw_kg04_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12628 !
12629    implicit none
12630 !
12631    save
12632 !
12633 ! Input
12634 !
12635    integer, intent(in   ) :: rrtmg_unit
12636 !
12637 ! Local
12638 !
12639    character*80       :: errmess
12640    logical, external  :: wrf_dm_on_monitor
12641 !-------------------------------------------------------------------------------
12642 !
12643    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12644         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
12645    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12646    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12647    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12648    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12649    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12650    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12651 !
12652    return
12653 9010 continue
12654    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12655                                'DATA on unit ',rrtmg_unit
12656 !
12657    end subroutine lw_kgb04
12658 !-------------------------------------------------------------------------------
12659 !
12660 !
12661 !-------------------------------------------------------------------------------
12662    subroutine lw_kgb05(rrtmg_unit)
12663 !-------------------------------------------------------------------------------
12664 !
12665 !  abstract :
12666 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12667 !  and upper atmosphere.
12668 !  Planck fraction mapping levels:
12669 !  Lower: P = 473.42 mb, T = 259.83
12670 !  Upper: P = 0.2369280 mbar, T = 253.60 K
12671 !
12672 !  The arrays kao_mo3 and ccl4o contain the coefficients for
12673 !  ozone and ccl4 in the lower atmosphere.
12674 !  Minor gas mapping level:
12675 !  Lower - o3: P = 317.34 mbar, T = 240.77 k
12676 !  Lower - ccl4:
12677 !
12678 !  The array KAO contains absorption coefs for each of the 16 g-intervals
12679 !  for a range of pressure levels > ~100mb, temperatures, and ratios
12680 !  of water vapor to CO2.  The first index in the array, JS, runs
12681 !  from 1 to 10, and corresponds to different gas column amount ratios,
12682 !  as expressed through the binary species parameter eta, defined as
12683 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12684 !  ratio of the reference MLS column amount value of gas 1
12685 !  to that of gas2.
12686 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12687 !  to different temperatures.  More specifically, JT = 3 means that the
12688 !  data are for the reference temperature TREF for this  pressure
12689 !  level, JT = 2 refers to the temperature
12690 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12691 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12692 !  to the reference pressure level (e.g. JP = 1 is for a
12693 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
12694 !  and tells us which g-interval the absorption coefficients are for.
12695 !
12696 !  The array KBO contains absorption coefs for each of the 16 g-intervals
12697 !  for a range of pressure levels  < ~100mb, temperatures, and ratios
12698 !  of H2O to CO2.  The first index in the array, JS, runs
12699 !  from 1 to 10, and corresponds to different gas column amount ratios,
12700 !  as expressed through the binary species parameter eta, defined as
12701 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12702 !  ratio of the reference MLS column amount value of gas 1
12703 !  to that of gas2.  The second index, JT, which
12704 !  runs from 1 to 5, corresponds to different temperatures.  More
12705 !  specifically, JT = 3 means that the data are for the corresponding
12706 !  reference temperature TREF for this  pressure level, JT = 2 refers
12707 !  to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
12708 !  JT = 5 is for TREF+30.  The third index, JP, runs from 13 to 59 and
12709 !  refers to the corresponding pressure level in PREF (e.g. JP = 13 is
12710 !  for a pressure of 95.5835 mb).  The fourth index, IG, goes from 1 to
12711 !  16, and tells us which g-interval the absorption coefficients are for.
12712 !
12713 !  The array KAO_Mxx contains the absorption coefficient for
12714 !  a minor species at the 16 chosen g-values for a reference pressure
12715 !  level below 100~ mb.   The first index in the array, JS, runs
12716 !  from 1 to 10, and corresponds to different gas column amount ratios,
12717 !  as expressed through the binary species parameter eta, defined as
12718 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12719 !  ratio of the reference MLS column amount value of gas 1
12720 !  to that of gas2.  The second index refers to temperature
12721 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12722 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12723 !  runs over the g-channel (1 to 16).
12724 !
12725 !  The array FORREFO contains the coefficient of the water vapor
12726 !  foreign-continuum (including the energy term).  The first
12727 !  index refers to reference temperature (296,260,224,260) and
12728 !  pressure (970,475,219,3 mbar) levels.  The second index
12729 !  runs over the g-channel (1 to 16).
12730 !
12731 !  The array SELFREFO contains the coefficient of the water vapor
12732 !  self-continuum (including the energy term).  The first index
12733 !  refers to temperature in 7.2 degree increments.  For instance,
12734 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12735 !  etc.  The second index runs over the g-channel (1 to 16).
12736 !
12737 !-------------------------------------------------------------------------------
12738    use rrlw_kg05_k, only : fracrefao, fracrefbo, kao, kbo, kao_mo3,            &
12739                          selfrefo, forrefo, ccl4o
12740 !
12741    implicit none
12742 !
12743    save
12744 !
12745 ! Input
12746 !
12747    integer, intent(in   ) :: rrtmg_unit
12748 !
12749 ! Local
12750 !
12751    character*80       :: errmess
12752    logical, external  :: wrf_dm_on_monitor
12753 !-------------------------------------------------------------------------------
12754 !
12755    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12756         fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
12757    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12758    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12759    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12760    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12761    call wrf_dm_bcast_bytes ( kao_mo3 , size ( kao_mo3 ) * 4 )
12762    call wrf_dm_bcast_bytes ( ccl4o , size ( ccl4o ) * 4 )
12763    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12764    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12765 !
12766    return
12767 9010 continue
12768    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12769                                'DATA on unit ',rrtmg_unit
12770 !
12771    end subroutine lw_kgb05
12772 !-------------------------------------------------------------------------------
12773 !
12774 !
12775 !-------------------------------------------------------------------------------
12776    subroutine lw_kgb06(rrtmg_unit)
12777 !-------------------------------------------------------------------------------
12778 !
12779 !  abstract :
12780 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12781 !  and upper atmosphere.
12782 !  Planck fraction mapping levels:
12783 !  Lower: : P = 473.4280 mb, T = 259.83 K
12784 !
12785 !  The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
12786 !  carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
12787 !  atmosphere.
12788 !  Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
12789 !  Minor gas mapping level:
12790 !  Lower - co2: P = 706.2720 mb, T = 294.2 k
12791 !  Upper - cfc11, cfc12
12792 !
12793 !  The array KAO contains absorption coefs at the 16 chosen g-values
12794 !  for a range of pressure levels > ~100mb and temperatures.  The first
12795 !  index in the array, JT, which runs from 1 to 5, corresponds to
12796 !  different temperatures.  More specifically, JT = 3 means that the
12797 !  data are for the corresponding TREF for this  pressure level,
12798 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
12799 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
12800 !  index, JP, runs from 1 to 13 and refers to the corresponding
12801 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
12802 !  The third index, IG, goes from 1 to 16, and tells us which
12803 !  g-interval the absorption coefficients are for.
12804 !
12805 !  The array KAO_Mxx contains the absorption coefficient for
12806 !  a minor species at the 16 chosen g-values for a reference pressure
12807 !  level below 100~ mb.   The first index refers to temperature
12808 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12809 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
12810 !  runs over the g-channel (1 to 16).
12811 !
12812 !  The array FORREFO contains the coefficient of the water vapor
12813 !  foreign-continuum (including the energy term).  The first
12814 !  index refers to reference temperature (296,260,224,260) and
12815 !  pressure (970,475,219,3 mbar) levels.  The second index
12816 !  runs over the g-channel (1 to 16).
12817 !
12818 !  The array SELFREFO contains the coefficient of the water vapor
12819 !  self-continuum (including the energy term).  The first index
12820 !  refers to temperature in 7.2 degree increments.  For instance,
12821 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12822 !  etc.  The second index runs over the g-channel (1 to 16).
12823 !
12824 !-------------------------------------------------------------------------------
12825    use rrlw_kg06_k, only : fracrefao, kao, kao_mco2, selfrefo, forrefo,        &
12826                          cfc11adjo, cfc12o
12827 !
12828    implicit none
12829 !
12830    save
12831 !
12832 ! Input
12833 !
12834    integer, intent(in   ) :: rrtmg_unit
12835 !
12836 ! Local
12837 !
12838    character*80       :: errmess
12839    logical, external  :: wrf_dm_on_monitor
12840 !-------------------------------------------------------------------------------
12841 !
12842    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12843         fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
12844    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12845    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12846    call wrf_dm_bcast_bytes ( kao_mco2 , size ( kao_mco2 ) * 4 )
12847    call wrf_dm_bcast_bytes ( cfc11adjo , size ( cfc11adjo ) * 4 )
12848    call wrf_dm_bcast_bytes ( cfc12o , size ( cfc12o ) * 4 )
12849    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12850    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12851 !
12852    return
12853 9010 continue
12854    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12855                                'DATA on unit ',rrtmg_unit
12856 !
12857    end subroutine lw_kgb06
12858 !-------------------------------------------------------------------------------
12859 !
12860 !
12861 !-------------------------------------------------------------------------------
12862    subroutine lw_kgb07(rrtmg_unit)
12863 !-------------------------------------------------------------------------------
12864 !
12865 !  abstract :
12866 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12867 !  and upper atmosphere.
12868 !  Planck fraction mapping levels:
12869 !  Lower : P = 706.27 mb, T = 278.94 K
12870 !  Upper : P = 95.58 mbar, T= 215.70 K
12871 !
12872 !  The array KAO contains absorption coefs for each of the 16 g-intervals
12873 !  for a range of pressure levels > ~100mb, temperatures, and ratios
12874 !  of water vapor to CO2.  The first index in the array, JS, runs
12875 !  from 1 to 10, and corresponds to different gas column amount ratios,
12876 !  as expressed through the binary species parameter eta, defined as
12877 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12878 !  ratio of the reference MLS column amount value of gas 1
12879 !  to that of gas2.
12880 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
12881 !  to different temperatures.  More specifically, JT = 3 means that the
12882 !  data are for the reference temperature TREF for this  pressure
12883 !  level, JT = 2 refers to the temperature
12884 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12885 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12886 !  to the reference pressure level (e.g. JP = 1 is for a
12887 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
12888 !  and tells us which g-interval the absorption coefficients are for.
12889 !
12890 !  The array KBO contains absorption coefs at the 16 chosen g-values
12891 !  for a range of pressure levels < ~100mb and temperatures. The first
12892 !  index in the array, JT, which runs from 1 to 5, corresponds to
12893 !  different temperatures.  More specifically, JT = 3 means that the
12894 !  data are for the reference temperature TREF for this pressure
12895 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12896 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12897 !  The second index, JP, runs from 13 to 59 and refers to the JPth
12898 !  reference pressure level (see taumol.f for the value of these
12899 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
12900 !  and tells us which g-interval the absorption coefficients are for.
12901 !
12902 !  The array KAO_Mxx contains the absorption coefficient for
12903 !  a minor species at the 16 chosen g-values for a reference pressure
12904 !  level below 100~ mb.   The first index in the array, JS, runs
12905 !  from 1 to 10, and corresponds to different gas column amount ratios,
12906 !  as expressed through the binary species parameter eta, defined as
12907 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
12908 !  ratio of the reference MLS column amount value of gas 1
12909 !  to that of gas2.  The second index refers to temperature
12910 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12911 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
12912 !  runs over the g-channel (1 to 16).
12913 !
12914 !  The array KBO_Mxx contains the absorption coefficient for
12915 !  a minor species at the 16 chosen g-values for a reference pressure
12916 !  level above 100~ mb.   The first index refers to temperature
12917 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
12918 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
12919 !  runs over the g-channel (1 to 16).
12920 !
12921 !  The array FORREFO contains the coefficient of the water vapor
12922 !  foreign-continuum (including the energy term).  The first
12923 !  index refers to reference temperature (296_rb,260_rb,224,260) and
12924 !  pressure (970,475,219,3 mbar) levels.  The second index
12925 !  runs over the g-channel (1 to 16).
12926 !
12927 !  The array SELFREFO contains the coefficient of the water vapor
12928 !  self-continuum (including the energy term).  The first index
12929 !  refers to temperature in 7.2 degree increments.  For instance,
12930 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12931 !  etc.  The second index runs over the g-channel (1 to 16).
12932 !
12933 !-------------------------------------------------------------------------------
12934    use rrlw_kg07_k, only : fracrefao, fracrefbo, kao, kbo, kao_mco2,           &
12935                          kbo_mco2, selfrefo, forrefo
12936 !
12937    implicit none
12938 !
12939    save
12940 !
12941 ! Input
12942 !
12943    integer, intent(in   ) :: rrtmg_unit
12944 !
12945 ! Local
12946 !
12947    character*80       :: errmess
12948    logical, external  :: wrf_dm_on_monitor
12949 !-------------------------------------------------------------------------------
12950 !
12951    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12952         fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
12953    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
12954    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
12955    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12956    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12957    call wrf_dm_bcast_bytes ( kao_mco2 , size ( kao_mco2 ) * 4 )
12958    call wrf_dm_bcast_bytes ( kbo_mco2 , size ( kbo_mco2 ) * 4 )
12959    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12960    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12961 !
12962    return
12963 9010 continue
12964    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
12965                                'DATA on unit ',rrtmg_unit
12966 !
12967    end subroutine lw_kgb07
12968 !-------------------------------------------------------------------------------
12969 !
12970 !
12971 !-------------------------------------------------------------------------------
12972    subroutine lw_kgb08(rrtmg_unit)
12973 !-------------------------------------------------------------------------------
12974 !
12975 !  abstract :
12976 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
12977 !  and upper atmosphere.
12978 !  Planck fraction mapping levels:
12979 !  Lower: P=473.4280 mb, T = 259.83 K
12980 !  Upper: P=95.5835 mb, T= 215.7 K
12981 !  The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients
12982 !  for carbon dioxide and n2o in the lower and upper atmosphere.
12983 !  The array kao_mo3 contains the coefficients for ozone in the lower atmosphere
12984 !  , and arrays cfc12o & cfc12adjo contain the coefficients for cfc12 & cfc22.
12985 !  Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1
12986 !  and 1290-1335 cm-1 bands.
12987 !  Minor gas mapping level:
12988 !  Lower - co2: P = 1053.63 mb, T = 294.2 k
12989 !  Lower - o3: P = 317.348 mb, T = 240.77 k
12990 !  Lower - n2o: P = 706.2720 mb, T= 278.94 k
12991 !  Lower - cfc12, cfc22
12992 !  Upper - co2: P = 35.1632 mb, T = 223.28 k
12993 !  Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
12994 !  The array KAO contains absorption coefs at the 16 chosen g-values
12995 !  for a range of pressure levels > ~100mb and temperatures.  The first
12996 !  index in the array, JT, which runs from 1 to 5, corresponds to
12997 !  different temperatures.  More specifically, JT = 3 means that the
12998 !  data are for the corresponding TREF for this  pressure level,
12999 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13000 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
13001 !  index, JP, runs from 1 to 13 and refers to the corresponding
13002 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13003 !  The third index, IG, goes from 1 to 16, and tells us which
13004 !  g-interval the absorption coefficients are for.
13005 !  The array KBO contains absorption coefs at the 16 chosen g-values
13006 !  for a range of pressure levels < ~100mb and temperatures. The first
13007 !  index in the array, JT, which runs from 1 to 5, corresponds to
13008 !  different temperatures.  More specifically, JT = 3 means that the
13009 !  data are for the reference temperature TREF for this pressure
13010 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13011 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13012 !  The second index, JP, runs from 13 to 59 and refers to the JPth
13013 !  reference pressure level (see taumol.f for the value of these
13014 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
13015 !  and tells us which g-interval the absorption coefficients are for.
13016 !  The array KAO_Mxx contains the absorption coefficient for
13017 !  a minor species at the 16 chosen g-values for a reference pressure
13018 !  level below 100~ mb.   The first index refers to temperature
13019 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13020 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13021 !  runs over the g-channel (1 to 16).
13022 !  The array KBO_Mxx contains the absorption coefficient for
13023 !  a minor species at the 16 chosen g-values for a reference pressure
13024 !  level above 100~ mb.   The first index refers to temperature
13025 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13026 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13027 !  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).
13033 !  The array SELFREFO contains the coefficient of the water vapor
13034 !  self-continuum (including the energy term).  The first index
13035 !  refers to temperature in 7.2 degree increments.  For instance,
13036 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13037 !  etc.  The second index runs over the g-channel (1 to 16).
13038 !
13039 !-------------------------------------------------------------------------------
13040    use rrlw_kg08_k, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o,      &
13041                          kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo,  &
13042                          cfc12o, cfc22adjo
13043 !
13044    implicit none
13045 !
13046    save
13047 !
13048 ! Input
13049 !
13050    integer, intent(in   ) :: rrtmg_unit
13051 !
13052 ! Local
13053 !
13054    character*80       :: errmess
13055    logical, external  :: wrf_dm_on_monitor
13056 !-------------------------------------------------------------------------------
13057 !
13058    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13059         fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o,          &
13060         kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
13061    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13062    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13063    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13064    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13065    call wrf_dm_bcast_bytes ( kao_mco2 , size ( kao_mco2 ) * 4 )
13066    call wrf_dm_bcast_bytes ( kbo_mco2 , size ( kbo_mco2 ) * 4 )
13067    call wrf_dm_bcast_bytes ( kao_mn2o , size ( kao_mn2o ) * 4 )
13068    call wrf_dm_bcast_bytes ( kbo_mn2o , size ( kbo_mn2o ) * 4 )
13069    call wrf_dm_bcast_bytes ( kao_mo3 , size ( kao_mo3 ) * 4 )
13070    call wrf_dm_bcast_bytes ( cfc12o , size ( cfc12o ) * 4 )
13071    call wrf_dm_bcast_bytes ( cfc22adjo , size ( cfc22adjo ) * 4 )
13072    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13073    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13074 !
13075    return
13076 9010 continue
13077    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13078                                'DATA on unit ',rrtmg_unit
13079 !
13080    end subroutine lw_kgb08
13081 !-------------------------------------------------------------------------------
13082 !
13083 !
13084 !-------------------------------------------------------------------------------
13085    subroutine lw_kgb09(rrtmg_unit)
13086 !-------------------------------------------------------------------------------
13087 !
13088 !  abstract :
13089 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13090 !  and upper atmosphere.
13091 !  Planck fraction mapping levels:
13092 !  Lower: P=212.7250 mb, T = 223.06 K
13093 !  Upper: P=3.20e-2 mb, T = 197.92 k
13094 !
13095 !  The array KAO contains absorption coefs for each of the 16 g-intervals
13096 !  for a range of pressure levels > ~100mb, temperatures, and ratios
13097 !  of water vapor to CO2.  The first index in the array, JS, runs
13098 !  from 1 to 10, and corresponds to different gas column amount ratios,
13099 !  as expressed through the binary species parameter eta, defined as
13100 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13101 !  ratio of the reference MLS column amount value of gas 1
13102 !  to that of gas2.
13103 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13104 !  to different temperatures.  More specifically, JT = 3 means that the
13105 !  data are for the reference temperature TREF for this  pressure
13106 !  level, JT = 2 refers to the temperature
13107 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13108 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13109 !  to the reference pressure level (e.g. JP = 1 is for a
13110 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
13111 !  and tells us which g-interval the absorption coefficients are for.
13112 !
13113 !  The array KBO contains absorption coefs at the 16 chosen g-values
13114 !  for a range of pressure levels < ~100mb and temperatures. The first
13115 !  index in the array, JT, which runs from 1 to 5, corresponds to
13116 !  different temperatures.  More specifically, JT = 3 means that the
13117 !  data are for the reference temperature TREF for this pressure
13118 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13119 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13120 !  The second index, JP, runs from 13 to 59 and refers to the JPth
13121 !  reference pressure level (see taumol.f for the value of these
13122 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
13123 !  and tells us which g-interval the absorption coefficients are for.
13124 !
13125 !  The array KAO_Mxx contains the absorption coefficient for
13126 !  a minor species at the 16 chosen g-values for a reference pressure
13127 !  level below 100~ mb.   The first index in the array, JS, runs
13128 !  from 1 to 10, and corresponds to different gas column amount ratios,
13129 !  as expressed through the binary species parameter eta, defined as
13130 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13131 !  ratio of the reference MLS column amount value of gas 1
13132 !  to that of gas2.  The second index refers to temperature
13133 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13134 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13135 !  runs over the g-channel (1 to 16).
13136 !
13137 !  The array KBO_Mxx contains the absorption coefficient for
13138 !  a minor species at the 16 chosen g-values for a reference pressure
13139 !  level above 100~ mb.   The first index refers to temperature
13140 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13141 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13142 !  runs over the g-channel (1 to 16).
13143 !
13144 !  The array FORREFO contains the coefficient of the water vapor
13145 !  foreign-continuum (including the energy term).  The first
13146 !  index refers to reference temperature (296,260,224,260) and
13147 !  pressure (970,475,219,3 mbar) levels.  The second index
13148 !  runs over the g-channel (1 to 16).
13149 !
13150 !  The array SELFREFO contains the coefficient of the water vapor
13151 !  self-continuum (including the energy term).  The first index
13152 !  refers to temperature in 7.2 degree increments.  For instance,
13153 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13154 !  etc.  The second index runs over the g-channel (1 to 16).
13155 !
13156 !-------------------------------------------------------------------------------
13157    use rrlw_kg09_k, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o,           &
13158                          kbo_mn2o, selfrefo, forrefo
13159 !
13160    implicit none
13161 !
13162    save
13163 !
13164 ! Input
13165 !
13166    integer, intent(in   ) :: rrtmg_unit
13167 !
13168 ! Local
13169 !
13170    character*80       :: errmess
13171    logical, external  :: wrf_dm_on_monitor
13172 !-------------------------------------------------------------------------------
13173 !
13174    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13175         fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
13176    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13177    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13178    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13179    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13180    call wrf_dm_bcast_bytes ( kao_mn2o , size ( kao_mn2o ) * 4 )
13181    call wrf_dm_bcast_bytes ( kbo_mn2o , size ( kbo_mn2o ) * 4 )
13182    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13183    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13184 !
13185    return
13186 9010 continue
13187    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13188                                'DATA on unit ',rrtmg_unit
13189 !
13190    end subroutine lw_kgb09
13191 !-------------------------------------------------------------------------------
13192 !
13193 !
13194 !-------------------------------------------------------------------------------
13195    subroutine lw_kgb10(rrtmg_unit)
13196 !-------------------------------------------------------------------------------
13197 !
13198 !  abstract :
13199 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13200 !  and upper atmosphere.
13201 !  Planck fraction mapping levels:
13202 !  Lower: P = 212.7250 mb, T = 223.06 K
13203 !  Upper: P = 95.58350 mb, T = 215.70 K
13204 !
13205 !  The array KAO contains absorption coefs at the 16 chosen g-values
13206 !  for a range of pressure levels > ~100mb and temperatures.  The first
13207 !  index in the array, JT, which runs from 1 to 5, corresponds to
13208 !  different temperatures.  More specifically, JT = 3 means that the
13209 !  data are for the corresponding TREF for this  pressure level,
13210 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13211 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
13212 !  index, JP, runs from 1 to 13 and refers to the corresponding
13213 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13214 !  The third index, IG, goes from 1 to 16, and tells us which
13215 !  g-interval the absorption coefficients are for.
13216 !
13217 !  The array KBO contains absorption coefs at the 16 chosen g-values
13218 !  for a range of pressure levels < ~100mb and temperatures. The first
13219 !  index in the array, JT, which runs from 1 to 5, corresponds to
13220 !  different temperatures.  More specifically, JT = 3 means that the
13221 !  data are for the reference temperature TREF for this pressure
13222 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13223 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13224 !  The second index, JP, runs from 13 to 59 and refers to the JPth
13225 !  reference pressure level (see taumol.f for the value of these
13226 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
13227 !  and tells us which g-interval the absorption coefficients are for.
13228 !
13229 !  The array FORREFO contains the coefficient of the water vapor
13230 !  foreign-continuum (including the energy term).  The first
13231 !  index refers to reference temperature (296,260,224,260) and
13232 !  pressure (970,475,219,3 mbar) levels.  The second index
13233 !  runs over the g-channel (1 to 16).
13234 !
13235 !  The array SELFREFO contains the coefficient of the water vapor
13236 !  self-continuum (including the energy term).  The first index
13237 !  refers to temperature in 7.2 degree increments.  For instance,
13238 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13239 !  etc.  The second index runs over the g-channel (1 to 16).
13240 !
13241 !-------------------------------------------------------------------------------
13242    use rrlw_kg10_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13243 !
13244    implicit none
13245 !
13246    save
13247 !
13248 ! Input
13249 !
13250    integer, intent(in   ) :: rrtmg_unit
13251 !
13252 ! Local
13253 !
13254    character*80       :: errmess
13255    logical, external  :: wrf_dm_on_monitor
13256 !-------------------------------------------------------------------------------
13257 !
13258    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13259         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13260    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13261    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13262    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13263    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13264    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13265    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13266 !
13267    return
13268 9010 continue
13269    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13270                                'DATA on unit ',rrtmg_unit
13271 !
13272    end subroutine lw_kgb10
13273 !-------------------------------------------------------------------------------
13274 !
13275 !
13276 !-------------------------------------------------------------------------------
13277    subroutine lw_kgb11(rrtmg_unit)
13278 !-------------------------------------------------------------------------------
13279 !
13280 !  abstract :
13281 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13282 !  and upper atmosphere.
13283 !  Planck fraction mapping levels:
13284 !  Lower: P=1053.63 mb, T= 294.2 K
13285 !  Upper: P=0.353 mb, T = 262.11 K
13286 !
13287 !  The array KAO contains absorption coefs at the 16 chosen g-values
13288 !  for a range of pressure levels > ~100mb and temperatures.  The first
13289 !  index in the array, JT, which runs from 1 to 5, corresponds to
13290 !  different temperatures.  More specifically, JT = 3 means that the
13291 !  data are for the corresponding TREF for this  pressure level,
13292 !  JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
13293 !  JT = 4 is for TREF+15, and JT = 5 is for TREF+30.  The second
13294 !  index, JP, runs from 1 to 13 and refers to the corresponding
13295 !  pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
13296 !  The third index, IG, goes from 1 to 16, and tells us which
13297 !  g-interval the absorption coefficients are for.
13298 !
13299 !  The array KBO contains absorption coefs at the 16 chosen g-values
13300 !  for a range of pressure levels < ~100mb and temperatures. The first
13301 !  index in the array, JT, which runs from 1 to 5, corresponds to
13302 !  different temperatures.  More specifically, JT = 3 means that the
13303 !  data are for the reference temperature TREF for this pressure
13304 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13305 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13306 !  The second index, JP, runs from 13 to 59 and refers to the JPth
13307 !  reference pressure level (see taumol.f for the value of these
13308 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
13309 !  and tells us which g-interval the absorption coefficients are for.
13310 !
13311 !  The array KAO_Mxx contains the absorption coefficient for
13312 !  a minor species at the 16 chosen g-values for a reference pressure
13313 !  level below 100~ mb.   The first index refers to temperature
13314 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13315 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13316 !  runs over the g-channel (1 to 16).
13317 !
13318 !  The array KBO_Mxx contains the absorption coefficient for
13319 !  a minor species at the 16 chosen g-values for a reference pressure
13320 !  level above 100~ mb.   The first index refers to temperature
13321 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13322 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13323 !  runs over the g-channel (1 to 16).
13324 !
13325 !  The array FORREFO contains the coefficient of the water vapor
13326 !  foreign-continuum (including the energy term).  The first
13327 !  index refers to reference temperature (296,260,224,260) and
13328 !  pressure (970,475,219,3 mbar) levels.  The second index
13329 !  runs over the g-channel (1 to 16).
13330 !
13331 !  The array SELFREFO contains the coefficient of the water vapor
13332 !  self-continuum (including the energy term).  The first index
13333 !  refers to temperature in 7.2 degree increments.  For instance,
13334 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13335 !  etc.  The second index runs over the g-channel (1 to 16).
13336 !
13337 !-------------------------------------------------------------------------------
13338    use rrlw_kg11_k, only : fracrefao, fracrefbo, kao, kbo, kao_mo2,            &
13339                          kbo_mo2, selfrefo, forrefo
13340 !
13341    implicit none
13342 !
13343    save
13344 !
13345 ! Input
13346 !
13347    integer, intent(in   ) :: rrtmg_unit
13348 !
13349 ! Local
13350 !
13351    character*80       :: errmess
13352    logical, external  :: wrf_dm_on_monitor
13353 !-------------------------------------------------------------------------------
13354 !
13355    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13356         fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
13357    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13358    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13359    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13360    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13361    call wrf_dm_bcast_bytes ( kao_mo2 , size ( kao_mo2 ) * 4 )
13362    call wrf_dm_bcast_bytes ( kbo_mo2 , size ( kbo_mo2 ) * 4 )
13363    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13364    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13365 !
13366    return
13367 9010 continue
13368    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13369                                'DATA on unit ',rrtmg_unit
13370 !
13371    end subroutine lw_kgb11
13372 !-------------------------------------------------------------------------------
13373 !
13374 !
13375 !-------------------------------------------------------------------------------
13376    subroutine lw_kgb12(rrtmg_unit)
13377 !-------------------------------------------------------------------------------
13378 !
13379 !  abstract :
13380 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13381 !  and upper atmosphere.
13382 !  Planck fraction mapping levels:
13383 !  Lower: P = 174.1640 mbar, T= 215.78 K
13384 !
13385 !  The array KAO contains absorption coefs for each of the 16 g-intervals
13386 !  for a range of pressure levels > ~100mb, temperatures, and ratios
13387 !  of water vapor to CO2.  The first index in the array, JS, runs
13388 !  from 1 to 10, and corresponds to different gas column amount ratios,
13389 !  as expressed through the binary species parameter eta, defined as
13390 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13391 !  ratio of the reference MLS column amount value of gas 1
13392 !  to that of gas2.
13393 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13394 !  to different temperatures.  More specifically, JT = 3 means that the
13395 !  data are for the reference temperature TREF for this  pressure
13396 !  level, JT = 2 refers to the temperature
13397 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13398 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13399 !  to the reference pressure level (e.g. JP = 1 is for a
13400 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
13401 !  and tells us which g-interval the absorption coefficients are for.
13402 !
13403 !  The array FORREFO contains the coefficient of the water vapor
13404 !  foreign-continuum (including the energy term).  The first
13405 !  index refers to reference temperature (296,260,224,260) and
13406 !  pressure (970,475,219,3 mbar) levels.  The second index
13407 !  runs over the g-channel (1 to 16).
13408 !
13409 !  The array SELFREFO contains the coefficient of the water vapor
13410 !  self-continuum (including the energy term).  The first index
13411 !  refers to temperature in 7.2 degree increments.  For instance,
13412 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13413 !  etc.  The second index runs over the g-channel (1 to 16).
13414 !
13415 !-------------------------------------------------------------------------------
13416    use rrlw_kg12_k, only : fracrefao, kao, selfrefo, forrefo
13417 !
13418    implicit none
13419 !
13420    save
13421 !
13422 ! Input
13423 !
13424    integer, intent(in   ) :: rrtmg_unit
13425 !
13426 ! Local
13427 !
13428    character*80       :: errmess
13429    logical, external  :: wrf_dm_on_monitor
13430 !-------------------------------------------------------------------------------
13431 !
13432    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13433          fracrefao, kao, selfrefo, forrefo
13434    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13435    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13436    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13437    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13438 !
13439    return
13440 9010 continue
13441    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13442                                'DATA on unit ',rrtmg_unit
13443 !
13444    end subroutine lw_kgb12
13445 !-------------------------------------------------------------------------------
13446 !
13447 !
13448 !-------------------------------------------------------------------------------
13449    subroutine lw_kgb13(rrtmg_unit)
13450 !-------------------------------------------------------------------------------
13451 !
13452 !  abstract :
13453 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13454 !  and upper atmosphere.
13455 !  Planck fraction mapping levels:
13456 !  Lower: P=473.4280 mb, T = 259.83 K
13457 !  Upper: P=4.758820 mb, T = 250.85 K
13458 !
13459 !  The array KAO contains absorption coefs for each of the 16 g-intervals
13460 !  for a range of pressure levels > ~100mb, temperatures, and ratios
13461 !  of water vapor to CO2.  The first index in the array, JS, runs
13462 !  from 1 to 10, and corresponds to different gas column amount ratios,
13463 !  as expressed through the binary species parameter eta, defined as
13464 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13465 !  ratio of the reference MLS column amount value of gas 1
13466 !  to that of gas2.
13467 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13468 !  to different temperatures.  More specifically, JT = 3 means that the
13469 !  data are for the reference temperature TREF for this  pressure
13470 !  level, JT = 2 refers to the temperature
13471 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13472 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13473 !  to the reference pressure level (e.g. JP = 1 is for a
13474 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
13475 !  and tells us which g-interval the absorption coefficients are for.
13476 !
13477 !  The array KAO_Mxx contains the absorption coefficient for
13478 !  a minor species at the 16 chosen g-values for a reference pressure
13479 !  level below 100~ mb.   The first index in the array, JS, runs
13480 !  from 1 to 10, and corresponds to different gas column amount ratios,
13481 !  as expressed through the binary species parameter eta, defined as
13482 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13483 !  ratio of the reference MLS column amount value of gas 1
13484 !  to that of gas2.  The second index refers to temperature
13485 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13486 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13487 !  runs over the g-channel (1 to 16).
13488 !
13489 !  The array KBO_Mxx contains the absorption coefficient for
13490 !  a minor species at the 16 chosen g-values for a reference pressure
13491 !  level above 100~ mb.   The first index refers to temperature
13492 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13493 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
13494 !  runs over the g-channel (1 to 16).
13495 !
13496 !  The array FORREFO contains the coefficient of the water vapor
13497 !  foreign-continuum (including the energy term).  The first
13498 !  index refers to reference temperature (296,260,224,260) and
13499 !  pressure (970,475,219,3 mbar) levels.  The second index
13500 !  runs over the g-channel (1 to 16).
13501 !
13502 !  The array SELFREFO contains the coefficient of the water vapor
13503 !  self-continuum (including the energy term).  The first index
13504 !  refers to temperature in 7.2 degree increments.  For instance,
13505 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13506 !  etc.  The second index runs over the g-channel (1 to 16).
13507 !
13508 !-------------------------------------------------------------------------------
13509    use rrlw_kg13_k, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco,       &
13510                          kbo_mo3, selfrefo, forrefo
13511 !
13512    implicit none
13513 !
13514    save
13515 !
13516 ! Input
13517 !
13518    integer, intent(in   ) :: rrtmg_unit
13519 !
13520 ! Local
13521 !
13522    character*80       :: errmess
13523    logical, external  :: wrf_dm_on_monitor
13524 !-------------------------------------------------------------------------------
13525 !
13526    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13527         fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
13528    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13529    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13530    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13531    call wrf_dm_bcast_bytes ( kao_mco2 , size ( kao_mco2 ) * 4 )
13532    call wrf_dm_bcast_bytes ( kao_mco , size ( kao_mco ) * 4 )
13533    call wrf_dm_bcast_bytes ( kbo_mo3 , size ( kbo_mo3 ) * 4 )
13534    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13535    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13536 !
13537    return
13538 9010 continue
13539    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13540                                'DATA on unit ',rrtmg_unit
13541 !
13542    end subroutine lw_kgb13
13543 !-------------------------------------------------------------------------------
13544 !
13545 !
13546 !-------------------------------------------------------------------------------
13547    subroutine lw_kgb14(rrtmg_unit)
13548 !-------------------------------------------------------------------------------
13549 !
13550 !  abstract :
13551 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13552 !  and upper atmosphere.
13553 !  Planck fraction mapping levels:
13554 !  Lower: P = 142.5940 mb, T = 215.70 K
13555 !  Upper: P = 4.758820 mb, T = 250.85 K
13556 !
13557 !  The array KAO contains absorption coefs for each of the 16 g-intervals
13558 !  for a range of pressure levels > ~100mb, temperatures, and ratios
13559 !  of water vapor to CO2.  The first index in the array, JS, runs
13560 !  from 1 to 10, and corresponds to different gas column amount ratios,
13561 !  as expressed through the binary species parameter eta, defined as
13562 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13563 !  ratio of the reference MLS column amount value of gas 1
13564 !  to that of gas2.
13565 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13566 !  to different temperatures.  More specifically, JT = 3 means that the
13567 !  data are for the reference temperature TREF for this  pressure
13568 !  level, JT = 2 refers to the temperature
13569 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13570 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13571 !  to the reference pressure level (e.g. JP = 1 is for a
13572 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
13573 !  and tells us which g-interval the absorption coefficients are for.
13574 !
13575 !  The array KBO contains absorption coefs at the 16 chosen g-values
13576 !  for a range of pressure levels < ~100mb and temperatures. The first
13577 !  index in the array, JT, which runs from 1 to 5, corresponds to
13578 !  different temperatures.  More specifically, JT = 3 means that the
13579 !  data are for the reference temperature TREF for this pressure
13580 !  level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13581 !  TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13582 !  The second index, JP, runs from 13 to 59 and refers to the JPth
13583 !  reference pressure level (see taumol.f for the value of these
13584 !  pressure levels in mb).  The third index, IG, goes from 1 to 16,
13585 !  and tells us which g-interval the absorption coefficients are for.
13586 !
13587 !  The array FORREFO contains the coefficient of the water vapor
13588 !  foreign-continuum (including the energy term).  The first
13589 !  index refers to reference temperature (296,260,224,260) and
13590 !  pressure (970,475,219,3 mbar) levels.  The second index
13591 !  runs over the g-channel (1 to 16).
13592 !
13593 !  The array SELFREFO contains the coefficient of the water vapor
13594 !  self-continuum (including the energy term).  The first index
13595 !  refers to temperature in 7.2 degree increments.  For instance,
13596 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13597 !  etc.  The second index runs over the g-channel (1 to 16).
13598 !
13599 !-------------------------------------------------------------------------------
13600    use rrlw_kg14_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13601 !
13602    implicit none
13603 !
13604    save
13605 !
13606 ! Input
13607 !
13608    integer, intent(in   ) :: rrtmg_unit
13609 !
13610 ! Local
13611 !
13612    character*80       :: errmess
13613    logical, external  :: wrf_dm_on_monitor
13614 !-------------------------------------------------------------------------------
13615 !
13616    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13617         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13618    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13619    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13620    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13621    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13622    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13623    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13624 !
13625    return
13626 9010 continue
13627    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13628                                'DATA on unit ',rrtmg_unit
13629 !
13630    end subroutine lw_kgb14
13631 !-------------------------------------------------------------------------------
13632 !
13633 !
13634 !-------------------------------------------------------------------------------
13635    subroutine lw_kgb15(rrtmg_unit)
13636 !-------------------------------------------------------------------------------
13637 !
13638 !  abstract :
13639 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13640 !  and upper atmosphere.
13641 !  Planck fraction mapping levels:
13642 !  Lower: P = 1053. mb, T = 294.2 K
13643 !
13644 !  The array KAO contains absorption coefs for each of the 16 g-intervals
13645 !  for a range of pressure levels > ~100mb, temperatures, and ratios
13646 !  of water vapor to CO2.  The first index in the array, JS, runs
13647 !  from 1 to 10, and corresponds to different gas column amount ratios,
13648 !  as expressed through the binary species parameter eta, defined as
13649 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13650 !  ratio of the reference MLS column amount value of gas 1
13651 !  to that of gas2.
13652 !  The 2nd index in the array, JT, which runs from 1 to 5, corresponds
13653 !  to different temperatures.  More specifically, JT = 3 means that the
13654 !  data are for the reference temperature TREF for this  pressure
13655 !  level, JT = 2 refers to the temperature
13656 !  TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13657 !  is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13658 !  to the reference pressure level (e.g. JP = 1 is for a
13659 !  pressure of 1053.63 mb).  The fourth index, IG, goes from 1 to 16,
13660 !  and tells us which g-interval the absorption coefficients are for.
13661 !
13662 !  The array KA_Mxx contains the absorption coefficient for
13663 !  a minor species at the 16 chosen g-values for a reference pressure
13664 !  level below 100~ mb.   The first index in the array, JS, runs
13665 !  from 1 to 10, and corresponds to different gas column amount ratios,
13666 !  as expressed through the binary species parameter eta, defined as
13667 !  eta = gas1/(gas1 + (rat) * gas2), where rat is the
13668 !  ratio of the reference MLS column amount value of gas 1
13669 !  to that of gas2.  The second index refers to temperature
13670 !  in 7.2 degree increments.  For instance, JT = 1 refers to a
13671 !  temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
13672 !  runs over the g-channel (1 to 16).
13673 !
13674 !  The array FORREFO contains the coefficient of the water vapor
13675 !  foreign-continuum (including the energy term).  The first
13676 !  index refers to reference temperature (296,260,224,260) and
13677 !  pressure (970,475,219,3 mbar) levels.  The second index
13678 !  runs over the g-channel (1 to 16).
13679 !
13680 !  The array SELFREFO contains the coefficient of the water vapor
13681 !  self-continuum (including the energy term).  The first index
13682 !  refers to temperature in 7.2 degree increments.  For instance,
13683 !  JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13684 !  etc.  The second index runs over the g-channel (1 to 16).
13685 !
13686 !-------------------------------------------------------------------------------
13687    use rrlw_kg15_k, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
13688 !
13689    implicit none
13690 !
13691    save
13692 !
13693 ! Input
13694 !
13695    integer, intent(in   ) :: rrtmg_unit
13696 !
13697 ! Local
13698 !
13699    character*80       :: errmess
13700    logical, external  :: wrf_dm_on_monitor
13701 !-------------------------------------------------------------------------------
13702 !
13703    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13704         fracrefao, kao, kao_mn2, selfrefo, forrefo
13705    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13706    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13707    call wrf_dm_bcast_bytes ( kao_mn2 , size ( kao_mn2 ) * 4 )
13708    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13709    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13710 !
13711    return
13712 9010 continue
13713    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13714                                'DATA on unit ',rrtmg_unit
13715 !
13716    end subroutine lw_kgb15
13717 !-------------------------------------------------------------------------------
13718 !
13719 !
13720 !-------------------------------------------------------------------------------
13721    subroutine lw_kgb16(rrtmg_unit)
13722 !-------------------------------------------------------------------------------
13723 !
13724 !  abstract :
13725 !  Arrays fracrefao and fracrefbo are the Planck fractions for the lower
13726 !  and upper atmosphere.
13727 !  Planck fraction mapping levels:
13728 !  Lower: P = 387.6100 mbar, T = 250.17 K
13729 !  Upper: P=95.58350 mb, T = 215.70 K
13730 !
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.
13748 !
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.
13760 !
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).
13766 !
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).
13772 !
13773 !-------------------------------------------------------------------------------
13774    use rrlw_kg16_k, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13775 !
13776    implicit none
13777 !
13778    save
13779 !
13780 ! Input
13781 !
13782    integer, intent(in   ) :: rrtmg_unit
13783 !
13784 ! Local
13785 !
13786    character*80       :: errmess
13787    logical, external  :: wrf_dm_on_monitor
13788 !-------------------------------------------------------------------------------
13789 !
13790    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
13791         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
13792    call wrf_dm_bcast_bytes ( fracrefao , size ( fracrefao ) * 4 )
13793    call wrf_dm_bcast_bytes ( fracrefbo , size ( fracrefbo ) * 4 )
13794    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
13795    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
13796    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
13797    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
13798 !
13799    return
13800 9010 continue
13801    write( errmess , '(a,i4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_'// &
13802                                'DATA on unit ',rrtmg_unit
13803 !
13804    end subroutine lw_kgb16
13805 !-------------------------------------------------------------------------------
13806 !
13807 !
13808 !-------------------------------------------------------------------------------
13809    subroutine relcalc(ncol, pcols, pver, t, landfrac, landm, icefrac, rel,snowh)
13810 !-------------------------------------------------------------------------------
13811 !
13812 !  abstract :
13813 !
13814 !  Purpose:
13815 !  Compute cloud water size
13816 !
13817 !  Method:
13818 !  analytic formula following the formulation originally developed by J.T. Kiehl
13819 !
13820 !  Author: Phil Rasch
13821 !
13822 !  input :
13823 !    landfrac - Land fraction
13824 !    icefrac  - Ice fraction
13825 !    snowh    - Snow depth over land, water equivalent (m)
13826 !    landm    - Land fraction ramping to zero over ocean
13827 !    t        - Temperature
13828 !
13829 !  output :
13830 !    rel      - Liquid effective drop size (microns)
13831 !
13832 !-------------------------------------------------------------------------------
13833 !
13834    implicit none
13835 !
13836 ! Input arguments
13837 !
13838    integer,                     intent(in   ) :: ncol
13839    integer,                     intent(in   ) :: pcols, pver
13840    real, dimension(pcols),      intent(in   ) :: landfrac
13841    real, dimension(pcols),      intent(in   ) :: icefrac
13842    real, dimension(pcols),      intent(in   ) :: snowh
13843    real, dimension(pcols),      intent(in   ) :: landm
13844    real, dimension(pcols,pver), intent(in   ) :: t
13845 !
13846 ! Output arguments
13847 !
13848    real, dimension(pcols,pver), intent(  out) :: rel
13849 !
13850 ! Local
13851 !
13852    integer :: i, k             ! lon, lev indices
13853    real    :: tmelt            ! freezing temperature of fresh water (K)
13854    real    :: rliqland         ! liquid drop size if over land
13855    real    :: rliqocean        ! liquid drop size if over ocean
13856    real    :: rliqice          ! liquid drop size if over sea ice
13857 !-------------------------------------------------------------------------------
13858 !
13859    tmelt = 273.16
13860    rliqocean = 14.0
13861    rliqice   = 14.0
13862    rliqland  = 8.0
13863 !
13864    do k = 1,pver
13865      do i = 1,ncol
13866 !
13867 ! jrm Reworked effective radius algorithm
13868 ! Start with temperature-dependent value appropriate for continental air
13869 ! Note: findmcnew has a pressure dependence here
13870 !
13871        rel(i,k) = rliqland + (rliqocean-rliqland)                              &
13872                              *min(1.0,max(0.0,(tmelt-t(i,k))*0.05))
13873 !
13874 ! Modify for snow depth over land
13875 !
13876        rel(i,k) = rel(i,k) + (rliqocean-rel(i,k))*min(1.0,max(0.0,snowh(i)*10.))
13877 !
13878 ! Ramp between polluted value over land to clean value over ocean.
13879 !
13880        rel(i,k) = rel(i,k) + (rliqocean-rel(i,k))*min(1.0,max(0.0,1.0-landm(i)))
13881 !
13882 ! Ramp between the resultant value and a sea ice value in the presence of ice.
13883 !
13884        rel(i,k) = rel(i,k) + (rliqice-rel(i,k))*min(1.0,max(0.0,icefrac(i)))
13885 !
13886 ! end jrm
13887 !
13888      enddo
13889    enddo
13890 !
13891    end subroutine relcalc
13892 !-------------------------------------------------------------------------------
13893 !
13894 !
13895 !-------------------------------------------------------------------------------
13896    subroutine reicalc(ncol, pcols, pver, t, re)
13897 !-------------------------------------------------------------------------------
13898 !
13899    integer,                     intent(in   ) :: ncol, pcols, pver
13900    real, dimension(pcols,pver), intent(in   ) :: t
13901    real, dimension(pcols,pver), intent(  out) :: re
13902 !
13903 ! local variables
13904 !
13905    real    :: corr
13906    integer :: i, k, index
13907 !-------------------------------------------------------------------------------
13908 !
13909 ! Tabulated values of re(T) in the temperature interval
13910 ! 180 K -- 274 K; hexagonal columns assumed:
13911 !
13912    do k = 1,pver
13913      do i = 1,ncol
13914        index = int(t(i,k)-179.)
13915        index = min(max(index,1),94)
13916        corr = t(i,k) - int(t(i,k))
13917        re(i,k) = retab(index)*(1.-corr) + retab(index+1)*corr
13918 !      re(i,k) = amax1(amin1(re(i,k),30.),10.)
13919      enddo
13920    enddo
13921 !
13922    return
13923    end subroutine reicalc
13924 !-------------------------------------------------------------------------------
13925 !
13926 !
13927 !-------------------------------------------------------------------------------
13928 !-------------------------------------------------------------------------------
13929 !
13930 !
13931 !-------------------------------------------------------------------------------
13932    end module module_ra_rrtmg_lwk
13933 !-------------------------------------------------------------------------------
13934 #endif