phys/module_ra_rrtmg_swk.F

   1 #if( BUILD_RRTMK != 1)
   2       MODULE module_ra_rrtmg_swk
   3       CONTAINS
   4       SUBROUTINE rrtmg_sw
   5          REAL :: dummy
   6          dummy = 1
   7       END SUBROUTINE rrtmg_sw
   8       END MODULE module_ra_rrtmg_swk
   9 #else
  10 !
  11 !-------------------------------------------------------------------------------
  12    module parrrsw_k
  13 !-------------------------------------------------------------------------------
  14 !  abstract : rrtmg_sw main parameters
  15 !
  16 !  history log :
  17 !    1998-07 JJMorcrette  Initial version
  18 !    2006-06 MJIacono     Revised
  19 !    2008-08 MJIacono     Revised
  20 !
  21 !  variable :
  22 !-------------------------------------------------------------------------------
  23 !
  24 !  name     type     purpose
  25 ! -----  :  ----   : -----------------------------------------------------------
  26 ! mxlay  :  integer: maximum number of layers
  27 ! mg     :  integer: number of original g-intervals per spectral band
  28 ! nbndsw :  integer: number of spectral bands
  29 ! naerec :  integer: number of aerosols (iaer=6, ecmwf aerosol option)
  30 ! ngptsw :  integer: total number of reduced g-intervals for rrtmg_lw
  31 ! ngNN   :  integer: number of reduced g-intervals per spectral band
  32 ! ngsNN  :  integer: cumulative number of g-intervals per band
  33 !-------------------------------------------------------------------------------
  34    use parkind_k , only : im => kind_im, rb => kind_rb
  35 !
  36 !  implicit none
  37 !
  38    save
  39    integer(kind=im), parameter :: mxlay  = 203    !jplay, klev
  40    integer(kind=im), parameter :: mg     = 16     !jpg
  41    integer(kind=im), parameter :: nbndsw = 14     !jpsw, ksw
  42    integer(kind=im), parameter :: naerec  = 6     !jpaer
  43    integer(kind=im), parameter :: mxmol  = 38
  44    integer(kind=im), parameter :: nstr   = 2
  45    integer(kind=im), parameter :: nmol   = 7
  46 !
  47 ! Use for 112 g-point model
  48 !
  49    integer(kind=im), parameter :: ngptsw = 112    !jpgpt
  50 !
  51 ! Use for 224 g-point model
  52 !      integer(kind=im), parameter :: ngptsw = 224   !jpgpt
  53 !
  54 ! may need to rename these - from v2.6
  55 !
  56    integer(kind=im), parameter :: jpband   = 29
  57    integer(kind=im), parameter :: jpb1     = 16   !istart
  58    integer(kind=im), parameter :: jpb2     = 29   !iend
  59    integer(kind=im), parameter :: jmcmu    = 32
  60    integer(kind=im), parameter :: jmumu    = 32
  61    integer(kind=im), parameter :: jmphi    = 3
  62    integer(kind=im), parameter :: jmxang   = 4
  63    integer(kind=im), parameter :: jmxstr   = 16
  64 !
  65 ! Use for 112 g-point model
  66 !
  67    integer(kind=im), parameter :: ng16 = 6
  68    integer(kind=im), parameter :: ng17 = 12
  69    integer(kind=im), parameter :: ng18 = 8
  70    integer(kind=im), parameter :: ng19 = 8
  71    integer(kind=im), parameter :: ng20 = 10
  72    integer(kind=im), parameter :: ng21 = 10
  73    integer(kind=im), parameter :: ng22 = 2
  74    integer(kind=im), parameter :: ng23 = 10
  75    integer(kind=im), parameter :: ng24 = 8
  76    integer(kind=im), parameter :: ng25 = 6
  77    integer(kind=im), parameter :: ng26 = 6
  78    integer(kind=im), parameter :: ng27 = 8
  79    integer(kind=im), parameter :: ng28 = 6
  80    integer(kind=im), parameter :: ng29 = 12
  81    integer(kind=im), parameter :: ngs16 = 6
  82    integer(kind=im), parameter :: ngs17 = 18
  83    integer(kind=im), parameter :: ngs18 = 26
  84    integer(kind=im), parameter :: ngs19 = 34
  85    integer(kind=im), parameter :: ngs20 = 44
  86    integer(kind=im), parameter :: ngs21 = 54
  87    integer(kind=im), parameter :: ngs22 = 56
  88    integer(kind=im), parameter :: ngs23 = 66
  89    integer(kind=im), parameter :: ngs24 = 74
  90    integer(kind=im), parameter :: ngs25 = 80
  91    integer(kind=im), parameter :: ngs26 = 86
  92    integer(kind=im), parameter :: ngs27 = 94
  93    integer(kind=im), parameter :: ngs28 = 100
  94    integer(kind=im), parameter :: ngs29 = 112
  95 !
  96 ! Use for 224 g-point model
  97 !  integer(kind=im), parameter :: ng16 = 16
  98 !  integer(kind=im), parameter :: ng17 = 16
  99 !  integer(kind=im), parameter :: ng18 = 16
 100 !  integer(kind=im), parameter :: ng19 = 16
 101 !  integer(kind=im), parameter :: ng20 = 16
 102 !  integer(kind=im), parameter :: ng21 = 16
 103 !  integer(kind=im), parameter :: ng22 = 16
 104 !  integer(kind=im), parameter :: ng23 = 16
 105 !  integer(kind=im), parameter :: ng24 = 16
 106 !  integer(kind=im), parameter :: ng25 = 16
 107 !  integer(kind=im), parameter :: ng26 = 16
 108 !  integer(kind=im), parameter :: ng27 = 16
 109 !  integer(kind=im), parameter :: ng28 = 16
 110 !  integer(kind=im), parameter :: ng29 = 16
 111 !
 112 !  integer(kind=im), parameter :: ngs16 = 16
 113 !  integer(kind=im), parameter :: ngs17 = 32
 114 !  integer(kind=im), parameter :: ngs18 = 48
 115 !  integer(kind=im), parameter :: ngs19 = 64
 116 !  integer(kind=im), parameter :: ngs20 = 80
 117 !  integer(kind=im), parameter :: ngs21 = 96
 118 !  integer(kind=im), parameter :: ngs22 = 112
 119 !  integer(kind=im), parameter :: ngs23 = 128
 120 !  integer(kind=im), parameter :: ngs24 = 144
 121 !  integer(kind=im), parameter :: ngs25 = 160
 122 !  integer(kind=im), parameter :: ngs26 = 176
 123 !  integer(kind=im), parameter :: ngs27 = 192
 124 !  integer(kind=im), parameter :: ngs28 = 208
 125 !  integer(kind=im), parameter :: ngs29 = 224
 126 !
 127 ! Source function solar constant
 128 !
 129    real(kind=rb), parameter :: rrsw_scon = 1.36822e+03     ! W/m2
 130 !-------------------------------------------------------------------------------
 131    end module parrrsw_k
 132 !-------------------------------------------------------------------------------
 133 !
 134 !
 135 !-------------------------------------------------------------------------------
 136    module rrsw_aer_k
 137 !-------------------------------------------------------------------------------
 138 !  abstract :
 139 !    rrtmg_sw aerosol optical properties
 140 !    Data derived from six ECMWF aerosol types and defined for
 141 !    the rrtmg_sw spectral intervals
 142 !
 143 !  history log :
 144 !    2003-03 J.-J. Morcrette, ECMWF Initial
 145 !    2006-07 MJIacono         Revised
 146 !    2008-08 MJIacono         Revised
 147 !-------------------------------------------------------------------------------
 148 !
 149 !-- The six ECMWF aerosol types ar e respectively:
 150 !
 151 !  1/ continental average                 2/ maritime
 152 !  3/ desert                              4/ urban
 153 !  5/ volcanic active                     6/ stratospheric background
 154 !
 155 ! computed from Hess and Koepke (con, mar, des, urb)
 156 !          from Bonnel et al.   (vol, str)
 157 !
 158 ! rrtmg_sw 14 spectral intervals (microns):
 159 !  3.846 -  3.077
 160 !  3.077 -  2.500
 161 !  2.500 -  2.150
 162 !  2.150 -  1.942
 163 !  1.942 -  1.626
 164 !  1.626 -  1.299
 165 !  1.299 -  1.242
 166 !  1.242 -  0.7782
 167 !  0.7782-  0.6250
 168 !  0.6250-  0.4415
 169 !  0.4415-  0.3448
 170 !  0.3448-  0.2632
 171 !  0.2632-  0.2000
 172 ! 12.195 -  3.846
 173 !
 174 !-------------------------------------------------------------------------------
 175 !
 176 !  name     type     purpose
 177 ! -----   : ----   : ----------------------------------------------
 178 ! rsrtaua : real   : ratio of average optical thickness in
 179 !                    spectral band to that at 0.55 micron
 180 ! rsrpiza : real   : average single scattering albedo (unitless)
 181 ! rsrasya : real   : average asymmetry parameter (unitless)
 182 !-------------------------------------------------------------------------------
 183    use parkind_k, only : im => kind_im, rb => kind_rb
 184    use parrrsw_k, only : nbndsw, naerec
 185 !
 186 !  implicit none
 187 !
 188    save
 189    real(kind=rb), dimension(nbndsw,naerec) :: rsrtaua
 190    real(kind=rb), dimension(nbndsw,naerec) :: rsrpiza
 191    real(kind=rb), dimension(nbndsw,naerec) :: rsrasya
 192 !-------------------------------------------------------------------------------
 193    end module rrsw_aer_k
 194 !-------------------------------------------------------------------------------
 195 !
 196 !
 197 !-------------------------------------------------------------------------------
 198    module rrsw_cld_k
 199 !-------------------------------------------------------------------------------
 200 ! abstract :
 201 !   rrtmg_sw cloud property coefficients
 202 !
 203 ! history log :
 204 !   1999-08 J.-J. Morcrette, ECMWF      Initial
 205 !   2005-08 J. Delamere/MJIacono, AER,  Revised
 206 !   2005-11 MJIacono, AER               Revised
 207 !   2008-08 MJIacono, AER               Revised
 208 !-------------------------------------------------------------------------------
 209 !
 210 !  name     type     purpose
 211 ! -----  :  ----   : --------------------------------------------------------
 212 ! xxxliq1 : real   : optical properties (extinction coefficient, single
 213 !                    scattering albedo, assymetry factor) from
 214 !                    Hu & Stamnes, j. clim., 6, 728-742, 1993.
 215 ! xxxice2 : real   : optical properties (extinction coefficient, single
 216 !                    scattering albedo, assymetry factor) from streamer v3.0,
 217 !                    Key, streamer user's guide, cooperative institude
 218 !                    for meteorological studies, 95 pp., 2001.
 219 ! xxxice3 : real   : optical properties (extinction coefficient, single
 220 !                    scattering albedo, assymetry factor) from
 221 !                    Fu, j. clim., 9, 1996.
 222 ! xbari   : real   : optical property coefficients for five spectral
 223 !                    intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
 224 !                    and 14285-40000 wavenumbers) following
 225 !                    Ebert and Curry, jgr, 97, 3831-3836, 1992.
 226 !-------------------------------------------------------------------------------
 227    use parkind_k, only : im => kind_im, rb => kind_rb
 228 !
 229 !  implicit none
 230 !
 231    save
 232    real(kind=rb), dimension(58,16:29) :: extliq1, ssaliq1, asyliq1
 233    real(kind=rb), dimension(43,16:29) :: extice2, ssaice2, asyice2
 234    real(kind=rb), dimension(46,16:29) :: extice3, ssaice3, asyice3
 235    real(kind=rb), dimension(46,16:29) :: fdlice3
 236    real(kind=rb), dimension(5) :: abari, bbari, cbari, dbari, ebari, fbari
 237 !-------------------------------------------------------------------------------
 238    end module rrsw_cld_k
 239 !-------------------------------------------------------------------------------
 240 !
 241 !
 242 !-------------------------------------------------------------------------------
 243    module rrsw_con_k
 244 !-------------------------------------------------------------------------------
 245 !  abstract :
 246 !    rrtmg_sw constants
 247 !
 248 !  history log :
 249 !    2006-06 MJIacono AER    Initial
 250 !    2008-08 MJIacono AER    Revised
 251 !-------------------------------------------------------------------------------
 252 !  name     type     purpose
 253 ! -----  :  ----   : -----------------------------------------------------------
 254 ! fluxfac:  real   : radiance to flux conversion factor
 255 ! heatfac:  real   : flux to heating rate conversion factor
 256 !oneminus:  real   : 1.-1.e-6
 257 ! pi     :  real   : pi
 258 ! grav   :  real   : acceleration of gravity
 259 ! planck :  real   : planck constant
 260 ! boltz  :  real   : boltzmann constant
 261 ! clight :  real   : speed of light
 262 ! avogad :  real   : avogadro constant
 263 ! alosmt :  real   : loschmidt constant
 264 ! gascon :  real   : molar gas constant
 265 ! radcn1 :  real   : first radiation constant
 266 ! radcn2 :  real   : second radiation constant
 267 ! sbcnst :  real   : stefan-boltzmann constant
 268 !  secdy :  real   : seconds per day
 269 !-------------------------------------------------------------------------------
 270    use parkind_k, only : im => kind_im, rb => kind_rb
 271 !
 272 !  implicit none
 273 !
 274    save
 275    real(kind=rb) :: fluxfac, heatfac
 276    real(kind=rb) :: oneminus, pi, grav
 277    real(kind=rb) :: planck, boltz, clight
 278    real(kind=rb) :: avogad, alosmt, gascon
 279    real(kind=rb) :: radcn1, radcn2
 280    real(kind=rb) :: sbcnst, secdy
 281 !-------------------------------------------------------------------------------
 282    end module rrsw_con_k
 283 !-------------------------------------------------------------------------------
 284 !
 285 !
 286 !
 287 !-------------------------------------------------------------------------------
 288    module rrsw_kg16_k
 289 !-------------------------------------------------------------------------------
 290 ! abstract :
 291 !   rrtmg_sw ORIGINAL abs. coefficients for interval 16
 292 !   band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
 293 !
 294 ! history log :
 295 !   1999-10 JJMorcrette  Initial version
 296 !   2006-07 MJIacono     Revised, AER
 297 !   2008-08 MJIacono     Revised, AER
 298 !-------------------------------------------------------------------------------
 299 !
 300 !  name     type     purpose
 301 !  ----   : ----   : ---------------------------------------------
 302 ! kao     : real
 303 ! kbo     : real
 304 ! selfrefo: real
 305 ! forrefo : real
 306 !sfluxrefo: real
 307 !-------------------------------------------------------------------------------
 308 ! rrtmg_sw COMBINED abs. coefficients for interval 16
 309 ! band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
 310 !
 311 ! Initial version:  JJMorcrette, ECMWF, oct1999
 312 ! Revised: MJIacono, AER, jul2006
 313 ! Revised: MJIacono, AER, aug2008
 314 !-------------------------------------------------------------------------------
 315 !
 316 !  name     type     purpose
 317 !  ----   : ----   : ---------------------------------------------
 318 ! ka      : real
 319 ! kb      : real
 320 ! absa    : real
 321 ! absb    : real
 322 ! selfref : real
 323 ! forref  : real
 324 ! sfluxref: real
 325 !-------------------------------------------------------------------------------
 326    use parkind_k, only : im => kind_im, rb => kind_rb
 327    use parrrsw_k, only : ng16
 328 !
 329 !  implicit none
 330 !
 331    save
 332    integer(kind=im), parameter           :: no16 = 16
 333    real(kind=rb), dimension(9,5,13,no16) :: kao
 334    real(kind=rb), dimension(5,13:59,no16):: kbo
 335    real(kind=rb), dimension(10,no16)     :: selfrefo
 336    real(kind=rb), dimension(3,no16)      :: forrefo
 337    real(kind=rb), dimension(no16)        :: sfluxrefo
 338    integer(kind=im)                      :: layreffr
 339    real(kind=rb)                         :: rayl, strrat1
 340 !
 341    real(kind=rb), dimension(9,5,13,ng16) :: ka
 342    real(kind=rb), dimension(585,ng16)    :: absa
 343    real(kind=rb), dimension(5,13:59,ng16):: kb
 344    real(kind=rb), dimension(235,ng16)    :: absb
 345    real(kind=rb), dimension(10,ng16)     :: selfref
 346    real(kind=rb), dimension(3,ng16)      :: forref
 347    real(kind=rb), dimension(ng16)        :: sfluxref
 348 !
 349    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 350 !-------------------------------------------------------------------------------
 351    end module rrsw_kg16_k
 352 !-------------------------------------------------------------------------------
 353 !
 354 !
 355 !-------------------------------------------------------------------------------
 356    module rrsw_kg17_k
 357 !-------------------------------------------------------------------------------
 358 ! abstract :
 359 !   rrtmg_sw ORIGINAL abs. coefficients for interval 17
 360 !   band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
 361 !
 362 ! history log :
 363 !   1999-10 JJMorcrette  Initial version
 364 !   2006-07 MJIacono     Revised, AER
 365 !   2008-08 MJIacono     Revised, AER
 366 !-----------------------------------------------------------------
 367 !
 368 !  name     type     purpose
 369 !  ----   : ----   : ---------------------------------------------
 370 ! kao     : real
 371 ! kbo     : real
 372 ! selfrefo: real
 373 ! forrefo : real
 374 !sfluxrefo: real
 375 !-------------------------------------------------------------------------------
 376 ! rrtmg_sw COMBINED abs. coefficients for interval 17
 377 ! band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
 378 !
 379 ! Initial version:  JJMorcrette, ECMWF, oct1999
 380 ! Revised: MJIacono, AER, jul2006
 381 ! Revised: MJIacono, AER, aug2008
 382 !-------------------------------------------------------------------------------
 383 !
 384 !  name     type     purpose
 385 !  ----   : ----   : ---------------------------------------------
 386 ! ka      : real
 387 ! kb      : real
 388 ! absa    : real
 389 ! absb    : real
 390 ! selfref : real
 391 ! forref  : real
 392 ! sfluxref: real
 393 !-------------------------------------------------------------------------------
 394    use parkind_k, only : im => kind_im, rb => kind_rb
 395    use parrrsw_k, only : ng17
 396 !-------------------------------------------------------------------------------
 397 !
 398 !  implicit none
 399 !
 400    save
 401    integer(kind=im), parameter             :: no17 = 16
 402 !
 403    real(kind=rb), dimension(9,5,13,no17)   :: kao
 404    real(kind=rb), dimension(5,5,13:59,no17):: kbo
 405    real(kind=rb), dimension(10,no17)       :: selfrefo
 406    real(kind=rb), dimension(4,no17)        :: forrefo
 407    real(kind=rb), dimension(no17,5)        :: sfluxrefo
 408 !
 409    integer(kind=im)                        :: layreffr
 410    real(kind=rb)                           :: rayl, strrat
 411 !
 412    real(kind=rb), dimension(9,5,13,ng17)   :: ka
 413    real(kind=rb), dimension(585,ng17)      :: absa
 414    real(kind=rb), dimension(5,5,13:59,ng17):: kb
 415    real(kind=rb), dimension(1175,ng17)     :: absb
 416    real(kind=rb), dimension(10,ng17)       :: selfref
 417    real(kind=rb), dimension(4,ng17)        :: forref
 418    real(kind=rb), dimension(ng17,5)        :: sfluxref
 419 !
 420    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
 421 !-------------------------------------------------------------------------------
 422    end module rrsw_kg17_k
 423 !-------------------------------------------------------------------------------
 424 !
 425 !
 426 !-------------------------------------------------------------------------------
 427    module rrsw_kg18_k
 428 !-------------------------------------------------------------------------------
 429 !  abstract :
 430 !    rrtmg_sw ORIGINAL abs. coefficients for interval 18
 431 !    band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
 432 !
 433 !  history log :
 434 !   1999-10 JJMorcrette  Initial version
 435 !   2006-07 MJIacono     Revised, AER
 436 !   2008-08 MJIacono     Revised, AER
 437 !-------------------------------------------------------------------------------
 438 !
 439 !  name     type     purpose
 440 !  ----   : ----   : ---------------------------------------------
 441 ! kao     : real
 442 ! kbo     : real
 443 ! selfrefo: real
 444 ! forrefo : real
 445 !sfluxrefo: real
 446 !-------------------------------------------------------------------------------
 447 ! rrtmg_sw COMBINED abs. coefficients for interval 18
 448 ! band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
 449 !
 450 ! Initial version:  JJMorcrette, ECMWF, oct1999
 451 ! Revised: MJIacono, AER, jul2006
 452 ! Revised: MJIacono, AER, aug2008
 453 !-------------------------------------------------------------------------------
 454 !
 455 !  name     type     purpose
 456 !  ----   : ----   : ---------------------------------------------
 457 ! ka      : real
 458 ! kb      : real
 459 ! absa    : real
 460 ! absb    : real
 461 ! selfref : real
 462 ! forref  : real
 463 ! sfluxref: real
 464 !-------------------------------------------------------------------------------
 465    use parkind_k, only : im => kind_im, rb => kind_rb
 466    use parrrsw_k, only : ng18
 467 !
 468 !  implicit none
 469 !
 470    save
 471    integer(kind=im), parameter :: no18 = 16
 472 !
 473    real(kind=rb), dimension(9,5,13,no18)   :: kao
 474    real(kind=rb), dimension(5,13:59,no18)  :: kbo
 475    real(kind=rb), dimension(10,no18)       :: selfrefo
 476    real(kind=rb), dimension(3,no18)        :: forrefo
 477    real(kind=rb), dimension(no18,9)        :: sfluxrefo
 478 !
 479    integer(kind=im)                        :: layreffr
 480    real(kind=rb)                           :: rayl, strrat
 481 !
 482    real(kind=rb), dimension(9,5,13,ng18)   :: ka
 483    real(kind=rb), dimension(585,ng18)      :: absa
 484    real(kind=rb), dimension(5,13:59,ng18)  :: kb
 485    real(kind=rb), dimension(235,ng18)      :: absb
 486    real(kind=rb), dimension(10,ng18)       :: selfref
 487    real(kind=rb), dimension(3,ng18)        :: forref
 488    real(kind=rb), dimension(ng18,9)        :: sfluxref
 489    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 490 !-------------------------------------------------------------------------------
 491    end module rrsw_kg18_k
 492 !-------------------------------------------------------------------------------
 493 !
 494 !
 495 !-------------------------------------------------------------------------------
 496    module rrsw_kg19_k
 497 !-------------------------------------------------------------------------------
 498 ! abstract :
 499 !   rrtmg_sw ORIGINAL abs. coefficients for interval 19
 500 !    band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
 501 !
 502 ! history log :
 503 !   1999-10 JJMorcrette  Initial version
 504 !   2006-07 MJIacono     Revised, AER
 505 !   2008-08 MJIacono     Revised, AER
 506 !-------------------------------------------------------------------------------
 507 !
 508 !  name     type     purpose
 509 !  ----   : ----   : ---------------------------------------------
 510 ! kao     : real
 511 ! kbo     : real
 512 ! selfrefo: real
 513 ! forrefo : real
 514 !sfluxrefo: real
 515 !-------------------------------------------------------------------------------
 516 ! rrtmg_sw COMBINED abs. coefficients for interval 19
 517 ! band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
 518 !
 519 ! Initial version:  JJMorcrette, ECMWF, oct1999
 520 ! Revised: MJIacono, AER, jul2006
 521 ! Revised: MJIacono, AER, aug2008
 522 !-------------------------------------------------------------------------------
 523 !
 524 !  name     type     purpose
 525 !  ----   : ----   : ---------------------------------------------
 526 ! ka      : real
 527 ! kb      : real
 528 ! absa    : real
 529 ! absb    : real
 530 ! selfref : real
 531 ! forref  : real
 532 ! sfluxref: real
 533 !-------------------------------------------------------------------------------
 534    use parkind_k, only : im => kind_im, rb => kind_rb
 535    use parrrsw_k, only : ng19
 536 !
 537 !  implicit none
 538 !
 539    save
 540    integer(kind=im), parameter :: no19 = 16
 541 !
 542    real(kind=rb), dimension(9,5,13,no19)   :: kao
 543    real(kind=rb), dimension(5,13:59,no19)  :: kbo
 544    real(kind=rb), dimension(10,no19)       :: selfrefo
 545    real(kind=rb), dimension(3,no19)        :: forrefo
 546    real(kind=rb), dimension(no19,9)        :: sfluxrefo
 547 !
 548    integer(kind=im)                        :: layreffr
 549    real(kind=rb)                           :: rayl, strrat
 550 !
 551    real(kind=rb), dimension(9,5,13,ng19)   :: ka
 552    real(kind=rb), dimension(585,ng19)      :: absa
 553    real(kind=rb), dimension(5,13:59,ng19)  :: kb
 554    real(kind=rb), dimension(235,ng19)      :: absb
 555    real(kind=rb), dimension(10,ng19)       :: selfref
 556    real(kind=rb), dimension(3,ng19)        :: forref
 557    real(kind=rb), dimension(ng19,9)        :: sfluxref
 558    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 559 !-------------------------------------------------------------------------------
 560    end module rrsw_kg19_k
 561 !-------------------------------------------------------------------------------
 562 !
 563 !
 564 !-------------------------------------------------------------------------------
 565    module rrsw_kg20_k
 566 !-------------------------------------------------------------------------------
 567 ! abstract :
 568 !   rrtmg_sw ORIGINAL abs. coefficients for interval 20
 569 !   band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
 570 !
 571 ! history log :
 572 !   1999-10 JJMorcrette  Initial version
 573 !   2006-07 MJIacono     Revised, AER
 574 !   2008-08 MJIacono     Revised, AER
 575 !-------------------------------------------------------------------------------
 576 !
 577 !  name     type     purpose
 578 !  ----   : ----   : ---------------------------------------------
 579 ! kao     : real
 580 ! kbo     : real
 581 ! selfrefo: real
 582 ! forrefo : real
 583 !sfluxrefo: real
 584 ! absch4o : real
 585 !-------------------------------------------------------------------------------
 586 ! rrtmg_sw COMBINED abs. coefficients for interval 20
 587 ! band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
 588 !
 589 ! Initial version:  JJMorcrette, ECMWF, oct1999
 590 ! Revised: MJIacono, AER, jul2006
 591 ! Revised: MJIacono, AER, aug2008
 592 !-------------------------------------------------------------------------------
 593 !
 594 !  name     type     purpose
 595 !  ----   : ----   : ---------------------------------------------
 596 ! ka      : real
 597 ! kb      : real
 598 ! absa    : real
 599 ! absb    : real
 600 ! selfref : real
 601 ! forref  : real
 602 ! sfluxref: real
 603 ! absch4  : real
 604 !-------------------------------------------------------------------------------
 605    use parkind_k, only : im => kind_im, rb => kind_rb
 606    use parrrsw_k, only : ng20
 607 !
 608 !  implicit none
 609 !
 610    save
 611    integer(kind=im), parameter :: no20 = 16
 612 !
 613    real(kind=rb), dimension(5,13,no20)     :: kao
 614    real(kind=rb), dimension(5,13:59,no20)  :: kbo
 615    real(kind=rb), dimension(10,no20)       :: selfrefo
 616    real(kind=rb), dimension(4,no20)        :: forrefo
 617    real(kind=rb), dimension(no20)          :: sfluxrefo
 618    real(kind=rb), dimension(no20)          :: absch4o
 619 !
 620    integer(kind=im)                        :: layreffr
 621    real(kind=rb)                           :: rayl, strrat
 622 !
 623    real(kind=rb), dimension(5,13,ng20)     :: ka
 624    real(kind=rb), dimension(65,ng20)       :: absa
 625    real(kind=rb), dimension(5,13:59,ng20)  :: kb
 626    real(kind=rb), dimension(235,ng20)      :: absb
 627    real(kind=rb), dimension(10,ng20)       :: selfref
 628    real(kind=rb), dimension(4,ng20)        :: forref
 629    real(kind=rb), dimension(ng20)          :: sfluxref
 630    real(kind=rb), dimension(no20)          :: absch4
 631    equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 632 !-------------------------------------------------------------------------------
 633    end module rrsw_kg20_k
 634 !-------------------------------------------------------------------------------
 635 !
 636 !
 637 !-------------------------------------------------------------------------------
 638    module rrsw_kg21_k
 639 !-------------------------------------------------------------------------------
 640 !  abstract :
 641 !    rrtmg_sw ORIGINAL abs. coefficients for interval 21
 642 !     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
 643 !
 644 ! history log :
 645 !   1999-10 JJMorcrette  Initial version
 646 !   2006-07 MJIacono     Revised, AER
 647 !   2008-08 MJIacono     Revised, AER
 648 !-------------------------------------------------------------------------------
 649 !
 650 !  name     type     purpose
 651 !  ----   : ----   : ---------------------------------------------
 652 ! kao     : real
 653 ! kbo     : real
 654 ! selfrefo: real
 655 ! forrefo : real
 656 !sfluxrefo: real
 657 !-------------------------------------------------------------------------------
 658 ! rrtmg_sw COMBINED abs. coefficients for interval 21
 659 ! band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
 660 !
 661 ! Initial version:  JJMorcrette, ECMWF, oct1999
 662 ! Revised: MJIacono, AER, jul2006
 663 ! Revised: MJIacono, AER, aug2008
 664 !-------------------------------------------------------------------------------
 665 !
 666 !  name     type     purpose
 667 !  ----   : ----   : ---------------------------------------------
 668 ! ka      : real
 669 ! kb      : real
 670 ! absa    : real
 671 ! absb    : real
 672 ! selfref : real
 673 ! forref  : real
 674 ! sfluxref: real
 675 !-------------------------------------------------------------------------------
 676    use parkind_k, only : im => kind_im, rb => kind_rb
 677    use parrrsw_k, only : ng21
 678 !
 679 !  implicit none
 680 !
 681    save
 682    integer(kind=im), parameter :: no21 = 16
 683 !
 684    real(kind=rb), dimension(9,5,13,no21)     :: kao
 685    real(kind=rb), dimension(5,5,13:59,no21)  :: kbo
 686    real(kind=rb), dimension(10,no21)         :: selfrefo
 687    real(kind=rb), dimension(4,no21)          :: forrefo
 688    real(kind=rb), dimension(no21,9)          :: sfluxrefo
 689 !
 690    integer(kind=im)                          :: layreffr
 691    real(kind=rb)                             :: rayl, strrat
 692 !
 693    real(kind=rb), dimension(9,5,13,ng21)     :: ka
 694    real(kind=rb), dimension(585,ng21)        :: absa
 695    real(kind=rb), dimension(5,5,13:59,ng21)  :: kb
 696    real(kind=rb), dimension(1175,ng21)       :: absb
 697    real(kind=rb), dimension(10,ng21)         :: selfref
 698    real(kind=rb), dimension(4,ng21)          :: forref
 699    real(kind=rb), dimension(ng21,9)          :: sfluxref
 700    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
 701 !-------------------------------------------------------------------------------
 702    end module rrsw_kg21_k
 703 !-------------------------------------------------------------------------------
 704 !
 705 !
 706 !-------------------------------------------------------------------------------
 707    module rrsw_kg22_k
 708 !-------------------------------------------------------------------------------
 709 !  abstract :
 710 !    rrtmg_sw ORIGINAL abs. coefficients for interval 22
 711 !    band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
 712 !
 713 ! history log :
 714 !   1999-10 JJMorcrette  Initial version
 715 !   2006-07 MJIacono     Revised, AER
 716 !   2008-08 MJIacono     Revised, AER
 717 !-------------------------------------------------------------------------------
 718 !
 719 !  name     type     purpose
 720 !  ----   : ----   : ---------------------------------------------
 721 ! kao     : real
 722 ! kbo     : real
 723 ! selfrefo: real
 724 ! forrefo : real
 725 !sfluxrefo: real
 726 !-------------------------------------------------------------------------------
 727 ! rrtmg_sw ORIGINAL abs. coefficients for interval 22
 728 ! band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
 729 !
 730 ! Initial version:  JJMorcrette, ECMWF, oct1999
 731 ! Revised: MJIacono, AER, jul2006
 732 ! Revised: MJIacono, AER, aug2008
 733 !-------------------------------------------------------------------------------
 734 !
 735 !  name     type     purpose
 736 !  ----   : ----   : ---------------------------------------------
 737 ! kao     : real
 738 ! kbo     : real
 739 ! selfrefo: real
 740 ! forrefo : real
 741 !sfluxrefo: real
 742 !-------------------------------------------------------------------------------
 743    use parkind_k, only : im => kind_im, rb => kind_rb
 744    use parrrsw_k, only : ng22
 745 !
 746 !  implicit none
 747 !
 748    save
 749    integer(kind=im), parameter :: no22 = 16
 750 !
 751    real(kind=rb), dimension(9,5,13,no22)     :: kao
 752    real(kind=rb), dimension(5,13:59,no22)    :: kbo
 753    real(kind=rb), dimension(10,no22)         :: selfrefo
 754    real(kind=rb), dimension(3,no22)          :: forrefo
 755    real(kind=rb), dimension(no22,9)          :: sfluxrefo
 756 !
 757    integer(kind=im)                          :: layreffr
 758    real(kind=rb)                             :: rayl, strrat
 759 !
 760    real(kind=rb), dimension(9,5,13,ng22)     :: ka
 761    real(kind=rb), dimension(585,ng22)        :: absa
 762    real(kind=rb), dimension(5,13:59,ng22)    :: kb
 763    real(kind=rb), dimension(235,ng22)        :: absb
 764    real(kind=rb), dimension(10,ng22)         :: selfref
 765    real(kind=rb), dimension(3,ng22)          :: forref
 766    real(kind=rb), dimension(ng22,9)          :: sfluxref
 767    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 768 !-------------------------------------------------------------------------------
 769    end module rrsw_kg22_k
 770 !-------------------------------------------------------------------------------
 771 !
 772 !
 773 !-------------------------------------------------------------------------------
 774    module rrsw_kg23_k
 775 !-------------------------------------------------------------------------------
 776 !  abstract :
 777 !    rrtmg_sw ORIGINAL abs. coefficients for interval 23
 778 !    band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
 779 !
 780 !  history log :
 781 !   1999-10 JJMorcrette  Initial version
 782 !   2006-07 MJIacono     Revised, AER
 783 !   2008-08 MJIacono     Revised, AER
 784 !-------------------------------------------------------------------------------
 785 !
 786 !  name     type     purpose
 787 !  ----   : ----   : ---------------------------------------------
 788 ! kao     : real
 789 ! kbo     : real
 790 ! selfrefo: real
 791 ! forrefo : real
 792 !sfluxrefo: real
 793 !-------------------------------------------------------------------------------
 794 ! rrtmg_sw COMBINED abs. coefficients for interval 23
 795 ! band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
 796 !
 797 ! Initial version:  JJMorcrette, ECMWF, oct1999
 798 ! Revised: MJIacono, AER, jul2006
 799 ! Revised: MJIacono, AER, aug2008
 800 !-------------------------------------------------------------------------------
 801 !
 802 !  name     type     purpose
 803 !  ----   : ----   : ---------------------------------------------
 804 ! ka      : real
 805 ! kb      : real
 806 ! absa    : real
 807 ! absb    : real
 808 ! selfref : real
 809 ! forref  : real
 810 ! sfluxref: real
 811 !-------------------------------------------------------------------------------
 812    use parkind_k, only : im => kind_im, rb => kind_rb
 813    use parrrsw_k, only : ng23
 814 !
 815 !  implicit none
 816 !
 817    save
 818    integer(kind=im), parameter :: no23 = 16
 819 !
 820    real(kind=rb), dimension(5,13,no23)       :: kao
 821    real(kind=rb), dimension(10,no23)         :: selfrefo
 822    real(kind=rb), dimension(3,no23)          :: forrefo
 823    real(kind=rb), dimension(no23)            :: sfluxrefo
 824    real(kind=rb), dimension(no23)            :: raylo
 825 !
 826    integer(kind=im)                          :: layreffr
 827    real(kind=rb)                             :: givfac
 828 !
 829    real(kind=rb), dimension(5,13,ng23)       :: ka
 830    real(kind=rb), dimension(65,ng23)         :: absa
 831    real(kind=rb), dimension(10,ng23)         :: selfref
 832    real(kind=rb), dimension(3,ng23)          :: forref
 833    real(kind=rb), dimension(ng23)            :: sfluxref
 834    real(kind=rb), dimension(no23)            :: rayl
 835    equivalence (ka(1,1,1),absa(1,1))
 836 !-------------------------------------------------------------------------------
 837    end module rrsw_kg23_k
 838 !-------------------------------------------------------------------------------
 839 !
 840 !
 841 !-------------------------------------------------------------------------------
 842    module rrsw_kg24_k
 843 !-------------------------------------------------------------------------------
 844 ! abstract :
 845 !   rrtmg_sw ORIGINAL abs. coefficients for interval 24
 846 !   band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
 847 !
 848 ! history log :
 849 !   1999-10 JJMorcrette  Initial version
 850 !   2006-07 MJIacono     Revised, AER
 851 !   2008-08 MJIacono     Revised, AER
 852 !-------------------------------------------------------------------------------
 853 !
 854 !  name     type     purpose
 855 !  ----   : ----   : ---------------------------------------------
 856 ! kao     : real
 857 ! kbo     : real
 858 ! selfrefo: real
 859 ! forrefo : real
 860 !sfluxrefo: real
 861 ! abso3ao : real
 862 ! abso3bo : real
 863 ! raylao  : real
 864 ! raylbo  : real
 865 !-------------------------------------------------------------------------------
 866 ! rrtmg_sw COMBINED abs. coefficients for interval 24
 867 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
 868 !
 869 ! Initial version:  JJMorcrette, ECMWF, oct1999
 870 ! Revised: MJIacono, AER, jul2006
 871 ! Revised: MJIacono, AER, aug2008
 872 !-------------------------------------------------------------------------------
 873 !
 874 !  name     type     purpose
 875 !  ----   : ----   : ---------------------------------------------
 876 ! ka      : real
 877 ! kb      : real
 878 ! absa    : real
 879 ! absb    : real
 880 ! selfref : real
 881 ! forref  : real
 882 ! sfluxref: real
 883 ! abso3a  : real
 884 ! abso3b  : real
 885 ! rayla   : real
 886 ! raylb   : real
 887 !-------------------------------------------------------------------------------
 888    use parkind_k, only : im => kind_im, rb => kind_rb
 889    use parrrsw_k, only : ng24
 890 !
 891 !  implicit none
 892 !
 893    save
 894    integer(kind=im), parameter :: no24 = 16
 895 !
 896    real(kind=rb), dimension(9,5,13,no24)     :: kao
 897    real(kind=rb), dimension(5,13:59,no24)    :: kbo
 898    real(kind=rb), dimension(10,no24)         :: selfrefo
 899    real(kind=rb), dimension(3,no24)          :: forrefo
 900    real(kind=rb), dimension(no24,9)          :: sfluxrefo
 901    real(kind=rb), dimension(no24)            :: abso3ao
 902    real(kind=rb), dimension(no24)            :: abso3bo
 903    real(kind=rb), dimension(no24,9)          :: raylao
 904    real(kind=rb), dimension(no24)            :: raylbo
 905 !
 906    integer(kind=im)                          :: layreffr
 907    real(kind=rb)                             :: strrat
 908 !
 909    real(kind=rb), dimension(9,5,13,ng24)     :: ka
 910    real(kind=rb), dimension(585,ng24)        :: absa
 911    real(kind=rb), dimension(5,13:59,ng24)    :: kb
 912    real(kind=rb), dimension(235,ng24)        :: absb
 913    real(kind=rb), dimension(10,ng24)         :: selfref
 914    real(kind=rb), dimension(3,ng24)          :: forref
 915    real(kind=rb), dimension(ng24,9)          :: sfluxref
 916    real(kind=rb), dimension(ng24)            :: abso3a
 917    real(kind=rb), dimension(ng24)            :: abso3b
 918    real(kind=rb), dimension(ng24,9)          :: rayla
 919    real(kind=rb), dimension(ng24)            :: raylb
 920    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 921 !-------------------------------------------------------------------------------
 922    end module rrsw_kg24_k
 923 !-------------------------------------------------------------------------------
 924 !
 925 !
 926 !-------------------------------------------------------------------------------
 927    module rrsw_kg25_k
 928 !-------------------------------------------------------------------------------
 929 !  abstract :
 930 !    rrtmg_sw ORIGINAL abs. coefficients for interval 25
 931 !    band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
 932 !
 933 ! history log :
 934 !   1999-10 JJMorcrette  Initial version
 935 !   2006-07 MJIacono     Revised, AER
 936 !   2008-08 MJIacono     Revised, AER
 937 !-------------------------------------------------------------------------------
 938 !
 939 !  name     type     purpose
 940 !  ----   : ----   : ---------------------------------------------
 941 ! kao     : real
 942 !sfluxrefo: real
 943 ! abso3ao : real
 944 ! abso3bo : real
 945 ! raylo   : real
 946 !-------------------------------------------------------------------------------
 947 ! rrtmg_sw COMBINED abs. coefficients for interval 25
 948 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
 949 !
 950 ! Initial version:  JJMorcrette, ECMWF, oct1999
 951 ! Revised: MJIacono, AER, jul2006
 952 ! Revised: MJIacono, AER, aug2008
 953 !-------------------------------------------------------------------------------
 954 !
 955 !  name     type     purpose
 956 !  ----   : ----   : ---------------------------------------------
 957 ! ka      : real
 958 ! absa    : real
 959 ! sfluxref: real
 960 ! abso3a  : real
 961 ! abso3b  : real
 962 ! rayl    : real
 963 !-------------------------------------------------------------------------------
 964    use parkind_k, only : im => kind_im, rb => kind_rb
 965    use parrrsw_k, only : ng25
 966 !
 967 !  implicit none
 968 !
 969    save
 970    integer(kind=im), parameter          :: no25 = 16
 971 !
 972    real(kind=rb), dimension(5,13,no25)  :: kao
 973    real(kind=rb), dimension(no25)       :: sfluxrefo
 974    real(kind=rb), dimension(no25)       :: abso3ao
 975    real(kind=rb), dimension(no25)       :: abso3bo
 976    real(kind=rb), dimension(no25)       :: raylo
 977 !
 978    integer(kind=im)                     :: layreffr
 979 !
 980    real(kind=rb), dimension(5,13,ng25)  :: ka
 981    real(kind=rb), dimension(65,ng25)    :: absa
 982    real(kind=rb), dimension(ng25)       :: sfluxref
 983    real(kind=rb), dimension(ng25)       :: abso3a
 984    real(kind=rb), dimension(ng25)       :: abso3b
 985    real(kind=rb), dimension(ng25)       :: rayl
 986    equivalence (ka(1,1,1),absa(1,1))
 987 !-------------------------------------------------------------------------------
 988    end module rrsw_kg25_k
 989 !-------------------------------------------------------------------------------
 990 !
 991 !
 992 !-------------------------------------------------------------------------------
 993    module rrsw_kg26_k
 994 !-------------------------------------------------------------------------------
 995 !  abstract :
 996 !    rrtmg_sw ORIGINAL abs. coefficients for interval 26
 997 !    band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
 998 !
 999 ! history log :
1000 !   1999-10 JJMorcrette  Initial version
1001 !   2006-07 MJIacono     Revised, AER
1002 !   2008-08 MJIacono     Revised, AER
1003 !-------------------------------------------------------------------------------
1004 !
1005 !  name     type     purpose
1006 !  ----   : ----   : ---------------------------------------------
1007 !sfluxrefo: real
1008 ! raylo   : real
1009 !-------------------------------------------------------------------------------
1010 ! rrtmg_sw COMBINED abs. coefficients for interval 26
1011 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1012 !
1013 ! Initial version:  JJMorcrette, ECMWF, oct1999
1014 ! Revised: MJIacono, AER, jul2006
1015 ! Revised: MJIacono, AER, aug2008
1016 !-------------------------------------------------------------------------------
1017 !
1018 !  name     type     purpose
1019 !  ----   : ----   : ---------------------------------------------
1020 ! sfluxref: real
1021 ! rayl    : real
1022 !-------------------------------------------------------------------------------
1023    use parkind_k, only : im => kind_im, rb => kind_rb
1024    use parrrsw_k, only : ng26
1025 !
1026 !  implicit none
1027 !
1028    save
1029    integer(kind=im), parameter     :: no26 = 16
1030 !
1031    real(kind=rb), dimension(no26) :: sfluxrefo
1032    real(kind=rb), dimension(no26) :: raylo
1033 !
1034    real(kind=rb), dimension(ng26) :: sfluxref
1035    real(kind=rb), dimension(ng26) :: rayl
1036 !-------------------------------------------------------------------------------
1037    end module rrsw_kg26_k
1038 !-------------------------------------------------------------------------------
1039 !
1040 !
1041 !-------------------------------------------------------------------------------
1042    module rrsw_kg27_k
1043 !-------------------------------------------------------------------------------
1044 ! abstract :
1045 !   rrtmg_sw ORIGINAL abs. coefficients for interval 27
1046 !   band 27: 29000-38000 cm-1 (low - o3; high - o3)
1047 !
1048 ! history log :
1049 !   1999-10 JJMorcrette  Initial version
1050 !   2006-07 MJIacono     Revised, AER
1051 !   2008-08 MJIacono     Revised, AER
1052 !-------------------------------------------------------------------------------
1053 !
1054 !  name     type     purpose
1055 !  ----   : ----   : ---------------------------------------------
1056 ! kao     : real
1057 ! kbo     : real
1058 !sfluxrefo: real
1059 ! raylo   : real
1060 !-------------------------------------------------------------------------------
1061 ! rrtmg_sw COMBINED abs. coefficients for interval 27
1062 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1063 !
1064 ! Initial version:  JJMorcrette, ECMWF, oct1999
1065 ! Revised: MJIacono, AER, jul2006
1066 ! Revised: MJIacono, AER, aug2008
1067 !-------------------------------------------------------------------------------
1068 !
1069 !  name     type     purpose
1070 !  ----   : ----   : ---------------------------------------------
1071 ! ka      : real
1072 ! kb      : real
1073 ! absa    : real
1074 ! absb    : real
1075 ! sfluxref: real
1076 ! rayl    : real
1077 !-------------------------------------------------------------------------------
1078    use parkind_k, only : im => kind_im, rb => kind_rb
1079    use parrrsw_k, only : ng27
1080 !
1081 !  implicit none
1082 !
1083    save
1084    integer(kind=im), parameter :: no27 = 16
1085 !
1086    real(kind=rb), dimension(5,13,no27)    :: kao
1087    real(kind=rb), dimension(5,13:59,no27) :: kbo
1088    real(kind=rb), dimension(no27)         :: sfluxrefo
1089    real(kind=rb), dimension(no27)         :: raylo
1090 !
1091    integer(kind=im)                       :: layreffr
1092    real(kind=rb)                          :: scalekur
1093 !
1094    real(kind=rb), dimension(5,13,ng27)    :: ka
1095    real(kind=rb), dimension(65,ng27)      :: absa
1096    real(kind=rb), dimension(5,13:59,ng27) :: kb
1097    real(kind=rb), dimension(235,ng27)     :: absb
1098    real(kind=rb), dimension(ng27)         :: sfluxref
1099    real(kind=rb), dimension(ng27)         :: rayl
1100 !
1101    equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1102 !-------------------------------------------------------------------------------
1103    end module rrsw_kg27_k
1104 !-------------------------------------------------------------------------------
1105 !
1106 !
1107 !-------------------------------------------------------------------------------
1108    module rrsw_kg28_k
1109 !-------------------------------------------------------------------------------
1110 !  abstract :
1111 !    rrtmg_sw ORIGINAL abs. coefficients for interval 28
1112 !    band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1113 !
1114 ! history log :
1115 !   1999-10 JJMorcrette  Initial version
1116 !   2006-07 MJIacono     Revised, AER
1117 !   2008-08 MJIacono     Revised, AER
1118 !-------------------------------------------------------------------------------
1119 !
1120 !  name     type     purpose
1121 !  ----   : ----   : ---------------------------------------------
1122 ! kao     : real
1123 ! kbo     : real
1124 !sfluxrefo: real
1125 !-------------------------------------------------------------------------------
1126 ! rrtmg_sw COMBINED abs. coefficients for interval 28
1127 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1128 !
1129 ! Initial version:  JJMorcrette, ECMWF, oct1999
1130 ! Revised: MJIacono, AER, jul2006
1131 ! Revised: MJIacono, AER, aug2008
1132 !-------------------------------------------------------------------------------
1133 !
1134 !  name     type     purpose
1135 !  ----   : ----   : ---------------------------------------------
1136 ! ka      : real
1137 ! kb      : real
1138 ! sfluxref: real
1139 !-------------------------------------------------------------------------------
1140    use parkind_k, only : im => kind_im, rb => kind_rb
1141    use parrrsw_k, only : ng28
1142 !
1143 !  implicit none
1144 !
1145    save
1146    integer(kind=im), parameter :: no28 = 16
1147 !
1148    real(kind=rb), dimension(9,5,13,no28)    :: kao
1149    real(kind=rb), dimension(5,5,13:59,no28) :: kbo
1150    real(kind=rb), dimension(no28,5)         :: sfluxrefo
1151 !
1152    integer(kind=im)                         :: layreffr
1153    real(kind=rb)                            :: rayl, strrat
1154 !
1155    real(kind=rb), dimension(9,5,13,ng28)    :: ka
1156    real(kind=rb), dimension(585,ng28)       :: absa
1157    real(kind=rb), dimension(5,5,13:59,ng28) :: kb
1158    real(kind=rb), dimension(1175,ng28)      :: absb
1159    real(kind=rb), dimension(ng28,5)         :: sfluxref
1160    equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
1161 !-------------------------------------------------------------------------------
1162    end module rrsw_kg28_k
1163 !-------------------------------------------------------------------------------
1164 !
1165 !
1166 !-------------------------------------------------------------------------------
1167    module rrsw_kg29_k
1168 !-------------------------------------------------------------------------------
1169 !  abstract :
1170 !    rrtmg_sw ORIGINAL abs. coefficients for interval 29
1171 !    band 29:  820-2600 cm-1 (low - h2o; high - co2)
1172 !
1173 ! history log :
1174 !   1999-10 JJMorcrette  Initial version
1175 !   2006-07 MJIacono     Revised, AER
1176 !   2008-08 MJIacono     Revised, AER
1177 !-------------------------------------------------------------------------------
1178 !
1179 !  name     type     purpose
1180 !  ----   : ----   : ---------------------------------------------
1181 ! kao     : real
1182 ! kbo     : real
1183 ! selfrefo: real
1184 ! forrefo : real
1185 !sfluxrefo: real
1186 ! absh2oo : real
1187 ! absco2o : real
1188 !-------------------------------------------------------------------------------
1189 ! rrtmg_sw COMBINED abs. coefficients for interval 29
1190 ! band 29:  820-2600 cm-1 (low - h2o; high - co2)
1191 !
1192 ! Initial version:  JJMorcrette, ECMWF, oct1999
1193 ! Revised: MJIacono, AER, jul2006
1194 ! Revised: MJIacono, AER, aug2008
1195 !-------------------------------------------------------------------------------
1196 !
1197 !  name     type     purpose
1198 !  ----   : ----   : ---------------------------------------------
1199 ! ka      : real
1200 ! kb      : real
1201 ! selfref : real
1202 ! forref  : real
1203 ! sfluxref: real
1204 ! absh2o  : real
1205 ! absco2  : real
1206 !-------------------------------------------------------------------------------
1207 !
1208    use parkind_k, only : im => kind_im, rb => kind_rb
1209    use parrrsw_k, only : ng29
1210 !
1211 !  implicit none
1212 !
1213    save
1214    integer(kind=im), parameter :: no29 = 16
1215 !
1216    real(kind=rb), dimension(5,13,no29)    :: kao
1217    real(kind=rb), dimension(5,13:59,no29) :: kbo
1218    real(kind=rb), dimension(10,no29)      :: selfrefo
1219    real(kind=rb), dimension(4,no29)       :: forrefo
1220    real(kind=rb), dimension(no29)         :: sfluxrefo
1221    real(kind=rb), dimension(no29)         :: absh2oo, absco2o
1222 !
1223    integer(kind=im)                       :: layreffr
1224    real(kind=rb)                          :: rayl
1225 !
1226    real(kind=rb), dimension(5,13,ng29)    :: ka
1227    real(kind=rb), dimension(65,ng29)      :: absa
1228    real(kind=rb), dimension(5,13:59,ng29) :: kb
1229    real(kind=rb), dimension(235,ng29)     :: absb
1230    real(kind=rb), dimension(10,ng29)      :: selfref
1231    real(kind=rb), dimension(4,ng29)       ::  forref
1232    real(kind=rb), dimension(ng29)         :: sfluxref
1233    real(kind=rb), dimension(ng29)         :: absh2o,absco2
1234    equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1235 !-------------------------------------------------------------------------------
1236    end module rrsw_kg29_k
1237 !-------------------------------------------------------------------------------
1238 !
1239 !
1240 !-------------------------------------------------------------------------------
1241    module rrsw_ref_k
1242 !-------------------------------------------------------------------------------
1243 !  abstract :
1244 !    rrtmg_sw reference atmosphere
1245 !    Based on standard mid-latitude summer profile
1246 !
1247 ! history log :
1248 !   1998-07 JJMorcrette  Initial version
1249 !   2006-07 MJIacono     Revised, AER
1250 !   2008-08 MJIacono     Revised, AER
1251 !-------------------------------------------------------------------------------
1252 !  name     type     purpose
1253 ! -----  :  ----   : ----------------------------------------------
1254 ! pref   :  real   : Reference pressure levels
1255 ! preflog:  real   : Reference pressure levels, ln(pref)
1256 ! tref   :  real   : Reference temperature levels for MLS profile
1257 !-------------------------------------------------------------------------------
1258    use parkind_k, only : im => kind_im, rb => kind_rb
1259 !
1260 !  implicit none
1261 !
1262    save
1263    real(kind=rb) , dimension(59) :: pref
1264    real(kind=rb) , dimension(59) :: preflog
1265    real(kind=rb) , dimension(59) :: tref
1266 !-------------------------------------------------------------------------------
1267    end module rrsw_ref_k
1268 !-------------------------------------------------------------------------------
1269 !
1270 !
1271 !-------------------------------------------------------------------------------
1272    module rrsw_tbl_k
1273 !-------------------------------------------------------------------------------
1274 !  abstract :
1275 !    rrtmg_sw lookup table arrays
1276 !
1277 !  history log :
1278 !   2007-05 MJIAcono     Initial version
1279 !   2006-07 MJIacono     Revised, AER
1280 !   2008-08 MJIacono     Revised, AER
1281 !-------------------------------------------------------------------------------
1282 !  name     type     purpose
1283 ! -----  :  ----   : ----------------------------------------------
1284 ! ntbl   :  integer: Lookup table dimension
1285 ! tblint :  real   : Lookup table conversion factor
1286 ! tau_tbl:  real   : Clear-sky optical depth
1287 ! exp_tbl:  real   : Exponential lookup table for transmittance
1288 ! od_lo  :  real   : Value of tau below which expansion is used
1289 !                  : in place of lookup table
1290 ! pade   :  real   : Pade approximation constant
1291 ! bpade  :  real   : Inverse of Pade constant
1292 !-------------------------------------------------------------------------------
1293    use parkind_k, only : im => kind_im, rb => kind_rb
1294 !
1295 !  implicit none
1296 !
1297    save
1298    integer(kind=im), parameter      :: ntbl = 10000
1299    real(kind=rb), parameter         :: tblint = 10000.0_rb
1300    real(kind=rb), parameter         :: od_lo = 0.06_rb
1301    real(kind=rb)                    :: tau_tbl
1302    real(kind=rb), dimension(0:ntbl) :: exp_tbl
1303 !
1304    real(kind=rb), parameter         :: pade = 0.278_rb
1305    real(kind=rb)                    :: bpade
1306 !
1307    end module rrsw_tbl_k
1308 !-------------------------------------------------------------------------------
1309 !
1310 !
1311 !-------------------------------------------------------------------------------
1312    module rrsw_vsn_k
1313 !-------------------------------------------------------------------------------
1314 !  abstract :
1315 !    rrtmg_sw version information
1316 !
1317 !  history log :
1318 !    1998-07 JJMorcrette  Initial version
1319 !    2006-07 MJIacono     Revised, AER
1320 !    2008-08 MJIacono     Revised, AER
1321 !-------------------------------------------------------------------------------
1322 !  name     type     purpose
1323 ! -----  :  ----   : ----------------------------------------------
1324 !hnamrtm :character:
1325 !hnamini :character:
1326 !hnamcld :character:
1327 !hnamclc :character:
1328 !hnamrft :character:
1329 !hnamspv :character:
1330 !hnamspc :character:
1331 !hnamset :character:
1332 !hnamtau :character:
1333 !hnamvqd :character:
1334 !hnamatm :character:
1335 !hnamutl :character:
1336 !hnamext :character:
1337 !hnamkg  :character:
1338 !
1339 ! hvrrtm :character:
1340 ! hvrini :character:
1341 ! hvrcld :character:
1342 ! hvrclc :character:
1343 ! hvrrft :character:
1344 ! hvrspv :character:
1345 ! hvrspc :character:
1346 ! hvrset :character:
1347 ! hvrtau :character:
1348 ! hvrvqd :character:
1349 ! hvratm :character:
1350 ! hvrutl :character:
1351 ! hvrext :character:
1352 ! hvrkg  :character:
1353 !-------------------------------------------------------------------------------
1354 !
1355 !  implicit none
1356 !
1357    save
1358    character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv,                     &
1359                 hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
1360    character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv,               &
1361                 hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
1362 !
1363    character*18 hvrkg
1364    character*20 hnamkg
1365 !-------------------------------------------------------------------------------
1366    end module rrsw_vsn_k
1367 !-------------------------------------------------------------------------------
1368 !
1369 !
1370 !-------------------------------------------------------------------------------
1371    module rrsw_wvn_k
1372 !-------------------------------------------------------------------------------
1373    use parkind_k, only : im => kind_im, rb => kind_rb
1374    use parrrsw_k, only : nbndsw, mg, ngptsw, jpb1, jpb2
1375 !-------------------------------------------------------------------------------
1376 !  abstract :
1377 !    rrtmg_sw spectral information
1378 !
1379 !  history log :
1380 !    1998-07 JJMorcrette  Initial version
1381 !    2006-07 MJIacono     Revised, AER
1382 !    2008-08 MJIacono     Revised, AER
1383 !-------------------------------------------------------------------------------
1384 !  name     type     purpose
1385 ! -----  :  ----   : ----------------------------------------------
1386 ! ng     :  integer: Number of original g-intervals in each spectral band
1387 ! nspa   :  integer:
1388 ! nspb   :  integer:
1389 !wavenum1:  real   : Spectral band lower boundary in wavenumbers
1390 !wavenum2:  real   : Spectral band upper boundary in wavenumbers
1391 ! delwave:  real   : Spectral band width in wavenumbers
1392 !
1393 ! ngc    :  integer: The number of new g-intervals in each band
1394 ! ngs    :  integer: The cumulative sum of new g-intervals for each band
1395 ! ngm    :  integer: The index of each new g-interval relative to the
1396 !                    original 16 g-intervals in each band
1397 ! ngn    :  integer: The number of original g-intervals that are
1398 !                    combined to make each new g-intervals in each band
1399 ! ngb    :  integer: The band index for each new g-interval
1400 ! wt     :  real   : RRTM weights for the original 16 g-intervals
1401 ! rwgt   :  real   : Weights for combining original 16 g-intervals
1402 !                    (224 total) into reduced set of g-intervals
1403 !                    (112 total)
1404 !-------------------------------------------------------------------------------
1405 !
1406 !  implicit none
1407 !
1408    save
1409    integer(kind=im), dimension(jpb1:jpb2) :: ng, nspa, nspb
1410 !
1411    real(kind=rb), dimension(jpb1:jpb2)    :: wavenum1, wavenum2, delwave
1412 !
1413    integer(kind=im), dimension(nbndsw)    :: ngc, ngs
1414    integer(kind=im), dimension(ngptsw)    :: ngn, ngb
1415    integer(kind=im), dimension(nbndsw*mg) :: ngm
1416 !
1417    real(kind=rb), dimension(mg)           :: wt
1418    real(kind=rb), dimension(nbndsw*mg)    :: rwgt
1419 !-------------------------------------------------------------------------------
1420    end module rrsw_wvn_k
1421 !-------------------------------------------------------------------------------
1422 !
1423 !
1424 !-------------------------------------------------------------------------------
1425    module rrtmg_sw_cldprmc_k
1426 !-------------------------------------------------------------------------------
1427 !  --------------------------------------------------------------------------
1428 ! |                                                                          |
1429 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
1430 ! |  This software may be used, copied, or redistributed as long as it is    |
1431 ! |  not sold and this copyright notice is reproduced on each copy made.     |
1432 ! |  This model is provided as is without any express or implied warranties. |
1433 ! |                       (http://www.rtweb.aer.com/)                        |
1434 ! |                                                                          |
1435 !  --------------------------------------------------------------------------
1436 ! ------- Modules -------
1437 !
1438    use parkind_k, only : im => kind_im, rb => kind_rb
1439    use parrrsw_k, only : ngptsw, jpband, jpb1, jpb2
1440    use rrsw_cld_k, only : extliq1, ssaliq1, asyliq1,                             &
1441                         extice2, ssaice2, asyice2,                             &
1442                         extice3, ssaice3, asyice3, fdlice3,                    &
1443                         abari, bbari, cbari, dbari, ebari, fbari
1444    use rrsw_wvn_k, only : wavenum1, wavenum2, ngb
1445    use rrsw_vsn_k, only : hvrclc, hnamclc
1446 !
1447    implicit none
1448 !
1449    contains
1450 !-------------------------------------------------------------------------------
1451    subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc,            &
1452                          ciwpmc, clwpmc, reicmc, relqmc,                       &
1453                             cswpmc, resnmc,                                    &
1454                          dtliq, dtice, dtsno, dwliq, dwice, dwsno,             &
1455                          daliq, daice, dasno,                                  &
1456                          taormc, taucmc, ssacmc, asmcmc, fsfcmc)
1457 !-------------------------------------------------------------------------------
1458 !
1459 !  abstract:
1460 !    Compute the cloud optical properties for each cloudy layer
1461 !    and g-point interval for use by the McICA method.
1462 !    Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available;
1463 !
1464 !  history log :
1465 !
1466 !  reference :
1467 !    Hu & Stamnes, Key, and Fu
1468 !
1469 !  variables :
1470 !  input :
1471 !    nlayer - total number of layers
1472 !    inflag - see definitions
1473 !    iceflag - see definitions
1474 !    liqflag - see definitions
1475 !    cldfmc(ngptsw,nlayers) - cloud fraction [mcica]
1476 !    ciwpmc(ngptsw,nlayers) - cloud ice water path [mcica]
1477 !    clwpmc(ngptsw,nlayers) - cloud liquid water path [mcica]
1478 !    cswpmc(ngptsw,nlayers) - cloud snow water path [mcica]
1479 !    relqmc(nlayers) -  cloud liquid particle effective radius (microns)
1480 !    reicmc(nlayers) - cloud ice particle effective radius (microns)
1481 !    resnmc(nlayers) -  cloud snow particle effective radius (microns)
1482 !
1483 !    specific definition of reicmc depends on setting of iceflag:
1484 !    iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
1485 !                r_ec range is limited to 13.0 to 130.0 microns
1486 !    iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
1487 !               r_k range is limited to 5.0 to 131.0 microns
1488 !    iceflag = 3: generalized effective size, dge, (Fu, 1996),
1489 !              dge range is limited to 5.0 to 140.0 microns
1490 !              [dge = 1.0315 * r_ec]
1491 !    fsfcmc(ngptsw,nlayers) - cloud forward scattering fraction
1492 !
1493 !  output :
1494 !    taucmc(ngptsw,nlayers) -  cloud optical depth (delta scaled)
1495 !    ssacmc(ngptsw,nlayers) -  single scattering albedo (delta scaled)
1496 !    asmcmc(ngptsw,nlayers) -  asymmetry parameter (delta scaled)
1497 !    taormc(ngptsw,nlayers) -  cloud optical depth (non-delta scaled)
1498 !
1499 !  local :
1500 !    eps - epsilon
1501 !    cldmin - minimum value for cloud quantities
1502 !    cwp - total cloud water path
1503 !    radliq - cloud liquid droplet radius (microns)
1504 !    radice - cloud ice effective size (microns)
1505 !    radsno - cloud snow effective size (microns)
1506 !
1507 ! ------- Input -------
1508 !
1509    integer(kind=im), intent(in   ) :: nlayers
1510    integer(kind=im), intent(in   ) :: inflag
1511    integer(kind=im), intent(in   ) :: iceflag
1512    integer(kind=im), intent(in   ) :: liqflag
1513    real(kind=rb), dimension(:,:), intent(in   ) :: cldfmc
1514    real(kind=rb), dimension(:,:), intent(in   ) :: ciwpmc
1515    real(kind=rb), dimension(:,:), intent(in   ) :: clwpmc
1516    real(kind=rb), dimension(:,:), intent(in   ) :: cswpmc
1517    real(kind=rb), dimension(:),        intent(in   ) :: relqmc
1518    real(kind=rb), dimension(:),        intent(in   ) :: reicmc
1519    real(kind=rb), dimension(:),        intent(in   ) :: resnmc
1520    real(kind=rb), dimension(:,:), intent(in   ) :: fsfcmc
1521 !
1522 ! ------- Output -------
1523 !
1524    real(kind=rb), dimension(:,:), intent(inout) :: taucmc
1525    real(kind=rb), dimension(:,:), intent(inout) :: ssacmc
1526    real(kind=rb), dimension(:,:), intent(inout) :: asmcmc
1527    real(kind=rb), dimension(:,:), intent(out) :: taormc
1528    real(kind=rb), dimension(:,:), intent(inout) :: dtliq, dtice, dtsno
1529    real(kind=rb), dimension(:,:), intent(inout) :: dwliq, dwice, dwsno
1530    real(kind=rb), dimension(:,:), intent(inout) :: daliq, daice, dasno
1531 !
1532 ! ------- Local -------
1533 !
1534    integer(kind=im) :: ib, lay, istr, index, icx, ig
1535 !
1536    real(kind=rb), parameter :: eps = 1.e-06_rb
1537    real(kind=rb), parameter :: cldmin = 1.e-20_rb
1538    real(kind=rb) :: cwp
1539    real(kind=rb) :: radliq
1540    real(kind=rb) :: radice
1541    real(kind=rb) :: radsno
1542    real(kind=rb) :: factor
1543    real(kind=rb) :: fint
1544 !
1545    real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
1546    real(kind=rb) :: tauiceorig, scatice, ssaice, tauice
1547    real(kind=rb) :: tauliqorig, scatliq, ssaliq, tauliq
1548    real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno
1549    real(kind=rb), dimension(ngptsw) :: fdelta
1550    real(kind=rb), dimension(ngptsw) :: extcoice, gice
1551    real(kind=rb), dimension(ngptsw) :: ssacoice, forwice
1552    real(kind=rb), dimension(ngptsw) :: extcoliq, gliq
1553    real(kind=rb), dimension(ngptsw) :: ssacoliq, forwliq
1554    real(kind=rb), dimension(ngptsw) :: extcosno, gsno
1555    real(kind=rb), dimension(ngptsw) :: ssacosno, forwsno
1556 !-------------------------------------------------------------------------------
1557 !
1558 ! Initialize
1559 !
1560    hvrclc = '$Revision: 1.3 $'
1561 !
1562 ! Some of these initializations are done elsewhere
1563 !
1564    do lay = 1,nlayers
1565      do ig = 1,ngptsw
1566        taormc(ig,lay) = taucmc(ig,lay)
1567 !      taucmc(ig,lay) = 0.0_rb
1568 !      ssacmc(ig,lay) = 1.0_rb
1569 !      asmcmc(ig,lay) = 0.0_rb
1570      enddo
1571    enddo
1572 !
1573 ! Main layer loop
1574 !
1575    do lay = 1,nlayers
1576 !
1577 ! Main g-point interval loop
1578 !
1579      do ig = 1,ngptsw
1580        cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
1581        if(cldfmc(ig,lay).ge.cldmin .and.                                       &
1582          (cwp.ge.cldmin .or. taucmc(ig,lay).ge.cldmin)) then
1583 !
1584 ! (inflag=0): Cloud optical properties input directly
1585 !
1586          if(inflag.eq.0) then
1587 !
1588 ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are
1589 ! unscaled;  Apply delta-M scaling here (using Henyey-Greenstein approximation)
1590 !
1591            taucldorig_a = taucmc(ig,lay)
1592            ffp = fsfcmc(ig,lay)
1593            ffp1 = 1.0_rb-ffp
1594            ffpssa = 1.0_rb-ffp*ssacmc(ig,lay)
1595            ssacloud_a = ffp1*ssacmc(ig,lay)/ffpssa
1596            taucloud_a = ffpssa*taucldorig_a
1597 !
1598            taormc(ig,lay) = taucldorig_a
1599            ssacmc(ig,lay) = ssacloud_a
1600            taucmc(ig,lay) = taucloud_a
1601            asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1)
1602 !
1603          elseif(inflag.eq.1) then
1604            stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
1605 !
1606 ! (inflag=2): Separate treatement of ice clouds and water clouds.
1607 !
1608          elseif(inflag.ge.2) then
1609            radice = reicmc(lay)
1610 !
1611 ! Calculation of absorption coefficients due to ice clouds.
1612 !
1613            if((ciwpmc(ig,lay)+cswpmc(ig,lay)).eq.0.0_rb) then
1614              extcoice(ig) = 0.0_rb
1615              ssacoice(ig) = 0.0_rb
1616              gice(ig)     = 0.0_rb
1617              forwice(ig)  = 0.0_rb
1618              extcosno(ig) = 0.0_rb
1619              ssacosno(ig) = 0.0_rb
1620              gsno(ig)     = 0.0_rb
1621              forwsno(ig)  = 0.0_rb
1622 !
1623 ! (iceflag = 1):
1624 ! Note: This option uses Ebert and Curry approach for all particle sizes similar
1625 ! to CAM3 implementation, though this is somewhat unjustified for large ice
1626 ! particles
1627 !
1628            elseif(iceflag.eq.1) then
1629              ib = ngb(ig)
1630              if(wavenum2(ib).gt.1.43e04_rb) then
1631                icx = 1
1632              elseif (wavenum2(ib).gt.7.7e03_rb) then
1633                icx = 2
1634              elseif (wavenum2(ib).gt.5.3e03_rb) then
1635                icx = 3
1636              elseif (wavenum2(ib).gt.4.0e03_rb) then
1637                icx = 4
1638              elseif (wavenum2(ib).ge.2.5e03_rb) then
1639                icx = 5
1640              endif
1641              extcoice(ig) = (abari(icx)+bbari(icx)/radice)
1642              ssacoice(ig) = 1._rb-cbari(icx)-dbari(icx)*radice
1643              gice(ig) = ebari(icx)+fbari(icx)*radice
1644 !
1645 ! Check to ensure upper limit of gice is within physical limits for large
1646 ! particles
1647 !
1648              if (gice(ig).ge.1._rb) gice(ig) = 1._rb-eps
1649              forwice(ig) = gice(ig)*gice(ig)
1650 !
1651 ! Check to ensure all calculated quantities are within physical limits.
1652 !
1653              if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1654              if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1655              if(ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1656              if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1657              if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1658 !
1659 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0
1660 ! microns
1661 !
1662            elseif (iceflag .eq. 2) then
1663              if(radice.lt.5.0_rb .or. radice.gt.131.0_rb)                      &
1664                  stop 'ICE RADIUS OUT OF BOUNDS'
1665              factor = (radice - 2._rb)/3._rb
1666              index = int(factor)
1667              if(index.eq.43) index = 42
1668              fint = factor - real(index)
1669              ib = ngb(ig)
1670              extcoice(ig) = extice2(index,ib) + fint *                         &
1671                            (extice2(index+1,ib) -  extice2(index,ib))
1672              ssacoice(ig) = ssaice2(index,ib) + fint *                         &
1673                            (ssaice2(index+1,ib) -  ssaice2(index,ib))
1674              gice(ig) = asyice2(index,ib) + fint *                             &
1675                        (asyice2(index+1,ib) -  asyice2(index,ib))
1676              forwice(ig) = gice(ig)*gice(ig)
1677 !
1678 ! Check to ensure all calculated quantities are within physical limits.
1679 !
1680              if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1681              if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1682              if(ssacoice(ig).lt.0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1683              if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1684              if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1685 !
1686 ! For iceflag=3 option, ice particle generalized effective size is limited to
1687 ! 5.0 to 140.0 microns
1688 !
1689            elseif(iceflag.ge.3) then
1690 !
1691              if(radice.lt.5.0_rb .or. radice.gt.140.0_rb)                      &
1692                   stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
1693              factor = (radice - 2._rb)/3._rb
1694              index = int(factor)
1695              if(index.eq.46) index = 45
1696              fint = factor - real(index)
1697              ib = ngb(ig)
1698              extcoice(ig) = extice3(index,ib)+fint*                            &
1699                            (extice3(index+1,ib)-extice3(index,ib))
1700              ssacoice(ig) = ssaice3(index,ib)+fint*                            &
1701                            (ssaice3(index+1,ib)-ssaice3(index,ib))
1702              gice(ig) = asyice3(index,ib)+fint*                                &
1703                        (asyice3(index+1,ib)-asyice3(index,ib))
1704              fdelta(ig) = fdlice3(index,ib)+fint*                              &
1705                          (fdlice3(index+1,ib)-fdlice3(index,ib))
1706              if(fdelta(ig).lt.0.0_rb) stop 'FDELTA LESS THAN 0.0'
1707              if(fdelta(ig).gt.1.0_rb) stop 'FDELTA GT THAN 1.0'
1708              forwice(ig) = fdelta(ig)+0.5_rb/ssacoice(ig)
1709 !
1710 ! See Fu 1996 p. 2067
1711 !
1712              if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
1713 !
1714 ! Check to ensure all calculated quantities are within physical limits.
1715 !
1716              if(extcoice(ig).lt.0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
1717              if(ssacoice(ig).gt.1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
1718              if(ssacoice(ig).lt.0.0_rb) stop 'ICE SSA LESS THAN 0.0'
1719              if(gice(ig).gt.1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
1720              if(gice(ig).lt.0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
1721            endif
1722 !
1723 ! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
1724 ! Although far from perfect, the snow will utilize the
1725 ! same lookup table constants as cloud ice.  Changes
1726 ! to those constants for larger particle snow would be
1727 ! an improvement.
1728 !
1729            if(cswpmc(ig,lay).gt.0.0_rb .and. iceflag.eq.5) then
1730              radsno = resnmc(lay)
1731              if(radsno.lt.5.0_rb .or. radsno.gt.140.0_rb) stop                 &
1732                       'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
1733              factor = (radsno - 2._rb)/3._rb
1734              index = int(factor)
1735              if(index.eq.46) index = 45
1736              fint = factor-real(index)
1737              ib = ngb(ig)
1738              extcosno(ig) = extice3(index,ib)+fint*                            &
1739                            (extice3(index+1,ib)-extice3(index,ib))
1740              ssacosno(ig) = ssaice3(index,ib)+fint*                            &
1741                            (ssaice3(index+1,ib)-ssaice3(index,ib))
1742              gsno(ig) = asyice3(index,ib)+fint*                                &
1743                        (asyice3(index+1,ib)-asyice3(index,ib))
1744              fdelta(ig) = fdlice3(index,ib)+fint*                              &
1745                          (fdlice3(index+1,ib)-fdlice3(index,ib))
1746              if(fdelta(ig).lt.0.0_rb) stop 'FDELTA LESS THAN 0.0'
1747              if(fdelta(ig).gt.1.0_rb) stop 'FDELTA GT THAN 1.0'
1748              forwsno(ig) = fdelta(ig)+0.5_rb/ssacosno(ig)
1749              if(forwsno(ig).gt.gsno(ig)) forwsno(ig) = gsno(ig)
1750 !
1751 ! Check to ensure all calculated quantities are within physical limits.
1752 !
1753              if(extcosno(ig).lt.0.0_rb) stop 'SNOW EXTINCTION LESS THAN 0.0'
1754              if(ssacosno(ig).gt.1.0_rb) stop 'SNOW SSA GRTR THAN 1.0'
1755              if(ssacosno(ig).lt.0.0_rb) stop 'SNOW SSA LESS THAN 0.0'
1756              if(gsno(ig).gt.1.0_rb) stop 'SNOW ASYM GRTR THAN 1.0'
1757              if(gsno(ig).lt.0.0_rb) stop 'SNOW ASYM LESS THAN 0.0'
1758            else
1759              extcosno(ig) = 0.0_rb
1760              ssacosno(ig) = 0.0_rb
1761              gsno(ig)     = 0.0_rb
1762              forwsno(ig)  = 0.0_rb
1763            endif
1764 !
1765 ! Calculation of absorption coefficients due to water clouds.
1766 !
1767            if (clwpmc(ig,lay) .eq. 0.0_rb) then
1768              extcoliq(ig) = 0.0_rb
1769              ssacoliq(ig) = 0.0_rb
1770              gliq(ig) = 0.0_rb
1771              forwliq(ig) = 0.0_rb
1772            elseif (liqflag .eq. 1) then
1773              radliq = relqmc(lay)
1774              if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop              &
1775                         'liquid effective radius out of bounds'
1776              index = int(radliq - 1.5_rb)
1777              if (index .eq. 0) index = 1
1778              if (index .eq. 58) index = 57
1779              fint = radliq - 1.5_rb - real(index)
1780              ib = ngb(ig)
1781              extcoliq(ig) = extliq1(index,ib) + fint *                         &
1782                                    (extliq1(index+1,ib) - extliq1(index,ib))
1783              ssacoliq(ig) = ssaliq1(index,ib) + fint *                         &
1784                                    (ssaliq1(index+1,ib) - ssaliq1(index,ib))
1785              if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb)                &
1786                                     ssacoliq(ig) = ssaliq1(index,ib)
1787              gliq(ig) = asyliq1(index,ib) + fint *                             &
1788                                (asyliq1(index+1,ib) - asyliq1(index,ib))
1789              forwliq(ig) = gliq(ig)*gliq(ig)
1790 !
1791 ! Check to ensure all calculated quantities are within physical limits.
1792 !
1793              if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
1794              if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
1795              if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
1796              if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
1797              if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
1798            endif
1799 !
1800            if(iceflag.lt.5) then
1801              tauliqorig = clwpmc(ig,lay)*extcoliq(ig)
1802              tauiceorig = ciwpmc(ig,lay)*extcoice(ig)
1803              taormc(ig,lay) = tauliqorig+tauiceorig
1804 !
1805              ssaliq = ssacoliq(ig)*(1._rb-forwliq(ig))                         &
1806                                   /(1._rb-forwliq(ig)*ssacoliq(ig))
1807              tauliq = (1._rb-forwliq(ig)*ssacoliq(ig))*tauliqorig
1808              ssaice = ssacoice(ig)*(1._rb-forwice(ig))                         &
1809                                   /(1._rb-forwice(ig)*ssacoice(ig))
1810              tauice = (1._rb-forwice(ig)*ssacoice(ig))*tauiceorig
1811 !
1812              scatliq = ssaliq*tauliq
1813              scatice = ssaice*tauice
1814              scatsno = 0.0_rb
1815              taucmc(ig,lay) = tauliq+tauice
1816            else
1817              tauliqorig = clwpmc(ig,lay)*extcoliq(ig)
1818              tauiceorig = ciwpmc(ig,lay)*extcoice(ig)
1819              tausnoorig = cswpmc(ig,lay)*extcosno(ig)
1820              taormc(ig,lay) = tauliqorig+tauiceorig+tausnoorig
1821 !
1822              ssaliq = ssacoliq(ig)*(1._rb-forwliq(ig))                         &
1823                                   /(1._rb-forwliq(ig)*ssacoliq(ig))
1824              tauliq = (1._rb-forwliq(ig)*ssacoliq(ig))*tauliqorig
1825              ssaice = ssacoice(ig)*(1._rb-forwice(ig))                         &
1826                                   /(1._rb-forwice(ig)*ssacoice(ig))
1827              tauice = (1._rb-forwice(ig)*ssacoice(ig))*tauiceorig
1828              ssasno = ssacosno(ig)*(1._rb-forwsno(ig))                         &
1829                                   /(1._rb-forwsno(ig)*ssacosno(ig))
1830              tausno = (1._rb-forwsno(ig)*ssacosno(ig))*tausnoorig
1831              scatliq = ssaliq*tauliq
1832              scatice = ssaice*tauice
1833              scatsno = ssasno*tausno
1834              taucmc(ig,lay) = tauliq+tauice+tausno
1835            endif
1836            dtliq(ig,lay)=tauliq ; dwliq(ig,lay)=ssaliq
1837            dtice(ig,lay)=tauice ; dwice(ig,lay)=ssaice
1838            dtsno(ig,lay)=tausno ; dwsno(ig,lay)=ssasno
1839            daliq(ig,lay)=(gliq(ig)-forwliq(ig))/(1._rb-forwliq(ig))
1840            daice(ig,lay)=(gice(ig)-forwice(ig))/(1._rb-forwice(ig))
1841            dasno(ig,lay)=(gsno(ig)-forwsno(ig))/(1._rb-forwsno(ig))
1842 !
1843 ! Ensure non-zero taucmc and scatice
1844 !
1845            if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
1846            if(scatice.eq.0.) scatice = cldmin
1847            if(scatsno.eq.0.) scatsno = cldmin
1848 !
1849            if(iceflag.lt.5) then
1850              ssacmc(ig,lay) = (scatliq+scatice)/taucmc(ig,lay)
1851            else
1852              ssacmc(ig,lay) = (scatliq+scatice+scatsno)/taucmc(ig,lay)
1853            endif
1854 !
1855            if(iceflag.eq.3 .or. iceflag.eq.4) then
1856 !
1857 ! In accordance with the 1996 Fu paper, equation A.3,
1858 ! the moments for ice were calculated depending on whether using spheres
1859 ! or hexagonal ice crystals.
1860 ! Set asymetry parameter to first moment (istr=1)
1861 !
1862              istr = 1
1863              asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))*                      &
1864                    (scatliq*(gliq(ig)**istr - forwliq(ig)) /                   &
1865                    (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
1866                    (1.0_rb - forwice(ig)))**istr)
1867            elseif(iceflag.eq.5) then
1868              istr = 1
1869              asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno))               &
1870                    *(scatliq*(gliq(ig)**istr-forwliq(ig))/(1.0_rb-forwliq(ig)) &
1871                    + scatice*((gice(ig)-forwice(ig))/(1.0_rb-forwice(ig)))     &
1872                    + scatsno*((gsno(ig)-forwsno(ig))/                          &
1873                      (1.0_rb-forwsno(ig)))**istr)
1874            else
1875 !
1876 ! This code is the standard method for delta-m scaling.
1877 ! Set asymetry parameter to first moment (istr=1)
1878 !
1879              istr = 1
1880              asmcmc(ig,lay) = (scatliq *                                       &
1881                         (gliq(ig)**istr - forwliq(ig)) /                       &
1882            (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / &
1883                         (1.0_rb - forwice(ig)))/(scatliq + scatice)
1884            endif
1885 !
1886          endif
1887 !
1888        endif
1889 !
1890 ! End g-point interval loop
1891 !
1892      enddo
1893 !
1894 ! End layer loop
1895 !
1896    enddo
1897 !
1898    end subroutine cldprmc_sw
1899 !-------------------------------------------------------------------------------
1900 !
1901 !
1902 !-------------------------------------------------------------------------------
1903    end module rrtmg_sw_cldprmc_k
1904 !-------------------------------------------------------------------------------
1905 !
1906 !
1907 !-------------------------------------------------------------------------------
1908    module rrtmg_sw_reftra_k
1909 !-------------------------------------------------------------------------------
1910 !  --------------------------------------------------------------------------
1911 ! |                                                                          |
1912 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
1913 ! |  This software may be used, copied, or redistributed as long as it is    |
1914 ! |  not sold and this copyright notice is reproduced on each copy made.     |
1915 ! |  This model is provided as is without any express or implied warranties. |
1916 ! |                       (http://www.rtweb.aer.com/)                        |
1917 ! |                                                                          |
1918 !  --------------------------------------------------------------------------
1919 ! ------- Modules -------
1920 !
1921    use parkind_k, only : im => kind_im, rb => kind_rb
1922    use rrsw_tbl_k, only : tblint, bpade, od_lo, exp_tbl
1923    use rrsw_vsn_k, only : hvrrft, hnamrft
1924 !
1925    implicit none
1926 !
1927    contains
1928 !-------------------------------------------------------------------------------
1929 !
1930 !
1931 !-------------------------------------------------------------------------------
1932    subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw,                 &
1933                            al1, al2, al3,                                      &
1934                            pref, prefd, ptra, ptrad)
1935 !-------------------------------------------------------------------------------
1936 !
1937 ! abstract:
1938 !   computes the reflectivity and transmissivity of a clear or
1939 !   cloudy layer using a choice of various approximations.
1940 !
1941 ! history log :
1942 !  2016-10-27 sunghye baek revised TSA
1943 ! Interface:  *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
1944 !
1945 ! Description:
1946 ! explicit arguments :
1947 ! --------------------
1948 ! inputs
1949 ! ------
1950 !      lrtchk  = .t. for all layers in clear profile
1951 !      lrtchk  = .t. for cloudy layers in cloud profile
1952 !              = .f. for clear layers in cloud profile
1953 !      pgg     = assymetry factor
1954 !      prmuz   = cosine solar zenith angle
1955 !      ptau    = optical thickness
1956 !      pw      = single scattering albedo
1957 !      al,a2,a3= coefficients for Ritter and Geleyn 1992 convention
1958 !
1959 ! outputs
1960 ! -------
1961 !      pref    : collimated beam reflectivity
1962 !      prefd   : diffuse beam reflectivity
1963 !      ptra    : collimated beam transmissivity
1964 !      ptrad   : diffuse beam transmissivity
1965 !
1966 !
1967 ! Method:
1968 ! -------
1969 !      standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
1970 !      kmodts  = 1 eddington (joseph et al., 1976)
1971 !              = 2 pifm (zdunkowski et al., 1980)
1972 !              = 3 discrete ordinates (liou, 1973)
1973 !              = 4 same as pifm, but Ritter and Geleyn 1992 convention
1974 !              = 5 revised TSA (sunghye baek)
1975 !
1976 ! Modifications:
1977 ! --------------
1978 ! Original: J-JMorcrette, ECMWF, Feb 2003
1979 ! Revised for F90 reformatting: MJIacono, AER, Jul 2006
1980 ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
1981 ! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008
1982 !
1983 !
1984 ! lrtchk(nlayers) : Logical flag for reflectivity and transmissivity calculation
1985 ! pgg(nlayers) : asymmetry parameter
1986 ! ptau(nlayers) : optical depth
1987 ! pw(nlayers) : single scattering albedo
1988 ! prmuz : cosine of solar zenith angle
1989 !
1990 ! pref(nlayers+1) :  direct beam reflectivity
1991 ! prefd(nlayers+1) : diffuse beam reflectivity
1992 ! ptra(nlayers+1) : direct beam transmissivity
1993 ! ptrad(nlayers+1) : diffuse beam transmissivity
1994 ! ------------------------------------------------------------------------------
1995 !
1996 ! ------- Declarations ------
1997 !
1998 ! ------- Input -------
1999 !
2000    integer(kind=im),                  intent(in   ) :: nlayers
2001    logical, dimension(:),         intent(in   ) :: lrtchk
2002    real(kind=rb), dimension(:),   intent(in   ) :: pgg
2003    real(kind=rb), dimension(:),   intent(in   ) :: ptau
2004    real(kind=rb), dimension(:),   intent(in   ) :: pw
2005    real(kind=rb),                 intent(in   ) :: prmuz
2006    real(kind=rb), dimension(:),   intent(in   ) :: al1
2007    real(kind=rb), dimension(:),   intent(in   ) :: al2
2008    real(kind=rb), dimension(:),   intent(in   ) :: al3
2009 !
2010 ! ------- Output -------
2011 !
2012    real(kind=rb), dimension(:),   intent(inout) :: pref
2013    real(kind=rb), dimension(:),   intent(inout) :: prefd
2014    real(kind=rb), dimension(:),   intent(inout) :: ptra
2015    real(kind=rb), dimension(:),   intent(inout) :: ptrad
2016 !
2017 ! ------- Local -------
2018 !
2019    integer(kind=im) :: jk, jl, kmodts
2020    integer(kind=im) :: itind
2021 !
2022    real(kind=rb) :: tblind
2023    real(kind=rb) :: za, za1, za2
2024    real(kind=rb) :: zbeta, zdend, zdenr, zdent
2025    real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
2026    real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
2027    real(kind=rb) :: zr1, zr2, zr3, zr4, zr5
2028    real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
2029    real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
2030    real(kind=rb) :: zw, zwcrit, zwo
2031    real(kind=rb) :: denom
2032 !
2033    real(kind=rb), parameter :: eps = 1.e-08_rb
2034    real(kind=rb) :: zbetab, zbetad, ztos, ztoa, zto2
2035 !-------------------------------------------------------------------------------
2036 !
2037 ! Initialize
2038 !
2039    hvrrft = '$Revision: 1.3 $'
2040    zsr3=sqrt(3._rb)
2041    zwcrit=0.9999995_rb
2042    kmodts=5
2043 !
2044    do jk = 1,nlayers
2045      if (.not.lrtchk(jk)) then
2046        pref(jk) =0._rb
2047        ptra(jk) =1._rb
2048        prefd(jk)=0._rb
2049        ptrad(jk)=1._rb
2050      else
2051        zto1=ptau(jk)
2052        zw  =pw(jk)
2053        zg  =pgg(jk)
2054 !
2055 ! General two-stream expressions
2056 !
2057        zg3= 3._rb * zg
2058        if (kmodts == 1) then
2059          zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb
2060          zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb
2061          zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2062        else if (kmodts == 2) then
2063          zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb
2064          zgamma2=  3._rb *(zw * (1._rb - zg )) * 0.25_rb
2065          zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
2066        else if (kmodts == 3) then
2067          zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb
2068          zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb
2069          zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb
2070        else if (kmodts == 4) then ! Ritter and Geleyn 1992 convention
2071          zbetad = 3._rb*0.125_rb*(1._rb-zg)
2072          zbetab = 0.25_rb*(2._rb-3._rb*zg*prmuz)
2073          ztos = zw*zto1
2074          ztoa = zto1 - ztos
2075          zto2 = ztos/zto1
2076          zgamma1= (2._rb * ztoa + 2._rb * zbetad * ztos) / zto1
2077          zgamma2= 2._rb * zbetad * zto2
2078          zgamma3= zbetab*zw
2079        else if (kmodts == 5) then
2080          zgamma1= al1(jk)
2081          zgamma2= al2(jk)
2082          zgamma3= al3(jk)
2083        end if
2084        if(kmodts .ge. 4) then
2085          zgamma4= zw - zgamma3
2086        else
2087          zgamma4= 1._rb - zgamma3
2088        endif
2089 !
2090 ! Recompute original s.s.a. to test for conservative solution
2091 !
2092        zwo = 0._rb
2093        denom = 1._rb
2094        if (zg .ne. 1._rb) denom = (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2)
2095        if (zw .gt. 0._rb .and. denom .ne. 0._rb) zwo = zw / denom
2096 !
2097        if (zwo >= zwcrit) then
2098 !
2099 ! Conservative scattering
2100 !
2101          za  = zgamma1 * prmuz
2102          za1 = za - zgamma3
2103          zgt = zgamma1 * zto1
2104 !
2105 ! Homogeneous reflectance and transmittance,
2106 ! collimated beam
2107 !
2108          ze1 = min ( zto1 / prmuz , 500._rb)
2109 !               ze2 = exp( -ze1 )
2110 !
2111 ! Use exponential lookup table for transmittance, or expansion of
2112 ! exponential for low tau
2113 !
2114          if (ze1 .le. od_lo) then
2115            ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2116          else
2117            tblind = ze1 / (bpade + ze1)
2118            itind = tblint * tblind + 0.5_rb
2119            ze2 = exp_tbl(itind)
2120          endif
2121 !
2122          pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt)
2123          ptra(jk) = 1._rb - pref(jk)
2124 !
2125 ! isotropic incidence
2126 !
2127          prefd(jk) = zgt / (1._rb + zgt)
2128          ptrad(jk) = 1._rb - prefd(jk)
2129 !
2130 ! This is applied for consistency between total (delta-scaled) and direct
2131 ! (unscaled) calculations at very low optical depths (tau < 1.e-4) when
2132 ! the exponential lookup table returns a transmittance of 1.0.
2133 !
2134          if (ze2 .eq. 1.0_rb) then
2135            pref(jk) = 0.0_rb
2136            ptra(jk) = 1.0_rb
2137            prefd(jk) = 0.0_rb
2138            ptrad(jk) = 1.0_rb
2139          endif
2140 !
2141        else
2142 !
2143 ! Non-conservative scattering
2144 !
2145          za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
2146          za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
2147          zrk = sqrt ( zgamma1**2 - zgamma2**2)
2148          zrp = zrk * prmuz
2149          zrp1 = 1._rb + zrp
2150          zrm1 = 1._rb - zrp
2151          zrk2 = 2._rb * zrk
2152          zrpp = 1._rb - zrp*zrp
2153          zrkg = zrk + zgamma1
2154          zr1  = zrm1 * (za2 + zrk * zgamma3)
2155          zr2  = zrp1 * (za2 - zrk * zgamma3)
2156          zr3  = zrk2 * (zgamma3 - za2 * prmuz )
2157          zr4  = zrpp * zrkg
2158          zr5  = zrpp * (zrk - zgamma1)
2159          zt1  = zrp1 * (za1 + zrk * zgamma4)
2160          zt2  = zrm1 * (za1 - zrk * zgamma4)
2161          zt3  = zrk2 * (zgamma4 + za1 * prmuz )
2162          zt4  = zr4
2163          zt5  = zr5
2164 !
2165 ! mji - reformulated code to avoid potential floating point exceptions
2166 !        zbeta = - zr5 / zr4
2167          zbeta = (zgamma1 - zrk) / zrkg
2168 !
2169 ! Homogeneous reflectance and transmittance
2170 !
2171          ze1 = min ( zrk * zto1, 500._rb)
2172          ze2 = min ( zto1 / prmuz , 500._rb)
2173 !
2174 ! Original
2175 !        zep1 = exp( ze1 )
2176 !        zem1 = exp(-ze1 )
2177 !        zep2 = exp( ze2 )
2178 !        zem2 = exp(-ze2 )
2179 !
2180 ! Revised original, to reduce exponentials
2181 !        zep1 = exp( ze1 )
2182 !        zem1 = 1._rb / zep1
2183 !        zep2 = exp( ze2 )
2184 !        zem2 = 1._rb / zep2
2185 !
2186 ! Use exponential lookup table for transmittance, or expansion of
2187 ! exponential for low tau
2188 !
2189          if (ze1 .le. od_lo) then
2190            zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
2191            zep1 = 1._rb / zem1
2192          else
2193            tblind = ze1 / (bpade + ze1)
2194            itind = tblint * tblind + 0.5_rb
2195            zem1 = exp_tbl(itind)
2196            zep1 = 1._rb / zem1
2197          endif
2198 !
2199          if (ze2 .le. od_lo) then
2200            zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2
2201            zep2 = 1._rb / zem2
2202          else
2203            tblind = ze2 / (bpade + ze2)
2204            itind = tblint * tblind + 0.5_rb
2205            zem2 = exp_tbl(itind)
2206            zep2 = 1._rb / zem2
2207          endif
2208 !
2209 ! collimated beam
2210 !
2211 ! mji - reformulated code to avoid potential floating point exceptions
2212 !       zdenr = zr4*zep1 + zr5*zem1
2213 !       pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2214 !       zdent = zt4*zep1 + zt5*zem1
2215 !       ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2216 !
2217          zdenr = zr4*zep1 + zr5*zem1
2218          zdent = zt4*zep1 + zt5*zem1
2219          if (zdenr .ge. -eps .and. zdenr .le. eps) then
2220            pref(jk) = eps
2221            ptra(jk) = zem2
2222          else
2223            if(kmodts .ge. 4) then
2224              pref(jk) = (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2225              ptra(jk) = zem2 - zem2 * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2226            else
2227              pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
2228              ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
2229            endif
2230          endif
2231 !
2232 ! diffuse beam
2233 !
2234          zemm = zem1*zem1
2235          zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg)
2236          prefd(jk) =  zgamma2 * (1._rb - zemm) * zdend
2237          ptrad(jk) =  zrk2*zem1*zdend
2238        endif
2239 !
2240      endif
2241 !
2242    enddo
2243 !
2244    end subroutine reftra_sw
2245 !-------------------------------------------------------------------------------
2246 !
2247 !
2248 !-------------------------------------------------------------------------------
2249    end module rrtmg_sw_reftra_k
2250 !-------------------------------------------------------------------------------
2251 !
2252 !
2253 !-------------------------------------------------------------------------------
2254    module rrtmg_sw_setcoef_k
2255 !-------------------------------------------------------------------------------
2256 !  --------------------------------------------------------------------------
2257 ! |                                                                          |
2258 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
2259 ! |  This software may be used, copied, or redistributed as long as it is    |
2260 ! |  not sold and this copyright notice is reproduced on each copy made.     |
2261 ! |  This model is provided as is without any express or implied warranties. |
2262 ! |                       (http://www.rtweb.aer.com/)                        |
2263 ! |                                                                          |
2264 !  --------------------------------------------------------------------------
2265 ! ------- Modules -------
2266 !
2267    use parkind_k, only : im => kind_im, rb => kind_rb
2268    use parrrsw_k, only : mxmol
2269    use rrsw_ref_k, only : pref, preflog, tref
2270    use rrsw_vsn_k, only : hvrset, hnamset
2271 !
2272    implicit none
2273 !
2274    contains
2275 !-------------------------------------------------------------------------------
2276 !
2277 !
2278 !-------------------------------------------------------------------------------
2279    subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl,   &
2280                             laytrop, layswtch, laylow, jp, jt, jt1,            &
2281                             co2mult, colch4, colco2, colh2o, colmol, coln2o,   &
2282                             colo2, colo3, fac00, fac01, fac10, fac11,          &
2283                             selffac, selffrac, indself, forfac, forfrac, indfor)
2284 !-------------------------------------------------------------------------------
2285 !
2286 ! abstract:  For a given atmosphere, calculate the indices and
2287 ! fractions related to the pressure and temperature interpolations.
2288 !
2289 ! history log:
2290 !   2002-04-01 J. Delamere, AER, Inc.   version 2.5
2291 !   2003-02-24 JJMorcrette              Rewritten and adapted to ECMWF F90
2292 !   2006-07    MJIacono                 For uniform rrtmg formatting
2293 !
2294 ! input :
2295 !   nlayers : total number of layers
2296 !   pavel(nlayers) : layer pressures (mb)
2297 !   tavel(nlayers) : layer temperatures (K)
2298 !   pz(0:nlayers) : level (interface) pressures (hPa, mb)
2299 !   tz(0:nlayers) : level (interface) temperatures (K)
2300 !   tbound : surface temperature (K)
2301 !   coldry(nlayers) : dry air column density (mol/cm2)
2302 !   wkl(mxmol,nlayers) : molecular amounts (mol/cm-2)
2303 !
2304 ! output :
2305 !   laytrop : tropopause layer index
2306 !   jp(nlayers)
2307 !   jt(nlayers)
2308 !   jt1(nlayers)
2309 !   colh2o(nlayers) column amount (h2o)
2310 !   colco2(nlayers) column amount (co2)
2311 !   colo3(nlayers) column amount (o3)
2312 !   coln2o(nlayers) column amount (n20)
2313 !   colch4(nlayers) column amount (ch4)
2314 !   colo2(nlayers) column amount (o2)
2315 !   colmol(nlayers)
2316 !   co2mult(nlayers)
2317 !
2318 !   indself(nlayers)
2319 !   indfor(nlayers)
2320 !   selffac(nlayers)
2321 !   forfac(nlayers)
2322 !   forfrac(nlayers)
2323 !   fac00(nlayers), fac01, fac10, fac11
2324 !-------------------------------------------------------------------------------
2325 !
2326 ! ----- Input -----
2327 !
2328    integer(kind=im),   intent(in   ) :: nlayers
2329    real(kind=rb), dimension(:),  intent(in   ) :: pavel
2330    real(kind=rb), dimension(:),  intent(in   ) :: tavel
2331    real(kind=rb), dimension(0:), intent(in   ) :: pz
2332    real(kind=rb), dimension(0:), intent(in   ) :: tz
2333    real(kind=rb),                intent(in   ) :: tbound
2334    real(kind=rb), dimension(:),  intent(in   ) :: coldry
2335    real(kind=rb), dimension(:,:),intent(in   ) :: wkl
2336 !
2337 ! ----- Output -----
2338 !
2339    integer(kind=im),   intent(  out) :: laytrop
2340    integer(kind=im),   intent(  out) :: layswtch
2341    integer(kind=im),   intent(  out) :: laylow
2342    integer(kind=im), dimension(:),  intent(  out) :: jp
2343    integer(kind=im), dimension(:),  intent(  out) :: jt
2344    integer(kind=im), dimension(:),  intent(  out) :: jt1
2345    real(kind=rb), dimension(:),     intent(  out) :: colh2o
2346    real(kind=rb), dimension(:),     intent(  out) :: colco2
2347    real(kind=rb), dimension(:),     intent(  out) :: colo3
2348    real(kind=rb), dimension(:),     intent(  out) :: coln2o
2349    real(kind=rb), dimension(:),     intent(  out) :: colch4
2350    real(kind=rb), dimension(:),     intent(  out) :: colo2
2351    real(kind=rb), dimension(:),     intent(  out) :: colmol
2352    real(kind=rb), dimension(:),     intent(  out) :: co2mult
2353 !
2354    integer(kind=im), dimension(:),  intent(   out) :: indself
2355    integer(kind=im), dimension(:),  intent(   out) :: indfor
2356    real(kind=rb), dimension(:), intent(out) :: selffac
2357    real(kind=rb), dimension(:), intent(out) :: selffrac
2358    real(kind=rb), dimension(:), intent(out) :: forfac
2359    real(kind=rb), dimension(:), intent(out) :: forfrac
2360    real(kind=rb), dimension(:), intent(out) :: fac00, fac01
2361    real(kind=rb), dimension(:), intent(out) :: fac10, fac11
2362 !
2363 ! ----- Local -----
2364 !
2365    integer(kind=im) :: indbound
2366    integer(kind=im) :: indlev0
2367    integer(kind=im) :: lay
2368    integer(kind=im) :: jp1
2369 !
2370    real(kind=rb) :: stpfac
2371    real(kind=rb) :: tbndfrac
2372    real(kind=rb) :: t0frac
2373    real(kind=rb) :: plog
2374    real(kind=rb) :: fp
2375    real(kind=rb) :: ft
2376    real(kind=rb) :: ft1
2377    real(kind=rb) :: water
2378    real(kind=rb) :: scalefac
2379    real(kind=rb) :: factor
2380    real(kind=rb) :: co2reg
2381    real(kind=rb) :: compfp
2382 !-------------------------------------------------------------------------------
2383 !
2384 ! Initializations
2385 !
2386    stpfac = 296._rb/1013._rb
2387 !
2388    indbound = tbound - 159._rb
2389    tbndfrac = tbound - int(tbound)
2390    indlev0  = tz(0) - 159._rb
2391    t0frac   = tz(0) - int(tz(0))
2392 !
2393    laytrop  = 0
2394    layswtch = 0
2395    laylow   = 0
2396 !
2397 ! Begin layer loop
2398 !
2399    do lay = 1,nlayers
2400 !
2401 ! Find the two reference pressures on either side of the
2402 ! layer pressure.  Store them in JP and JP1.  Store in FP the
2403 ! fraction of the difference (in ln(pressure)) between these
2404 ! two values that the layer pressure lies.
2405 !
2406      plog = log(pavel(lay))
2407      jp(lay) = int(36._rb - 5*(plog+0.04_rb))
2408      if (jp(lay) .lt. 1) then
2409        jp(lay) = 1
2410      elseif (jp(lay) .gt. 58) then
2411        jp(lay) = 58
2412      endif
2413      jp1 = jp(lay) + 1
2414      fp = 5._rb * (preflog(jp(lay)) - plog)
2415 !
2416 ! Determine, for each reference pressure (JP and JP1), which
2417 ! reference temperature (these are different for each
2418 ! reference pressure) is nearest the layer temperature but does
2419 ! not exceed it.  Store these indices in JT and JT1, resp.
2420 ! Store in FT (resp. FT1) the fraction of the way between JT
2421 ! (JT1) and the next highest reference temperature that the
2422 ! layer temperature falls.
2423 !
2424      jt(lay) = int(3._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
2425      if (jt(lay) .lt. 1) then
2426        jt(lay) = 1
2427      elseif (jt(lay) .gt. 4) then
2428        jt(lay) = 4
2429      endif
2430      ft = ((tavel(lay)-tref(jp(lay)))/15._rb) - real(jt(lay)-3)
2431      jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
2432      if (jt1(lay) .lt. 1) then
2433        jt1(lay) = 1
2434      elseif (jt1(lay) .gt. 4) then
2435        jt1(lay) = 4
2436      endif
2437      ft1 = ((tavel(lay)-tref(jp1))/15._rb) - real(jt1(lay)-3)
2438 !
2439      water = wkl(1,lay)/coldry(lay)
2440      scalefac = pavel(lay) * stpfac / tavel(lay)
2441 !
2442 ! If the pressure is less than ~100mb, perform a different
2443 ! set of species interpolations.
2444 !
2445      if (plog .le. 4.56_rb) go to 5300
2446      laytrop =  laytrop + 1
2447      if (plog .ge. 6.62_rb) laylow = laylow + 1
2448 !
2449 ! Set up factors needed to separately include the water vapor
2450 ! foreign-continuum in the calculation of absorption coefficient.
2451 !
2452      forfac(lay) = scalefac / (1.+water)
2453      factor = (332.0_rb-tavel(lay))/36.0_rb
2454      indfor(lay) = min(2, max(1, int(factor)))
2455      forfrac(lay) = factor - real(indfor(lay))
2456 !
2457 ! Set up factors needed to separately include the water vapor
2458 ! self-continuum in the calculation of absorption coefficient.
2459 !
2460      selffac(lay) = water * forfac(lay)
2461      factor = (tavel(lay)-188.0_rb)/7.2_rb
2462      indself(lay) = min(9, max(1, int(factor)-7))
2463      selffrac(lay) = factor - real(indself(lay) + 7)
2464 !
2465 ! Calculate needed column amounts.
2466 !
2467      colh2o(lay) = 1.e-20_rb * wkl(1,lay)
2468      colco2(lay) = 1.e-20_rb * wkl(2,lay)
2469      colo3(lay) = 1.e-20_rb * wkl(3,lay)
2470 !    colo3(lay) = 0._rb
2471 !    colo3(lay) = colo3(lay)/1.16_rb
2472      coln2o(lay) = 1.e-20_rb * wkl(4,lay)
2473      colch4(lay) = 1.e-20_rb * wkl(6,lay)
2474      colo2(lay) = 1.e-20_rb * wkl(7,lay)
2475      colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
2476 !    colco2(lay) = 0._rb
2477 !    colo3(lay) = 0._rb
2478 !    coln2o(lay) = 0._rb
2479 !    colch4(lay) = 0._rb
2480 !    colo2(lay) = 0._rb
2481 !    colmol(lay) = 0._rb
2482      if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
2483      if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
2484      if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
2485      if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
2486 !
2487 ! Using E = 1334.2 cm-1.
2488 !
2489      co2reg = 3.55e-24_rb * coldry(lay)
2490      co2mult(lay)= (colco2(lay) - co2reg) *                                    &
2491                272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
2492      goto 5400
2493 !
2494 ! Above laytrop.
2495 !
2496 5300    continue
2497 !
2498 ! Set up factors needed to separately include the water vapor
2499 ! foreign-continuum in the calculation of absorption coefficient.
2500 !
2501      forfac(lay) = scalefac / (1.+water)
2502      factor = (tavel(lay)-188.0_rb)/36.0_rb
2503      indfor(lay) = 3
2504      forfrac(lay) = factor - 1.0_rb
2505 !
2506 ! Calculate needed column amounts.
2507 !
2508      colh2o(lay) = 1.e-20_rb * wkl(1,lay)
2509      colco2(lay) = 1.e-20_rb * wkl(2,lay)
2510      colo3(lay)  = 1.e-20_rb * wkl(3,lay)
2511      coln2o(lay) = 1.e-20_rb * wkl(4,lay)
2512      colch4(lay) = 1.e-20_rb * wkl(6,lay)
2513      colo2(lay)  = 1.e-20_rb * wkl(7,lay)
2514      colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
2515      if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
2516      if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
2517      if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
2518      if (colo2(lay)  .eq. 0._rb) colo2(lay)  = 1.e-32_rb * coldry(lay)
2519      co2reg = 3.55e-24_rb * coldry(lay)
2520      co2mult(lay)= (colco2(lay) - co2reg) *                                    &
2521                272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
2522      selffac(lay) = 0._rb
2523      selffrac(lay)= 0._rb
2524      indself(lay) = 0
2525 !
2526 5400    continue
2527 !
2528 ! We have now isolated the layer ln pressure and temperature,
2529 ! between two reference pressures and two reference temperatures
2530 ! (for each reference pressure).  We multiply the pressure
2531 ! fraction FP with the appropriate temperature fractions to get
2532 ! the factors that will be needed for the interpolation that yields
2533 ! the optical depths (performed in routines TAUGBn for band n).
2534 !
2535      compfp = 1._rb - fp
2536      fac10(lay) = compfp * ft
2537      fac00(lay) = compfp * (1._rb - ft)
2538      fac11(lay) = fp * ft1
2539      fac01(lay) = fp * (1._rb - ft1)
2540 !
2541 ! End layer loop
2542 !
2543    enddo
2544 !
2545    end subroutine setcoef_sw
2546 !-------------------------------------------------------------------------------
2547 !
2548 !
2549 !-------------------------------------------------------------------------------
2550    subroutine swatmref
2551 !-------------------------------------------------------------------------------
2552 !
2553    save
2554 !
2555 ! These pressures are chosen such that the ln of the first pressure
2556 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
2557 ! each subsequent ln(pressure) differs from the previous one by 0.2.
2558 !
2559    pref(:) = (/                                                                &
2560    1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
2561    3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
2562    1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
2563    5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
2564    1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
2565    7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
2566    2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
2567    9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
2568    3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
2569    1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
2570    4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
2571    1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /)
2572 !
2573    preflog(:) = (/                                                             &
2574     6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
2575     5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
2576     4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
2577     3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
2578     2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
2579     1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
2580     9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
2581    -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
2582    -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
2583    -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
2584    -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
2585    -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /)
2586 !
2587 ! These are the temperatures associated with the respective
2588 ! pressures for the MLS standard atmosphere.
2589 !
2590    tref(:) = (/                                                                &
2591     2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
2592     2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
2593     2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
2594     2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
2595     2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
2596     2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
2597     2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
2598     2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
2599     2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
2600     2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
2601     2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
2602     1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /)
2603 !
2604    end subroutine swatmref
2605 !-------------------------------------------------------------------------------
2606 !
2607 !
2608 !-------------------------------------------------------------------------------
2609    end module rrtmg_sw_setcoef_k
2610 !-------------------------------------------------------------------------------
2611 !
2612 !
2613 !-------------------------------------------------------------------------------
2614    module rrtmg_sw_taumol_k
2615 !-------------------------------------------------------------------------------
2616 !  --------------------------------------------------------------------------
2617 ! |                                                                          |
2618 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
2619 ! |  This software may be used, copied, or redistributed as long as it is    |
2620 ! |  not sold and this copyright notice is reproduced on each copy made.     |
2621 ! |  This model is provided as is without any express or implied warranties. |
2622 ! |                       (http://www.rtweb.aer.com/)                        |
2623 ! |                                                                          |
2624 !  --------------------------------------------------------------------------
2625 ! ------- Modules -------
2626 !
2627    use parkind_k, only : im => kind_im, rb => kind_rb
2628 !  use parrrsw, only : mg, jpband, nbndsw, ngptsw
2629    use rrsw_con_k, only: oneminus
2630    use rrsw_wvn_k, only: nspa, nspb
2631    use rrsw_vsn_k, only: hvrtau, hnamtau
2632 !
2633    implicit none
2634 !
2635    contains
2636 !-------------------------------------------------------------------------------
2637 !
2638 !
2639 !-------------------------------------------------------------------------------
2640    subroutine taumol_sw(nlayers,                                               &
2641                            colh2o, colco2, colch4, colo2, colo3, colmol,       &
2642                            laytrop, jp, jt, jt1,                               &
2643                            fac00, fac01, fac10, fac11,                         &
2644                            selffac, selffrac, indself, forfac, forfrac, indfor,&
2645                            sfluxzen, taug, taur)
2646 !-------------------------------------------------------------------------------
2647 ! ******************************************************************************
2648 ! *                                                                            *
2649 ! *                 Optical depths developed for the                           *
2650 ! *                                                                            *
2651 ! *               RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
2652 ! *                                                                            *
2653 ! *                                                                            *
2654 ! *           ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
2655 ! *                       131 HARTWELL AVENUE                                  *
2656 ! *                       LEXINGTON, MA 02421                                  *
2657 ! *                                                                            *
2658 ! *                                                                            *
2659 ! *                          ELI J. MLAWER                                     *
2660 ! *                        JENNIFER DELAMERE                                   *
2661 ! *                        STEVEN J. TAUBMAN                                   *
2662 ! *                        SHEPARD A. CLOUGH                                   *
2663 ! *                                                                            *
2664 ! *                                                                            *
2665 ! *                                                                            *
2666 ! *                                                                            *
2667 ! *                      email:  mlawer@aer.com                                *
2668 ! *                      email:  jdelamer@aer.com                              *
2669 ! *                                                                            *
2670 ! *       The authors wish to acknowledge the contributions of the             *
2671 ! *       following people:  Patrick D. Brown, Michael J. Iacono,              *
2672 ! *       Ronald E. Farren, Luke Chen, Robert Bergstrom.                       *
2673 ! *                                                                            *
2674 ! ******************************************************************************
2675 ! *    TAUMOL                                                                  *
2676 ! *                                                                            *
2677 ! *    This file contains the subroutines TAUGBn (where n goes from            *
2678 ! *    1 to 28).  TAUGBn calculates the optical depths and Planck fractions    *
2679 ! *    per g-value and layer for band n.                                       *
2680 ! *                                                                            *
2681 ! * Output:  optical depths (unitless)                                         *
2682 ! *          fractions needed to compute Planck functions at every layer       *
2683 ! *              and g-value                                                   *
2684 ! *                                                                            *
2685 ! *    COMMON /TAUGCOM/  TAUG(MXLAY,MG)                                        *
2686 ! *    COMMON /PLANKG/   FRACS(MXLAY,MG)                                       *
2687 ! *                                                                            *
2688 ! * Input                                                                      *
2689 ! *                                                                            *
2690 ! *    PARAMETER (MG=16, MXLAY=203, NBANDS=14)                                 *
2691 ! *                                                                            *
2692 ! *    COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)                  *
2693 ! *    COMMON /PRECISE/  ONEMINUS                                              *
2694 ! *    COMMON /PROFILE/  NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),                    *
2695 ! *   &                  PZ(0:MXLAY),TZ(0:MXLAY),TBOUND                        *
2696 ! *    COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW,                              *
2697 ! *   &                  COLH2O(MXLAY),COLCO2(MXLAY),                          *
2698 ! *   &                  COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY),             *
2699 ! *   &                  COLO2(MXLAY),CO2MULT(MXLAY)                           *
2700 ! *    COMMON /INTFAC/   FAC00(MXLAY),FAC01(MXLAY),                            *
2701 ! *   &                  FAC10(MXLAY),FAC11(MXLAY)                             *
2702 ! *    COMMON /INTIND/   JP(MXLAY),JT(MXLAY),JT1(MXLAY)                        *
2703 ! *    COMMON /SELF/     SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY)       *
2704 ! *                                                                            *
2705 ! *    Description:                                                            *
2706 ! *    NG(IBAND) - number of g-values in band IBAND                            *
2707 ! *    NSPA(IBAND) - for the lower atmosphere, the number of reference         *
2708 ! *                  atmospheres that are stored for band IBAND per            *
2709 ! *                  pressure level and temperature.  Each of these            *
2710 ! *                  atmospheres has different relative amounts of the         *
2711 ! *                  key species for the band (i.e. different binary           *
2712 ! *                  species parameters).                                      *
2713 ! *    NSPB(IBAND) - same for upper atmosphere                                 *
2714 ! *    ONEMINUS - since problems are caused in some cases by interpolation     *
2715 ! *               parameters equal to or greater than 1, for these cases       *
2716 ! *               these parameters are set to this value, slightly < 1.        *
2717 ! *    PAVEL - layer pressures (mb)                                            *
2718 ! *    TAVEL - layer temperatures (degrees K)                                  *
2719 ! *    PZ - level pressures (mb)                                               *
2720 ! *    TZ - level temperatures (degrees K)                                     *
2721 ! *    LAYTROP - layer at which switch is made from one combination of         *
2722 ! *              key species to another                                        *
2723 ! *    COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water         *
2724 ! *              vapor,carbon dioxide, ozone, nitrous ozide, methane,          *
2725 ! *              respectively (molecules/cm**2)                                *
2726 ! *    CO2MULT - for bands in which carbon dioxide is implemented as a         *
2727 ! *              trace species, this is the factor used to multiply the        *
2728 ! *              band's average CO2 absorption coefficient to get the added    *
2729 ! *              contribution to the optical depth relative to 355 ppm.        *
2730 ! *    FACij(LAY) - for layer LAY, these are factors that are needed to        *
2731 ! *                 compute the interpolation factors that multiply the        *
2732 ! *                 appropriate reference k-values.  A value of 0 (1) for      *
2733 ! *                 i,j indicates that the corresponding factor multiplies     *
2734 ! *                 reference k-value for the lower (higher) of the two        *
2735 ! *                 appropriate temperatures, and altitudes, respectively.     *
2736 ! *    JP - the index of the lower (in altitude) of the two appropriate        *
2737 ! *         reference pressure levels needed for interpolation                 *
2738 ! *    JT, JT1 - the indices of the lower of the two appropriate reference     *
2739 ! *              temperatures needed for interpolation (for pressure           *
2740 ! *              levels JP and JP+1, respectively)                             *
2741 ! *    SELFFAC - scale factor needed to water vapor self-continuum, equals     *
2742 ! *              (water vapor density)/(atmospheric density at 296K and        *
2743 ! *              1013 mb)                                                      *
2744 ! *    SELFFRAC - factor needed for temperature interpolation of reference     *
2745 ! *               water vapor self-continuum data                              *
2746 ! *    INDSELF - index of the lower of the two appropriate reference           *
2747 ! *              temperatures needed for the self-continuum interpolation      *
2748 ! *                                                                            *
2749 ! * Data input                                                                 *
2750 ! *    COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
2751 ! *       (note:  n is the band number)                                        *
2752 ! *                                                                            *
2753 ! *    Description:                                                            *
2754 ! *    KA - k-values for low reference atmospheres (no water vapor             *
2755 ! *         self-continuum) (units: cm**2/molecule)                            *
2756 ! *    KB - k-values for high reference atmospheres (all sources)              *
2757 ! *         (units: cm**2/molecule)                                            *
2758 ! *    SELFREF - k-values for water vapor self-continuum for reference         *
2759 ! *              atmospheres (used below LAYTROP)                              *
2760 ! *              (units: cm**2/molecule)                                       *
2761 ! *                                                                            *
2762 ! *    DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG)                     *
2763 ! *    EQUIVALENCE (KA,ABSA),(KB,ABSB)                                         *
2764 ! *                                                                            *
2765 ! *****************************************************************************
2766 !
2767 ! history log :
2768 !
2769 ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003
2770 ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003
2771 ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
2772 !
2773 ! input :
2774 !   nlayers : total number of layers
2775 !   laytrop : tropopause layer index
2776 !   jp(nlayers)
2777 !   jt(nlayers)
2778 !   jt1(nlayers)
2779 !
2780 !   colh2o(nlayers) column amount (h2o)
2781 !   colco2(nlayers) column amount (co2)
2782 !   colo3(nlayers) column amount (o3)
2783 !   coln2o(nlayers) column amount (n20)
2784 !   colch4(nlayers) column amount (ch4)
2785 !   colo2(nlayers) column amount (o2)
2786 !   colmol(nlayers)
2787 !
2788 !   indself(nlayers)
2789 !   indfor(nlayers)
2790 !   selffac(nlayers)
2791 !   selffrac(nlayers)
2792 !   forfac(nlayers)
2793 !   forfrac(nlayers)
2794 !   fac00(nlayers), fac01, fac10, fac11
2795 !
2796 ! output :
2797 !  sfluxzen(ngptsw) : solar source function
2798 !  taug(nlayers,ngptsw) : gaseous optical depth
2799 !  taur(nlayers,ngptsw) : Rayleigh scattering
2800 !  ssa(nlayers,ngptsw) : single scattering albedo (inactive)
2801 ! ------- Declarations -------
2802 !
2803 ! ----- Input -----
2804    integer(kind=im), intent(in   ) :: nlayers
2805    integer(kind=im), intent(in   ) :: laytrop
2806    integer(kind=im), dimension(:), intent(in   ) :: jp
2807    integer(kind=im), dimension(:), intent(in   ) :: jt
2808    integer(kind=im), dimension(:), intent(in   ) :: jt1
2809    real(kind=rb),    dimension(:), intent(in   ) :: colh2o
2810    real(kind=rb),    dimension(:), intent(in   ) :: colco2
2811    real(kind=rb),    dimension(:), intent(in   ) :: colo3
2812    real(kind=rb),    dimension(:), intent(in   ) :: colch4
2813    real(kind=rb),    dimension(:), intent(in   ) :: colo2
2814    real(kind=rb),    dimension(:), intent(in   ) :: colmol
2815    integer(kind=im), dimension(:), intent(in   ) :: indself
2816    integer(kind=im), dimension(:), intent(in   ) :: indfor
2817    real(kind=rb),    dimension(:), intent(in   ) :: selffac
2818    real(kind=rb),    dimension(:), intent(in   ) :: selffrac
2819    real(kind=rb),    dimension(:), intent(in   ) :: forfac
2820    real(kind=rb),    dimension(:), intent(in   ) :: forfrac
2821    real(kind=rb),    dimension(:), intent(in   ) :: fac00, fac01
2822    real(kind=rb),    dimension(:), intent(in   ) :: fac10, fac11
2823 !
2824 ! ----- Output -----
2825 !
2826    real(kind=rb), dimension(:),   intent(  out) :: sfluxzen
2827    real(kind=rb), dimension(:,:), intent(  out) :: taug
2828    real(kind=rb), dimension(:,:), intent(  out) :: taur
2829 !  real(kind=rb), intent(out) :: ssa(:,:)
2830    hvrtau = '$Revision: 1.3 $'
2831 !
2832 ! Calculate gaseous optical depth and planck fractions for each spectral band.
2833 !
2834    call taumol16
2835    call taumol17
2836    call taumol18
2837    call taumol19
2838    call taumol20
2839    call taumol21
2840    call taumol22
2841    call taumol23
2842    call taumol24
2843    call taumol25
2844    call taumol26
2845    call taumol27
2846    call taumol28
2847    call taumol29
2848 !
2849    contains
2850 !-------------------------------------------------------------------------------
2851 !
2852 !
2853 !-------------------------------------------------------------------------------
2854    subroutine taumol16
2855 !-------------------------------------------------------------------------------
2856 !     band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
2857 !-------------------------------------------------------------------------------
2858 !
2859 ! ------- Modules -------
2860 !
2861    use parrrsw_k, only : ng16
2862    use rrsw_kg16_k, only : absa, ka, absb, kb, forref, selfref,                  &
2863                          sfluxref, rayl, layreffr, strrat1
2864 !
2865 ! ------- Declarations -------
2866 !
2867 ! Local
2868 !
2869    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2870    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
2871                     fac110, fac111, fs, speccomb, specmult, specparm,          &
2872                     tauray
2873 !-------------------------------------------------------------------------------
2874 !
2875 ! Compute the optical depth by interpolating in ln(pressure),
2876 ! temperature, and appropriate species.  Below LAYTROP, the water
2877 ! vapor self-continuum is interpolated (in temperature) separately.
2878 !
2879 ! Lower atmosphere loop
2880 !
2881    do lay = 1,laytrop
2882      speccomb = colh2o(lay) + strrat1*colch4(lay)
2883      specparm = colh2o(lay)/speccomb
2884      if (specparm .ge. oneminus) specparm = oneminus
2885      specmult = 8._rb*(specparm)
2886      js = 1 + int(specmult)
2887      fs = mod(specmult, 1._rb )
2888      fac000 = (1._rb - fs) * fac00(lay)
2889      fac010 = (1._rb - fs) * fac10(lay)
2890      fac100 = fs * fac00(lay)
2891      fac110 = fs * fac10(lay)
2892      fac001 = (1._rb - fs) * fac01(lay)
2893      fac011 = (1._rb - fs) * fac11(lay)
2894      fac101 = fs * fac01(lay)
2895      fac111 = fs * fac11(lay)
2896      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
2897      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js
2898      inds = indself(lay)
2899      indf = indfor(lay)
2900      tauray = colmol(lay) * rayl
2901      do ig = 1,ng16
2902        taug(lay,ig) = speccomb *                                               &
2903                 (fac000 * absa(ind0   ,ig) +                                   &
2904                  fac100 * absa(ind0 +1,ig) +                                   &
2905                  fac010 * absa(ind0 +9,ig) +                                   &
2906                  fac110 * absa(ind0+10,ig) +                                   &
2907                  fac001 * absa(ind1   ,ig) +                                   &
2908                  fac101 * absa(ind1 +1,ig) +                                   &
2909                  fac011 * absa(ind1 +9,ig) +                                   &
2910                  fac111 * absa(ind1+10,ig)) +                                  &
2911                  colh2o(lay) *                                                 &
2912                  (selffac(lay) * (selfref(inds,ig) +                           &
2913                  selffrac(lay) *                                               &
2914                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
2915                  forfac(lay) * (forref(indf,ig) +                              &
2916                  forfrac(lay) *                                                &
2917                  (forref(indf+1,ig) - forref(indf,ig))))
2918 !      ssa(lay,ig) = tauray/taug(lay,ig)
2919        taur(lay,ig) = tauray
2920      enddo
2921    enddo
2922 !
2923    laysolfr = nlayers
2924 !
2925 ! Upper atmosphere loop
2926 !
2927    do lay = laytrop+1,nlayers
2928      if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr)                  &
2929             laysolfr = lay
2930      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
2931      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
2932      tauray = colmol(lay) * rayl
2933      do ig = 1,ng16
2934        taug(lay,ig) = colch4(lay) *                                            &
2935                 (fac00(lay) * absb(ind0  ,ig) +                                &
2936                  fac10(lay) * absb(ind0+1,ig) +                                &
2937                  fac01(lay) * absb(ind1  ,ig) +                                &
2938                  fac11(lay) * absb(ind1+1,ig))
2939 !      ssa(lay,ig) = tauray/taug(lay,ig)
2940        if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig)
2941        taur(lay,ig) = tauray
2942      enddo
2943    enddo
2944 !
2945    end subroutine taumol16
2946 !-------------------------------------------------------------------------------
2947 !
2948 !
2949 !-------------------------------------------------------------------------------
2950    subroutine taumol17
2951 !-------------------------------------------------------------------------------
2952 !     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
2953 !-------------------------------------------------------------------------------
2954 !
2955 ! ------- Modules -------
2956 !
2957    use parrrsw_k, only : ng17, ngs16
2958    use rrsw_kg17_k, only : absa, ka, absb, kb, forref, selfref,                  &
2959                             sfluxref, rayl, layreffr, strrat
2960 !
2961 ! ------- Declarations -------
2962 !
2963 ! Local
2964 !
2965    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2966    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
2967                        fac110, fac111, fs, speccomb, specmult, specparm,       &
2968                        tauray
2969 !-------------------------------------------------------------------------------
2970 !
2971 ! Compute the optical depth by interpolating in ln(pressure),
2972 ! temperature, and appropriate species.  Below LAYTROP, the water
2973 ! vapor self-continuum is interpolated (in temperature) separately.
2974 !
2975 ! Lower atmosphere loop
2976 !
2977    do lay = 1,laytrop
2978      speccomb = colh2o(lay) + strrat*colco2(lay)
2979      specparm = colh2o(lay)/speccomb
2980      if (specparm .ge. oneminus) specparm = oneminus
2981      specmult = 8._rb*(specparm)
2982      js = 1 + int(specmult)
2983      fs = mod(specmult, 1._rb )
2984      fac000 = (1._rb - fs) * fac00(lay)
2985      fac010 = (1._rb - fs) * fac10(lay)
2986      fac100 = fs * fac00(lay)
2987      fac110 = fs * fac10(lay)
2988      fac001 = (1._rb - fs) * fac01(lay)
2989      fac011 = (1._rb - fs) * fac11(lay)
2990      fac101 = fs * fac01(lay)
2991      fac111 = fs * fac11(lay)
2992      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js
2993      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js
2994      inds = indself(lay)
2995      indf = indfor(lay)
2996      tauray = colmol(lay) * rayl
2997      do ig = 1,ng17
2998        taug(lay,ngs16+ig) = speccomb *                                         &
2999                 (fac000 * absa(ind0,ig) +                                      &
3000                  fac100 * absa(ind0+1,ig) +                                    &
3001                  fac010 * absa(ind0+9,ig) +                                    &
3002                  fac110 * absa(ind0+10,ig) +                                   &
3003                  fac001 * absa(ind1,ig) +                                      &
3004                  fac101 * absa(ind1+1,ig) +                                    &
3005                  fac011 * absa(ind1+9,ig) +                                    &
3006                  fac111 * absa(ind1+10,ig)) +                                  &
3007                  colh2o(lay) *                                                 &
3008                  (selffac(lay) * (selfref(inds,ig) +                           &
3009                  selffrac(lay) *                                               &
3010                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3011                  forfac(lay) * (forref(indf,ig) +                              &
3012                  forfrac(lay) *                                                &
3013                  (forref(indf+1,ig) - forref(indf,ig))))
3014 !      ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3015        taur(lay,ngs16+ig) = tauray
3016      enddo
3017    enddo
3018 !
3019    laysolfr = nlayers
3020 !
3021 ! Upper atmosphere loop
3022 !
3023    do lay = laytrop+1,nlayers
3024      if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr)                  &
3025             laysolfr = lay
3026      speccomb = colh2o(lay) + strrat*colco2(lay)
3027      specparm = colh2o(lay)/speccomb
3028      if (specparm .ge. oneminus) specparm = oneminus
3029      specmult = 4._rb*(specparm)
3030      js = 1 + int(specmult)
3031      fs = mod(specmult, 1._rb )
3032      fac000 = (1._rb - fs) * fac00(lay)
3033      fac010 = (1._rb - fs) * fac10(lay)
3034      fac100 = fs * fac00(lay)
3035      fac110 = fs * fac10(lay)
3036      fac001 = (1._rb - fs) * fac01(lay)
3037      fac011 = (1._rb - fs) * fac11(lay)
3038      fac101 = fs * fac01(lay)
3039      fac111 = fs * fac11(lay)
3040      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js
3041      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js
3042      indf = indfor(lay)
3043      tauray = colmol(lay) * rayl
3044      do ig = 1,ng17
3045        taug(lay,ngs16+ig) = speccomb *                                         &
3046                 (fac000 * absb(ind0,ig) +                                      &
3047                  fac100 * absb(ind0+1,ig) +                                    &
3048                  fac010 * absb(ind0+5,ig) +                                    &
3049                  fac110 * absb(ind0+6,ig) +                                    &
3050                  fac001 * absb(ind1,ig) +                                      &
3051                  fac101 * absb(ind1+1,ig) +                                    &
3052                  fac011 * absb(ind1+5,ig) +                                    &
3053                  fac111 * absb(ind1+6,ig)) +                                   &
3054                  colh2o(lay) *                                                 &
3055                  forfac(lay) * (forref(indf,ig) +                              &
3056                  forfrac(lay) *                                                &
3057                  (forref(indf+1,ig) - forref(indf,ig)))
3058 !      ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3059        if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js)             &
3060                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3061        taur(lay,ngs16+ig) = tauray
3062      enddo
3063    enddo
3064 !
3065    end subroutine taumol17
3066 !-------------------------------------------------------------------------------
3067 !
3068 !
3069 !-------------------------------------------------------------------------------
3070    subroutine taumol18
3071 !-------------------------------------------------------------------------------
3072 !     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
3073 !-------------------------------------------------------------------------------
3074 !
3075 ! ------- Modules -------
3076 !
3077    use parrrsw_k, only : ng18, ngs17
3078    use rrsw_kg18_k, only : absa, ka, absb, kb, forref, selfref,                  &
3079                             sfluxref, rayl, layreffr, strrat
3080 !
3081 ! ------- Declarations -------
3082 !
3083 ! Local
3084 !
3085    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3086    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3087                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3088                        tauray
3089 !-------------------------------------------------------------------------------
3090 !
3091 ! Compute the optical depth by interpolating in ln(pressure),
3092 ! temperature, and appropriate species.  Below LAYTROP, the water
3093 ! vapor self-continuum is interpolated (in temperature) separately.
3094 !
3095    laysolfr = laytrop
3096 !
3097 ! Lower atmosphere loop
3098 !
3099    do lay = 1,laytrop
3100      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3101             laysolfr = min(lay+1,laytrop)
3102      speccomb = colh2o(lay) + strrat*colch4(lay)
3103      specparm = colh2o(lay)/speccomb
3104      if (specparm .ge. oneminus) specparm = oneminus
3105      specmult = 8._rb*(specparm)
3106      js = 1 + int(specmult)
3107      fs = mod(specmult, 1._rb )
3108      fac000 = (1._rb - fs) * fac00(lay)
3109      fac010 = (1._rb - fs) * fac10(lay)
3110      fac100 = fs * fac00(lay)
3111      fac110 = fs * fac10(lay)
3112      fac001 = (1._rb - fs) * fac01(lay)
3113      fac011 = (1._rb - fs) * fac11(lay)
3114      fac101 = fs * fac01(lay)
3115      fac111 = fs * fac11(lay)
3116      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js
3117      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js
3118      inds = indself(lay)
3119      indf = indfor(lay)
3120      tauray = colmol(lay) * rayl
3121      do ig = 1,ng18
3122        taug(lay,ngs17+ig) = speccomb *                                         &
3123                 (fac000 * absa(ind0,ig) +                                      &
3124                  fac100 * absa(ind0+1,ig) +                                    &
3125                  fac010 * absa(ind0+9,ig) +                                    &
3126                  fac110 * absa(ind0+10,ig) +                                   &
3127                  fac001 * absa(ind1,ig) +                                      &
3128                  fac101 * absa(ind1+1,ig) +                                    &
3129                  fac011 * absa(ind1+9,ig) +                                    &
3130                  fac111 * absa(ind1+10,ig)) +                                  &
3131                  colh2o(lay) *                                                 &
3132                  (selffac(lay) * (selfref(inds,ig) +                           &
3133                  selffrac(lay) *                                               &
3134                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3135                  forfac(lay) * (forref(indf,ig) +                              &
3136                  forfrac(lay) *                                                &
3137                  (forref(indf+1,ig) - forref(indf,ig))))
3138 !      ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3139        if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js)             &
3140                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3141        taur(lay,ngs17+ig) = tauray
3142      enddo
3143    enddo
3144 !
3145 ! Upper atmosphere loop
3146 !
3147    do lay = laytrop+1,nlayers
3148      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1
3149      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1
3150      tauray = colmol(lay) * rayl
3151 !
3152      do ig = 1,ng18
3153        taug(lay,ngs17+ig) = colch4(lay) *                                      &
3154                 (fac00(lay) * absb(ind0,ig) +                                  &
3155                  fac10(lay) * absb(ind0+1,ig) +                                &
3156                  fac01(lay) * absb(ind1,ig) +                                  &
3157                  fac11(lay) * absb(ind1+1,ig))
3158 !      ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3159        taur(lay,ngs17+ig) = tauray
3160      enddo
3161    enddo
3162 !
3163    end subroutine taumol18
3164 !-------------------------------------------------------------------------------
3165 !
3166 !
3167 !-------------------------------------------------------------------------------
3168    subroutine taumol19
3169 !-------------------------------------------------------------------------------
3170 !     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
3171 !-------------------------------------------------------------------------------
3172 !
3173 ! ------- Modules -------
3174 !
3175    use parrrsw_k, only : ng19, ngs18
3176    use rrsw_kg19_k, only : absa, ka, absb, kb, forref, selfref,                  &
3177                             sfluxref, rayl, layreffr, strrat
3178 !
3179 ! ------- Declarations -------
3180 !
3181 ! Local
3182 !
3183    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3184    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3185                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3186                        tauray
3187 !-------------------------------------------------------------------------------
3188 !
3189 ! Compute the optical depth by interpolating in ln(pressure),
3190 ! temperature, and appropriate species.  Below LAYTROP, the water
3191 ! vapor self-continuum is interpolated (in temperature) separately.
3192 !
3193    laysolfr = laytrop
3194 !
3195 ! Lower atmosphere loop
3196 !
3197    do lay = 1,laytrop
3198      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3199             laysolfr = min(lay+1,laytrop)
3200      speccomb = colh2o(lay) + strrat*colco2(lay)
3201      specparm = colh2o(lay)/speccomb
3202      if (specparm .ge. oneminus) specparm = oneminus
3203      specmult = 8._rb*(specparm)
3204      js = 1 + int(specmult)
3205      fs = mod(specmult, 1._rb )
3206      fac000 = (1._rb - fs) * fac00(lay)
3207      fac010 = (1._rb - fs) * fac10(lay)
3208      fac100 = fs * fac00(lay)
3209      fac110 = fs * fac10(lay)
3210      fac001 = (1._rb - fs) * fac01(lay)
3211      fac011 = (1._rb - fs) * fac11(lay)
3212      fac101 = fs * fac01(lay)
3213      fac111 = fs * fac11(lay)
3214      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js
3215      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js
3216      inds = indself(lay)
3217      indf = indfor(lay)
3218      tauray = colmol(lay) * rayl
3219      do ig = 1,ng19
3220        taug(lay,ngs18+ig) = speccomb *                                         &
3221                 (fac000 * absa(ind0,ig) +                                      &
3222                  fac100 * absa(ind0+1,ig) +                                    &
3223                  fac010 * absa(ind0+9,ig) +                                    &
3224                  fac110 * absa(ind0+10,ig) +                                   &
3225                  fac001 * absa(ind1,ig) +                                      &
3226                  fac101 * absa(ind1+1,ig) +                                    &
3227                  fac011 * absa(ind1+9,ig) +                                    &
3228                  fac111 * absa(ind1+10,ig)) +                                  &
3229                  colh2o(lay) *                                                 &
3230                  (selffac(lay) * (selfref(inds,ig) +                           &
3231                  selffrac(lay) *                                               &
3232                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3233                  forfac(lay) * (forref(indf,ig) +                              &
3234                  forfrac(lay) *                                                &
3235                  (forref(indf+1,ig) - forref(indf,ig))))
3236 !      ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3237        if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js)             &
3238                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3239        taur(lay,ngs18+ig) = tauray
3240      enddo
3241    enddo
3242 !
3243 ! Upper atmosphere loop
3244 !
3245    do lay = laytrop+1,nlayers
3246      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1
3247      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1
3248      tauray = colmol(lay) * rayl
3249      do ig = 1,ng19
3250        taug(lay,ngs18+ig) = colco2(lay) *                                      &
3251                 (fac00(lay) * absb(ind0,ig) +                                  &
3252                  fac10(lay) * absb(ind0+1,ig) +                                &
3253                  fac01(lay) * absb(ind1,ig) +                                  &
3254                  fac11(lay) * absb(ind1+1,ig))
3255 !      ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3256        taur(lay,ngs18+ig) = tauray
3257      enddo
3258    enddo
3259 !
3260    end subroutine taumol19
3261 !-------------------------------------------------------------------------------
3262 !
3263 !
3264 !-------------------------------------------------------------------------------
3265    subroutine taumol20
3266 !-------------------------------------------------------------------------------
3267 !     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
3268 !-------------------------------------------------------------------------------
3269 !
3270 ! ------- Modules -------
3271 !
3272    use parrrsw_k, only : ng20, ngs19
3273    use rrsw_kg20_k, only : absa, ka, absb, kb, forref, selfref,                  &
3274                             sfluxref, absch4, rayl, layreffr
3275 !
3276    implicit none
3277 !
3278 !
3279 ! ------- Declarations -------
3280 !
3281 ! Local
3282 !
3283    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3284    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3285                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3286                        tauray
3287 !-------------------------------------------------------------------------------
3288 !
3289 ! Compute the optical depth by interpolating in ln(pressure),
3290 ! temperature, and appropriate species.  Below LAYTROP, the water
3291 ! vapor self-continuum is interpolated (in temperature) separately.
3292 !
3293    laysolfr = laytrop
3294 !
3295 ! Lower atmosphere loop
3296 !
3297    do lay = 1,laytrop
3298      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3299             laysolfr = min(lay+1,laytrop)
3300      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1
3301      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1
3302      inds = indself(lay)
3303      indf = indfor(lay)
3304      tauray = colmol(lay) * rayl
3305      do ig = 1,ng20
3306        taug(lay,ngs19+ig) = colh2o(lay) *                                      &
3307                ((fac00(lay) * absa(ind0,ig) +                                  &
3308                  fac10(lay) * absa(ind0+1,ig) +                                &
3309                  fac01(lay) * absa(ind1,ig) +                                  &
3310                  fac11(lay) * absa(ind1+1,ig)) +                               &
3311                  selffac(lay) * (selfref(inds,ig) +                            &
3312                  selffrac(lay) *                                               &
3313                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3314                  forfac(lay) * (forref(indf,ig) +                              &
3315                  forfrac(lay) *                                                &
3316                  (forref(indf+1,ig) - forref(indf,ig))))                       &
3317                  + colch4(lay) * absch4(ig)
3318 !      ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3319        taur(lay,ngs19+ig) = tauray
3320        if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig)
3321      enddo
3322    enddo
3323 !
3324 ! Upper atmosphere loop
3325 !
3326    do lay = laytrop+1,nlayers
3327      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1
3328      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1
3329      indf = indfor(lay)
3330      tauray = colmol(lay) * rayl
3331      do ig = 1,ng20
3332        taug(lay,ngs19+ig) = colh2o(lay) *                                      &
3333                 (fac00(lay) * absb(ind0,ig) +                                  &
3334                  fac10(lay) * absb(ind0+1,ig) +                                &
3335                  fac01(lay) * absb(ind1,ig) +                                  &
3336                  fac11(lay) * absb(ind1+1,ig) +                                &
3337                  forfac(lay) * (forref(indf,ig) +                              &
3338                  forfrac(lay) *                                                &
3339                  (forref(indf+1,ig) - forref(indf,ig)))) +                     &
3340                  colch4(lay) * absch4(ig)
3341 !      ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3342        taur(lay,ngs19+ig) = tauray
3343      enddo
3344    enddo
3345 !
3346    end subroutine taumol20
3347 !-------------------------------------------------------------------------------
3348 !
3349 !
3350 !-------------------------------------------------------------------------------
3351    subroutine taumol21
3352 !-------------------------------------------------------------------------------
3353 !     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
3354 !-------------------------------------------------------------------------------
3355 !
3356 ! ------- Modules -------
3357 !
3358    use parrrsw_k, only : ng21, ngs20
3359    use rrsw_kg21_k, only : absa, ka, absb, kb, forref, selfref,                  &
3360                             sfluxref, rayl, layreffr, strrat
3361 !
3362 ! ------- Declarations -------
3363 !
3364 ! Local
3365 !
3366    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3367    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3368                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3369                        tauray
3370 !-------------------------------------------------------------------------------
3371 !
3372 ! Compute the optical depth by interpolating in ln(pressure),
3373 ! temperature, and appropriate species.  Below LAYTROP, the water
3374 ! vapor self-continuum is interpolated (in temperature) separately.
3375 !
3376    laysolfr = laytrop
3377 !
3378 ! Lower atmosphere loop
3379 !
3380    do lay = 1,laytrop
3381      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3382             laysolfr = min(lay+1,laytrop)
3383      speccomb = colh2o(lay) + strrat*colco2(lay)
3384      specparm = colh2o(lay)/speccomb
3385      if (specparm .ge. oneminus) specparm = oneminus
3386      specmult = 8._rb*(specparm)
3387      js = 1 + int(specmult)
3388      fs = mod(specmult, 1._rb )
3389      fac000 = (1._rb - fs) * fac00(lay)
3390      fac010 = (1._rb - fs) * fac10(lay)
3391      fac100 = fs * fac00(lay)
3392      fac110 = fs * fac10(lay)
3393      fac001 = (1._rb - fs) * fac01(lay)
3394      fac011 = (1._rb - fs) * fac11(lay)
3395      fac101 = fs * fac01(lay)
3396      fac111 = fs * fac11(lay)
3397      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js
3398      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js
3399      inds = indself(lay)
3400      indf = indfor(lay)
3401      tauray = colmol(lay) * rayl
3402      do ig = 1,ng21
3403        taug(lay,ngs20+ig) = speccomb *                                         &
3404                 (fac000 * absa(ind0,ig) +                                      &
3405                  fac100 * absa(ind0+1,ig) +                                    &
3406                  fac010 * absa(ind0+9,ig) +                                    &
3407                  fac110 * absa(ind0+10,ig) +                                   &
3408                  fac001 * absa(ind1,ig) +                                      &
3409                  fac101 * absa(ind1+1,ig) +                                    &
3410                  fac011 * absa(ind1+9,ig) +                                    &
3411                  fac111 * absa(ind1+10,ig)) +                                  &
3412                  colh2o(lay) *                                                 &
3413                  (selffac(lay) * (selfref(inds,ig) +                           &
3414                  selffrac(lay) *                                               &
3415                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3416                  forfac(lay) * (forref(indf,ig) +                              &
3417                  forfrac(lay) *                                                &
3418                  (forref(indf+1,ig) - forref(indf,ig))))
3419 !      ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3420        if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js)             &
3421                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3422        taur(lay,ngs20+ig) = tauray
3423      enddo
3424    enddo
3425 !
3426 ! Upper atmosphere loop
3427 !
3428    do lay = laytrop+1,nlayers
3429      speccomb = colh2o(lay) + strrat*colco2(lay)
3430      specparm = colh2o(lay)/speccomb
3431      if (specparm .ge. oneminus) specparm = oneminus
3432      specmult = 4._rb*(specparm)
3433      js = 1 + int(specmult)
3434      fs = mod(specmult, 1._rb )
3435      fac000 = (1._rb - fs) * fac00(lay)
3436      fac010 = (1._rb - fs) * fac10(lay)
3437      fac100 = fs * fac00(lay)
3438      fac110 = fs * fac10(lay)
3439      fac001 = (1._rb - fs) * fac01(lay)
3440      fac011 = (1._rb - fs) * fac11(lay)
3441      fac101 = fs * fac01(lay)
3442      fac111 = fs * fac11(lay)
3443      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js
3444      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js
3445      indf = indfor(lay)
3446      tauray = colmol(lay) * rayl
3447      do ig = 1,ng21
3448        taug(lay,ngs20+ig) = speccomb *                                         &
3449                 (fac000 * absb(ind0,ig) +                                      &
3450                  fac100 * absb(ind0+1,ig) +                                    &
3451                  fac010 * absb(ind0+5,ig) +                                    &
3452                  fac110 * absb(ind0+6,ig) +                                    &
3453                  fac001 * absb(ind1,ig) +                                      &
3454                  fac101 * absb(ind1+1,ig) +                                    &
3455                  fac011 * absb(ind1+5,ig) +                                    &
3456                  fac111 * absb(ind1+6,ig)) +                                   &
3457                  colh2o(lay) *                                                 &
3458                  forfac(lay) * (forref(indf,ig) +                              &
3459                  forfrac(lay) *                                                &
3460                  (forref(indf+1,ig) - forref(indf,ig)))
3461 !      ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3462        taur(lay,ngs20+ig) = tauray
3463      enddo
3464    enddo
3465 !
3466    end subroutine taumol21
3467 !-------------------------------------------------------------------------------
3468 !
3469 !
3470 !-------------------------------------------------------------------------------
3471    subroutine taumol22
3472 !-------------------------------------------------------------------------------
3473 !     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
3474 !-------------------------------------------------------------------------------
3475 !
3476 ! ------- Modules -------
3477 !
3478    use parrrsw_k, only : ng22, ngs21
3479    use rrsw_kg22_k, only : absa, ka, absb, kb, forref, selfref,                  &
3480                             sfluxref, rayl, layreffr, strrat
3481 !
3482 ! ------- Declarations -------
3483 !
3484 ! Local
3485 !
3486    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3487    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3488                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3489                        tauray, o2adj, o2cont
3490 !-------------------------------------------------------------------------------
3491 !
3492 ! The following factor is the ratio of total O2 band intensity (lines
3493 ! and Mate continuum) to O2 band intensity (line only).  It is needed
3494 ! to adjust the optical depths since the k's include only lines.
3495 !
3496    o2adj = 1.6_rb
3497 !
3498 ! Compute the optical depth by interpolating in ln(pressure),
3499 ! temperature, and appropriate species.  Below LAYTROP, the water
3500 ! vapor self-continuum is interpolated (in temperature) separately.
3501 !
3502    laysolfr = laytrop
3503 !
3504 ! Lower atmosphere loop
3505 !
3506    do lay = 1,laytrop
3507      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3508             laysolfr = min(lay+1,laytrop)
3509      o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
3510      speccomb = colh2o(lay) + o2adj*strrat*colo2(lay)
3511      specparm = colh2o(lay)/speccomb
3512      if (specparm .ge. oneminus) specparm = oneminus
3513      specmult = 8._rb*(specparm)
3514 !    odadj = specparm + o2adj * (1._rb - specparm)
3515      js = 1 + int(specmult)
3516      fs = mod(specmult, 1._rb )
3517      fac000 = (1._rb - fs) * fac00(lay)
3518      fac010 = (1._rb - fs) * fac10(lay)
3519      fac100 = fs * fac00(lay)
3520      fac110 = fs * fac10(lay)
3521      fac001 = (1._rb - fs) * fac01(lay)
3522      fac011 = (1._rb - fs) * fac11(lay)
3523      fac101 = fs * fac01(lay)
3524      fac111 = fs * fac11(lay)
3525      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js
3526      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js
3527      inds = indself(lay)
3528      indf = indfor(lay)
3529      tauray = colmol(lay) * rayl
3530      do ig = 1,ng22
3531        taug(lay,ngs21+ig) = speccomb *                                         &
3532                 (fac000 * absa(ind0,ig) +                                      &
3533                  fac100 * absa(ind0+1,ig) +                                    &
3534                  fac010 * absa(ind0+9,ig) +                                    &
3535                  fac110 * absa(ind0+10,ig) +                                   &
3536                  fac001 * absa(ind1,ig) +                                      &
3537                  fac101 * absa(ind1+1,ig) +                                    &
3538                  fac011 * absa(ind1+9,ig) +                                    &
3539                  fac111 * absa(ind1+10,ig)) +                                  &
3540                  colh2o(lay) *                                                 &
3541                  (selffac(lay) * (selfref(inds,ig) +                           &
3542                  selffrac(lay) *                                               &
3543                   (selfref(inds+1,ig) - selfref(inds,ig))) +                   &
3544                  forfac(lay) * (forref(indf,ig) +                              &
3545                  forfrac(lay) *                                                &
3546                  (forref(indf+1,ig) - forref(indf,ig))))                       &
3547                  + o2cont
3548 !      ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
3549        if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js)             &
3550                 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3551        taur(lay,ngs21+ig) = tauray
3552      enddo
3553    enddo
3554 !
3555 ! Upper atmosphere loop
3556 !
3557    do lay = laytrop+1,nlayers
3558      o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
3559      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1
3560      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1
3561      tauray = colmol(lay) * rayl
3562      do ig = 1,ng22
3563        taug(lay,ngs21+ig) = colo2(lay) * o2adj *                               &
3564                 (fac00(lay) * absb(ind0,ig) +                                  &
3565                  fac10(lay) * absb(ind0+1,ig) +                                &
3566                  fac01(lay) * absb(ind1,ig) +                                  &
3567                  fac11(lay) * absb(ind1+1,ig)) +                               &
3568                  o2cont
3569 !      ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
3570        taur(lay,ngs21+ig) = tauray
3571      enddo
3572    enddo
3573 !
3574    end subroutine taumol22
3575 !-------------------------------------------------------------------------------
3576 !
3577 !
3578 !-------------------------------------------------------------------------------
3579    subroutine taumol23
3580 !-------------------------------------------------------------------------------
3581 !     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
3582 !-------------------------------------------------------------------------------
3583 !
3584 ! ------- Modules -------
3585 !
3586    use parrrsw_k, only : ng23, ngs22
3587    use rrsw_kg23_k, only : absa, ka, forref, selfref,                            &
3588                             sfluxref, rayl, layreffr, givfac
3589 !
3590 ! ------- Declarations -------
3591 !
3592 ! Local
3593 !
3594    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3595    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3596                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3597                        tauray
3598 !-------------------------------------------------------------------------------
3599 !
3600 ! Compute the optical depth by interpolating in ln(pressure),
3601 ! temperature, and appropriate species.  Below LAYTROP, the water
3602 ! vapor self-continuum is interpolated (in temperature) separately.
3603 !
3604    laysolfr = laytrop
3605 !
3606 ! Lower atmosphere loop
3607 !
3608    do lay = 1,laytrop
3609      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3610             laysolfr = min(lay+1,laytrop)
3611      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1
3612      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1
3613      inds = indself(lay)
3614      indf = indfor(lay)
3615      do ig = 1,ng23
3616        tauray = colmol(lay) * rayl(ig)
3617        taug(lay,ngs22+ig) = colh2o(lay) *                                      &
3618                 (givfac * (fac00(lay) * absa(ind0,ig) +                        &
3619                  fac10(lay) * absa(ind0+1,ig) +                                &
3620                  fac01(lay) * absa(ind1,ig) +                                  &
3621                  fac11(lay) * absa(ind1+1,ig)) +                               &
3622                  selffac(lay) * (selfref(inds,ig) +                            &
3623                  selffrac(lay) *                                               &
3624                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3625                  forfac(lay) * (forref(indf,ig) +                              &
3626                  forfrac(lay) *                                                &
3627                  (forref(indf+1,ig) - forref(indf,ig))))
3628 !      ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
3629        if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig)
3630        taur(lay,ngs22+ig) = tauray
3631      enddo
3632    enddo
3633 !
3634 ! Upper atmosphere loop
3635 !
3636    do lay = laytrop+1,nlayers
3637      do ig = 1,ng23
3638 !      taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
3639 !      ssa(lay,ngs22+ig) = 1.0_rb
3640        taug(lay,ngs22+ig) = 0._rb
3641        taur(lay,ngs22+ig) = colmol(lay) * rayl(ig)
3642      enddo
3643    enddo
3644 !
3645    end subroutine taumol23
3646 !-------------------------------------------------------------------------------
3647 !
3648 !
3649 !-------------------------------------------------------------------------------
3650    subroutine taumol24
3651 !-------------------------------------------------------------------------------
3652 !     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
3653 !-------------------------------------------------------------------------------
3654 !
3655 ! ------- Modules -------
3656 !
3657    use parrrsw_k, only : ng24, ngs23
3658    use rrsw_kg24_k, only : absa, ka, absb, kb, forref, selfref,                  &
3659                             sfluxref, abso3a, abso3b, rayla, raylb,            &
3660                             layreffr, strrat
3661 !
3662 ! ------- Declarations -------
3663 !
3664 ! Local
3665 !
3666    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3667    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3668                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3669                        tauray
3670 !-------------------------------------------------------------------------------
3671 !
3672 ! Compute the optical depth by interpolating in ln(pressure),
3673 ! temperature, and appropriate species.  Below LAYTROP, the water
3674 ! vapor self-continuum is interpolated (in temperature) separately.
3675 !
3676    laysolfr = laytrop
3677 !
3678 ! Lower atmosphere loop
3679 !
3680    do lay = 1,laytrop
3681      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3682             laysolfr = min(lay+1,laytrop)
3683      speccomb = colh2o(lay) + strrat*colo2(lay)
3684      specparm = colh2o(lay)/speccomb
3685      if (specparm .ge. oneminus) specparm = oneminus
3686      specmult = 8._rb*(specparm)
3687      js = 1 + int(specmult)
3688      fs = mod(specmult, 1._rb )
3689      fac000 = (1._rb - fs) * fac00(lay)
3690      fac010 = (1._rb - fs) * fac10(lay)
3691      fac100 = fs * fac00(lay)
3692      fac110 = fs * fac10(lay)
3693      fac001 = (1._rb - fs) * fac01(lay)
3694      fac011 = (1._rb - fs) * fac11(lay)
3695      fac101 = fs * fac01(lay)
3696      fac111 = fs * fac11(lay)
3697      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js
3698      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js
3699      inds = indself(lay)
3700      indf = indfor(lay)
3701      do ig = 1,ng24
3702        tauray = colmol(lay) * (rayla(ig,js) +                                  &
3703                fs * (rayla(ig,js+1) - rayla(ig,js)))
3704             taug(lay,ngs23+ig) = speccomb *                                    &
3705                 (fac000 * absa(ind0,ig) +                                      &
3706                  fac100 * absa(ind0+1,ig) +                                    &
3707                  fac010 * absa(ind0+9,ig) +                                    &
3708                  fac110 * absa(ind0+10,ig) +                                   &
3709                  fac001 * absa(ind1,ig) +                                      &
3710                  fac101 * absa(ind1+1,ig) +                                    &
3711                  fac011 * absa(ind1+9,ig) +                                    &
3712                  fac111 * absa(ind1+10,ig)) +                                  &
3713                  colo3(lay) * abso3a(ig) +                                     &
3714                  colh2o(lay) *                                                 &
3715                  (selffac(lay) * (selfref(inds,ig) +                           &
3716                  selffrac(lay) *                                               &
3717                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
3718                  forfac(lay) * (forref(indf,ig) +                              &
3719                  forfrac(lay) *                                                &
3720                  (forref(indf+1,ig) - forref(indf,ig))))
3721 !      ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
3722        if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js)             &
3723                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3724        taur(lay,ngs23+ig) = tauray
3725      enddo
3726    enddo
3727 !
3728 ! Upper atmosphere loop
3729 !
3730    do lay = laytrop+1,nlayers
3731      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1
3732      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1
3733      do ig = 1,ng24
3734        tauray = colmol(lay) * raylb(ig)
3735        taug(lay,ngs23+ig) = colo2(lay) *                                       &
3736                 (fac00(lay) * absb(ind0,ig) +                                  &
3737                  fac10(lay) * absb(ind0+1,ig) +                                &
3738                  fac01(lay) * absb(ind1,ig) +                                  &
3739                  fac11(lay) * absb(ind1+1,ig)) +                               &
3740                  colo3(lay) * abso3b(ig)
3741 !      ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
3742        taur(lay,ngs23+ig) = tauray
3743      enddo
3744    enddo
3745 !
3746    end subroutine taumol24
3747 !-------------------------------------------------------------------------------
3748 !
3749 !
3750 !-------------------------------------------------------------------------------
3751    subroutine taumol25
3752 !-------------------------------------------------------------------------------
3753 !     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
3754 !-------------------------------------------------------------------------------
3755 !
3756 ! ------- Modules -------
3757 !
3758    use parrrsw_k, only : ng25, ngs24
3759    use rrsw_kg25_k, only : absa, ka,                                             &
3760                             sfluxref, abso3a, abso3b, rayl, layreffr
3761 !
3762 ! ------- Declarations -------
3763 !
3764 ! Local
3765 !
3766    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3767    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3768                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3769                        tauray
3770 !-------------------------------------------------------------------------------
3771 !
3772 ! Compute the optical depth by interpolating in ln(pressure),
3773 ! temperature, and appropriate species.  Below LAYTROP, the water
3774 ! vapor self-continuum is interpolated (in temperature) separately.
3775 !
3776    laysolfr = laytrop
3777 !
3778 ! Lower atmosphere loop
3779 !
3780    do lay = 1,laytrop
3781      if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr)                  &
3782             laysolfr = min(lay+1,laytrop)
3783      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1
3784      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1
3785      do ig = 1,ng25
3786        tauray = colmol(lay) * rayl(ig)
3787        taug(lay,ngs24+ig) = colh2o(lay) *                                      &
3788                 (fac00(lay) * absa(ind0,ig) +                                  &
3789                  fac10(lay) * absa(ind0+1,ig) +                                &
3790                  fac01(lay) * absa(ind1,ig) +                                  &
3791                  fac11(lay) * absa(ind1+1,ig)) +                               &
3792                  colo3(lay) * abso3a(ig)
3793 !      ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
3794        if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig)
3795        taur(lay,ngs24+ig) = tauray
3796      enddo
3797    enddo
3798 !
3799 ! Upper atmosphere loop
3800 !
3801    do lay = laytrop+1,nlayers
3802      do ig = 1,ng25
3803        tauray = colmol(lay) * rayl(ig)
3804        taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig)
3805 !      ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
3806        taur(lay,ngs24+ig) = tauray
3807      enddo
3808    enddo
3809 !
3810    end subroutine taumol25
3811 !-------------------------------------------------------------------------------
3812 !
3813 !
3814 !-------------------------------------------------------------------------------
3815    subroutine taumol26
3816 !-------------------------------------------------------------------------------
3817 !     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
3818 !-------------------------------------------------------------------------------
3819 !
3820 ! ------- Modules -------
3821 !
3822    use parrrsw_k, only : ng26, ngs25
3823    use rrsw_kg26_k, only : sfluxref, rayl
3824 !
3825 ! ------- Declarations -------
3826 !
3827 ! Local
3828 !
3829    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3830    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3831                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3832                        tauray
3833 !-------------------------------------------------------------------------------
3834 !
3835 ! Compute the optical depth by interpolating in ln(pressure),
3836 ! temperature, and appropriate species.  Below LAYTROP, the water
3837 ! vapor self-continuum is interpolated (in temperature) separately.
3838 !
3839    laysolfr = laytrop
3840 !
3841 ! Lower atmosphere loop
3842 !
3843    do lay = 1,laytrop
3844      do ig = 1,ng26
3845 !      taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3846 !      ssa(lay,ngs25+ig) = 1.0_rb
3847        if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig)
3848        taug(lay,ngs25+ig) = 0._rb
3849        taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3850      enddo
3851    enddo
3852 !
3853 ! Upper atmosphere loop
3854 !
3855    do lay = laytrop+1,nlayers
3856      do ig = 1,ng26
3857 !      taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3858 !      ssa(lay,ngs25+ig) = 1.0_rb
3859        taug(lay,ngs25+ig) = 0._rb
3860        taur(lay,ngs25+ig) = colmol(lay) * rayl(ig)
3861      enddo
3862    enddo
3863 !
3864    end subroutine taumol26
3865 !-------------------------------------------------------------------------------
3866 !
3867 !
3868 !-------------------------------------------------------------------------------
3869    subroutine taumol27
3870 !-------------------------------------------------------------------------------
3871 !     band 27:  29000-38000 cm-1 (low - o3; high - o3)
3872 !-------------------------------------------------------------------------------
3873 !
3874 ! ------- Modules -------
3875 !
3876    use parrrsw_k, only : ng27, ngs26
3877    use rrsw_kg27_k, only : absa, ka, absb, kb,                                   &
3878                             sfluxref, rayl, layreffr, scalekur
3879 !
3880 ! ------- Declarations -------
3881 !
3882 ! Local
3883 !
3884    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3885    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3886                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3887                        tauray
3888 !-------------------------------------------------------------------------------
3889 !
3890 ! Compute the optical depth by interpolating in ln(pressure),
3891 ! temperature, and appropriate species.  Below LAYTROP, the water
3892 ! vapor self-continuum is interpolated (in temperature) separately.
3893 !
3894 ! Lower atmosphere loop
3895 !
3896    do lay = 1,laytrop
3897      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1
3898      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1
3899      do ig = 1,ng27
3900        tauray = colmol(lay) * rayl(ig)
3901        taug(lay,ngs26+ig) = colo3(lay) *                                       &
3902                 (fac00(lay) * absa(ind0,ig) +                                  &
3903                  fac10(lay) * absa(ind0+1,ig) +                                &
3904                  fac01(lay) * absa(ind1,ig) +                                  &
3905                  fac11(lay) * absa(ind1+1,ig))
3906 !      ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
3907        taur(lay,ngs26+ig) = tauray
3908      enddo
3909    enddo
3910 !
3911    laysolfr = nlayers
3912 !
3913 ! Upper atmosphere loop
3914 !
3915    do lay = laytrop+1,nlayers
3916      if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr)                  &
3917             laysolfr = lay
3918      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1
3919      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1
3920      do ig = 1,ng27
3921        tauray = colmol(lay) * rayl(ig)
3922        taug(lay,ngs26+ig) = colo3(lay) *                                       &
3923                 (fac00(lay) * absb(ind0,ig) +                                  &
3924                  fac10(lay) * absb(ind0+1,ig) +                                &
3925                  fac01(lay) * absb(ind1,ig) +                                  &
3926                  fac11(lay) * absb(ind1+1,ig))
3927 !      ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
3928        if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig)
3929        taur(lay,ngs26+ig) = tauray
3930      enddo
3931    enddo
3932 !
3933    end subroutine taumol27
3934 !-------------------------------------------------------------------------------
3935 !
3936 !
3937 !-------------------------------------------------------------------------------
3938    subroutine taumol28
3939 !-------------------------------------------------------------------------------
3940 !     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
3941 !------------------------------------------------------------------------------
3942 !
3943 ! ------- Modules -------
3944 !
3945    use parrrsw_k, only : ng28, ngs27
3946    use rrsw_kg28_k, only : absa, ka, absb, kb,                                   &
3947                             sfluxref, rayl, layreffr, strrat
3948 !
3949 ! ------- Declarations -------
3950 !
3951 ! Local
3952 !
3953    integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3954    real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,            &
3955                        fac110, fac111, fs, speccomb, specmult, specparm,       &
3956                        tauray
3957 !-------------------------------------------------------------------------------
3958 !
3959 ! Compute the optical depth by interpolating in ln(pressure),
3960 ! temperature, and appropriate species.  Below LAYTROP, the water
3961 ! vapor self-continuum is interpolated (in temperature) separately.
3962 !
3963 ! Lower atmosphere loop
3964 !
3965    do lay = 1,laytrop
3966      speccomb = colo3(lay) + strrat*colo2(lay)
3967      specparm = colo3(lay)/speccomb
3968      if (specparm .ge. oneminus) specparm = oneminus
3969      specmult = 8._rb*(specparm)
3970      js = 1 + int(specmult)
3971      fs = mod(specmult, 1._rb )
3972      fac000 = (1._rb - fs) * fac00(lay)
3973      fac010 = (1._rb - fs) * fac10(lay)
3974      fac100 = fs * fac00(lay)
3975      fac110 = fs * fac10(lay)
3976      fac001 = (1._rb - fs) * fac01(lay)
3977      fac011 = (1._rb - fs) * fac11(lay)
3978      fac101 = fs * fac01(lay)
3979      fac111 = fs * fac11(lay)
3980      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js
3981      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js
3982      tauray = colmol(lay) * rayl
3983      do ig = 1,ng28
3984        taug(lay,ngs27+ig) = speccomb *                                         &
3985                 (fac000 * absa(ind0,ig) +                                      &
3986                  fac100 * absa(ind0+1,ig) +                                    &
3987                  fac010 * absa(ind0+9,ig) +                                    &
3988                  fac110 * absa(ind0+10,ig) +                                   &
3989                  fac001 * absa(ind1,ig) +                                      &
3990                  fac101 * absa(ind1+1,ig) +                                    &
3991                  fac011 * absa(ind1+9,ig) +                                    &
3992                  fac111 * absa(ind1+10,ig))
3993 !      ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
3994        taur(lay,ngs27+ig) = tauray
3995      enddo
3996    enddo
3997 !
3998    laysolfr = nlayers
3999 !
4000 ! Upper atmosphere loop
4001 !
4002    do lay = laytrop+1,nlayers
4003      if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr)                  &
4004             laysolfr = lay
4005      speccomb = colo3(lay) + strrat*colo2(lay)
4006      specparm = colo3(lay)/speccomb
4007      if (specparm .ge. oneminus) specparm = oneminus
4008      specmult = 4._rb*(specparm)
4009      js = 1 + int(specmult)
4010      fs = mod(specmult, 1._rb )
4011      fac000 = (1._rb - fs) * fac00(lay)
4012      fac010 = (1._rb - fs) * fac10(lay)
4013      fac100 = fs * fac00(lay)
4014      fac110 = fs * fac10(lay)
4015      fac001 = (1._rb - fs) * fac01(lay)
4016      fac011 = (1._rb - fs) * fac11(lay)
4017      fac101 = fs * fac01(lay)
4018      fac111 = fs * fac11(lay)
4019      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js
4020      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js
4021      tauray = colmol(lay) * rayl
4022      do ig = 1,ng28
4023        taug(lay,ngs27+ig) = speccomb *                                         &
4024                 (fac000 * absb(ind0,ig) +                                      &
4025                  fac100 * absb(ind0+1,ig) +                                    &
4026                  fac010 * absb(ind0+5,ig) +                                    &
4027                  fac110 * absb(ind0+6,ig) +                                    &
4028                  fac001 * absb(ind1,ig) +                                      &
4029                  fac101 * absb(ind1+1,ig) +                                    &
4030                  fac011 * absb(ind1+5,ig) +                                    &
4031                  fac111 * absb(ind1+6,ig))
4032 !      ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
4033        if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js)             &
4034                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4035        taur(lay,ngs27+ig) = tauray
4036      enddo
4037    enddo
4038 !
4039    end subroutine taumol28
4040 !-------------------------------------------------------------------------------
4041 !
4042 !
4043 !-------------------------------------------------------------------------------
4044    subroutine taumol29
4045 !-------------------------------------------------------------------------------
4046 !     band 29:  820-2600 cm-1 (low - h2o; high - co2)
4047 !-------------------------------------------------------------------------------
4048 !
4049 ! ------- Modules -------
4050 !
4051    use parrrsw_k, only : ng29, ngs28
4052    use rrsw_kg29_k, only : absa, ka, absb, kb, forref, selfref,                  &
4053                             sfluxref, absh2o, absco2, rayl, layreffr
4054 !
4055 ! ------- Declarations -------
4056 ! Local
4057       integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4058       real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101,         &
4059                        fac110, fac111, fs, speccomb, specmult, specparm,       &
4060                        tauray
4061 !-------------------------------------------------------------------------------
4062 !
4063 ! Compute the optical depth by interpolating in ln(pressure),
4064 ! temperature, and appropriate species.  Below LAYTROP, the water
4065 ! vapor self-continuum is interpolated (in temperature) separately.
4066 !
4067 ! Lower atmosphere loop
4068 !
4069    do lay = 1,laytrop
4070      ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1
4071      ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1
4072      inds = indself(lay)
4073      indf = indfor(lay)
4074      tauray = colmol(lay) * rayl
4075      do ig = 1,ng29
4076        taug(lay,ngs28+ig) = colh2o(lay) *                                      &
4077                ((fac00(lay) * absa(ind0,ig) +                                  &
4078                  fac10(lay) * absa(ind0+1,ig) +                                &
4079                  fac01(lay) * absa(ind1,ig) +                                  &
4080                  fac11(lay) * absa(ind1+1,ig)) +                               &
4081                  selffac(lay) * (selfref(inds,ig) +                            &
4082                  selffrac(lay) *                                               &
4083                  (selfref(inds+1,ig) - selfref(inds,ig))) +                    &
4084                  forfac(lay) * (forref(indf,ig) +                              &
4085                  forfrac(lay) *                                                &
4086                  (forref(indf+1,ig) - forref(indf,ig))))                       &
4087                  + colco2(lay) * absco2(ig)
4088 !      ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4089        taur(lay,ngs28+ig) = tauray
4090      enddo
4091    enddo
4092 !
4093    laysolfr = nlayers
4094 !
4095 ! Upper atmosphere loop
4096 !
4097    do lay = laytrop+1,nlayers
4098      if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr)                  &
4099             laysolfr = lay
4100      ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1
4101      ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1
4102      tauray = colmol(lay) * rayl
4103      do ig = 1,ng29
4104        taug(lay,ngs28+ig) = colco2(lay) *                                      &
4105                 (fac00(lay) * absb(ind0,ig) +                                  &
4106                  fac10(lay) * absb(ind0+1,ig) +                                &
4107                  fac01(lay) * absb(ind1,ig) +                                  &
4108                  fac11(lay) * absb(ind1+1,ig))                                 &
4109                  + colh2o(lay) * absh2o(ig)
4110 !      ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
4111        if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig)
4112        taur(lay,ngs28+ig) = tauray
4113      enddo
4114    enddo
4115 !
4116    end subroutine taumol29
4117 !-------------------------------------------------------------------------------
4118 !
4119 !
4120 !-------------------------------------------------------------------------------
4121    end subroutine taumol_sw
4122 !-------------------------------------------------------------------------------
4123 !
4124 !
4125 !-------------------------------------------------------------------------------
4126    end module rrtmg_sw_taumol_k
4127 !-------------------------------------------------------------------------------
4128 !
4129 !
4130 !-------------------------------------------------------------------------------
4131    module rrtmg_sw_init_k
4132 !-------------------------------------------------------------------------------
4133 !  --------------------------------------------------------------------------
4134 ! |                                                                          |
4135 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
4136 ! |  This software may be used, copied, or redistributed as long as it is    |
4137 ! |  not sold and this copyright notice is reproduced on each copy made.     |
4138 ! |  This model is provided as is without any express or implied warranties. |
4139 ! |                       (http://www.rtweb.aer.com/)                        |
4140 ! |                                                                          |
4141 !  --------------------------------------------------------------------------
4142 ! ------- Modules -------
4143 !
4144    use parkind_k, only : im => kind_im, rb => kind_rb
4145    use rrsw_wvn_k
4146    use rrtmg_sw_setcoef_k, only: swatmref
4147 !
4148    implicit none
4149 !
4150    contains
4151 !-------------------------------------------------------------------------------
4152 !
4153 !
4154 !-------------------------------------------------------------------------------
4155    subroutine rrtmg_sw_ini(cpdair)
4156 !-------------------------------------------------------------------------------
4157 !  abstract :
4158 !    This subroutine performs calculations necessary for the initialization
4159 !    of the shortwave model.  Lookup tables are computed for use in the SW
4160 !    radiative transfer, and input absorption coefficient data for each
4161 !    spectral band are reduced from 224 g-point intervals to 112.
4162 !
4163 !  history log :
4164 !    2004-02 Michael J. Iacono  Original version
4165 !    2006-07 M. J. Iacono       Revision for F90 formatting
4166 !
4167 !-------------------------------------------------------------------------------
4168    use parrrsw_k, only : mg, nbndsw, ngptsw
4169    use rrsw_tbl_k, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
4170    use rrsw_vsn_k, only: hvrini, hnamini
4171 !
4172    real(kind=rb), intent(in) :: cpdair     ! Specific heat capacity of dry air
4173                                            ! at constant pressure at 273 K
4174                                            ! (J kg-1 K-1)
4175 !
4176 ! ------- Local -------
4177 !
4178    integer(kind=im) :: ibnd, igc, ig, ind, ipr
4179    integer(kind=im) :: igcsm, iprsm
4180    integer(kind=im) :: itr
4181 !
4182    real(kind=rb) :: wtsum, wtsm(mg)
4183    real(kind=rb) :: tfn
4184 !
4185    real(kind=rb), parameter :: expeps = 1.e-20
4186                                ! Smallest value for exponential table
4187 !
4188 ! ------- Definitions -------
4189 !     Arrays for 10000-point look-up tables:
4190 !     TAU_TBL  Clear-sky optical depth
4191 !     EXP_TBL  Exponential lookup table for transmittance
4192 !     PADE     Pade approximation constant (= 0.278)
4193 !     BPADE    Inverse of the Pade approximation constant
4194 !
4195    hvrini = '$Revision: 1.3 $'
4196 !
4197 ! Initialize model data
4198 !
4199    call swdatinit(cpdair)
4200    call swcmbdat              ! g-point interval reduction data
4201    call swaerpr               ! aerosol optical properties
4202    call swcldpr               ! cloud optical properties
4203    call swatmref              ! reference MLS profile
4204 !
4205 ! Moved to module_ra_rrtmg_sw for WRF
4206 !  call sw_kgb16              ! molecular absorption coefficients
4207 !  call sw_kgb17
4208 !  call sw_kgb18
4209 !  call sw_kgb19
4210 !  call sw_kgb20
4211 !  call sw_kgb21
4212 !  call sw_kgb22
4213 !  call sw_kgb23
4214 !  call sw_kgb24
4215 !  call sw_kgb25
4216 !  call sw_kgb26
4217 !  call sw_kgb27
4218 !  call sw_kgb28
4219 !  call sw_kgb29
4220 !
4221 ! Define exponential lookup tables for transmittance. Tau is
4222 ! computed as a function of the tau transition function, and transmittance
4223 ! is calculated as a function of tau.  All tables are computed at intervals
4224 ! of 0.0001.  The inverse of the constant used in the Pade approximation to
4225 ! the tau transition function is set to bpade.
4226 !
4227    exp_tbl(0) = 1.0_rb
4228    exp_tbl(ntbl) = expeps
4229    bpade = 1.0_rb / pade
4230    do itr = 1,ntbl-1
4231      tfn = real(itr) / real(ntbl)
4232      tau_tbl = bpade * tfn / (1._rb - tfn)
4233      exp_tbl(itr) = exp(-tau_tbl)
4234      if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
4235    enddo
4236 !
4237 ! Perform g-point reduction from 16 per band (224 total points) to
4238 ! a band dependent number (112 total points) for all absorption
4239 ! coefficient input data and Planck fraction input data.
4240 ! Compute relative weighting for new g-point combinations.
4241 !
4242    igcsm = 0
4243    do ibnd = 1,nbndsw
4244      iprsm = 0
4245      if (ngc(ibnd).lt.mg) then
4246        do igc = 1,ngc(ibnd)
4247          igcsm = igcsm + 1
4248          wtsum = 0.
4249          do ipr = 1,ngn(igcsm)
4250            iprsm = iprsm + 1
4251            wtsum = wtsum + wt(iprsm)
4252          enddo
4253          wtsm(igc) = wtsum
4254        enddo
4255        do ig = 1,ng(ibnd+15)
4256          ind = (ibnd-1)*mg + ig
4257          rwgt(ind) = wt(ig)/wtsm(ngm(ind))
4258        enddo
4259      else
4260        do ig = 1,ng(ibnd+15)
4261          igcsm = igcsm + 1
4262          ind = (ibnd-1)*mg + ig
4263          rwgt(ind) = 1.0_rb
4264        enddo
4265      endif
4266    enddo
4267 !
4268 ! Reduce g-points for absorption coefficient data in each LW spectral band.
4269 !
4270    call cmbgb16s
4271    call cmbgb17
4272    call cmbgb18
4273    call cmbgb19
4274    call cmbgb20
4275    call cmbgb21
4276    call cmbgb22
4277    call cmbgb23
4278    call cmbgb24
4279    call cmbgb25
4280    call cmbgb26
4281    call cmbgb27
4282    call cmbgb28
4283    call cmbgb29
4284 !
4285    end subroutine rrtmg_sw_ini
4286 !-------------------------------------------------------------------------------
4287 !
4288 !
4289 !-------------------------------------------------------------------------------
4290    subroutine swdatinit(cpdair)
4291 !
4292 ! --------- Modules ----------
4293 !
4294    use rrsw_con_k, only: heatfac, grav, planck, boltz,                         &
4295                           clight, avogad, alosmt, gascon, radcn1, radcn2,      &
4296                           sbcnst, secdy
4297    use rrsw_vsn_k
4298 !
4299    save
4300 !
4301    real(kind=rb), intent(in) :: cpdair     ! Specific heat capacity of dry air
4302                                            ! at constant pressure at 273 K
4303                                            ! (J kg-1 K-1)
4304 !
4305 ! Shortwave spectral band limits (wavenumbers)
4306 !
4307    wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, &
4308                    7700._rb, 8050._rb,12850._rb,16000._rb,22650._rb,29000._rb, &
4309                    38000._rb,  820._rb/)
4310    wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, &
4311                    8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb, &
4312                    50000._rb, 2600._rb/)
4313    delwave(:) =  (/ 650._rb,  750._rb,  650._rb,  500._rb, 1000._rb, 1550._rb, &
4314                     350._rb, 4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb, &
4315                    12000._rb, 1780._rb/)
4316 !
4317 ! Spectral band information
4318 !
4319    ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
4320    nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
4321    nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
4322 !
4323 ! Fundamental physical constants from NIST 2002
4324 !
4325    grav = 9.8066_rb                        ! Acceleration of gravity
4326                                            ! (m s-2)
4327    planck = 6.62606876e-27_rb              ! Planck constant
4328                                            ! (ergs s; g cm2 s-1)
4329    boltz = 1.3806503e-16_rb                ! Boltzmann constant
4330                                            ! (ergs K-1; g cm2 s-2 K-1)
4331    clight = 2.99792458e+10_rb              ! Speed of light in a vacuum
4332                                            ! (cm s-1)
4333    avogad = 6.02214199e+23_rb              ! Avogadro constant
4334                                            ! (mol-1)
4335    alosmt = 2.6867775e+19_rb               ! Loschmidt constant
4336                                            ! (cm-3)
4337    gascon = 8.31447200e+07_rb              ! Molar gas constant
4338                                            ! (ergs mol-1 K-1)
4339    radcn1 = 1.191042772e-12_rb             ! First radiation constant
4340                                            ! (W cm2 sr-1)
4341    radcn2 = 1.4387752_rb                   ! Second radiation constant
4342                                            ! (cm K)
4343    sbcnst = 5.670400e-04_rb                ! Stefan-Boltzmann constant
4344                                            ! (W cm-2 K-4)
4345    secdy = 8.6400e4_rb                     ! Number of seconds per day
4346                                            ! (s d-1)
4347 !
4348 !     units are generally cgs
4349 !
4350 !     The first and second radiation constants are taken from NIST.
4351 !     They were previously obtained from the relations:
4352 !          radcn1 = 2.*planck*clight*clight*1.e-07
4353 !          radcn2 = planck*clight/boltz
4354 !
4355 !     Heatfac is the factor by which delta-flux / delta-pressure is
4356 !     multiplied, with flux in W/m-2 and pressure in mbar, to get
4357 !     the heating rate in units of degrees/day.  It is equal to:
4358 !     Original value:
4359 !           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4360 !           Here, cpdair (1.004) is in units of J g-1 K-1, and the
4361 !           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4362 !        =  (9.8066)(86400)(1e-5)/(1.004)
4363 !      heatfac = 8.4391_rb
4364 !
4365 !     Modified value for consistency with CAM3:
4366 !           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
4367 !           Here, cpdair (1.00464) is in units of J g-1 K-1, and the
4368 !           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
4369 !        =  (9.80616)(86400)(1e-5)/(1.00464)
4370 !      heatfac = 8.43339130434_rb
4371 !
4372 !     Calculated value (from constants above and input cpdair)
4373 !        (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
4374 !           Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
4375 !           converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
4376 !
4377    heatfac = grav * secdy / (cpdair * 1.e2_rb)
4378 !
4379    end subroutine swdatinit
4380 !-------------------------------------------------------------------------------
4381 !
4382 !
4383 !-------------------------------------------------------------------------------
4384    subroutine swcmbdat
4385 !-------------------------------------------------------------------------------
4386 !
4387 ! ------- Definitions -------
4388 !     Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
4389 !     This mapping from 224 to 112 points has been carefully selected to
4390 !     minimize the effect on the resulting fluxes and cooling rates, and
4391 !     caution should be used if the mapping is modified.  The full 224
4392 !     g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
4393 !     ngpt    The total number of new g-points
4394 !     ngc     The number of new g-points in each band
4395 !     ngs     The cumulative sum of new g-points for each band
4396 !     ngm     The index of each new g-point relative to the original
4397 !             16 g-points for each band.
4398 !     ngn     The number of original g-points that are combined to make
4399 !             each new g-point in each band.
4400 !     ngb     The band index for each new g-point.
4401 !     wt      RRTM weights for 16 g-points.
4402 !
4403 ! Use this set for 112 quadrature point (g-point) model
4404 ! ------- Data statements -------
4405 !
4406    save
4407    ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
4408    ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
4409    ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6,                                &
4410                ! band 16
4411                1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12,                           &
4412                ! band 17
4413                1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8,                                &
4414                ! band 18
4415                1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8,                                &
4416                ! band 19
4417                1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10,                          &
4418                ! band 20
4419                1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10,                          &
4420                ! band 21
4421                1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,                                &
4422                ! band 22
4423                1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10,                            &
4424                ! band 23
4425                1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,                                &
4426                ! band 24
4427                1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6,                                &
4428                ! band 25
4429                1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6,                                &
4430                ! band 26
4431                1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8,                                &
4432                ! band 27
4433                1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6,                                &
4434                ! band 28
4435                1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /)
4436                ! band 29
4437    ngn(:) = (/ 2,2,2,2,4,4,                                                    &
4438                ! band 16
4439                1,1,1,1,1,2,1,2,1,2,1,2,                                        &
4440                ! band 17
4441                1,1,1,1,2,2,4,4,                                                &
4442                ! band 18
4443                1,1,1,1,2,2,4,4,                                                &
4444                ! band 19
4445                1,1,1,1,1,1,1,1,2,6,                                            &
4446                ! band 20
4447                1,1,1,1,1,1,1,1,2,6,                                            &
4448                ! band 21
4449                8,8,                                                            &
4450                ! band 22
4451                2,2,1,1,1,1,1,1,2,4,                                            &
4452                ! band 23
4453                2,2,2,2,2,2,2,2,                                                &
4454                ! band 24
4455                1,1,2,2,4,6,                                                    &
4456                ! band 25
4457                1,1,2,2,4,6,                                                    &
4458                ! band 26
4459                1,1,1,1,1,1,4,6,                                                &
4460                ! band 27
4461                1,1,2,2,4,6,                                                    &
4462                ! band 28
4463                1,1,1,1,2,2,2,2,1,1,1,1 /)
4464                ! band 29
4465    ngb(:) = (/ 16,16,16,16,16,16,                                              &
4466                ! band 16
4467                17,17,17,17,17,17,17,17,17,17,17,17,                            &
4468                ! band 17
4469                18,18,18,18,18,18,18,18,                                        &
4470                ! band 18
4471                19,19,19,19,19,19,19,19,                                        &
4472                ! band 19
4473                20,20,20,20,20,20,20,20,20,20,                                  &
4474                ! band 20
4475                21,21,21,21,21,21,21,21,21,21,                                  &
4476                ! band 21
4477                22,22,                                                          &
4478                ! band 22
4479                23,23,23,23,23,23,23,23,23,23,                                  &
4480                ! band 23
4481                24,24,24,24,24,24,24,24,                                        &
4482                ! band 24
4483                25,25,25,25,25,25,                                              &
4484                ! band 25
4485                26,26,26,26,26,26,                                              &
4486                ! band 26
4487                27,27,27,27,27,27,27,27,                                        &
4488                ! band 27
4489                28,28,28,28,28,28,                                              &
4490                ! band 28
4491                29,29,29,29,29,29,29,29,29,29,29,29 /)
4492                ! band 29
4493 !
4494 ! Use this set for full 224 quadrature point (g-point) model
4495 ! ------- Data statements -------
4496 !      ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
4497 !      ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
4498 !      ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 16
4499 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 17
4500 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 18
4501 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 19
4502 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 20
4503 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 21
4504 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 22
4505 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 23
4506 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 24
4507 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 25
4508 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 26
4509 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 27
4510 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 28
4511 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /)    ! band 29
4512 !      ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 16
4513 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 17
4514 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 18
4515 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 19
4516 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 20
4517 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 21
4518 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 22
4519 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 23
4520 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 24
4521 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 25
4522 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 26
4523 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 27
4524 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 28
4525 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /)           ! band 29
4526 !      ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, &  ! band 16
4527 !                  17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, &  ! band 17
4528 !                  18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, &  ! band 18
4529 !                  19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, &  ! band 19
4530 !                  20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, &  ! band 20
4531 !                  21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, &  ! band 21
4532 !                  22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, &  ! band 22
4533 !                  23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, &  ! band 23
4534 !                  24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, &  ! band 24
4535 !                  25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, &  ! band 25
4536 !                  26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, &  ! band 26
4537 !                  27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, &  ! band 27
4538 !                  28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, &  ! band 28
4539 !                  29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /)  ! band 29
4540    wt(:) =  (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb,              &
4541                0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb,              &
4542                0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb,              &
4543                0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb,              &
4544                0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb,              &
4545                0.0000750000_rb /)
4546 !
4547    end subroutine swcmbdat
4548 !-------------------------------------------------------------------------------
4549 !
4550 !
4551 !-------------------------------------------------------------------------------
4552    subroutine swaerpr
4553 !-------------------------------------------------------------------------------
4554 !
4555 ! abstract:
4556 !   Define spectral aerosol properties for six ECMWF aerosol types
4557 !   as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
4558 !
4559 !  history log :
4560 !    2003-02 JJMorcrette, ECMWF  Defined for rrtmg_sw 14 spectral bands
4561 !    2006-07 MJIacono, AER       Reformatted for consistency with rrtmg_lw
4562 !
4563 !-------------------------------------------------------------------------------
4564    use rrsw_aer_k, only : rsrtaua, rsrpiza, rsrasya
4565 !
4566    save
4567 !
4568    rsrtaua( 1, :) = (/                                                         &
4569      0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4570    rsrtaua( 2, :) = (/                                                         &
4571      0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4572    rsrtaua( 3, :) = (/                                                         &
4573      0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4574    rsrtaua( 4, :) = (/                                                         &
4575      0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4576    rsrtaua( 5, :) = (/                                                         &
4577      0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4578    rsrtaua( 6, :) = (/                                                         &
4579      0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4580    rsrtaua( 7, :) = (/                                                         &
4581      0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
4582    rsrtaua( 8, :) = (/                                                         &
4583      0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
4584    rsrtaua( 9, :) = (/                                                         &
4585      0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
4586    rsrtaua(10, :) = (/                                                         &
4587      1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4588    rsrtaua(11, :) = (/                                                         &
4589      1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4590    rsrtaua(12, :) = (/                                                         &
4591      1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4592    rsrtaua(13, :) = (/                                                         &
4593      1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
4594    rsrtaua(14, :) = (/                                                         &
4595      0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
4596 !
4597    rsrpiza( 1, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb,      &
4598      .8748231_rb, .2355667_rb/)
4599    rsrpiza( 2, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb,      &
4600      .8748231_rb, .2355667_rb/)
4601    rsrpiza( 3, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb,      &
4602      .9467578_rb, .9955938_rb/)
4603    rsrpiza( 4, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb,      &
4604      .9467578_rb, .9955938_rb/)
4605    rsrpiza( 5, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb,      &
4606      .9467578_rb, .9955938_rb/)
4607    rsrpiza( 6, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb,      &
4608      .9467578_rb, .9955938_rb/)
4609    rsrpiza( 7, :) = (/.8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb,      &
4610      .9467578_rb, .9955938_rb/)
4611    rsrpiza( 8, :) = (/.8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb,      &
4612      .9532763_rb, .9999999_rb/)
4613    rsrpiza( 9, :) = (/.8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb,      &
4614      .9532763_rb, .9999999_rb/)
4615    rsrpiza(10, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb,      &
4616      .9401905_rb, .9999999_rb/)
4617    rsrpiza(11, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb,      &
4618      .9401905_rb, .9999999_rb/)
4619    rsrpiza(12, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb,      &
4620      .9401905_rb, .9999999_rb/)
4621    rsrpiza(13, :) = (/.9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb,      &
4622      .9401905_rb, .9999999_rb/)
4623    rsrpiza(14, :) = (/.5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb,      &
4624      .8748231_rb, .2355667_rb/)
4625 !
4626    rsrasya( 1, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb,      &
4627      .4629866_rb, .1907639_rb/)
4628    rsrasya( 2, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb,      &
4629      .4629866_rb, .1907639_rb/)
4630    rsrasya( 3, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb,      &
4631      .6105750_rb, .4760794_rb/)
4632    rsrasya( 4, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb,      &
4633      .6105750_rb, .4760794_rb/)
4634    rsrasya( 5, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb,      &
4635      .6105750_rb, .4760794_rb/)
4636    rsrasya( 6, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb,      &
4637      .6105750_rb, .4760794_rb/)
4638    rsrasya( 7, :) = (/0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb,      &
4639      .6105750_rb, .4760794_rb/)
4640    rsrasya( 8, :) = (/0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb,      &
4641      .6735182_rb, .6519706_rb/)
4642    rsrasya( 9, :) = (/0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb,      &
4643      .6735182_rb, .6519706_rb/)
4644    rsrasya(10, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb,      &
4645      .7008249_rb, .7270548_rb/)
4646    rsrasya(11, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb,      &
4647      .7008249_rb, .7270548_rb/)
4648    rsrasya(12, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb,      &
4649      .7008249_rb, .7270548_rb/)
4650    rsrasya(13, :) = (/0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb,      &
4651      .7008249_rb, .7270548_rb/)
4652    rsrasya(14, :) = (/0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb,      &
4653      .4629866_rb, .1907639_rb/)
4654 !
4655    end subroutine swaerpr
4656 !-------------------------------------------------------------------------------
4657 !
4658 !
4659 !-------------------------------------------------------------------------------
4660    subroutine cmbgb16s
4661 !-------------------------------------------------------------------------------
4662 !
4663 !  abstract :
4664 !    The subroutines CMBGB16->CMBGB29 input the absorption coefficient
4665 !    data for each band, which are defined for 16 g-points and 14 spectral
4666 !    bands. The data are combined with appropriate weighting following the
4667 !    g-point mapping arrays specified in RRTMG_SW_INIT.  Solar source
4668 !    function data in array SFLUXREF are combined without weighting.  All
4669 !    g-point reduced data are put into new arrays for use in RRTMG_SW.
4670 !
4671 !    band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
4672 !
4673 !  history log :
4674 !    1998-07  MJIacono   Original version
4675 !    2002-11  MJIacono   Revision for RRTM_SW
4676 !    2003-12  MJIacono   Revision for RRTMG_SW
4677 !    2006-07  MJIacono   Revision for F90 reformatting
4678 !-----------------------------------------------------------------------
4679 !
4680    use rrsw_kg16_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
4681                             absa, ka, absb, kb, selfref, forref, sfluxref
4682 !
4683 ! ------- Local -------
4684 !
4685    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4686    real(kind=rb) :: sumk, sumf
4687 !-------------------------------------------------------------------------------
4688    do jn = 1,9
4689      do jt = 1,5
4690        do jp = 1,13
4691          iprsm = 0
4692          do igc = 1,ngc(1)
4693            sumk = 0.
4694            do ipr = 1,ngn(igc)
4695              iprsm = iprsm + 1
4696              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
4697            enddo
4698            ka(jn,jt,jp,igc) = sumk
4699          enddo
4700        enddo
4701      enddo
4702    enddo
4703 !
4704    do jt = 1,5
4705      do jp = 13,59
4706        iprsm = 0
4707        do igc = 1,ngc(1)
4708          sumk = 0.
4709          do ipr = 1,ngn(igc)
4710            iprsm = iprsm + 1
4711            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
4712          enddo
4713          kb(jt,jp,igc) = sumk
4714        enddo
4715      enddo
4716    enddo
4717 !
4718    do jt = 1,10
4719      iprsm = 0
4720      do igc = 1,ngc(1)
4721        sumk = 0.
4722        do ipr = 1,ngn(igc)
4723          iprsm = iprsm + 1
4724          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
4725        enddo
4726        selfref(jt,igc) = sumk
4727      enddo
4728    enddo
4729 !
4730    do jt = 1,3
4731      iprsm = 0
4732      do igc = 1,ngc(1)
4733        sumk = 0.
4734        do ipr = 1,ngn(igc)
4735          iprsm = iprsm + 1
4736          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
4737        enddo
4738        forref(jt,igc) = sumk
4739      enddo
4740    enddo
4741 !
4742    iprsm = 0
4743    do igc = 1,ngc(1)
4744      sumf = 0.
4745      do ipr = 1,ngn(igc)
4746        iprsm = iprsm + 1
4747        sumf = sumf + sfluxrefo(iprsm)
4748      enddo
4749      sfluxref(igc) = sumf
4750    enddo
4751 !
4752    end subroutine cmbgb16s
4753 !-------------------------------------------------------------------------------
4754 !
4755 !
4756 !-------------------------------------------------------------------------------
4757    subroutine cmbgb17
4758 !-------------------------------------------------------------------------------
4759 !     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
4760 !-------------------------------------------------------------------------------
4761 !
4762    use rrsw_kg17_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
4763                             absa, ka, absb, kb, selfref, forref, sfluxref
4764 !
4765 ! ------- Local -------
4766 !
4767    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4768    real(kind=rb) :: sumk, sumf
4769 !-------------------------------------------------------------------------------
4770    do jn = 1,9
4771      do jt = 1,5
4772        do jp = 1,13
4773          iprsm = 0
4774          do igc = 1,ngc(2)
4775            sumk = 0.
4776            do ipr = 1,ngn(ngs(1)+igc)
4777              iprsm = iprsm + 1
4778              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
4779            enddo
4780            ka(jn,jt,jp,igc) = sumk
4781          enddo
4782        enddo
4783      enddo
4784    enddo
4785 !
4786    do jn = 1,5
4787      do jt = 1,5
4788        do jp = 13,59
4789          iprsm = 0
4790          do igc = 1,ngc(2)
4791            sumk = 0.
4792            do ipr = 1,ngn(ngs(1)+igc)
4793              iprsm = iprsm + 1
4794              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
4795            enddo
4796            kb(jn,jt,jp,igc) = sumk
4797          enddo
4798        enddo
4799      enddo
4800    enddo
4801 !
4802    do jt = 1,10
4803      iprsm = 0
4804      do igc = 1,ngc(2)
4805        sumk = 0.
4806        do ipr = 1,ngn(ngs(1)+igc)
4807          iprsm = iprsm + 1
4808          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
4809        enddo
4810        selfref(jt,igc) = sumk
4811      enddo
4812    enddo
4813 !
4814    do jt = 1,4
4815      iprsm = 0
4816      do igc = 1,ngc(2)
4817        sumk = 0.
4818        do ipr = 1,ngn(ngs(1)+igc)
4819          iprsm = iprsm + 1
4820          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
4821        enddo
4822        forref(jt,igc) = sumk
4823      enddo
4824    enddo
4825 !
4826    do jp = 1,5
4827      iprsm = 0
4828      do igc = 1,ngc(2)
4829        sumf = 0.
4830        do ipr = 1,ngn(ngs(1)+igc)
4831          iprsm = iprsm + 1
4832          sumf = sumf + sfluxrefo(iprsm,jp)
4833        enddo
4834        sfluxref(igc,jp) = sumf
4835      enddo
4836    enddo
4837 !
4838    end subroutine cmbgb17
4839 !-------------------------------------------------------------------------------
4840 !
4841 !
4842 !-------------------------------------------------------------------------------
4843    subroutine cmbgb18
4844 !-------------------------------------------------------------------------------
4845 !     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
4846 !-------------------------------------------------------------------------------
4847 !
4848    use rrsw_kg18_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
4849                             absa, ka, absb, kb, selfref, forref, sfluxref
4850 !
4851 ! ------- Local -------
4852 !
4853    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4854    real(kind=rb) :: sumk, sumf
4855 !-------------------------------------------------------------------------------
4856    do jn = 1,9
4857      do jt = 1,5
4858        do jp = 1,13
4859          iprsm = 0
4860          do igc = 1,ngc(3)
4861            sumk = 0.
4862            do ipr = 1,ngn(ngs(2)+igc)
4863              iprsm = iprsm + 1
4864              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
4865            enddo
4866            ka(jn,jt,jp,igc) = sumk
4867          enddo
4868        enddo
4869      enddo
4870    enddo
4871 !
4872    do jt = 1,5
4873      do jp = 13,59
4874        iprsm = 0
4875        do igc = 1,ngc(3)
4876          sumk = 0.
4877          do ipr = 1,ngn(ngs(2)+igc)
4878            iprsm = iprsm + 1
4879            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
4880          enddo
4881          kb(jt,jp,igc) = sumk
4882        enddo
4883      enddo
4884    enddo
4885 !
4886    do jt = 1,10
4887      iprsm = 0
4888      do igc = 1,ngc(3)
4889        sumk = 0.
4890        do ipr = 1,ngn(ngs(2)+igc)
4891          iprsm = iprsm + 1
4892          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
4893        enddo
4894        selfref(jt,igc) = sumk
4895      enddo
4896    enddo
4897 !
4898    do jt = 1,3
4899      iprsm = 0
4900      do igc = 1,ngc(3)
4901        sumk = 0.
4902        do ipr = 1,ngn(ngs(2)+igc)
4903          iprsm = iprsm + 1
4904          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
4905        enddo
4906        forref(jt,igc) = sumk
4907      enddo
4908    enddo
4909 !
4910    do jp = 1,9
4911      iprsm = 0
4912      do igc = 1,ngc(3)
4913        sumf = 0.
4914        do ipr = 1,ngn(ngs(2)+igc)
4915          iprsm = iprsm + 1
4916          sumf = sumf + sfluxrefo(iprsm,jp)
4917        enddo
4918        sfluxref(igc,jp) = sumf
4919      enddo
4920    enddo
4921 !
4922    end subroutine cmbgb18
4923 !-------------------------------------------------------------------------------
4924 !
4925 !
4926 !-------------------------------------------------------------------------------
4927    subroutine cmbgb19
4928 !-------------------------------------------------------------------------------
4929 !     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
4930 !-------------------------------------------------------------------------------
4931 !
4932    use rrsw_kg19_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
4933                             absa, ka, absb, kb, selfref, forref, sfluxref
4934 !
4935 ! ------- Local -------
4936 !
4937    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
4938    real(kind=rb) :: sumk, sumf
4939 !-------------------------------------------------------------------------------
4940    do jn = 1,9
4941      do jt = 1,5
4942        do jp = 1,13
4943          iprsm = 0
4944          do igc = 1,ngc(4)
4945            sumk = 0.
4946            do ipr = 1,ngn(ngs(3)+igc)
4947              iprsm = iprsm + 1
4948              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
4949            enddo
4950            ka(jn,jt,jp,igc) = sumk
4951          enddo
4952        enddo
4953      enddo
4954    enddo
4955 !
4956    do jt = 1,5
4957      do jp = 13,59
4958        iprsm = 0
4959        do igc = 1,ngc(4)
4960          sumk = 0.
4961          do ipr = 1,ngn(ngs(3)+igc)
4962            iprsm = iprsm + 1
4963            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
4964          enddo
4965          kb(jt,jp,igc) = sumk
4966        enddo
4967      enddo
4968    enddo
4969 !
4970    do jt = 1,10
4971      iprsm = 0
4972      do igc = 1,ngc(4)
4973        sumk = 0.
4974        do ipr = 1,ngn(ngs(3)+igc)
4975          iprsm = iprsm + 1
4976          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
4977        enddo
4978        selfref(jt,igc) = sumk
4979      enddo
4980    enddo
4981 !
4982    do jt = 1,3
4983      iprsm = 0
4984      do igc = 1,ngc(4)
4985        sumk = 0.
4986        do ipr = 1,ngn(ngs(3)+igc)
4987          iprsm = iprsm + 1
4988          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
4989        enddo
4990        forref(jt,igc) = sumk
4991      enddo
4992    enddo
4993 !
4994    do jp = 1,9
4995      iprsm = 0
4996      do igc = 1,ngc(4)
4997        sumf = 0.
4998        do ipr = 1,ngn(ngs(3)+igc)
4999          iprsm = iprsm + 1
5000          sumf = sumf + sfluxrefo(iprsm,jp)
5001        enddo
5002        sfluxref(igc,jp) = sumf
5003      enddo
5004    enddo
5005 !
5006    end subroutine cmbgb19
5007 !-------------------------------------------------------------------------------
5008 !
5009 !
5010 !-------------------------------------------------------------------------------
5011    subroutine cmbgb20
5012 !-------------------------------------------------------------------------------
5013 !     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
5014 !-------------------------------------------------------------------------------
5015 !
5016    use rrsw_kg20_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o,    &
5017                          absa, ka, absb, kb, selfref, forref, sfluxref, absch4
5018 !
5019 ! ------- Local -------
5020 !
5021    integer(kind=im) :: jt, jp, igc, ipr, iprsm
5022    real(kind=rb) :: sumk, sumf1, sumf2
5023 !-------------------------------------------------------------------------------
5024    do jt = 1,5
5025      do jp = 1,13
5026        iprsm = 0
5027        do igc = 1,ngc(5)
5028          sumk = 0.
5029          do ipr = 1,ngn(ngs(4)+igc)
5030            iprsm = iprsm + 1
5031            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
5032          enddo
5033          ka(jt,jp,igc) = sumk
5034        enddo
5035      enddo
5036      do jp = 13,59
5037        iprsm = 0
5038        do igc = 1,ngc(5)
5039          sumk = 0.
5040          do ipr = 1,ngn(ngs(4)+igc)
5041            iprsm = iprsm + 1
5042            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
5043          enddo
5044          kb(jt,jp,igc) = sumk
5045        enddo
5046      enddo
5047    enddo
5048 !
5049    do jt = 1,10
5050      iprsm = 0
5051      do igc = 1,ngc(5)
5052        sumk = 0.
5053        do ipr = 1,ngn(ngs(4)+igc)
5054          iprsm = iprsm + 1
5055          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
5056        enddo
5057        selfref(jt,igc) = sumk
5058      enddo
5059    enddo
5060 !
5061    do jt = 1,4
5062      iprsm = 0
5063      do igc = 1,ngc(5)
5064        sumk = 0.
5065        do ipr = 1,ngn(ngs(4)+igc)
5066          iprsm = iprsm + 1
5067          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
5068        enddo
5069        forref(jt,igc) = sumk
5070      enddo
5071    enddo
5072 !
5073    iprsm = 0
5074    do igc = 1,ngc(5)
5075      sumf1 = 0.
5076      sumf2 = 0.
5077      do ipr = 1,ngn(ngs(4)+igc)
5078        iprsm = iprsm + 1
5079        sumf1 = sumf1 + sfluxrefo(iprsm)
5080        sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
5081      enddo
5082      sfluxref(igc) = sumf1
5083      absch4(igc) = sumf2
5084    enddo
5085 !
5086    end subroutine cmbgb20
5087 !-------------------------------------------------------------------------------
5088 !
5089 !
5090 !-------------------------------------------------------------------------------
5091    subroutine cmbgb21
5092 !-------------------------------------------------------------------------------
5093 !     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
5094 !-------------------------------------------------------------------------------
5095 !
5096    use rrsw_kg21_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
5097                             absa, ka, absb, kb, selfref, forref, sfluxref
5098 !
5099 ! ------- Local -------
5100 !
5101    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5102    real(kind=rb) :: sumk, sumf
5103 !-------------------------------------------------------------------------------
5104    do jn = 1,9
5105      do jt = 1,5
5106        do jp = 1,13
5107          iprsm = 0
5108          do igc = 1,ngc(6)
5109            sumk = 0.
5110            do ipr = 1,ngn(ngs(5)+igc)
5111              iprsm = iprsm + 1
5112              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5113            enddo
5114            ka(jn,jt,jp,igc) = sumk
5115          enddo
5116        enddo
5117      enddo
5118    enddo
5119 !
5120    do jn = 1,5
5121      do jt = 1,5
5122        do jp = 13,59
5123          iprsm = 0
5124          do igc = 1,ngc(6)
5125            sumk = 0.
5126            do ipr = 1,ngn(ngs(5)+igc)
5127              iprsm = iprsm + 1
5128              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
5129            enddo
5130            kb(jn,jt,jp,igc) = sumk
5131          enddo
5132        enddo
5133      enddo
5134    enddo
5135 !
5136    do jt = 1,10
5137      iprsm = 0
5138      do igc = 1,ngc(6)
5139        sumk = 0.
5140        do ipr = 1,ngn(ngs(5)+igc)
5141          iprsm = iprsm + 1
5142          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
5143        enddo
5144        selfref(jt,igc) = sumk
5145      enddo
5146    enddo
5147 !
5148    do jt = 1,4
5149      iprsm = 0
5150      do igc = 1,ngc(6)
5151        sumk = 0.
5152        do ipr = 1,ngn(ngs(5)+igc)
5153          iprsm = iprsm + 1
5154          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
5155        enddo
5156        forref(jt,igc) = sumk
5157      enddo
5158    enddo
5159 !
5160    do jp = 1,9
5161      iprsm = 0
5162      do igc = 1,ngc(6)
5163        sumf = 0.
5164        do ipr = 1,ngn(ngs(5)+igc)
5165          iprsm = iprsm + 1
5166          sumf = sumf + sfluxrefo(iprsm,jp)
5167        enddo
5168        sfluxref(igc,jp) = sumf
5169      enddo
5170    enddo
5171 !
5172    end subroutine cmbgb21
5173 !-------------------------------------------------------------------------------
5174 !
5175 !
5176 !-------------------------------------------------------------------------------
5177    subroutine cmbgb22
5178 !-------------------------------------------------------------------------------
5179 !     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
5180 !-------------------------------------------------------------------------------
5181 !
5182    use rrsw_kg22_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
5183                             absa, ka, absb, kb, selfref, forref, sfluxref
5184 !
5185 ! ------- Local -------
5186 !
5187    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5188    real(kind=rb) :: sumk, sumf
5189 !-------------------------------------------------------------------------------
5190    do jn = 1,9
5191      do jt = 1,5
5192        do jp = 1,13
5193          iprsm = 0
5194          do igc = 1,ngc(7)
5195            sumk = 0.
5196            do ipr = 1,ngn(ngs(6)+igc)
5197              iprsm = iprsm + 1
5198              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
5199            enddo
5200            ka(jn,jt,jp,igc) = sumk
5201          enddo
5202        enddo
5203      enddo
5204    enddo
5205 !
5206    do jt = 1,5
5207      do jp = 13,59
5208        iprsm = 0
5209        do igc = 1,ngc(7)
5210          sumk = 0.
5211          do ipr = 1,ngn(ngs(6)+igc)
5212            iprsm = iprsm + 1
5213            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
5214          enddo
5215          kb(jt,jp,igc) = sumk
5216        enddo
5217      enddo
5218    enddo
5219 !
5220    do jt = 1,10
5221      iprsm = 0
5222      do igc = 1,ngc(7)
5223        sumk = 0.
5224        do ipr = 1,ngn(ngs(6)+igc)
5225          iprsm = iprsm + 1
5226          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
5227        enddo
5228        selfref(jt,igc) = sumk
5229      enddo
5230    enddo
5231 !
5232    do jt = 1,3
5233      iprsm = 0
5234      do igc = 1,ngc(7)
5235        sumk = 0.
5236        do ipr = 1,ngn(ngs(6)+igc)
5237          iprsm = iprsm + 1
5238          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
5239        enddo
5240        forref(jt,igc) = sumk
5241      enddo
5242    enddo
5243 !
5244    do jp = 1,9
5245      iprsm = 0
5246      do igc = 1,ngc(7)
5247        sumf = 0.
5248        do ipr = 1,ngn(ngs(6)+igc)
5249          iprsm = iprsm + 1
5250          sumf = sumf + sfluxrefo(iprsm,jp)
5251        enddo
5252        sfluxref(igc,jp) = sumf
5253      enddo
5254    enddo
5255 !
5256    end subroutine cmbgb22
5257 !-------------------------------------------------------------------------------
5258 !
5259 !
5260 !-------------------------------------------------------------------------------
5261    subroutine cmbgb23
5262 !-------------------------------------------------------------------------------
5263 !     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
5264 !-------------------------------------------------------------------------------
5265 !
5266    use rrsw_kg23_k, only : kao, selfrefo, forrefo, sfluxrefo, raylo,           &
5267                             absa, ka, selfref, forref, sfluxref, rayl
5268 !
5269 ! ------- Local -------
5270 !
5271    integer(kind=im) :: jt, jp, igc, ipr, iprsm
5272    real(kind=rb) :: sumk, sumf1, sumf2
5273 !-------------------------------------------------------------------------------
5274    do jt = 1,5
5275      do jp = 1,13
5276        iprsm = 0
5277        do igc = 1,ngc(8)
5278          sumk = 0.
5279          do ipr = 1,ngn(ngs(7)+igc)
5280            iprsm = iprsm + 1
5281            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
5282          enddo
5283          ka(jt,jp,igc) = sumk
5284        enddo
5285      enddo
5286    enddo
5287 !
5288    do jt = 1,10
5289      iprsm = 0
5290      do igc = 1,ngc(8)
5291        sumk = 0.
5292        do ipr = 1,ngn(ngs(7)+igc)
5293          iprsm = iprsm + 1
5294          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
5295        enddo
5296        selfref(jt,igc) = sumk
5297      enddo
5298    enddo
5299 !
5300    do jt = 1,3
5301      iprsm = 0
5302      do igc = 1,ngc(8)
5303        sumk = 0.
5304        do ipr = 1,ngn(ngs(7)+igc)
5305          iprsm = iprsm + 1
5306          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
5307        enddo
5308        forref(jt,igc) = sumk
5309      enddo
5310    enddo
5311 !
5312    iprsm = 0
5313    do igc = 1,ngc(8)
5314      sumf1 = 0.
5315      sumf2 = 0.
5316      do ipr = 1,ngn(ngs(7)+igc)
5317        iprsm = iprsm + 1
5318        sumf1 = sumf1 + sfluxrefo(iprsm)
5319        sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
5320      enddo
5321      sfluxref(igc) = sumf1
5322      rayl(igc) = sumf2
5323    enddo
5324 !
5325    end subroutine cmbgb23
5326 !-------------------------------------------------------------------------------
5327 !
5328 !
5329 !-------------------------------------------------------------------------------
5330    subroutine cmbgb24
5331 !-------------------------------------------------------------------------------
5332 !     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
5333 !-------------------------------------------------------------------------------
5334 !
5335    use rrsw_kg24_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
5336                             abso3ao, abso3bo, raylao, raylbo,                  &
5337                             absa, ka, absb, kb, selfref, forref, sfluxref,     &
5338                             abso3a, abso3b, rayla, raylb
5339 !
5340 ! ------- Local -------
5341 !
5342    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5343    real(kind=rb) :: sumk, sumf1, sumf2, sumf3
5344 !-------------------------------------------------------------------------------
5345    do jn = 1,9
5346      do jt = 1,5
5347        do jp = 1,13
5348          iprsm = 0
5349          do igc = 1,ngc(9)
5350            sumk = 0.
5351            do ipr = 1,ngn(ngs(8)+igc)
5352              iprsm = iprsm + 1
5353              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
5354            enddo
5355            ka(jn,jt,jp,igc) = sumk
5356          enddo
5357        enddo
5358      enddo
5359    enddo
5360 !
5361    do jt = 1,5
5362      do jp = 13,59
5363        iprsm = 0
5364        do igc = 1,ngc(9)
5365          sumk = 0.
5366          do ipr = 1,ngn(ngs(8)+igc)
5367            iprsm = iprsm + 1
5368            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
5369          enddo
5370          kb(jt,jp,igc) = sumk
5371        enddo
5372      enddo
5373    enddo
5374 !
5375    do jt = 1,10
5376      iprsm = 0
5377      do igc = 1,ngc(9)
5378        sumk = 0.
5379        do ipr = 1,ngn(ngs(8)+igc)
5380          iprsm = iprsm + 1
5381          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
5382        enddo
5383        selfref(jt,igc) = sumk
5384      enddo
5385    enddo
5386 !
5387    do jt = 1,3
5388      iprsm = 0
5389      do igc = 1,ngc(9)
5390        sumk = 0.
5391        do ipr = 1,ngn(ngs(8)+igc)
5392          iprsm = iprsm + 1
5393          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
5394        enddo
5395        forref(jt,igc) = sumk
5396      enddo
5397    enddo
5398 !
5399    iprsm = 0
5400    do igc = 1,ngc(9)
5401      sumf1 = 0.
5402      sumf2 = 0.
5403      sumf3 = 0.
5404      do ipr = 1,ngn(ngs(8)+igc)
5405        iprsm = iprsm + 1
5406        sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
5407        sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
5408        sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
5409      enddo
5410      raylb(igc) = sumf1
5411      abso3a(igc) = sumf2
5412      abso3b(igc) = sumf3
5413    enddo
5414 !
5415    do jp = 1,9
5416      iprsm = 0
5417      do igc = 1,ngc(9)
5418        sumf1 = 0.
5419        sumf2 = 0.
5420        do ipr = 1,ngn(ngs(8)+igc)
5421          iprsm = iprsm + 1
5422          sumf1 = sumf1 + sfluxrefo(iprsm,jp)
5423          sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
5424        enddo
5425        sfluxref(igc,jp) = sumf1
5426        rayla(igc,jp) = sumf2
5427      enddo
5428    enddo
5429 !
5430    end subroutine cmbgb24
5431 !-------------------------------------------------------------------------------
5432 !
5433 !
5434 !-------------------------------------------------------------------------------
5435    subroutine cmbgb25
5436 !-------------------------------------------------------------------------------
5437 !     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
5438 !-------------------------------------------------------------------------------
5439 !
5440    use rrsw_kg25_k, only : kao, sfluxrefo,                                     &
5441                             abso3ao, abso3bo, raylo,                           &
5442                             absa, ka, sfluxref,                                &
5443                             abso3a, abso3b, rayl
5444 !
5445 ! ------- Local -------
5446 !
5447    integer(kind=im) :: jt, jp, igc, ipr, iprsm
5448    real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4
5449 !-------------------------------------------------------------------------------
5450    do jt = 1,5
5451      do jp = 1,13
5452        iprsm = 0
5453        do igc = 1,ngc(10)
5454          sumk = 0.
5455          do ipr = 1,ngn(ngs(9)+igc)
5456            iprsm = iprsm + 1
5457            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
5458          enddo
5459          ka(jt,jp,igc) = sumk
5460        enddo
5461      enddo
5462    enddo
5463 !
5464    iprsm = 0
5465    do igc = 1,ngc(10)
5466      sumf1 = 0.
5467      sumf2 = 0.
5468      sumf3 = 0.
5469      sumf4 = 0.
5470      do ipr = 1,ngn(ngs(9)+igc)
5471        iprsm = iprsm + 1
5472        sumf1 = sumf1 + sfluxrefo(iprsm)
5473        sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
5474        sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
5475        sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
5476      enddo
5477      sfluxref(igc) = sumf1
5478      abso3a(igc) = sumf2
5479      abso3b(igc) = sumf3
5480      rayl(igc) = sumf4
5481    enddo
5482 !
5483    end subroutine cmbgb25
5484 !-------------------------------------------------------------------------------
5485 !
5486 !
5487 !-------------------------------------------------------------------------------
5488    subroutine cmbgb26
5489 !-------------------------------------------------------------------------------
5490 !     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
5491 !-------------------------------------------------------------------------------
5492 !
5493    use rrsw_kg26_k, only : sfluxrefo, raylo, sfluxref, rayl
5494 !
5495 ! ------- Local -------
5496 !
5497    integer(kind=im) :: igc, ipr, iprsm
5498    real(kind=rb) :: sumf1, sumf2
5499 !-------------------------------------------------------------------------------
5500    iprsm = 0
5501    do igc = 1,ngc(11)
5502      sumf1 = 0.
5503      sumf2 = 0.
5504      do ipr = 1,ngn(ngs(10)+igc)
5505        iprsm = iprsm + 1
5506        sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
5507        sumf2 = sumf2 + sfluxrefo(iprsm)
5508      enddo
5509      rayl(igc) = sumf1
5510      sfluxref(igc) = sumf2
5511    enddo
5512 !
5513    end subroutine cmbgb26
5514 !-------------------------------------------------------------------------------
5515 !
5516 !
5517 !-------------------------------------------------------------------------------
5518    subroutine cmbgb27
5519 !-------------------------------------------------------------------------------
5520 !     band 27:  29000-38000 cm-1 (low - o3; high - o3)
5521 !-------------------------------------------------------------------------------
5522 !
5523    use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo,                         &
5524                             absa, ka, absb, kb, sfluxref, rayl
5525 !
5526 ! ------- Local -------
5527 !
5528    integer(kind=im) :: jt, jp, igc, ipr, iprsm
5529    real(kind=rb) :: sumk, sumf1, sumf2
5530 !-------------------------------------------------------------------------------
5531    do jt = 1,5
5532      do jp = 1,13
5533        iprsm = 0
5534        do igc = 1,ngc(12)
5535          sumk = 0.
5536          do ipr = 1,ngn(ngs(11)+igc)
5537            iprsm = iprsm + 1
5538            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
5539          enddo
5540          ka(jt,jp,igc) = sumk
5541        enddo
5542      enddo
5543      do jp = 13,59
5544        iprsm = 0
5545        do igc = 1,ngc(12)
5546          sumk = 0.
5547          do ipr = 1,ngn(ngs(11)+igc)
5548            iprsm = iprsm + 1
5549            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
5550          enddo
5551          kb(jt,jp,igc) = sumk
5552        enddo
5553      enddo
5554    enddo
5555 !
5556    iprsm = 0
5557    do igc = 1,ngc(12)
5558      sumf1 = 0.
5559      sumf2 = 0.
5560      do ipr = 1,ngn(ngs(11)+igc)
5561        iprsm = iprsm + 1
5562        sumf1 = sumf1 + sfluxrefo(iprsm)
5563        sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
5564      enddo
5565      sfluxref(igc) = sumf1
5566      rayl(igc) = sumf2
5567    enddo
5568 !
5569    end subroutine cmbgb27
5570 !-------------------------------------------------------------------------------
5571 !
5572 !
5573 !-------------------------------------------------------------------------------
5574    subroutine cmbgb28
5575 !-------------------------------------------------------------------------------
5576 !     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
5577 !-------------------------------------------------------------------------------
5578 !
5579    use rrsw_kg28_k, only : kao, kbo, sfluxrefo,                                &
5580                             absa, ka, absb, kb, sfluxref
5581 !
5582 ! ------- Local -------
5583 !
5584    integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
5585    real(kind=rb) :: sumk, sumf
5586 !-------------------------------------------------------------------------------
5587    do jn = 1,9
5588      do jt = 1,5
5589        do jp = 1,13
5590          iprsm = 0
5591          do igc = 1,ngc(13)
5592            sumk = 0.
5593            do ipr = 1,ngn(ngs(12)+igc)
5594              iprsm = iprsm + 1
5595              sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
5596            enddo
5597            ka(jn,jt,jp,igc) = sumk
5598          enddo
5599        enddo
5600      enddo
5601    enddo
5602 !
5603    do jn = 1,5
5604      do jt = 1,5
5605        do jp = 13,59
5606          iprsm = 0
5607          do igc = 1,ngc(13)
5608            sumk = 0.
5609            do ipr = 1,ngn(ngs(12)+igc)
5610              iprsm = iprsm + 1
5611              sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
5612            enddo
5613            kb(jn,jt,jp,igc) = sumk
5614          enddo
5615        enddo
5616      enddo
5617    enddo
5618 !
5619    do jp = 1,5
5620      iprsm = 0
5621      do igc = 1,ngc(13)
5622        sumf = 0.
5623        do ipr = 1,ngn(ngs(12)+igc)
5624          iprsm = iprsm + 1
5625          sumf = sumf + sfluxrefo(iprsm,jp)
5626        enddo
5627        sfluxref(igc,jp) = sumf
5628      enddo
5629    enddo
5630 !
5631    end subroutine cmbgb28
5632 !-------------------------------------------------------------------------------
5633 !
5634 !
5635 !-------------------------------------------------------------------------------
5636    subroutine cmbgb29
5637 !-------------------------------------------------------------------------------
5638 !     band 29:  820-2600 cm-1 (low - h2o; high - co2)
5639 !-------------------------------------------------------------------------------
5640 !
5641    use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
5642                             absh2oo, absco2o,                                  &
5643                             absa, ka, absb, kb, selfref, forref, sfluxref,     &
5644                             absh2o, absco2
5645 !
5646 ! ------- Local -------
5647 !
5648    integer(kind=im) :: jt, jp, igc, ipr, iprsm
5649    real(kind=rb) :: sumk, sumf1, sumf2, sumf3
5650 !-------------------------------------------------------------------------------
5651    do jt = 1,5
5652      do jp = 1,13
5653        iprsm = 0
5654        do igc = 1,ngc(14)
5655          sumk = 0.
5656          do ipr = 1,ngn(ngs(13)+igc)
5657            iprsm = iprsm + 1
5658            sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
5659          enddo
5660          ka(jt,jp,igc) = sumk
5661        enddo
5662      enddo
5663      do jp = 13,59
5664        iprsm = 0
5665        do igc = 1,ngc(14)
5666          sumk = 0.
5667          do ipr = 1,ngn(ngs(13)+igc)
5668            iprsm = iprsm + 1
5669            sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
5670          enddo
5671          kb(jt,jp,igc) = sumk
5672        enddo
5673      enddo
5674    enddo
5675 !
5676    do jt = 1,10
5677      iprsm = 0
5678      do igc = 1,ngc(14)
5679        sumk = 0.
5680        do ipr = 1,ngn(ngs(13)+igc)
5681          iprsm = iprsm + 1
5682          sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
5683        enddo
5684        selfref(jt,igc) = sumk
5685      enddo
5686    enddo
5687 !
5688    do jt = 1,4
5689      iprsm = 0
5690      do igc = 1,ngc(14)
5691        sumk = 0.
5692        do ipr = 1,ngn(ngs(13)+igc)
5693          iprsm = iprsm + 1
5694          sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
5695        enddo
5696        forref(jt,igc) = sumk
5697      enddo
5698    enddo
5699 !
5700    iprsm = 0
5701    do igc = 1,ngc(14)
5702      sumf1 = 0.
5703      sumf2 = 0.
5704      sumf3 = 0.
5705      do ipr = 1,ngn(ngs(13)+igc)
5706        iprsm = iprsm + 1
5707        sumf1 = sumf1 + sfluxrefo(iprsm)
5708        sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
5709        sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
5710      enddo
5711      sfluxref(igc) = sumf1
5712      absco2(igc) = sumf2
5713      absh2o(igc) = sumf3
5714    enddo
5715 !
5716    end subroutine cmbgb29
5717 !-------------------------------------------------------------------------------
5718 !
5719 !
5720 !-------------------------------------------------------------------------------
5721    subroutine swcldpr
5722 !-------------------------------------------------------------------------------
5723 !
5724 ! abstract:
5725 !   Define cloud extinction coefficient, single scattering albedo
5726 !   and asymmetry parameter data.
5727 !
5728 ! history log :
5729 !
5730 !-------------------------------------------------------------------------------
5731 !
5732 ! Explanation of the method for each value of INFLAG.  A value of
5733 !  0 for INFLAG do not distingish being liquid and ice clouds.
5734 !  INFLAG = 2 does distinguish between liquid and ice clouds, and
5735 !    requires further user input to specify the method to be used to
5736 !    compute the aborption due to each.
5737 !  INFLAG = 0:  For each cloudy layer, the cloud fraction, the cloud optical
5738 !    depth, the cloud single-scattering albedo, and the
5739 !    moments of the phase function (0:NSTREAM).  Note
5740 !    that these values are delta-m scaled within this
5741 !    subroutine.
5742 !  INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud
5743 !    water path (g/m2), and cloud ice fraction are input.
5744 !  ICEFLAG = 2:  The ice effective radius (microns) is input and the
5745 !    optical properties due to ice clouds are computed from
5746 !    the optical properties stored in the RT code, STREAMER v3.0
5747 !    (Reference: Key. J., Streamer User's Guide, Cooperative
5748 !    Institute for Meteorological Satellite Studies, 2001, 96 pp.).
5749 !    Valid range of values for re are between 5.0 and
5750 !    131.0 micron.
5751 !    This version uses Ebert and Curry, JGR, (1992) method for
5752 !    ice particles larger than 131.0 microns.
5753 !  ICEFLAG = 3:  The ice generalized effective size (dge) is input
5754 !    and the optical depths, single-scattering albedo,
5755 !    and phase function moments are calculated as in
5756 !    Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
5757 !    tables which were appropriately averaged for the
5758 !    bands in RRTM_SW.  Linear interpolation is used to
5759 !    get the coefficients from the stored tables.
5760 !    Valid range of values for dge are between 5.0 and
5761 !    140.0 micron.
5762 !    This version uses Ebert and Curry, JGR, (1992) method for
5763 !    ice particles larger than 140.0 microns.
5764 !  LIQFLAG = 1:  The water droplet effective radius (microns) is input
5765 !    and the optical depths due to water clouds are computed
5766 !    as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
5767 !    The values for absorption coefficients appropriate for
5768 !    the spectral bands in RRTM have been obtained for a
5769 !    range of effective radii by an averaging procedure
5770 !    based on the work of J. Pinto (private communication).
5771 !    Linear interpolation is used to get the absorption
5772 !    coefficients for the input effective radius.
5773 !
5774 !     ------------------------------------------------------------------
5775 !
5776    use rrsw_cld_k, only : extliq1, ssaliq1, asyliq1,                           &
5777                            extice2, ssaice2, asyice2,                          &
5778                            extice3, ssaice3, asyice3, fdlice3,                 &
5779                            abari, bbari, cbari, dbari, ebari, fbari
5780 !
5781    save
5782 ! Everything below is for INFLAG = 2.
5783 !
5784 ! Coefficients for Ebert and Curry method
5785 !
5786    abari(:) = (/                                                               &
5787          3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /)
5788    bbari(:) = (/                                                               &
5789          2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /)
5790    cbari(:) = (/                                                               &
5791          1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /)
5792    dbari(:) = (/                                                               &
5793          0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /)
5794    ebari(:) = (/                                                               &
5795          7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /)
5796    fbari(:) = (/                                                               &
5797          5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /)
5798 !
5799 ! Extinction coefficient
5800 !
5801    extliq1(:, 16) = (/                                                         &
5802          8.981463e-01_rb,6.317895e-01_rb,4.557508e-01_rb,3.481624e-01_rb,      &
5803          2.797950e-01_rb,2.342753e-01_rb,2.026934e-01_rb,1.800102e-01_rb,      &
5804          1.632408e-01_rb,1.505384e-01_rb,1.354524e-01_rb,1.246520e-01_rb,      &
5805          1.154342e-01_rb,1.074756e-01_rb,1.005353e-01_rb,9.442987e-02_rb,      &
5806          8.901760e-02_rb,8.418693e-02_rb,7.984904e-02_rb,7.593229e-02_rb,      &
5807          7.237827e-02_rb,6.913887e-02_rb,6.617415e-02_rb,6.345061e-02_rb,      &
5808          6.094001e-02_rb,5.861834e-02_rb,5.646506e-02_rb,5.446250e-02_rb,      &
5809          5.249596e-02_rb,5.081114e-02_rb,4.922243e-02_rb,4.772189e-02_rb,      &
5810          4.630243e-02_rb,4.495766e-02_rb,4.368189e-02_rb,4.246995e-02_rb,      &
5811          4.131720e-02_rb,4.021941e-02_rb,3.917276e-02_rb,3.817376e-02_rb,      &
5812          3.721926e-02_rb,3.630635e-02_rb,3.543237e-02_rb,3.459491e-02_rb,      &
5813          3.379171e-02_rb,3.302073e-02_rb,3.228007e-02_rb,3.156798e-02_rb,      &
5814          3.088284e-02_rb,3.022315e-02_rb,2.958753e-02_rb,2.897468e-02_rb,      &
5815          2.838340e-02_rb,2.781258e-02_rb,2.726117e-02_rb,2.672821e-02_rb,      &
5816          2.621278e-02_rb,2.5714e-02_rb /)
5817    extliq1(:, 17) = (/                                                         &
5818          8.293797e-01_rb,6.048371e-01_rb,4.465706e-01_rb,3.460387e-01_rb,      &
5819          2.800064e-01_rb,2.346584e-01_rb,2.022399e-01_rb,1.782626e-01_rb,      &
5820          1.600153e-01_rb,1.457903e-01_rb,1.334061e-01_rb,1.228548e-01_rb,      &
5821          1.138396e-01_rb,1.060486e-01_rb,9.924856e-02_rb,9.326208e-02_rb,      &
5822          8.795158e-02_rb,8.320883e-02_rb,7.894750e-02_rb,7.509792e-02_rb,      &
5823          7.160323e-02_rb,6.841653e-02_rb,6.549889e-02_rb,6.281763e-02_rb,      &
5824          6.034516e-02_rb,5.805802e-02_rb,5.593615e-02_rb,5.396226e-02_rb,      &
5825          5.202302e-02_rb,5.036246e-02_rb,4.879606e-02_rb,4.731610e-02_rb,      &
5826          4.591565e-02_rb,4.458852e-02_rb,4.332912e-02_rb,4.213243e-02_rb,      &
5827          4.099390e-02_rb,3.990941e-02_rb,3.887522e-02_rb,3.788792e-02_rb,      &
5828          3.694440e-02_rb,3.604183e-02_rb,3.517760e-02_rb,3.434934e-02_rb,      &
5829          3.355485e-02_rb,3.279211e-02_rb,3.205925e-02_rb,3.135458e-02_rb,      &
5830          3.067648e-02_rb,3.002349e-02_rb,2.939425e-02_rb,2.878748e-02_rb,      &
5831          2.820200e-02_rb,2.763673e-02_rb,2.709062e-02_rb,2.656272e-02_rb,      &
5832          2.605214e-02_rb,2.5558e-02_rb /)
5833    extliq1(:, 18) = (/                                                         &
5834          9.193685e-01_rb,6.128292e-01_rb,4.344150e-01_rb,3.303048e-01_rb,      &
5835          2.659500e-01_rb,2.239727e-01_rb,1.953457e-01_rb,1.751012e-01_rb,      &
5836          1.603515e-01_rb,1.493360e-01_rb,1.323791e-01_rb,1.219335e-01_rb,      &
5837          1.130076e-01_rb,1.052926e-01_rb,9.855839e-02_rb,9.262925e-02_rb,      &
5838          8.736918e-02_rb,8.267112e-02_rb,7.844965e-02_rb,7.463585e-02_rb,      &
5839          7.117343e-02_rb,6.801601e-02_rb,6.512503e-02_rb,6.246815e-02_rb,      &
5840          6.001806e-02_rb,5.775154e-02_rb,5.564872e-02_rb,5.369250e-02_rb,      &
5841          5.176284e-02_rb,5.011536e-02_rb,4.856099e-02_rb,4.709211e-02_rb,      &
5842          4.570193e-02_rb,4.438430e-02_rb,4.313375e-02_rb,4.194529e-02_rb,      &
5843          4.081443e-02_rb,3.973712e-02_rb,3.870966e-02_rb,3.772866e-02_rb,      &
5844          3.679108e-02_rb,3.589409e-02_rb,3.503514e-02_rb,3.421185e-02_rb,      &
5845          3.342206e-02_rb,3.266377e-02_rb,3.193513e-02_rb,3.123447e-02_rb,      &
5846          3.056018e-02_rb,2.991081e-02_rb,2.928502e-02_rb,2.868154e-02_rb,      &
5847          2.809920e-02_rb,2.753692e-02_rb,2.699367e-02_rb,2.646852e-02_rb,      &
5848          2.596057e-02_rb,2.5469e-02_rb /)
5849    extliq1(:, 19) = (/                                                         &
5850          9.136931e-01_rb,5.743244e-01_rb,4.080708e-01_rb,3.150572e-01_rb,      &
5851          2.577261e-01_rb,2.197900e-01_rb,1.933037e-01_rb,1.740212e-01_rb,      &
5852          1.595056e-01_rb,1.482756e-01_rb,1.312164e-01_rb,1.209246e-01_rb,      &
5853          1.121227e-01_rb,1.045095e-01_rb,9.785967e-02_rb,9.200149e-02_rb,      &
5854          8.680170e-02_rb,8.215531e-02_rb,7.797850e-02_rb,7.420361e-02_rb,      &
5855          7.077530e-02_rb,6.764798e-02_rb,6.478369e-02_rb,6.215063e-02_rb,      &
5856          5.972189e-02_rb,5.747458e-02_rb,5.538913e-02_rb,5.344866e-02_rb,      &
5857          5.153216e-02_rb,4.989745e-02_rb,4.835476e-02_rb,4.689661e-02_rb,      &
5858          4.551629e-02_rb,4.420777e-02_rb,4.296563e-02_rb,4.178497e-02_rb,      &
5859          4.066137e-02_rb,3.959081e-02_rb,3.856963e-02_rb,3.759452e-02_rb,      &
5860          3.666244e-02_rb,3.577061e-02_rb,3.491650e-02_rb,3.409777e-02_rb,      &
5861          3.331227e-02_rb,3.255803e-02_rb,3.183322e-02_rb,3.113617e-02_rb,      &
5862          3.046530e-02_rb,2.981918e-02_rb,2.919646e-02_rb,2.859591e-02_rb,      &
5863          2.801635e-02_rb,2.745671e-02_rb,2.691599e-02_rb,2.639324e-02_rb,      &
5864          2.588759e-02_rb,2.5398e-02_rb /)
5865    extliq1(:, 20) = (/                                                         &
5866          8.447548e-01_rb,5.326840e-01_rb,3.921523e-01_rb,3.119082e-01_rb,      &
5867          2.597055e-01_rb,2.228737e-01_rb,1.954157e-01_rb,1.741155e-01_rb,      &
5868          1.570881e-01_rb,1.431520e-01_rb,1.302034e-01_rb,1.200491e-01_rb,      &
5869          1.113571e-01_rb,1.038330e-01_rb,9.725657e-02_rb,9.145949e-02_rb,      &
5870          8.631112e-02_rb,8.170840e-02_rb,7.756901e-02_rb,7.382641e-02_rb,      &
5871          7.042616e-02_rb,6.732338e-02_rb,6.448069e-02_rb,6.186672e-02_rb,      &
5872          5.945494e-02_rb,5.722277e-02_rb,5.515089e-02_rb,5.322262e-02_rb,      &
5873          5.132153e-02_rb,4.969799e-02_rb,4.816556e-02_rb,4.671686e-02_rb,      &
5874          4.534525e-02_rb,4.404480e-02_rb,4.281014e-02_rb,4.163643e-02_rb,      &
5875          4.051930e-02_rb,3.945479e-02_rb,3.843927e-02_rb,3.746945e-02_rb,      &
5876          3.654234e-02_rb,3.565518e-02_rb,3.480547e-02_rb,3.399088e-02_rb,      &
5877          3.320930e-02_rb,3.245876e-02_rb,3.173745e-02_rb,3.104371e-02_rb,      &
5878          3.037600e-02_rb,2.973287e-02_rb,2.911300e-02_rb,2.851516e-02_rb,      &
5879          2.793818e-02_rb,2.738101e-02_rb,2.684264e-02_rb,2.632214e-02_rb,      &
5880          2.581863e-02_rb,2.5331e-02_rb /)
5881    extliq1(:, 21) = (/                                                         &
5882          7.727642e-01_rb,5.034865e-01_rb,3.808673e-01_rb,3.080333e-01_rb,      &
5883          2.586453e-01_rb,2.224989e-01_rb,1.947060e-01_rb,1.725821e-01_rb,      &
5884          1.545096e-01_rb,1.394456e-01_rb,1.288683e-01_rb,1.188852e-01_rb,      &
5885          1.103317e-01_rb,1.029214e-01_rb,9.643967e-02_rb,9.072239e-02_rb,      &
5886          8.564194e-02_rb,8.109758e-02_rb,7.700875e-02_rb,7.331026e-02_rb,      &
5887          6.994879e-02_rb,6.688028e-02_rb,6.406807e-02_rb,6.148133e-02_rb,      &
5888          5.909400e-02_rb,5.688388e-02_rb,5.483197e-02_rb,5.292185e-02_rb,      &
5889          5.103763e-02_rb,4.942905e-02_rb,4.791039e-02_rb,4.647438e-02_rb,      &
5890          4.511453e-02_rb,4.382497e-02_rb,4.260043e-02_rb,4.143616e-02_rb,      &
5891          4.032784e-02_rb,3.927155e-02_rb,3.826375e-02_rb,3.730117e-02_rb,      &
5892          3.638087e-02_rb,3.550013e-02_rb,3.465646e-02_rb,3.384759e-02_rb,      &
5893          3.307141e-02_rb,3.232598e-02_rb,3.160953e-02_rb,3.092040e-02_rb,      &
5894          3.025706e-02_rb,2.961810e-02_rb,2.900220e-02_rb,2.840814e-02_rb,      &
5895          2.783478e-02_rb,2.728106e-02_rb,2.674599e-02_rb,2.622864e-02_rb,      &
5896          2.572816e-02_rb,2.5244e-02_rb /)
5897    extliq1(:, 22) = (/                                                         &
5898          7.416833e-01_rb,4.959591e-01_rb,3.775057e-01_rb,3.056353e-01_rb,      &
5899          2.565943e-01_rb,2.206935e-01_rb,1.931479e-01_rb,1.712860e-01_rb,      &
5900          1.534837e-01_rb,1.386906e-01_rb,1.281198e-01_rb,1.182344e-01_rb,      &
5901          1.097595e-01_rb,1.024137e-01_rb,9.598552e-02_rb,9.031320e-02_rb,      &
5902          8.527093e-02_rb,8.075927e-02_rb,7.669869e-02_rb,7.302481e-02_rb,      &
5903          6.968491e-02_rb,6.663542e-02_rb,6.384008e-02_rb,6.126838e-02_rb,      &
5904          5.889452e-02_rb,5.669654e-02_rb,5.465558e-02_rb,5.275540e-02_rb,      &
5905          5.087937e-02_rb,4.927904e-02_rb,4.776796e-02_rb,4.633895e-02_rb,      &
5906          4.498557e-02_rb,4.370202e-02_rb,4.248306e-02_rb,4.132399e-02_rb,      &
5907          4.022052e-02_rb,3.916878e-02_rb,3.816523e-02_rb,3.720665e-02_rb,      &
5908          3.629011e-02_rb,3.541290e-02_rb,3.457257e-02_rb,3.376685e-02_rb,      &
5909          3.299365e-02_rb,3.225105e-02_rb,3.153728e-02_rb,3.085069e-02_rb,      &
5910          3.018977e-02_rb,2.955310e-02_rb,2.893940e-02_rb,2.834742e-02_rb,      &
5911          2.777606e-02_rb,2.722424e-02_rb,2.669099e-02_rb,2.617539e-02_rb,      &
5912          2.567658e-02_rb,2.5194e-02_rb /)
5913    extliq1(:, 23) = (/                                                         &
5914          7.058580e-01_rb,4.866573e-01_rb,3.712238e-01_rb,2.998638e-01_rb,      &
5915          2.513441e-01_rb,2.161972e-01_rb,1.895576e-01_rb,1.686669e-01_rb,      &
5916          1.518437e-01_rb,1.380046e-01_rb,1.267564e-01_rb,1.170399e-01_rb,      &
5917          1.087026e-01_rb,1.014704e-01_rb,9.513729e-02_rb,8.954555e-02_rb,      &
5918          8.457221e-02_rb,8.012009e-02_rb,7.611136e-02_rb,7.248294e-02_rb,      &
5919          6.918317e-02_rb,6.616934e-02_rb,6.340584e-02_rb,6.086273e-02_rb,      &
5920          5.851465e-02_rb,5.634001e-02_rb,5.432027e-02_rb,5.243946e-02_rb,      &
5921          5.058070e-02_rb,4.899628e-02_rb,4.749975e-02_rb,4.608411e-02_rb,      &
5922          4.474303e-02_rb,4.347082e-02_rb,4.226237e-02_rb,4.111303e-02_rb,      &
5923          4.001861e-02_rb,3.897528e-02_rb,3.797959e-02_rb,3.702835e-02_rb,      &
5924          3.611867e-02_rb,3.524791e-02_rb,3.441364e-02_rb,3.361360e-02_rb,      &
5925          3.284577e-02_rb,3.210823e-02_rb,3.139923e-02_rb,3.071716e-02_rb,      &
5926          3.006052e-02_rb,2.942791e-02_rb,2.881806e-02_rb,2.822974e-02_rb,      &
5927          2.766185e-02_rb,2.711335e-02_rb,2.658326e-02_rb,2.607066e-02_rb,      &
5928          2.557473e-02_rb,2.5095e-02_rb /)
5929    extliq1(:, 24) = (/                                                         &
5930          6.822779e-01_rb,4.750373e-01_rb,3.634834e-01_rb,2.940726e-01_rb,      &
5931          2.468060e-01_rb,2.125768e-01_rb,1.866586e-01_rb,1.663588e-01_rb,      &
5932          1.500326e-01_rb,1.366192e-01_rb,1.253472e-01_rb,1.158052e-01_rb,      &
5933          1.076101e-01_rb,1.004954e-01_rb,9.426089e-02_rb,8.875268e-02_rb,      &
5934          8.385090e-02_rb,7.946063e-02_rb,7.550578e-02_rb,7.192466e-02_rb,      &
5935          6.866669e-02_rb,6.569001e-02_rb,6.295971e-02_rb,6.044642e-02_rb,      &
5936          5.812526e-02_rb,5.597500e-02_rb,5.397746e-02_rb,5.211690e-02_rb,      &
5937          5.027505e-02_rb,4.870703e-02_rb,4.722555e-02_rb,4.582373e-02_rb,      &
5938          4.449540e-02_rb,4.323497e-02_rb,4.203742e-02_rb,4.089821e-02_rb,      &
5939          3.981321e-02_rb,3.877867e-02_rb,3.779118e-02_rb,3.684762e-02_rb,      &
5940          3.594514e-02_rb,3.508114e-02_rb,3.425322e-02_rb,3.345917e-02_rb,      &
5941          3.269698e-02_rb,3.196477e-02_rb,3.126082e-02_rb,3.058352e-02_rb,      &
5942          2.993141e-02_rb,2.930310e-02_rb,2.869732e-02_rb,2.811289e-02_rb,      &
5943          2.754869e-02_rb,2.700371e-02_rb,2.647698e-02_rb,2.596760e-02_rb,      &
5944          2.547473e-02_rb,2.4998e-02_rb /)
5945    extliq1(:, 25) = (/                                                         &
5946          6.666233e-01_rb,4.662044e-01_rb,3.579517e-01_rb,2.902984e-01_rb,      &
5947          2.440475e-01_rb,2.104431e-01_rb,1.849277e-01_rb,1.648970e-01_rb,      &
5948          1.487555e-01_rb,1.354714e-01_rb,1.244173e-01_rb,1.149913e-01_rb,      &
5949          1.068903e-01_rb,9.985323e-02_rb,9.368351e-02_rb,8.823009e-02_rb,      &
5950          8.337507e-02_rb,7.902511e-02_rb,7.510529e-02_rb,7.155482e-02_rb,      &
5951          6.832386e-02_rb,6.537113e-02_rb,6.266218e-02_rb,6.016802e-02_rb,      &
5952          5.786408e-02_rb,5.572939e-02_rb,5.374598e-02_rb,5.189830e-02_rb,      &
5953          5.006825e-02_rb,4.851081e-02_rb,4.703906e-02_rb,4.564623e-02_rb,      &
5954          4.432621e-02_rb,4.307349e-02_rb,4.188312e-02_rb,4.075060e-02_rb,      &
5955          3.967183e-02_rb,3.864313e-02_rb,3.766111e-02_rb,3.672269e-02_rb,      &
5956          3.582505e-02_rb,3.496559e-02_rb,3.414196e-02_rb,3.335198e-02_rb,      &
5957          3.259362e-02_rb,3.186505e-02_rb,3.116454e-02_rb,3.049052e-02_rb,      &
5958          2.984152e-02_rb,2.921617e-02_rb,2.861322e-02_rb,2.803148e-02_rb,      &
5959          2.746986e-02_rb,2.692733e-02_rb,2.640295e-02_rb,2.589582e-02_rb,      &
5960          2.540510e-02_rb,2.4930e-02_rb /)
5961    extliq1(:, 26) = (/                                                         &
5962          6.535669e-01_rb,4.585865e-01_rb,3.529226e-01_rb,2.867245e-01_rb,      &
5963          2.413848e-01_rb,2.083956e-01_rb,1.833191e-01_rb,1.636150e-01_rb,      &
5964          1.477247e-01_rb,1.346392e-01_rb,1.236449e-01_rb,1.143095e-01_rb,      &
5965          1.062828e-01_rb,9.930773e-02_rb,9.319029e-02_rb,8.778150e-02_rb,      &
5966          8.296497e-02_rb,7.864847e-02_rb,7.475799e-02_rb,7.123343e-02_rb,      &
5967          6.802549e-02_rb,6.509332e-02_rb,6.240285e-02_rb,5.992538e-02_rb,      &
5968          5.763657e-02_rb,5.551566e-02_rb,5.354483e-02_rb,5.170870e-02_rb,      &
5969          4.988866e-02_rb,4.834061e-02_rb,4.687751e-02_rb,4.549264e-02_rb,      &
5970          4.417999e-02_rb,4.293410e-02_rb,4.175006e-02_rb,4.062344e-02_rb,      &
5971          3.955019e-02_rb,3.852663e-02_rb,3.754943e-02_rb,3.661553e-02_rb,      &
5972          3.572214e-02_rb,3.486669e-02_rb,3.404683e-02_rb,3.326040e-02_rb,      &
5973          3.250542e-02_rb,3.178003e-02_rb,3.108254e-02_rb,3.041139e-02_rb,      &
5974          2.976511e-02_rb,2.914235e-02_rb,2.854187e-02_rb,2.796247e-02_rb,      &
5975          2.740309e-02_rb,2.686271e-02_rb,2.634038e-02_rb,2.583520e-02_rb,      &
5976          2.534636e-02_rb,2.4873e-02_rb /)
5977    extliq1(:, 27) = (/                                                         &
5978          6.448790e-01_rb,4.541425e-01_rb,3.503348e-01_rb,2.850494e-01_rb,      &
5979          2.401966e-01_rb,2.074811e-01_rb,1.825631e-01_rb,1.629515e-01_rb,      &
5980          1.471142e-01_rb,1.340574e-01_rb,1.231462e-01_rb,1.138628e-01_rb,      &
5981          1.058802e-01_rb,9.894286e-02_rb,9.285818e-02_rb,8.747802e-02_rb,      &
5982          8.268676e-02_rb,7.839271e-02_rb,7.452230e-02_rb,7.101580e-02_rb,      &
5983          6.782418e-02_rb,6.490685e-02_rb,6.222991e-02_rb,5.976484e-02_rb,      &
5984          5.748742e-02_rb,5.537703e-02_rb,5.341593e-02_rb,5.158883e-02_rb,      &
5985          4.977355e-02_rb,4.823172e-02_rb,4.677430e-02_rb,4.539465e-02_rb,      &
5986          4.408680e-02_rb,4.284533e-02_rb,4.166539e-02_rb,4.054257e-02_rb,      &
5987          3.947283e-02_rb,3.845256e-02_rb,3.747842e-02_rb,3.654737e-02_rb,      &
5988          3.565665e-02_rb,3.480370e-02_rb,3.398620e-02_rb,3.320198e-02_rb,      &
5989          3.244908e-02_rb,3.172566e-02_rb,3.103002e-02_rb,3.036062e-02_rb,      &
5990          2.971600e-02_rb,2.909482e-02_rb,2.849582e-02_rb,2.791785e-02_rb,      &
5991          2.735982e-02_rb,2.682072e-02_rb,2.629960e-02_rb,2.579559e-02_rb,      &
5992          2.530786e-02_rb,2.4836e-02_rb /)
5993    extliq1(:, 28) = (/                                                         &
5994          6.422688e-01_rb,4.528453e-01_rb,3.497232e-01_rb,2.847724e-01_rb,      &
5995          2.400815e-01_rb,2.074403e-01_rb,1.825502e-01_rb,1.629415e-01_rb,      &
5996          1.470934e-01_rb,1.340183e-01_rb,1.230935e-01_rb,1.138049e-01_rb,      &
5997          1.058201e-01_rb,9.888245e-02_rb,9.279878e-02_rb,8.742053e-02_rb,      &
5998          8.263175e-02_rb,7.834058e-02_rb,7.447327e-02_rb,7.097000e-02_rb,      &
5999          6.778167e-02_rb,6.486765e-02_rb,6.219400e-02_rb,5.973215e-02_rb,      &
6000          5.745790e-02_rb,5.535059e-02_rb,5.339250e-02_rb,5.156831e-02_rb,      &
6001          4.975308e-02_rb,4.821235e-02_rb,4.675596e-02_rb,4.537727e-02_rb,      &
6002          4.407030e-02_rb,4.282968e-02_rb,4.165053e-02_rb,4.052845e-02_rb,      &
6003          3.945941e-02_rb,3.843980e-02_rb,3.746628e-02_rb,3.653583e-02_rb,      &
6004          3.564567e-02_rb,3.479326e-02_rb,3.397626e-02_rb,3.319253e-02_rb,      &
6005          3.244008e-02_rb,3.171711e-02_rb,3.102189e-02_rb,3.035289e-02_rb,      &
6006          2.970866e-02_rb,2.908784e-02_rb,2.848920e-02_rb,2.791156e-02_rb,      &
6007          2.735385e-02_rb,2.681507e-02_rb,2.629425e-02_rb,2.579053e-02_rb,      &
6008          2.530308e-02_rb,2.4831e-02_rb /)
6009    extliq1(:, 29) = (/                                                         &
6010          4.614710e-01_rb,4.556116e-01_rb,4.056568e-01_rb,3.529833e-01_rb,      &
6011          3.060334e-01_rb,2.658127e-01_rb,2.316095e-01_rb,2.024325e-01_rb,      &
6012          1.773749e-01_rb,1.556867e-01_rb,1.455558e-01_rb,1.332882e-01_rb,      &
6013          1.229052e-01_rb,1.140067e-01_rb,1.062981e-01_rb,9.955703e-02_rb,      &
6014          9.361333e-02_rb,8.833420e-02_rb,8.361467e-02_rb,7.937071e-02_rb,      &
6015          7.553420e-02_rb,7.204942e-02_rb,6.887031e-02_rb,6.595851e-02_rb,      &
6016          6.328178e-02_rb,6.081286e-02_rb,5.852854e-02_rb,5.640892e-02_rb,      &
6017          5.431269e-02_rb,5.252561e-02_rb,5.084345e-02_rb,4.925727e-02_rb,      &
6018          4.775910e-02_rb,4.634182e-02_rb,4.499907e-02_rb,4.372512e-02_rb,      &
6019          4.251484e-02_rb,4.136357e-02_rb,4.026710e-02_rb,3.922162e-02_rb,      &
6020          3.822365e-02_rb,3.727004e-02_rb,3.635790e-02_rb,3.548457e-02_rb,      &
6021          3.464764e-02_rb,3.384488e-02_rb,3.307424e-02_rb,3.233384e-02_rb,      &
6022          3.162192e-02_rb,3.093688e-02_rb,3.027723e-02_rb,2.964158e-02_rb,      &
6023          2.902864e-02_rb,2.843722e-02_rb,2.786621e-02_rb,2.731457e-02_rb,      &
6024          2.678133e-02_rb,2.6266e-02_rb /)
6025 !
6026 ! Single scattering albedo
6027 !
6028    ssaliq1(:, 16) = (/                                                         &
6029          8.143821e-01_rb,7.836739e-01_rb,7.550722e-01_rb,7.306269e-01_rb,      &
6030          7.105612e-01_rb,6.946649e-01_rb,6.825556e-01_rb,6.737762e-01_rb,      &
6031          6.678448e-01_rb,6.642830e-01_rb,6.679741e-01_rb,6.584607e-01_rb,      &
6032          6.505598e-01_rb,6.440951e-01_rb,6.388901e-01_rb,6.347689e-01_rb,      &
6033          6.315549e-01_rb,6.290718e-01_rb,6.271432e-01_rb,6.255928e-01_rb,      &
6034          6.242441e-01_rb,6.229207e-01_rb,6.214464e-01_rb,6.196445e-01_rb,      &
6035          6.173388e-01_rb,6.143527e-01_rb,6.105099e-01_rb,6.056339e-01_rb,      &
6036          6.108290e-01_rb,6.073939e-01_rb,6.043073e-01_rb,6.015473e-01_rb,      &
6037          5.990913e-01_rb,5.969173e-01_rb,5.950028e-01_rb,5.933257e-01_rb,      &
6038          5.918636e-01_rb,5.905944e-01_rb,5.894957e-01_rb,5.885453e-01_rb,      &
6039          5.877209e-01_rb,5.870003e-01_rb,5.863611e-01_rb,5.857811e-01_rb,      &
6040          5.852381e-01_rb,5.847098e-01_rb,5.841738e-01_rb,5.836081e-01_rb,      &
6041          5.829901e-01_rb,5.822979e-01_rb,5.815089e-01_rb,5.806011e-01_rb,      &
6042          5.795521e-01_rb,5.783396e-01_rb,5.769413e-01_rb,5.753351e-01_rb,      &
6043          5.734986e-01_rb,5.7141e-01_rb /)
6044    ssaliq1(:, 17) = (/                                                         &
6045          8.165821e-01_rb,8.002015e-01_rb,7.816921e-01_rb,7.634131e-01_rb,      &
6046          7.463721e-01_rb,7.312469e-01_rb,7.185883e-01_rb,7.088975e-01_rb,      &
6047          7.026671e-01_rb,7.004020e-01_rb,7.042138e-01_rb,6.960930e-01_rb,      &
6048          6.894243e-01_rb,6.840459e-01_rb,6.797957e-01_rb,6.765119e-01_rb,      &
6049          6.740325e-01_rb,6.721955e-01_rb,6.708391e-01_rb,6.698013e-01_rb,      &
6050          6.689201e-01_rb,6.680339e-01_rb,6.669805e-01_rb,6.655982e-01_rb,      &
6051          6.637250e-01_rb,6.611992e-01_rb,6.578588e-01_rb,6.535420e-01_rb,      &
6052          6.584449e-01_rb,6.553992e-01_rb,6.526547e-01_rb,6.501917e-01_rb,      &
6053          6.479905e-01_rb,6.460313e-01_rb,6.442945e-01_rb,6.427605e-01_rb,      &
6054          6.414094e-01_rb,6.402217e-01_rb,6.391775e-01_rb,6.382573e-01_rb,      &
6055          6.374413e-01_rb,6.367099e-01_rb,6.360433e-01_rb,6.354218e-01_rb,      &
6056          6.348257e-01_rb,6.342355e-01_rb,6.336313e-01_rb,6.329935e-01_rb,      &
6057          6.323023e-01_rb,6.315383e-01_rb,6.306814e-01_rb,6.297122e-01_rb,      &
6058          6.286110e-01_rb,6.273579e-01_rb,6.259333e-01_rb,6.243176e-01_rb,      &
6059          6.224910e-01_rb,6.2043e-01_rb /)
6060    ssaliq1(:, 18) = (/                                                         &
6061          9.900163e-01_rb,9.854307e-01_rb,9.797730e-01_rb,9.733113e-01_rb,      &
6062          9.664245e-01_rb,9.594976e-01_rb,9.529055e-01_rb,9.470112e-01_rb,      &
6063          9.421695e-01_rb,9.387304e-01_rb,9.344918e-01_rb,9.305302e-01_rb,      &
6064          9.267048e-01_rb,9.230072e-01_rb,9.194289e-01_rb,9.159616e-01_rb,      &
6065          9.125968e-01_rb,9.093260e-01_rb,9.061409e-01_rb,9.030330e-01_rb,      &
6066          8.999940e-01_rb,8.970154e-01_rb,8.940888e-01_rb,8.912058e-01_rb,      &
6067          8.883579e-01_rb,8.855368e-01_rb,8.827341e-01_rb,8.799413e-01_rb,      &
6068          8.777423e-01_rb,8.749566e-01_rb,8.722298e-01_rb,8.695605e-01_rb,      &
6069          8.669469e-01_rb,8.643875e-01_rb,8.618806e-01_rb,8.594246e-01_rb,      &
6070          8.570179e-01_rb,8.546589e-01_rb,8.523459e-01_rb,8.500773e-01_rb,      &
6071          8.478516e-01_rb,8.456670e-01_rb,8.435219e-01_rb,8.414148e-01_rb,      &
6072          8.393439e-01_rb,8.373078e-01_rb,8.353047e-01_rb,8.333330e-01_rb,      &
6073          8.313911e-01_rb,8.294774e-01_rb,8.275904e-01_rb,8.257282e-01_rb,      &
6074          8.238893e-01_rb,8.220721e-01_rb,8.202751e-01_rb,8.184965e-01_rb,      &
6075          8.167346e-01_rb,8.1499e-01_rb /)
6076    ssaliq1(:, 19) = (/                                                         &
6077          9.999916e-01_rb,9.987396e-01_rb,9.966900e-01_rb,9.950738e-01_rb,      &
6078          9.937531e-01_rb,9.925912e-01_rb,9.914525e-01_rb,9.902018e-01_rb,      &
6079          9.887046e-01_rb,9.868263e-01_rb,9.849039e-01_rb,9.832372e-01_rb,      &
6080          9.815265e-01_rb,9.797770e-01_rb,9.779940e-01_rb,9.761827e-01_rb,      &
6081          9.743481e-01_rb,9.724955e-01_rb,9.706303e-01_rb,9.687575e-01_rb,      &
6082          9.668823e-01_rb,9.650100e-01_rb,9.631457e-01_rb,9.612947e-01_rb,      &
6083          9.594622e-01_rb,9.576534e-01_rb,9.558734e-01_rb,9.541275e-01_rb,      &
6084          9.522059e-01_rb,9.504258e-01_rb,9.486459e-01_rb,9.468676e-01_rb,      &
6085          9.450921e-01_rb,9.433208e-01_rb,9.415548e-01_rb,9.397955e-01_rb,      &
6086          9.380441e-01_rb,9.363022e-01_rb,9.345706e-01_rb,9.328510e-01_rb,      &
6087          9.311445e-01_rb,9.294524e-01_rb,9.277761e-01_rb,9.261167e-01_rb,      &
6088          9.244755e-01_rb,9.228540e-01_rb,9.212534e-01_rb,9.196748e-01_rb,      &
6089          9.181197e-01_rb,9.165894e-01_rb,9.150851e-01_rb,9.136080e-01_rb,      &
6090          9.121596e-01_rb,9.107410e-01_rb,9.093536e-01_rb,9.079987e-01_rb,      &
6091          9.066775e-01_rb,9.0539e-01_rb /)
6092    ssaliq1(:, 20) = (/                                                         &
6093          9.979493e-01_rb,9.964113e-01_rb,9.950014e-01_rb,9.937045e-01_rb,      &
6094          9.924964e-01_rb,9.913546e-01_rb,9.902575e-01_rb,9.891843e-01_rb,      &
6095          9.881136e-01_rb,9.870238e-01_rb,9.859934e-01_rb,9.849372e-01_rb,      &
6096          9.838873e-01_rb,9.828434e-01_rb,9.818052e-01_rb,9.807725e-01_rb,      &
6097          9.797450e-01_rb,9.787225e-01_rb,9.777047e-01_rb,9.766914e-01_rb,      &
6098          9.756823e-01_rb,9.746771e-01_rb,9.736756e-01_rb,9.726775e-01_rb,      &
6099          9.716827e-01_rb,9.706907e-01_rb,9.697014e-01_rb,9.687145e-01_rb,      &
6100          9.678060e-01_rb,9.668108e-01_rb,9.658218e-01_rb,9.648391e-01_rb,      &
6101          9.638629e-01_rb,9.628936e-01_rb,9.619313e-01_rb,9.609763e-01_rb,      &
6102          9.600287e-01_rb,9.590888e-01_rb,9.581569e-01_rb,9.572330e-01_rb,      &
6103          9.563176e-01_rb,9.554108e-01_rb,9.545128e-01_rb,9.536239e-01_rb,      &
6104          9.527443e-01_rb,9.518741e-01_rb,9.510137e-01_rb,9.501633e-01_rb,      &
6105          9.493230e-01_rb,9.484931e-01_rb,9.476740e-01_rb,9.468656e-01_rb,      &
6106          9.460683e-01_rb,9.452824e-01_rb,9.445080e-01_rb,9.437454e-01_rb,      &
6107          9.429948e-01_rb,9.4226e-01_rb /)
6108    ssaliq1(:, 21) = (/                                                         &
6109          9.988742e-01_rb,9.982668e-01_rb,9.976935e-01_rb,9.971497e-01_rb,      &
6110          9.966314e-01_rb,9.961344e-01_rb,9.956545e-01_rb,9.951873e-01_rb,      &
6111          9.947286e-01_rb,9.942741e-01_rb,9.938457e-01_rb,9.933947e-01_rb,      &
6112          9.929473e-01_rb,9.925032e-01_rb,9.920621e-01_rb,9.916237e-01_rb,      &
6113          9.911875e-01_rb,9.907534e-01_rb,9.903209e-01_rb,9.898898e-01_rb,      &
6114          9.894597e-01_rb,9.890304e-01_rb,9.886015e-01_rb,9.881726e-01_rb,      &
6115          9.877435e-01_rb,9.873138e-01_rb,9.868833e-01_rb,9.864516e-01_rb,      &
6116          9.860698e-01_rb,9.856317e-01_rb,9.851957e-01_rb,9.847618e-01_rb,      &
6117          9.843302e-01_rb,9.839008e-01_rb,9.834739e-01_rb,9.830494e-01_rb,      &
6118          9.826275e-01_rb,9.822083e-01_rb,9.817918e-01_rb,9.813782e-01_rb,      &
6119          9.809675e-01_rb,9.805598e-01_rb,9.801552e-01_rb,9.797538e-01_rb,      &
6120          9.793556e-01_rb,9.789608e-01_rb,9.785695e-01_rb,9.781817e-01_rb,      &
6121          9.777975e-01_rb,9.774171e-01_rb,9.770404e-01_rb,9.766676e-01_rb,      &
6122          9.762988e-01_rb,9.759340e-01_rb,9.755733e-01_rb,9.752169e-01_rb,      &
6123          9.748649e-01_rb,9.7452e-01_rb /)
6124    ssaliq1(:, 22) = (/                                                         &
6125          9.994441e-01_rb,9.991608e-01_rb,9.988949e-01_rb,9.986439e-01_rb,      &
6126          9.984054e-01_rb,9.981768e-01_rb,9.979557e-01_rb,9.977396e-01_rb,      &
6127          9.975258e-01_rb,9.973120e-01_rb,9.971011e-01_rb,9.968852e-01_rb,      &
6128          9.966708e-01_rb,9.964578e-01_rb,9.962462e-01_rb,9.960357e-01_rb,      &
6129          9.958264e-01_rb,9.956181e-01_rb,9.954108e-01_rb,9.952043e-01_rb,      &
6130          9.949987e-01_rb,9.947937e-01_rb,9.945892e-01_rb,9.943853e-01_rb,      &
6131          9.941818e-01_rb,9.939786e-01_rb,9.937757e-01_rb,9.935728e-01_rb,      &
6132          9.933922e-01_rb,9.931825e-01_rb,9.929739e-01_rb,9.927661e-01_rb,      &
6133          9.925592e-01_rb,9.923534e-01_rb,9.921485e-01_rb,9.919447e-01_rb,      &
6134          9.917421e-01_rb,9.915406e-01_rb,9.913403e-01_rb,9.911412e-01_rb,      &
6135          9.909435e-01_rb,9.907470e-01_rb,9.905519e-01_rb,9.903581e-01_rb,      &
6136          9.901659e-01_rb,9.899751e-01_rb,9.897858e-01_rb,9.895981e-01_rb,      &
6137          9.894120e-01_rb,9.892276e-01_rb,9.890447e-01_rb,9.888637e-01_rb,      &
6138          9.886845e-01_rb,9.885070e-01_rb,9.883314e-01_rb,9.881576e-01_rb,      &
6139          9.879859e-01_rb,9.8782e-01_rb /)
6140    ssaliq1(:, 23) = (/                                                         &
6141          9.999138e-01_rb,9.998730e-01_rb,9.998338e-01_rb,9.997965e-01_rb,      &
6142          9.997609e-01_rb,9.997270e-01_rb,9.996944e-01_rb,9.996629e-01_rb,      &
6143          9.996321e-01_rb,9.996016e-01_rb,9.995690e-01_rb,9.995372e-01_rb,      &
6144          9.995057e-01_rb,9.994744e-01_rb,9.994433e-01_rb,9.994124e-01_rb,      &
6145          9.993817e-01_rb,9.993510e-01_rb,9.993206e-01_rb,9.992903e-01_rb,      &
6146          9.992600e-01_rb,9.992299e-01_rb,9.991998e-01_rb,9.991698e-01_rb,      &
6147          9.991398e-01_rb,9.991098e-01_rb,9.990799e-01_rb,9.990499e-01_rb,      &
6148          9.990231e-01_rb,9.989920e-01_rb,9.989611e-01_rb,9.989302e-01_rb,      &
6149          9.988996e-01_rb,9.988690e-01_rb,9.988386e-01_rb,9.988084e-01_rb,      &
6150          9.987783e-01_rb,9.987485e-01_rb,9.987187e-01_rb,9.986891e-01_rb,      &
6151          9.986598e-01_rb,9.986306e-01_rb,9.986017e-01_rb,9.985729e-01_rb,      &
6152          9.985443e-01_rb,9.985160e-01_rb,9.984879e-01_rb,9.984600e-01_rb,      &
6153          9.984324e-01_rb,9.984050e-01_rb,9.983778e-01_rb,9.983509e-01_rb,      &
6154          9.983243e-01_rb,9.982980e-01_rb,9.982719e-01_rb,9.982461e-01_rb,      &
6155          9.982206e-01_rb,9.9820e-01_rb /)
6156    ssaliq1(:, 24) = (/                                                         &
6157          9.999985e-01_rb,9.999979e-01_rb,9.999972e-01_rb,9.999966e-01_rb,      &
6158          9.999961e-01_rb,9.999955e-01_rb,9.999950e-01_rb,9.999944e-01_rb,      &
6159          9.999938e-01_rb,9.999933e-01_rb,9.999927e-01_rb,9.999921e-01_rb,      &
6160          9.999915e-01_rb,9.999910e-01_rb,9.999904e-01_rb,9.999899e-01_rb,      &
6161          9.999893e-01_rb,9.999888e-01_rb,9.999882e-01_rb,9.999877e-01_rb,      &
6162          9.999871e-01_rb,9.999866e-01_rb,9.999861e-01_rb,9.999855e-01_rb,      &
6163          9.999850e-01_rb,9.999844e-01_rb,9.999839e-01_rb,9.999833e-01_rb,      &
6164          9.999828e-01_rb,9.999823e-01_rb,9.999817e-01_rb,9.999812e-01_rb,      &
6165          9.999807e-01_rb,9.999801e-01_rb,9.999796e-01_rb,9.999791e-01_rb,      &
6166          9.999786e-01_rb,9.999781e-01_rb,9.999776e-01_rb,9.999770e-01_rb,      &
6167          9.999765e-01_rb,9.999761e-01_rb,9.999756e-01_rb,9.999751e-01_rb,      &
6168          9.999746e-01_rb,9.999741e-01_rb,9.999736e-01_rb,9.999732e-01_rb,      &
6169          9.999727e-01_rb,9.999722e-01_rb,9.999718e-01_rb,9.999713e-01_rb,      &
6170          9.999709e-01_rb,9.999705e-01_rb,9.999701e-01_rb,9.999697e-01_rb,      &
6171          9.999692e-01_rb,9.9997e-01_rb /)
6172    ssaliq1(:, 25) = (/                                                         &
6173          9.999999e-01_rb,9.999998e-01_rb,9.999997e-01_rb,9.999997e-01_rb,      &
6174          9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,      &
6175          9.999995e-01_rb,9.999994e-01_rb,9.999994e-01_rb,9.999993e-01_rb,      &
6176          9.999993e-01_rb,9.999992e-01_rb,9.999992e-01_rb,9.999991e-01_rb,      &
6177          9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,      &
6178          9.999989e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,      &
6179          9.999987e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999986e-01_rb,      &
6180          9.999985e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999984e-01_rb,      &
6181          9.999984e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999982e-01_rb,      &
6182          9.999982e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,      &
6183          9.999980e-01_rb,9.999980e-01_rb,9.999979e-01_rb,9.999979e-01_rb,      &
6184          9.999978e-01_rb,9.999978e-01_rb,9.999977e-01_rb,9.999977e-01_rb,      &
6185          9.999977e-01_rb,9.999976e-01_rb,9.999976e-01_rb,9.999975e-01_rb,      &
6186          9.999975e-01_rb,9.999974e-01_rb,9.999974e-01_rb,9.999974e-01_rb,      &
6187          9.999973e-01_rb,1.0000e+00_rb /)
6188    ssaliq1(:, 26) = (/                                                         &
6189          9.999997e-01_rb,9.999995e-01_rb,9.999993e-01_rb,9.999992e-01_rb,      &
6190          9.999990e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,      &
6191          9.999986e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999983e-01_rb,      &
6192          9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,      &
6193          9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999974e-01_rb,      &
6194          9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,      &
6195          9.999968e-01_rb,9.999967e-01_rb,9.999966e-01_rb,9.999965e-01_rb,      &
6196          9.999964e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999961e-01_rb,      &
6197          9.999959e-01_rb,9.999958e-01_rb,9.999957e-01_rb,9.999956e-01_rb,      &
6198          9.999955e-01_rb,9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,      &
6199          9.999951e-01_rb,9.999949e-01_rb,9.999949e-01_rb,9.999947e-01_rb,      &
6200          9.999946e-01_rb,9.999945e-01_rb,9.999944e-01_rb,9.999943e-01_rb,      &
6201          9.999942e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,      &
6202          9.999938e-01_rb,9.999937e-01_rb,9.999936e-01_rb,9.999935e-01_rb,      &
6203          9.999934e-01_rb,9.9999e-01_rb /)
6204    ssaliq1(:, 27) = (/                                                         &
6205          9.999984e-01_rb,9.999976e-01_rb,9.999969e-01_rb,9.999962e-01_rb,      &
6206          9.999956e-01_rb,9.999950e-01_rb,9.999945e-01_rb,9.999940e-01_rb,      &
6207          9.999935e-01_rb,9.999931e-01_rb,9.999926e-01_rb,9.999920e-01_rb,      &
6208          9.999914e-01_rb,9.999908e-01_rb,9.999903e-01_rb,9.999897e-01_rb,      &
6209          9.999891e-01_rb,9.999886e-01_rb,9.999880e-01_rb,9.999874e-01_rb,      &
6210          9.999868e-01_rb,9.999863e-01_rb,9.999857e-01_rb,9.999851e-01_rb,      &
6211          9.999846e-01_rb,9.999840e-01_rb,9.999835e-01_rb,9.999829e-01_rb,      &
6212          9.999824e-01_rb,9.999818e-01_rb,9.999812e-01_rb,9.999806e-01_rb,      &
6213          9.999800e-01_rb,9.999795e-01_rb,9.999789e-01_rb,9.999783e-01_rb,      &
6214          9.999778e-01_rb,9.999773e-01_rb,9.999767e-01_rb,9.999761e-01_rb,      &
6215          9.999756e-01_rb,9.999750e-01_rb,9.999745e-01_rb,9.999739e-01_rb,      &
6216          9.999734e-01_rb,9.999729e-01_rb,9.999723e-01_rb,9.999718e-01_rb,      &
6217          9.999713e-01_rb,9.999708e-01_rb,9.999703e-01_rb,9.999697e-01_rb,      &
6218          9.999692e-01_rb,9.999687e-01_rb,9.999683e-01_rb,9.999678e-01_rb,      &
6219          9.999673e-01_rb,9.9997e-01_rb /)
6220    ssaliq1(:, 28) = (/                                                         &
6221          9.999981e-01_rb,9.999973e-01_rb,9.999965e-01_rb,9.999958e-01_rb,      &
6222          9.999951e-01_rb,9.999943e-01_rb,9.999937e-01_rb,9.999930e-01_rb,      &
6223          9.999924e-01_rb,9.999918e-01_rb,9.999912e-01_rb,9.999905e-01_rb,      &
6224          9.999897e-01_rb,9.999890e-01_rb,9.999883e-01_rb,9.999876e-01_rb,      &
6225          9.999869e-01_rb,9.999862e-01_rb,9.999855e-01_rb,9.999847e-01_rb,      &
6226          9.999840e-01_rb,9.999834e-01_rb,9.999827e-01_rb,9.999819e-01_rb,      &
6227          9.999812e-01_rb,9.999805e-01_rb,9.999799e-01_rb,9.999791e-01_rb,      &
6228          9.999785e-01_rb,9.999778e-01_rb,9.999771e-01_rb,9.999764e-01_rb,      &
6229          9.999757e-01_rb,9.999750e-01_rb,9.999743e-01_rb,9.999736e-01_rb,      &
6230          9.999729e-01_rb,9.999722e-01_rb,9.999715e-01_rb,9.999709e-01_rb,      &
6231          9.999701e-01_rb,9.999695e-01_rb,9.999688e-01_rb,9.999682e-01_rb,      &
6232          9.999675e-01_rb,9.999669e-01_rb,9.999662e-01_rb,9.999655e-01_rb,      &
6233          9.999649e-01_rb,9.999642e-01_rb,9.999636e-01_rb,9.999630e-01_rb,      &
6234          9.999624e-01_rb,9.999618e-01_rb,9.999612e-01_rb,9.999606e-01_rb,      &
6235          9.999600e-01_rb,9.9996e-01_rb /)
6236    ssaliq1(:, 29) = (/                                                         &
6237          8.505737e-01_rb,8.465102e-01_rb,8.394829e-01_rb,8.279508e-01_rb,      &
6238          8.110806e-01_rb,7.900397e-01_rb,7.669615e-01_rb,7.444422e-01_rb,      &
6239          7.253055e-01_rb,7.124831e-01_rb,7.016434e-01_rb,6.885485e-01_rb,      &
6240          6.767340e-01_rb,6.661029e-01_rb,6.565577e-01_rb,6.480013e-01_rb,      &
6241          6.403373e-01_rb,6.334697e-01_rb,6.273034e-01_rb,6.217440e-01_rb,      &
6242          6.166983e-01_rb,6.120740e-01_rb,6.077796e-01_rb,6.037249e-01_rb,      &
6243          5.998207e-01_rb,5.959788e-01_rb,5.921123e-01_rb,5.881354e-01_rb,      &
6244          5.891285e-01_rb,5.851143e-01_rb,5.814653e-01_rb,5.781606e-01_rb,      &
6245          5.751792e-01_rb,5.724998e-01_rb,5.701016e-01_rb,5.679634e-01_rb,      &
6246          5.660642e-01_rb,5.643829e-01_rb,5.628984e-01_rb,5.615898e-01_rb,      &
6247          5.604359e-01_rb,5.594158e-01_rb,5.585083e-01_rb,5.576924e-01_rb,      &
6248          5.569470e-01_rb,5.562512e-01_rb,5.555838e-01_rb,5.549239e-01_rb,      &
6249          5.542503e-01_rb,5.535420e-01_rb,5.527781e-01_rb,5.519374e-01_rb,      &
6250          5.509989e-01_rb,5.499417e-01_rb,5.487445e-01_rb,5.473865e-01_rb,      &
6251          5.458466e-01_rb,5.4410e-01_rb /)
6252 !
6253 ! asymmetry parameter
6254 !
6255    asyliq1(:, 16) = (/                                                         &
6256          8.133297e-01_rb,8.133528e-01_rb,8.173865e-01_rb,8.243205e-01_rb,      &
6257          8.333063e-01_rb,8.436317e-01_rb,8.546611e-01_rb,8.657934e-01_rb,      &
6258          8.764345e-01_rb,8.859837e-01_rb,8.627394e-01_rb,8.824569e-01_rb,      &
6259          8.976887e-01_rb,9.089541e-01_rb,9.167699e-01_rb,9.216517e-01_rb,      &
6260          9.241147e-01_rb,9.246743e-01_rb,9.238469e-01_rb,9.221504e-01_rb,      &
6261          9.201045e-01_rb,9.182299e-01_rb,9.170491e-01_rb,9.170862e-01_rb,      &
6262          9.188653e-01_rb,9.229111e-01_rb,9.297468e-01_rb,9.398950e-01_rb,      &
6263          9.203269e-01_rb,9.260693e-01_rb,9.309373e-01_rb,9.349918e-01_rb,      &
6264          9.382935e-01_rb,9.409030e-01_rb,9.428809e-01_rb,9.442881e-01_rb,      &
6265          9.451851e-01_rb,9.456331e-01_rb,9.456926e-01_rb,9.454247e-01_rb,      &
6266          9.448902e-01_rb,9.441503e-01_rb,9.432661e-01_rb,9.422987e-01_rb,      &
6267          9.413094e-01_rb,9.403594e-01_rb,9.395102e-01_rb,9.388230e-01_rb,      &
6268          9.383594e-01_rb,9.381810e-01_rb,9.383489e-01_rb,9.389251e-01_rb,      &
6269          9.399707e-01_rb,9.415475e-01_rb,9.437167e-01_rb,9.465399e-01_rb,      &
6270          9.500786e-01_rb,9.5439e-01_rb /)
6271    asyliq1(:, 17) = (/                                                         &
6272          8.794448e-01_rb,8.819306e-01_rb,8.837667e-01_rb,8.853832e-01_rb,      &
6273          8.871010e-01_rb,8.892675e-01_rb,8.922584e-01_rb,8.964666e-01_rb,      &
6274          9.022940e-01_rb,9.101456e-01_rb,8.839999e-01_rb,9.035610e-01_rb,      &
6275          9.184568e-01_rb,9.292315e-01_rb,9.364282e-01_rb,9.405887e-01_rb,      &
6276          9.422554e-01_rb,9.419703e-01_rb,9.402759e-01_rb,9.377159e-01_rb,      &
6277          9.348345e-01_rb,9.321769e-01_rb,9.302888e-01_rb,9.297166e-01_rb,      &
6278          9.310075e-01_rb,9.347080e-01_rb,9.413643e-01_rb,9.515216e-01_rb,      &
6279          9.306286e-01_rb,9.361781e-01_rb,9.408374e-01_rb,9.446692e-01_rb,      &
6280          9.477363e-01_rb,9.501013e-01_rb,9.518268e-01_rb,9.529756e-01_rb,      &
6281          9.536105e-01_rb,9.537938e-01_rb,9.535886e-01_rb,9.530574e-01_rb,      &
6282          9.522633e-01_rb,9.512688e-01_rb,9.501370e-01_rb,9.489306e-01_rb,      &
6283          9.477126e-01_rb,9.465459e-01_rb,9.454934e-01_rb,9.446183e-01_rb,      &
6284          9.439833e-01_rb,9.436519e-01_rb,9.436866e-01_rb,9.441508e-01_rb,      &
6285          9.451073e-01_rb,9.466195e-01_rb,9.487501e-01_rb,9.515621e-01_rb,      &
6286          9.551185e-01_rb,9.5948e-01_rb /)
6287    asyliq1(:, 18) = (/                                                         &
6288          8.478817e-01_rb,8.269312e-01_rb,8.161352e-01_rb,8.135960e-01_rb,      &
6289          8.173586e-01_rb,8.254167e-01_rb,8.357072e-01_rb,8.461167e-01_rb,      &
6290          8.544952e-01_rb,8.586776e-01_rb,8.335562e-01_rb,8.524273e-01_rb,      &
6291          8.669052e-01_rb,8.775014e-01_rb,8.847277e-01_rb,8.890958e-01_rb,      &
6292          8.911173e-01_rb,8.913038e-01_rb,8.901669e-01_rb,8.882182e-01_rb,      &
6293          8.859692e-01_rb,8.839315e-01_rb,8.826164e-01_rb,8.825356e-01_rb,      &
6294          8.842004e-01_rb,8.881223e-01_rb,8.948131e-01_rb,9.047837e-01_rb,      &
6295          8.855951e-01_rb,8.911796e-01_rb,8.959229e-01_rb,8.998837e-01_rb,      &
6296          9.031209e-01_rb,9.056939e-01_rb,9.076609e-01_rb,9.090812e-01_rb,      &
6297          9.100134e-01_rb,9.105167e-01_rb,9.106496e-01_rb,9.104712e-01_rb,      &
6298          9.100404e-01_rb,9.094159e-01_rb,9.086568e-01_rb,9.078218e-01_rb,      &
6299          9.069697e-01_rb,9.061595e-01_rb,9.054499e-01_rb,9.048999e-01_rb,      &
6300          9.045683e-01_rb,9.045142e-01_rb,9.047962e-01_rb,9.054730e-01_rb,      &
6301          9.066037e-01_rb,9.082472e-01_rb,9.104623e-01_rb,9.133079e-01_rb,      &
6302          9.168427e-01_rb,9.2113e-01_rb /)
6303    asyliq1(:, 19) = (/                                                         &
6304          8.216697e-01_rb,7.982871e-01_rb,7.891147e-01_rb,7.909083e-01_rb,      &
6305          8.003833e-01_rb,8.142516e-01_rb,8.292290e-01_rb,8.420356e-01_rb,      &
6306          8.493945e-01_rb,8.480316e-01_rb,8.212381e-01_rb,8.394984e-01_rb,      &
6307          8.534095e-01_rb,8.634813e-01_rb,8.702242e-01_rb,8.741483e-01_rb,      &
6308          8.757638e-01_rb,8.755808e-01_rb,8.741095e-01_rb,8.718604e-01_rb,      &
6309          8.693433e-01_rb,8.670686e-01_rb,8.655464e-01_rb,8.652872e-01_rb,      &
6310          8.668006e-01_rb,8.705973e-01_rb,8.771874e-01_rb,8.870809e-01_rb,      &
6311          8.678284e-01_rb,8.732315e-01_rb,8.778084e-01_rb,8.816166e-01_rb,      &
6312          8.847146e-01_rb,8.871603e-01_rb,8.890116e-01_rb,8.903266e-01_rb,      &
6313          8.911632e-01_rb,8.915796e-01_rb,8.916337e-01_rb,8.913834e-01_rb,      &
6314          8.908869e-01_rb,8.902022e-01_rb,8.893873e-01_rb,8.885001e-01_rb,      &
6315          8.875986e-01_rb,8.867411e-01_rb,8.859852e-01_rb,8.853891e-01_rb,      &
6316          8.850111e-01_rb,8.849089e-01_rb,8.851405e-01_rb,8.857639e-01_rb,      &
6317          8.868372e-01_rb,8.884185e-01_rb,8.905656e-01_rb,8.933368e-01_rb,      &
6318          8.967899e-01_rb,9.0098e-01_rb /)
6319    asyliq1(:, 20) = (/                                                         &
6320          8.063610e-01_rb,7.938147e-01_rb,7.921304e-01_rb,7.985092e-01_rb,      &
6321          8.101339e-01_rb,8.242175e-01_rb,8.379913e-01_rb,8.486920e-01_rb,      &
6322          8.535547e-01_rb,8.498083e-01_rb,8.224849e-01_rb,8.405509e-01_rb,      &
6323          8.542436e-01_rb,8.640770e-01_rb,8.705653e-01_rb,8.742227e-01_rb,      &
6324          8.755630e-01_rb,8.751004e-01_rb,8.733491e-01_rb,8.708231e-01_rb,      &
6325          8.680365e-01_rb,8.655035e-01_rb,8.637381e-01_rb,8.632544e-01_rb,      &
6326          8.645665e-01_rb,8.681885e-01_rb,8.746346e-01_rb,8.844188e-01_rb,      &
6327          8.648180e-01_rb,8.700563e-01_rb,8.744672e-01_rb,8.781087e-01_rb,      &
6328          8.810393e-01_rb,8.833174e-01_rb,8.850011e-01_rb,8.861485e-01_rb,      &
6329          8.868183e-01_rb,8.870687e-01_rb,8.869579e-01_rb,8.865441e-01_rb,      &
6330          8.858857e-01_rb,8.850412e-01_rb,8.840686e-01_rb,8.830263e-01_rb,      &
6331          8.819726e-01_rb,8.809658e-01_rb,8.800642e-01_rb,8.793260e-01_rb,      &
6332          8.788099e-01_rb,8.785737e-01_rb,8.786758e-01_rb,8.791746e-01_rb,      &
6333          8.801283e-01_rb,8.815955e-01_rb,8.836340e-01_rb,8.863024e-01_rb,      &
6334          8.896592e-01_rb,8.9376e-01_rb /)
6335    asyliq1(:, 21) = (/                                                         &
6336          7.885899e-01_rb,7.937172e-01_rb,8.020658e-01_rb,8.123971e-01_rb,      &
6337          8.235502e-01_rb,8.343776e-01_rb,8.437336e-01_rb,8.504711e-01_rb,      &
6338          8.534421e-01_rb,8.514978e-01_rb,8.238888e-01_rb,8.417463e-01_rb,      &
6339          8.552057e-01_rb,8.647853e-01_rb,8.710038e-01_rb,8.743798e-01_rb,      &
6340          8.754319e-01_rb,8.746786e-01_rb,8.726386e-01_rb,8.698303e-01_rb,      &
6341          8.667724e-01_rb,8.639836e-01_rb,8.619823e-01_rb,8.612870e-01_rb,      &
6342          8.624165e-01_rb,8.658893e-01_rb,8.722241e-01_rb,8.819394e-01_rb,      &
6343          8.620216e-01_rb,8.671239e-01_rb,8.713983e-01_rb,8.749032e-01_rb,      &
6344          8.776970e-01_rb,8.798385e-01_rb,8.813860e-01_rb,8.823980e-01_rb,      &
6345          8.829332e-01_rb,8.830500e-01_rb,8.828068e-01_rb,8.822623e-01_rb,      &
6346          8.814750e-01_rb,8.805031e-01_rb,8.794056e-01_rb,8.782407e-01_rb,      &
6347          8.770672e-01_rb,8.759432e-01_rb,8.749275e-01_rb,8.740784e-01_rb,      &
6348          8.734547e-01_rb,8.731146e-01_rb,8.731170e-01_rb,8.735199e-01_rb,      &
6349          8.743823e-01_rb,8.757625e-01_rb,8.777191e-01_rb,8.803105e-01_rb,      &
6350          8.835953e-01_rb,8.8763e-01_rb /)
6351    asyliq1(:, 22) = (/                                                         &
6352          7.811516e-01_rb,7.962229e-01_rb,8.096199e-01_rb,8.212996e-01_rb,      &
6353          8.312212e-01_rb,8.393430e-01_rb,8.456236e-01_rb,8.500214e-01_rb,      &
6354          8.524950e-01_rb,8.530031e-01_rb,8.251485e-01_rb,8.429043e-01_rb,      &
6355          8.562461e-01_rb,8.656954e-01_rb,8.717737e-01_rb,8.750020e-01_rb,      &
6356          8.759022e-01_rb,8.749953e-01_rb,8.728027e-01_rb,8.698461e-01_rb,      &
6357          8.666466e-01_rb,8.637257e-01_rb,8.616047e-01_rb,8.608051e-01_rb,      &
6358          8.618483e-01_rb,8.652557e-01_rb,8.715487e-01_rb,8.812485e-01_rb,      &
6359          8.611645e-01_rb,8.662052e-01_rb,8.704173e-01_rb,8.738594e-01_rb,      &
6360          8.765901e-01_rb,8.786678e-01_rb,8.801517e-01_rb,8.810999e-01_rb,      &
6361          8.815713e-01_rb,8.816246e-01_rb,8.813185e-01_rb,8.807114e-01_rb,      &
6362          8.798621e-01_rb,8.788290e-01_rb,8.776713e-01_rb,8.764470e-01_rb,      &
6363          8.752152e-01_rb,8.740343e-01_rb,8.729631e-01_rb,8.720602e-01_rb,      &
6364          8.713842e-01_rb,8.709936e-01_rb,8.709475e-01_rb,8.713041e-01_rb,      &
6365          8.721221e-01_rb,8.734602e-01_rb,8.753774e-01_rb,8.779319e-01_rb,      &
6366          8.811825e-01_rb,8.8519e-01_rb /)
6367    asyliq1(:, 23) = (/                                                         &
6368          7.865744e-01_rb,8.093340e-01_rb,8.257596e-01_rb,8.369940e-01_rb,      &
6369          8.441574e-01_rb,8.483602e-01_rb,8.507096e-01_rb,8.523139e-01_rb,      &
6370          8.542834e-01_rb,8.577321e-01_rb,8.288960e-01_rb,8.465308e-01_rb,      &
6371          8.597175e-01_rb,8.689830e-01_rb,8.748542e-01_rb,8.778584e-01_rb,      &
6372          8.785222e-01_rb,8.773728e-01_rb,8.749370e-01_rb,8.717419e-01_rb,      &
6373          8.683145e-01_rb,8.651816e-01_rb,8.628704e-01_rb,8.619077e-01_rb,      &
6374          8.628205e-01_rb,8.661356e-01_rb,8.723803e-01_rb,8.820815e-01_rb,      &
6375          8.616715e-01_rb,8.666389e-01_rb,8.707753e-01_rb,8.741398e-01_rb,      &
6376          8.767912e-01_rb,8.787885e-01_rb,8.801908e-01_rb,8.810570e-01_rb,      &
6377          8.814460e-01_rb,8.814167e-01_rb,8.810283e-01_rb,8.803395e-01_rb,      &
6378          8.794095e-01_rb,8.782971e-01_rb,8.770613e-01_rb,8.757610e-01_rb,      &
6379          8.744553e-01_rb,8.732031e-01_rb,8.720634e-01_rb,8.710951e-01_rb,      &
6380          8.703572e-01_rb,8.699086e-01_rb,8.698084e-01_rb,8.701155e-01_rb,      &
6381          8.708887e-01_rb,8.721872e-01_rb,8.740698e-01_rb,8.765957e-01_rb,      &
6382          8.798235e-01_rb,8.8381e-01_rb /)
6383    asyliq1(:, 24) = (/                                                         &
6384          8.069513e-01_rb,8.262939e-01_rb,8.398241e-01_rb,8.486352e-01_rb,      &
6385          8.538213e-01_rb,8.564743e-01_rb,8.576854e-01_rb,8.585455e-01_rb,      &
6386          8.601452e-01_rb,8.635755e-01_rb,8.337383e-01_rb,8.512655e-01_rb,      &
6387          8.643049e-01_rb,8.733896e-01_rb,8.790535e-01_rb,8.818295e-01_rb,      &
6388          8.822518e-01_rb,8.808533e-01_rb,8.781676e-01_rb,8.747284e-01_rb,      &
6389          8.710690e-01_rb,8.677229e-01_rb,8.652236e-01_rb,8.641047e-01_rb,      &
6390          8.648993e-01_rb,8.681413e-01_rb,8.743640e-01_rb,8.841007e-01_rb,      &
6391          8.633558e-01_rb,8.682719e-01_rb,8.723543e-01_rb,8.756621e-01_rb,      &
6392          8.782547e-01_rb,8.801915e-01_rb,8.815318e-01_rb,8.823347e-01_rb,      &
6393          8.826598e-01_rb,8.825663e-01_rb,8.821135e-01_rb,8.813608e-01_rb,      &
6394          8.803674e-01_rb,8.791928e-01_rb,8.778960e-01_rb,8.765366e-01_rb,      &
6395          8.751738e-01_rb,8.738670e-01_rb,8.726755e-01_rb,8.716585e-01_rb,      &
6396          8.708755e-01_rb,8.703856e-01_rb,8.702483e-01_rb,8.705229e-01_rb,      &
6397          8.712687e-01_rb,8.725448e-01_rb,8.744109e-01_rb,8.769260e-01_rb,      &
6398          8.801496e-01_rb,8.8414e-01_rb /)
6399    asyliq1(:, 25) = (/                                                         &
6400          8.252182e-01_rb,8.379244e-01_rb,8.471709e-01_rb,8.535760e-01_rb,      &
6401          8.577540e-01_rb,8.603183e-01_rb,8.618820e-01_rb,8.630578e-01_rb,      &
6402          8.644587e-01_rb,8.666970e-01_rb,8.362159e-01_rb,8.536817e-01_rb,      &
6403          8.666387e-01_rb,8.756240e-01_rb,8.811746e-01_rb,8.838273e-01_rb,      &
6404          8.841191e-01_rb,8.825871e-01_rb,8.797681e-01_rb,8.761992e-01_rb,      &
6405          8.724174e-01_rb,8.689593e-01_rb,8.663623e-01_rb,8.651632e-01_rb,      &
6406          8.658988e-01_rb,8.691064e-01_rb,8.753226e-01_rb,8.850847e-01_rb,      &
6407          8.641620e-01_rb,8.690500e-01_rb,8.731026e-01_rb,8.763795e-01_rb,      &
6408          8.789400e-01_rb,8.808438e-01_rb,8.821503e-01_rb,8.829191e-01_rb,      &
6409          8.832095e-01_rb,8.830813e-01_rb,8.825938e-01_rb,8.818064e-01_rb,      &
6410          8.807787e-01_rb,8.795704e-01_rb,8.782408e-01_rb,8.768493e-01_rb,      &
6411          8.754557e-01_rb,8.741193e-01_rb,8.728995e-01_rb,8.718561e-01_rb,      &
6412          8.710484e-01_rb,8.705360e-01_rb,8.703782e-01_rb,8.706347e-01_rb,      &
6413          8.713650e-01_rb,8.726285e-01_rb,8.744849e-01_rb,8.769933e-01_rb,      &
6414          8.802136e-01_rb,8.8421e-01_rb /)
6415    asyliq1(:, 26) = (/                                                         &
6416          8.370583e-01_rb,8.467920e-01_rb,8.537769e-01_rb,8.585136e-01_rb,      &
6417          8.615034e-01_rb,8.632474e-01_rb,8.642468e-01_rb,8.650026e-01_rb,      &
6418          8.660161e-01_rb,8.677882e-01_rb,8.369760e-01_rb,8.543821e-01_rb,      &
6419          8.672699e-01_rb,8.761782e-01_rb,8.816454e-01_rb,8.842103e-01_rb,      &
6420          8.844114e-01_rb,8.827872e-01_rb,8.798766e-01_rb,8.762179e-01_rb,      &
6421          8.723500e-01_rb,8.688112e-01_rb,8.661403e-01_rb,8.648758e-01_rb,      &
6422          8.655563e-01_rb,8.687206e-01_rb,8.749072e-01_rb,8.846546e-01_rb,      &
6423          8.636289e-01_rb,8.684849e-01_rb,8.725054e-01_rb,8.757501e-01_rb,      &
6424          8.782785e-01_rb,8.801503e-01_rb,8.814249e-01_rb,8.821620e-01_rb,      &
6425          8.824211e-01_rb,8.822620e-01_rb,8.817440e-01_rb,8.809268e-01_rb,      &
6426          8.798699e-01_rb,8.786330e-01_rb,8.772756e-01_rb,8.758572e-01_rb,      &
6427          8.744374e-01_rb,8.730760e-01_rb,8.718323e-01_rb,8.707660e-01_rb,      &
6428          8.699366e-01_rb,8.694039e-01_rb,8.692271e-01_rb,8.694661e-01_rb,      &
6429          8.701803e-01_rb,8.714293e-01_rb,8.732727e-01_rb,8.757702e-01_rb,      &
6430          8.789811e-01_rb,8.8297e-01_rb /)
6431    asyliq1(:, 27) = (/                                                         &
6432          8.430819e-01_rb,8.510060e-01_rb,8.567270e-01_rb,8.606533e-01_rb,      &
6433          8.631934e-01_rb,8.647554e-01_rb,8.657471e-01_rb,8.665760e-01_rb,      &
6434          8.676496e-01_rb,8.693754e-01_rb,8.384298e-01_rb,8.557913e-01_rb,      &
6435          8.686214e-01_rb,8.774605e-01_rb,8.828495e-01_rb,8.853287e-01_rb,      &
6436          8.854393e-01_rb,8.837215e-01_rb,8.807161e-01_rb,8.769639e-01_rb,      &
6437          8.730053e-01_rb,8.693812e-01_rb,8.666321e-01_rb,8.652988e-01_rb,      &
6438          8.659219e-01_rb,8.690419e-01_rb,8.751999e-01_rb,8.849360e-01_rb,      &
6439          8.638013e-01_rb,8.686371e-01_rb,8.726369e-01_rb,8.758605e-01_rb,      &
6440          8.783674e-01_rb,8.802176e-01_rb,8.814705e-01_rb,8.821859e-01_rb,      &
6441          8.824234e-01_rb,8.822429e-01_rb,8.817038e-01_rb,8.808658e-01_rb,      &
6442          8.797887e-01_rb,8.785323e-01_rb,8.771560e-01_rb,8.757196e-01_rb,      &
6443          8.742828e-01_rb,8.729052e-01_rb,8.716467e-01_rb,8.705666e-01_rb,      &
6444          8.697250e-01_rb,8.691812e-01_rb,8.689950e-01_rb,8.692264e-01_rb,      &
6445          8.699346e-01_rb,8.711795e-01_rb,8.730209e-01_rb,8.755181e-01_rb,      &
6446          8.787312e-01_rb,8.8272e-01_rb /)
6447    asyliq1(:, 28) = (/                                                         &
6448          8.452284e-01_rb,8.522700e-01_rb,8.572973e-01_rb,8.607031e-01_rb,      &
6449          8.628802e-01_rb,8.642215e-01_rb,8.651198e-01_rb,8.659679e-01_rb,      &
6450          8.671588e-01_rb,8.690853e-01_rb,8.383803e-01_rb,8.557485e-01_rb,      &
6451          8.685851e-01_rb,8.774303e-01_rb,8.828245e-01_rb,8.853077e-01_rb,      &
6452          8.854207e-01_rb,8.837034e-01_rb,8.806962e-01_rb,8.769398e-01_rb,      &
6453          8.729740e-01_rb,8.693393e-01_rb,8.665761e-01_rb,8.652247e-01_rb,      &
6454          8.658253e-01_rb,8.689182e-01_rb,8.750438e-01_rb,8.847424e-01_rb,      &
6455          8.636140e-01_rb,8.684449e-01_rb,8.724400e-01_rb,8.756589e-01_rb,      &
6456          8.781613e-01_rb,8.800072e-01_rb,8.812559e-01_rb,8.819671e-01_rb,      &
6457          8.822007e-01_rb,8.820165e-01_rb,8.814737e-01_rb,8.806322e-01_rb,      &
6458          8.795518e-01_rb,8.782923e-01_rb,8.769129e-01_rb,8.754737e-01_rb,      &
6459          8.740342e-01_rb,8.726542e-01_rb,8.713934e-01_rb,8.703111e-01_rb,      &
6460          8.694677e-01_rb,8.689222e-01_rb,8.687344e-01_rb,8.689646e-01_rb,      &
6461          8.696715e-01_rb,8.709156e-01_rb,8.727563e-01_rb,8.752531e-01_rb,      &
6462          8.784659e-01_rb,8.8245e-01_rb /)
6463    asyliq1(:, 29) = (/                                                         &
6464          7.800869e-01_rb,8.091120e-01_rb,8.325369e-01_rb,8.466266e-01_rb,      &
6465          8.515495e-01_rb,8.499371e-01_rb,8.456203e-01_rb,8.430521e-01_rb,      &
6466          8.470286e-01_rb,8.625431e-01_rb,8.402261e-01_rb,8.610822e-01_rb,      &
6467          8.776608e-01_rb,8.904485e-01_rb,8.999294e-01_rb,9.065860e-01_rb,      &
6468          9.108995e-01_rb,9.133503e-01_rb,9.144187e-01_rb,9.145855e-01_rb,      &
6469          9.143320e-01_rb,9.141402e-01_rb,9.144933e-01_rb,9.158754e-01_rb,      &
6470          9.187716e-01_rb,9.236677e-01_rb,9.310503e-01_rb,9.414058e-01_rb,      &
6471          9.239108e-01_rb,9.300719e-01_rb,9.353612e-01_rb,9.398378e-01_rb,      &
6472          9.435609e-01_rb,9.465895e-01_rb,9.489829e-01_rb,9.508000e-01_rb,      &
6473          9.521002e-01_rb,9.529424e-01_rb,9.533860e-01_rb,9.534902e-01_rb,      &
6474          9.533143e-01_rb,9.529177e-01_rb,9.523596e-01_rb,9.516997e-01_rb,      &
6475          9.509973e-01_rb,9.503121e-01_rb,9.497037e-01_rb,9.492317e-01_rb,      &
6476          9.489558e-01_rb,9.489356e-01_rb,9.492311e-01_rb,9.499019e-01_rb,      &
6477          9.510077e-01_rb,9.526084e-01_rb,9.547636e-01_rb,9.575331e-01_rb,      &
6478          9.609766e-01_rb,9.6515e-01_rb /)
6479 !
6480 ! Spherical Ice Particle Parameterization
6481 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
6482 !
6483    extice2(:, 16) = (/                                                         &
6484 ! band 16
6485          4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb,      &
6486          1.063406e-01_rb,8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb,      &
6487          5.970353e-02_rb,5.375249e-02_rb,4.887577e-02_rb,4.481025e-02_rb,      &
6488          4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,3.365396e-02_rb,      &
6489          3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb,      &
6490          2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb,      &
6491          2.175276e-02_rb,2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb,      &
6492          1.888412e-02_rb,1.829018e-02_rb,1.773586e-02_rb,1.721738e-02_rb,      &
6493          1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,1.544122e-02_rb,      &
6494          1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb,      &
6495          1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /)
6496    extice2(:, 17) = (/                                                         &
6497 ! band 17
6498          3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb,      &
6499          1.031602e-01_rb,8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb,      &
6500          5.900909e-02_rb,5.328833e-02_rb,4.857728e-02_rb,4.463133e-02_rb,      &
6501          4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,3.369280e-02_rb,      &
6502          3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb,      &
6503          2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb,      &
6504          2.175571e-02_rb,2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb,      &
6505          1.881278e-02_rb,1.819901e-02_rb,1.762463e-02_rb,1.708598e-02_rb,      &
6506          1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,1.522937e-02_rb,      &
6507          1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb,      &
6508          1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /)
6509    extice2(:, 18) = (/                                                         &
6510 ! band 18
6511          4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb,      &
6512          1.047528e-01_rb,8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb,      &
6513          5.844616e-02_rb,5.259609e-02_rb,4.781531e-02_rb,4.383980e-02_rb,      &
6514          4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,3.298525e-02_rb,      &
6515          3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb,      &
6516          2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb,      &
6517          2.152164e-02_rb,2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb,      &
6518          1.878296e-02_rb,1.821744e-02_rb,1.769015e-02_rb,1.719741e-02_rb,      &
6519          1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,1.551298e-02_rb,      &
6520          1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb,      &
6521          1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /)
6522    extice2(:, 19) = (/                                                         &
6523 ! band 19
6524          3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb,      &
6525          1.038247e-01_rb,8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb,      &
6526          5.892850e-02_rb,5.313885e-02_rb,4.838068e-02_rb,4.440356e-02_rb,      &
6527          4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,3.343269e-02_rb,      &
6528          3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb,      &
6529          2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb,      &
6530          2.160789e-02_rb,2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb,      &
6531          1.873177e-02_rb,1.813469e-02_rb,1.757689e-02_rb,1.705468e-02_rb,      &
6532          1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,1.526192e-02_rb,      &
6533          1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb,      &
6534          1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /)
6535    extice2(:, 20) = (/                                                         &
6536 ! band 20
6537          3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb,      &
6538          1.028944e-01_rb,8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb,      &
6539          5.866714e-02_rb,5.293694e-02_rb,4.822153e-02_rb,4.427547e-02_rb,      &
6540          4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,3.336440e-02_rb,      &
6541          3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb,      &
6542          2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb,      &
6543          2.154821e-02_rb,2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb,      &
6544          1.866212e-02_rb,1.806221e-02_rb,1.750152e-02_rb,1.697637e-02_rb,      &
6545          1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,1.517172e-02_rb,      &
6546          1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb,      &
6547          1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /)
6548    extice2(:, 21) = (/                                                         &
6549 ! band 21
6550          3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb,      &
6551          1.019462e-01_rb,8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb,      &
6552          5.830218e-02_rb,5.263421e-02_rb,4.796697e-02_rb,4.405891e-02_rb,      &
6553          4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,3.324008e-02_rb,      &
6554          3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb,      &
6555          2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb,      &
6556          2.149614e-02_rb,2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb,      &
6557          1.862174e-02_rb,1.802389e-02_rb,1.746500e-02_rb,1.694142e-02_rb,      &
6558          1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,1.514129e-02_rb,      &
6559          1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb,      &
6560          1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /)
6561    extice2(:, 22) = (/                                                         &
6562 ! band 22
6563          3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb,      &
6564          1.016109e-01_rb,8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb,      &
6565          5.810290e-02_rb,5.245608e-02_rb,4.780702e-02_rb,4.391478e-02_rb,      &
6566          4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,3.314296e-02_rb,      &
6567          3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb,      &
6568          2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb,      &
6569          2.145688e-02_rb,2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb,      &
6570          1.859808e-02_rb,1.800356e-02_rb,1.744782e-02_rb,1.692721e-02_rb,      &
6571          1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,1.513751e-02_rb,      &
6572          1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb,      &
6573          1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /)
6574    extice2(:, 23) = (/                                                         &
6575 ! band 23
6576          3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb,      &
6577          1.004203e-01_rb,8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb,      &
6578          5.776176e-02_rb,5.219398e-02_rb,4.760288e-02_rb,4.375369e-02_rb,      &
6579          4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,3.307079e-02_rb,      &
6580          3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb,      &
6581          2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb,      &
6582          2.141556e-02_rb,2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb,      &
6583          1.855009e-02_rb,1.795330e-02_rb,1.739514e-02_rb,1.687199e-02_rb,      &
6584          1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,1.507143e-02_rb,      &
6585          1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb,      &
6586          1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /)
6587    extice2(:, 24) = (/                                                         &
6588 ! band 24
6589          3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb,      &
6590          9.955787e-02_rb,8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb,      &
6591          5.751081e-02_rb,5.199888e-02_rb,4.744835e-02_rb,4.362899e-02_rb,      &
6592          4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,3.300546e-02_rb,      &
6593          3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb,      &
6594          2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb,      &
6595          2.136402e-02_rb,2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb,      &
6596          1.849087e-02_rb,1.789178e-02_rb,1.733124e-02_rb,1.680565e-02_rb,      &
6597          1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,1.499502e-02_rb,      &
6598          1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb,      &
6599          1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /)
6600    extice2(:, 25) = (/                                                         &
6601 ! band 25
6602          3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb,      &
6603          9.881779e-02_rb,8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb,      &
6604          5.723183e-02_rb,5.176908e-02_rb,4.725658e-02_rb,4.346715e-02_rb,      &
6605          4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,3.291583e-02_rb,      &
6606          3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb,      &
6607          2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb,      &
6608          2.132934e-02_rb,2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb,      &
6609          1.846448e-02_rb,1.786680e-02_rb,1.730745e-02_rb,1.678289e-02_rb,      &
6610          1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,1.497499e-02_rb,      &
6611          1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb,      &
6612          1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /)
6613    extice2(:, 26) = (/                                                         &
6614 ! band 26
6615          3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb,      &
6616          9.838078e-02_rb,8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb,      &
6617          5.703770e-02_rb,5.160290e-02_rb,4.711259e-02_rb,4.334110e-02_rb,      &
6618          4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,3.283589e-02_rb,      &
6619          3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb,      &
6620          2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb,      &
6621          2.129165e-02_rb,2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb,      &
6622          1.843542e-02_rb,1.783943e-02_rb,1.728162e-02_rb,1.675847e-02_rb,      &
6623          1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,1.495515e-02_rb,      &
6624          1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb,      &
6625          1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /)
6626    extice2(:, 27) = (/                                                         &
6627 ! band 27
6628          3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb,      &
6629          9.790253e-02_rb,8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb,      &
6630          5.687024e-02_rb,5.146670e-02_rb,4.700001e-02_rb,4.324667e-02_rb,      &
6631          4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,3.278257e-02_rb,      &
6632          3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb,      &
6633          2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb,      &
6634          2.126273e-02_rb,2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb,      &
6635          1.840801e-02_rb,1.781204e-02_rb,1.725417e-02_rb,1.673086e-02_rb,      &
6636          1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,1.492634e-02_rb,      &
6637          1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb,      &
6638          1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /)
6639    extice2(:, 28) = (/                                                         &
6640 ! band 28
6641          3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb,      &
6642          9.804612e-02_rb,8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb,      &
6643          5.697710e-02_rb,5.156460e-02_rb,4.708957e-02_rb,4.332850e-02_rb,      &
6644          4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,3.283879e-02_rb,      &
6645          3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb,      &
6646          2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb,      &
6647          2.128195e-02_rb,2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb,      &
6648          1.841614e-02_rb,1.781774e-02_rb,1.725754e-02_rb,1.673203e-02_rb,      &
6649          1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,1.491958e-02_rb,      &
6650          1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb,      &
6651          1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /)
6652    extice2(:, 29) = (/                                                         &
6653 ! band 29
6654          4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb,      &
6655          1.102161e-01_rb,9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb,      &
6656          6.260168e-02_rb,5.645603e-02_rb,5.139732e-02_rb,4.716088e-02_rb,      &
6657          4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,3.541094e-02_rb,      &
6658          3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb,      &
6659          2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb,      &
6660          2.253072e-02_rb,2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb,      &
6661          1.933015e-02_rb,1.866041e-02_rb,1.803283e-02_rb,1.744348e-02_rb,      &
6662          1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,1.540539e-02_rb,      &
6663          1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb,      &
6664          1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /)
6665 !
6666 ! single-scattering albedo: unitless
6667 !
6668    ssaice2(:, 16) = (/                                                         &
6669 ! band 16
6670          6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb,      &
6671          6.178420e-01_rb,6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb,      &
6672          5.995830e-01_rb,5.963030e-01_rb,5.933372e-01_rb,5.906311e-01_rb,      &
6673          5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,5.816896e-01_rb,      &
6674          5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb,      &
6675          5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb,      &
6676          5.677571e-01_rb,5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb,      &
6677          5.630643e-01_rb,5.619850e-01_rb,5.609381e-01_rb,5.599214e-01_rb,      &
6678          5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,5.561193e-01_rb,      &
6679          5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb,      &
6680          5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /)
6681    ssaice2(:, 17) = (/                                                         &
6682 ! band 17
6683          7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb,      &
6684          6.956928e-01_rb,6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb,      &
6685          6.679838e-01_rb,6.632742e-01_rb,6.591036e-01_rb,6.553766e-01_rb,      &
6686          6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,6.436531e-01_rb,      &
6687          6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb,      &
6688          6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb,      &
6689          6.274512e-01_rb,6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb,      &
6690          6.225953e-01_rb,6.215201e-01_rb,6.204914e-01_rb,6.195055e-01_rb,      &
6691          6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,6.159280e-01_rb,      &
6692          6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb,      &
6693          6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /)
6694    ssaice2(:, 18) = (/                                                         &
6695 ! band 18
6696          9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb,      &
6697          9.577179e-01_rb,9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb,      &
6698          9.399467e-01_rb,9.365708e-01_rb,9.334672e-01_rb,9.305921e-01_rb,      &
6699          9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,9.207954e-01_rb,      &
6700          9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb,      &
6701          9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb,      &
6702          9.046406e-01_rb,9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb,      &
6703          8.989804e-01_rb,8.976655e-01_rb,8.963857e-01_rb,8.951389e-01_rb,      &
6704          8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,8.904464e-01_rb,      &
6705          8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb,      &
6706          8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /)
6707    ssaice2(:, 19) = (/                                                         &
6708 ! band 19
6709          9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb,      &
6710          9.014238e-01_rb,8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb,      &
6711          8.701736e-01_rb,8.643950e-01_rb,8.591299e-01_rb,8.542942e-01_rb,      &
6712          8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,8.381324e-01_rb,      &
6713          8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb,      &
6714          8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb,      &
6715          8.126403e-01_rb,8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb,      &
6716          8.040765e-01_rb,8.021156e-01_rb,8.002174e-01_rb,7.983781e-01_rb,      &
6717          7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,7.915432e-01_rb,      &
6718          7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb,      &
6719          7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /)
6720    ssaice2(:, 20) = (/                                                         &
6721 ! band 20
6722          9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb,      &
6723          9.743652e-01_rb,9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb,      &
6724          9.659531e-01_rb,9.643915e-01_rb,9.629667e-01_rb,9.616561e-01_rb,      &
6725          9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,9.572607e-01_rb,      &
6726          9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb,      &
6727          9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb,      &
6728          9.502643e-01_rb,9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb,      &
6729          9.478910e-01_rb,9.473456e-01_rb,9.468169e-01_rb,9.463039e-01_rb,      &
6730          9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,9.443910e-01_rb,      &
6731          9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb,      &
6732          9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /)
6733    ssaice2(:, 21) = (/                                                         &
6734 ! band 21
6735          9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb,      &
6736          9.710184e-01_rb,9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb,      &
6737          9.623352e-01_rb,9.607083e-01_rb,9.592198e-01_rb,9.578474e-01_rb,      &
6738          9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,9.532226e-01_rb,      &
6739          9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb,      &
6740          9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb,      &
6741          9.457985e-01_rb,9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb,      &
6742          9.432656e-01_rb,9.426826e-01_rb,9.421173e-01_rb,9.415684e-01_rb,      &
6743          9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,9.395198e-01_rb,      &
6744          9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb,      &
6745          9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /)
6746    ssaice2(:, 22) = (/                                                         &
6747 ! band 22
6748          9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb,      &
6749          9.981606e-01_rb,9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb,      &
6750          9.977691e-01_rb,9.976798e-01_rb,9.975929e-01_rb,9.975081e-01_rb,      &
6751          9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,9.971855e-01_rb,      &
6752          9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb,      &
6753          9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb,      &
6754          9.965250e-01_rb,9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb,      &
6755          9.962508e-01_rb,9.961836e-01_rb,9.961170e-01_rb,9.960508e-01_rb,      &
6756          9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,9.957906e-01_rb,      &
6757          9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb,      &
6758          9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /)
6759    ssaice2(:, 23) = (/                                                         &
6760 ! band 23
6761          9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb,      &
6762          9.997436e-01_rb,9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb,      &
6763          9.996999e-01_rb,9.996886e-01_rb,9.996771e-01_rb,9.996653e-01_rb,      &
6764          9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,9.996152e-01_rb,      &
6765          9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb,      &
6766          9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb,      &
6767          9.994831e-01_rb,9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb,      &
6768          9.994154e-01_rb,9.993976e-01_rb,9.993795e-01_rb,9.993610e-01_rb,      &
6769          9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,9.992837e-01_rb,      &
6770          9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb,      &
6771          9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /)
6772    ssaice2(:, 24) = (/                                                         &
6773 ! band 24
6774          9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb,      &
6775          9.999934e-01_rb,9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb,      &
6776          9.999904e-01_rb,9.999895e-01_rb,9.999885e-01_rb,9.999874e-01_rb,      &
6777          9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,9.999824e-01_rb,      &
6778          9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb,      &
6779          9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb,      &
6780          9.999673e-01_rb,9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb,      &
6781          9.999589e-01_rb,9.999566e-01_rb,9.999543e-01_rb,9.999519e-01_rb,      &
6782          9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,9.999418e-01_rb,      &
6783          9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb,      &
6784          9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /)
6785    ssaice2(:, 25) = (/                                                         &
6786 ! band 25
6787          9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb,      &
6788          9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb,      &
6789          9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999989e-01_rb,      &
6790          9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,      &
6791          9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,      &
6792          9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb,      &
6793          9.999969e-01_rb,9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb,      &
6794          9.999960e-01_rb,9.999957e-01_rb,9.999955e-01_rb,9.999953e-01_rb,      &
6795          9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,9.999942e-01_rb,      &
6796          9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb,      &
6797          9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /)
6798    ssaice2(:, 26) = (/                                                         &
6799 ! band 26
6800          9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,      &
6801          9.999994e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,      &
6802          9.999990e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,      &
6803          9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,      &
6804          9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb,      &
6805          9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb,      &
6806          9.999956e-01_rb,9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb,      &
6807          9.999944e-01_rb,9.999941e-01_rb,9.999938e-01_rb,9.999934e-01_rb,      &
6808          9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,9.999920e-01_rb,      &
6809          9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb,      &
6810          9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /)
6811    ssaice2(:, 27) = (/                                                         &
6812 ! band 27
6813          9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb,      &
6814          9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,      &
6815          9.999973e-01_rb,9.999970e-01_rb,9.999967e-01_rb,9.999964e-01_rb,      &
6816          9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,9.999948e-01_rb,      &
6817          9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb,      &
6818          9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb,      &
6819          9.999901e-01_rb,9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb,      &
6820          9.999874e-01_rb,9.999867e-01_rb,9.999860e-01_rb,9.999853e-01_rb,      &
6821          9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,9.999821e-01_rb,      &
6822          9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb,      &
6823          9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /)
6824    ssaice2(:, 28) = (/                                                         &
6825 ! band 28
6826          9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,      &
6827          9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,      &
6828          9.999975e-01_rb,9.999972e-01_rb,9.999969e-01_rb,9.999966e-01_rb,      &
6829          9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,9.999950e-01_rb,      &
6830          9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb,      &
6831          9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,      &
6832          9.999902e-01_rb,9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb,      &
6833          9.999876e-01_rb,9.999869e-01_rb,9.999861e-01_rb,9.999854e-01_rb,      &
6834          9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,9.999822e-01_rb,      &
6835          9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb,      &
6836          9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /)
6837    ssaice2(:, 29) = (/                                                         &
6838 ! band 29
6839          7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb,      &
6840          6.166381e-01_rb,6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb,      &
6841          5.826968e-01_rb,5.767343e-01_rb,5.713804e-01_rb,5.665256e-01_rb,      &
6842          5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,5.506794e-01_rb,      &
6843          5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb,      &
6844          5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb,      &
6845          5.263988e-01_rb,5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb,      &
6846          5.182280e-01_rb,5.163410e-01_rb,5.145062e-01_rb,5.127197e-01_rb,      &
6847          5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,5.059860e-01_rb,      &
6848          5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb,      &
6849          4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /)
6850 !
6851 ! asymmetry factor: unitless
6852 !
6853    asyice2(:, 16) = (/                                                         &
6854 ! band 16
6855          7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb,      &
6856          9.041676e-01_rb,9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb,      &
6857          9.216573e-01_rb,9.239620e-01_rb,9.258695e-01_rb,9.274745e-01_rb,      &
6858          9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,9.319665e-01_rb,      &
6859          9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb,      &
6860          9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb,      &
6861          9.369722e-01_rb,9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb,      &
6862          9.382352e-01_rb,9.385010e-01_rb,9.387505e-01_rb,9.389854e-01_rb,      &
6863          9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,9.398024e-01_rb,      &
6864          9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb,      &
6865          9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /)
6866    asyice2(:, 17) = (/                                                         &
6867 ! band 17
6868          9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb,      &
6869          9.354632e-01_rb,9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb,      &
6870          9.446301e-01_rb,9.461351e-01_rb,9.474555e-01_rb,9.486259e-01_rb,      &
6871          9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,9.522476e-01_rb,      &
6872          9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb,      &
6873          9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb,      &
6874          9.570953e-01_rb,9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb,      &
6875          9.585054e-01_rb,9.588142e-01_rb,9.591083e-01_rb,9.593888e-01_rb,      &
6876          9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,9.603952e-01_rb,      &
6877          9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb,      &
6878          9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /)
6879    asyice2(:, 18) = (/                                                         &
6880 ! band 18
6881          8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb,      &
6882          8.789054e-01_rb,8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb,      &
6883          8.932532e-01_rb,8.955965e-01_rb,8.976567e-01_rb,8.994887e-01_rb,      &
6884          9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,9.052237e-01_rb,      &
6885          9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb,      &
6886          9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb,      &
6887          9.132140e-01_rb,9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb,      &
6888          9.156524e-01_rb,9.161955e-01_rb,9.167160e-01_rb,9.172157e-01_rb,      &
6889          9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,9.190330e-01_rb,      &
6890          9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb,      &
6891          9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /)
6892    asyice2(:, 19) = (/                                                         &
6893 ! band 19
6894          8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb,      &
6895          8.865810e-01_rb,8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb,      &
6896          9.028980e-01_rb,9.052513e-01_rb,9.072468e-01_rb,9.089632e-01_rb,      &
6897          9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,9.139793e-01_rb,      &
6898          9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb,      &
6899          9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb,      &
6900          9.200455e-01_rb,9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb,      &
6901          9.216771e-01_rb,9.220262e-01_rb,9.223560e-01_rb,9.226680e-01_rb,      &
6902          9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,9.237652e-01_rb,      &
6903          9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb,      &
6904          9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /)
6905    asyice2(:, 20) = (/                                                         &
6906 ! band 20
6907          8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb,      &
6908          8.733206e-01_rb,8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb,      &
6909          8.862225e-01_rb,8.879904e-01_rb,8.894682e-01_rb,8.907228e-01_rb,      &
6910          8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,8.942943e-01_rb,      &
6911          8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb,      &
6912          8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb,      &
6913          8.983966e-01_rb,8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb,      &
6914          8.994533e-01_rb,8.996766e-01_rb,8.998865e-01_rb,9.000843e-01_rb,      &
6915          9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,9.007731e-01_rb,      &
6916          9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb,      &
6917          9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /)
6918    asyice2(:, 21) = (/                                                         &
6919 ! band 21
6920          8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb,      &
6921          8.758555e-01_rb,8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb,      &
6922          8.865939e-01_rb,8.880564e-01_rb,8.892765e-01_rb,8.903105e-01_rb,      &
6923          8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,8.932419e-01_rb,      &
6924          8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb,      &
6925          8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb,      &
6926          8.965762e-01_rb,8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb,      &
6927          8.974255e-01_rb,8.976042e-01_rb,8.977720e-01_rb,8.979298e-01_rb,      &
6928          8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,8.984771e-01_rb,      &
6929          8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb,      &
6930          8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /)
6931    asyice2(:, 22) = (/                                                         &
6932 ! band 22
6933          8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb,      &
6934          8.713217e-01_rb,8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb,      &
6935          8.811370e-01_rb,8.824649e-01_rb,8.835711e-01_rb,8.845073e-01_rb,      &
6936          8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,8.871560e-01_rb,      &
6937          8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb,      &
6938          8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb,      &
6939          8.901612e-01_rb,8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb,      &
6940          8.909265e-01_rb,8.910876e-01_rb,8.912388e-01_rb,8.913812e-01_rb,      &
6941          8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,8.918752e-01_rb,      &
6942          8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb,      &
6943          8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /)
6944    asyice2(:, 23) = (/                                                         &
6945 ! band 23
6946          8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb,      &
6947          8.747605e-01_rb,8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb,      &
6948          8.821179e-01_rb,8.831583e-01_rb,8.840361e-01_rb,8.847875e-01_rb,      &
6949          8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,8.869634e-01_rb,      &
6950          8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb,      &
6951          8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb,      &
6952          8.895504e-01_rb,8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb,      &
6953          8.902370e-01_rb,8.903833e-01_rb,8.905214e-01_rb,8.906518e-01_rb,      &
6954          8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,8.911094e-01_rb,      &
6955          8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb,      &
6956          8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /)
6957    asyice2(:, 24) = (/                                                         &
6958 ! band 24
6959          8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb,      &
6960          8.776354e-01_rb,8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb,      &
6961          8.832225e-01_rb,8.840333e-01_rb,8.847224e-01_rb,8.853162e-01_rb,      &
6962          8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,8.870595e-01_rb,      &
6963          8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb,      &
6964          8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb,      &
6965          8.891895e-01_rb,8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb,      &
6966          8.897683e-01_rb,8.898926e-01_rb,8.900102e-01_rb,8.901215e-01_rb,      &
6967          8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,8.905144e-01_rb,      &
6968          8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb,      &
6969          8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /)
6970    asyice2(:, 25) = (/                                                         &
6971 ! band 25
6972          8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb,      &
6973          8.789378e-01_rb,8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb,      &
6974          8.835480e-01_rb,8.842152e-01_rb,8.847817e-01_rb,8.852696e-01_rb,      &
6975          8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,8.866997e-01_rb,      &
6976          8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb,      &
6977          8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb,      &
6978          8.884418e-01_rb,8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb,      &
6979          8.889139e-01_rb,8.890152e-01_rb,8.891110e-01_rb,8.892017e-01_rb,      &
6980          8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,8.895214e-01_rb,      &
6981          8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb,      &
6982          8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /)
6983    asyice2(:, 26) = (/                                                         &
6984 ! band 26
6985          8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb,      &
6986          8.796983e-01_rb,8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb,      &
6987          8.829953e-01_rb,8.834501e-01_rb,8.838310e-01_rb,8.841549e-01_rb,      &
6988          8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,8.850795e-01_rb,      &
6989          8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb,      &
6990          8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb,      &
6991          8.861464e-01_rb,8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb,      &
6992          8.864218e-01_rb,8.864800e-01_rb,8.865347e-01_rb,8.865863e-01_rb,      &
6993          8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,8.867658e-01_rb,      &
6994          8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb,      &
6995          8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /)
6996    asyice2(:, 27) = (/                                                         &
6997 ! band 27
6998          8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb,      &
6999          8.768846e-01_rb,8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb,      &
7000          8.799960e-01_rb,8.804159e-01_rb,8.807660e-01_rb,8.810626e-01_rb,      &
7001          8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,8.819057e-01_rb,      &
7002          8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb,      &
7003          8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb,      &
7004          8.828764e-01_rb,8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb,      &
7005          8.831283e-01_rb,8.831817e-01_rb,8.832320e-01_rb,8.832795e-01_rb,      &
7006          8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,8.834454e-01_rb,      &
7007          8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb,      &
7008          8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /)
7009    asyice2(:, 28) = (/                                                         &
7010 ! band 28
7011          8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb,      &
7012          8.770154e-01_rb,8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb,      &
7013          8.799348e-01_rb,8.802952e-01_rb,8.805880e-01_rb,8.808300e-01_rb,      &
7014          8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,8.814832e-01_rb,      &
7015          8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb,      &
7016          8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb,      &
7017          8.821573e-01_rb,8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb,      &
7018          8.823150e-01_rb,8.823474e-01_rb,8.823775e-01_rb,8.824056e-01_rb,      &
7019          8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,8.825011e-01_rb,      &
7020          8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb,      &
7021          8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /)
7022    asyice2(:, 29) = (/                                                         &
7023 ! band 29
7024          8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb,      &
7025          9.142334e-01_rb,9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb,      &
7026          9.375689e-01_rb,9.412085e-01_rb,9.443604e-01_rb,9.471230e-01_rb,      &
7027          9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,9.555057e-01_rb,      &
7028          9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb,      &
7029          9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb,      &
7030          9.664513e-01_rb,9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb,      &
7031          9.696256e-01_rb,9.703237e-01_rb,9.709903e-01_rb,9.716280e-01_rb,      &
7032          9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,9.739336e-01_rb,      &
7033          9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb,      &
7034          9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /)
7035 !
7036 ! Hexagonal Ice Particle Parameterization
7037 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
7038 !
7039    extice3(:, 16) = (/                                                         &
7040 ! band 16
7041          5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb,      &
7042          1.499977e-01_rb,1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb,      &
7043          8.764435e-02_rb,7.939266e-02_rb,7.256081e-02_rb,6.681137e-02_rb,      &
7044          6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,5.073102e-02_rb,      &
7045          4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb,      &
7046          3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb,      &
7047          3.290694e-02_rb,3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb,      &
7048          2.846172e-02_rb,2.753188e-02_rb,2.666085e-02_rb,2.584322e-02_rb,      &
7049          2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,2.301926e-02_rb,      &
7050          2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb,      &
7051          2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb,      &
7052          1.847607e-02_rb,1.807956e-02_rb /)
7053    extice3(:, 17) = (/                                                         &
7054 ! band 17
7055          4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb,      &
7056          1.445402e-01_rb,1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb,      &
7057          8.495824e-02_rb,7.704501e-02_rb,7.048834e-02_rb,6.496693e-02_rb,      &
7058          6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,4.950698e-02_rb,      &
7059          4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb,      &
7060          3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb,      &
7061          3.234041e-02_rb,3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb,      &
7062          2.805413e-02_rb,2.715727e-02_rb,2.631705e-02_rb,2.552828e-02_rb,      &
7063          2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,2.280343e-02_rb,      &
7064          2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb,      &
7065          2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb,      &
7066          1.841781e-02_rb,1.803494e-02_rb /)
7067    extice3(:, 18) = (/                                                         &
7068 ! band 18
7069          5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb,      &
7070          1.487318e-01_rb,1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb,      &
7071          8.719819e-02_rb,7.902576e-02_rb,7.225433e-02_rb,6.655206e-02_rb,      &
7072          6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,5.058572e-02_rb,      &
7073          4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb,      &
7074          3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb,      &
7075          3.285686e-02_rb,3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb,      &
7076          2.843018e-02_rb,2.750395e-02_rb,2.663621e-02_rb,2.582160e-02_rb,      &
7077          2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,2.300750e-02_rb,      &
7078          2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb,      &
7079          2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb,      &
7080          1.847823e-02_rb,1.808281e-02_rb /)
7081    extice3(:, 19) = (/                                                         &
7082 ! band 19
7083          4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb,      &
7084          1.443736e-01_rb,1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb,      &
7085          8.509997e-02_rb,7.722769e-02_rb,7.070495e-02_rb,6.521211e-02_rb,      &
7086          6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,4.983217e-02_rb,      &
7087          4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb,      &
7088          3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb,      &
7089          3.275444e-02_rb,3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb,      &
7090          2.849034e-02_rb,2.759812e-02_rb,2.676226e-02_rb,2.597757e-02_rb,      &
7091          2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,2.326682e-02_rb,      &
7092          2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb,      &
7093          2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb,      &
7094          1.890389e-02_rb,1.852300e-02_rb /)
7095    extice3(:, 20) = (/                                                         &
7096 ! band 20
7097          5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb,      &
7098          1.497944e-01_rb,1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb,      &
7099          8.762610e-02_rb,7.936938e-02_rb,7.252809e-02_rb,6.676701e-02_rb,      &
7100          6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,5.063598e-02_rb,      &
7101          4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb,      &
7102          3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb,      &
7103          3.272425e-02_rb,3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb,      &
7104          2.825191e-02_rb,2.731612e-02_rb,2.643943e-02_rb,2.561642e-02_rb,      &
7105          2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,2.277329e-02_rb,      &
7106          2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb,      &
7107          1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb,      &
7108          1.819730e-02_rb,1.779781e-02_rb /)
7109    extice3(:, 21) = (/                                                         &
7110 ! band 21
7111          5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb,      &
7112          1.479819e-01_rb,1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb,      &
7113          8.675183e-02_rb,7.861971e-02_rb,7.188168e-02_rb,6.620754e-02_rb,      &
7114          6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,5.031995e-02_rb,      &
7115          4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb,      &
7116          3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb,      &
7117          3.267854e-02_rb,3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb,      &
7118          2.827370e-02_rb,2.735203e-02_rb,2.648858e-02_rb,2.567798e-02_rb,      &
7119          2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,2.287776e-02_rb,      &
7120          2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb,      &
7121          2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb,      &
7122          1.837083e-02_rb,1.797737e-02_rb /)
7123    extice3(:, 22) = (/                                                         &
7124 ! band 22
7125          4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb,      &
7126          1.460446e-01_rb,1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb,      &
7127          8.588928e-02_rb,7.789990e-02_rb,7.128013e-02_rb,6.570559e-02_rb,      &
7128          6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,5.009688e-02_rb,      &
7129          4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb,      &
7130          3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb,      &
7131          3.276512e-02_rb,3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb,      &
7132          2.843759e-02_rb,2.753211e-02_rb,2.668381e-02_rb,2.588744e-02_rb,      &
7133          2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,2.313637e-02_rb,      &
7134          2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb,      &
7135          2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb,      &
7136          1.870855e-02_rb,1.832199e-02_rb /)
7137    extice3(:, 23) = (/                                                         &
7138 ! band 23
7139          5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb,      &
7140          1.485473e-01_rb,1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb,      &
7141          8.704139e-02_rb,7.887264e-02_rb,7.210424e-02_rb,6.640454e-02_rb,      &
7142          6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,5.044537e-02_rb,      &
7143          4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb,      &
7144          3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb,      &
7145          3.272448e-02_rb,3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb,      &
7146          2.829979e-02_rb,2.737397e-02_rb,2.650663e-02_rb,2.569238e-02_rb,      &
7147          2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,2.287954e-02_rb,      &
7148          2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb,      &
7149          2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb,      &
7150          1.835231e-02_rb,1.795707e-02_rb /)
7151    extice3(:, 24) = (/                                                         &
7152 ! band 24
7153          5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb,      &
7154          1.482779e-01_rb,1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb,      &
7155          8.691087e-02_rb,7.876056e-02_rb,7.200745e-02_rb,6.632062e-02_rb,      &
7156          6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,5.039749e-02_rb,      &
7157          4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb,      &
7158          3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb,      &
7159          3.271661e-02_rb,3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb,      &
7160          2.830191e-02_rb,2.737818e-02_rb,2.651279e-02_rb,2.570039e-02_rb,      &
7161          2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,2.289390e-02_rb,      &
7162          2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb,      &
7163          2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb,      &
7164          1.837688e-02_rb,1.798254e-02_rb /)
7165    extice3(:, 25) = (/                                                         &
7166 ! band 25
7167          5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb,      &
7168          1.477544e-01_rb,1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb,      &
7169          8.663439e-02_rb,7.851688e-02_rb,7.179095e-02_rb,6.612700e-02_rb,      &
7170          6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,5.026796e-02_rb,      &
7171          4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb,      &
7172          3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb,      &
7173          3.265824e-02_rb,3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb,      &
7174          2.826131e-02_rb,2.734130e-02_rb,2.647939e-02_rb,2.567026e-02_rb,      &
7175          2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,2.287507e-02_rb,      &
7176          2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb,      &
7177          2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb,      &
7178          1.837623e-02_rb,1.798348e-02_rb /)
7179    extice3(:, 26) = (/                                                         &
7180 ! band 26
7181          5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb,      &
7182          1.489122e-01_rb,1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb,      &
7183          8.720201e-02_rb,7.900612e-02_rb,7.221524e-02_rb,6.649660e-02_rb,      &
7184          6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,5.048442e-02_rb,      &
7185          4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb,      &
7186          3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb,      &
7187          3.270466e-02_rb,3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb,      &
7188          2.826527e-02_rb,2.733638e-02_rb,2.646615e-02_rb,2.564920e-02_rb,      &
7189          2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,2.282702e-02_rb,      &
7190          2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb,      &
7191          2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb,      &
7192          1.828474e-02_rb,1.788819e-02_rb /)
7193    extice3(:, 27) = (/                                                         &
7194 ! band 27
7195          5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb,      &
7196          1.491691e-01_rb,1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb,      &
7197          8.734125e-02_rb,7.912973e-02_rb,7.232591e-02_rb,6.659637e-02_rb,      &
7198          6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,5.055367e-02_rb,      &
7199          4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb,      &
7200          3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb,      &
7201          3.274002e-02_rb,3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb,      &
7202          2.829216e-02_rb,2.736150e-02_rb,2.648961e-02_rb,2.567111e-02_rb,      &
7203          2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,2.284354e-02_rb,      &
7204          2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb,      &
7205          2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb,      &
7206          1.829261e-02_rb,1.789531e-02_rb /)
7207    extice3(:, 28) = (/                                                         &
7208 ! band 28
7209          5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb,      &
7210          1.487921e-01_rb,1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb,      &
7211          8.716516e-02_rb,7.898034e-02_rb,7.219863e-02_rb,6.648771e-02_rb,      &
7212          6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,5.049716e-02_rb,      &
7213          4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb,      &
7214          3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb,      &
7215          3.274141e-02_rb,3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb,      &
7216          2.830801e-02_rb,2.738037e-02_rb,2.651132e-02_rb,2.569547e-02_rb,      &
7217          2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,2.287710e-02_rb,      &
7218          2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb,      &
7219          2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb,      &
7220          1.834096e-02_rb,1.794495e-02_rb /)
7221    extice3(:, 29) = (/                                                         &
7222 ! band 29
7223          1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb,      &
7224          1.343937e-01_rb,1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb,      &
7225          8.685880e-02_rb,7.948698e-02_rb,7.319086e-02_rb,6.775669e-02_rb,      &
7226          6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,5.189810e-02_rb,      &
7227          4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb,      &
7228          3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb,      &
7229          3.317880e-02_rb,3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb,      &
7230          2.832256e-02_rb,2.729724e-02_rb,2.633377e-02_rb,2.542675e-02_rb,      &
7231          2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,2.227443e-02_rb,      &
7232          2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb,      &
7233          1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb,      &
7234          1.713899e-02_rb,1.668704e-02_rb /)
7235 !
7236 ! single-scattering albedo: unitless
7237 !
7238    ssaice3(:, 16) = (/                                                         &
7239 ! band 16
7240          6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb,      &
7241          6.420046e-01_rb,6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb,      &
7242          6.186783e-01_rb,6.138395e-01_rb,6.093543e-01_rb,6.052049e-01_rb,      &
7243          6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,5.916302e-01_rb,      &
7244          5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb,      &
7245          5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb,      &
7246          5.744262e-01_rb,5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb,      &
7247          5.704097e-01_rb,5.695739e-01_rb,5.687747e-01_rb,5.679964e-01_rb,      &
7248          5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,5.647860e-01_rb,      &
7249          5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb,      &
7250          5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb,      &
7251          5.527976e-01_rb,5.507005e-01_rb /)
7252    ssaice3(:, 17) = (/                                                         &
7253 ! band 17
7254          7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb,      &
7255          7.397745e-01_rb,7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb,      &
7256          7.201945e-01_rb,7.157894e-01_rb,7.115652e-01_rb,7.075145e-01_rb,      &
7257          7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,6.929007e-01_rb,      &
7258          6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb,      &
7259          6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb,      &
7260          6.673637e-01_rb,6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb,      &
7261          6.582561e-01_rb,6.561163e-01_rb,6.540182e-01_rb,6.519554e-01_rb,      &
7262          6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,6.439289e-01_rb,      &
7263          6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb,      &
7264          6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb,      &
7265          6.254825e-01_rb,6.232583e-01_rb /)
7266    ssaice3(:, 18) = (/                                                         &
7267 ! band 18
7268          9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb,      &
7269          9.763566e-01_rb,9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb,      &
7270          9.615104e-01_rb,9.579725e-01_rb,9.544997e-01_rb,9.510901e-01_rb,      &
7271          9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,9.380415e-01_rb,      &
7272          9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb,      &
7273          9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb,      &
7274          9.115688e-01_rb,9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb,      &
7275          9.007846e-01_rb,8.981592e-01_rb,8.955581e-01_rb,8.929792e-01_rb,      &
7276          8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,8.828464e-01_rb,      &
7277          8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb,      &
7278          8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb,      &
7279          8.605744e-01_rb,8.580989e-01_rb /)
7280    ssaice3(:, 19) = (/                                                         &
7281 ! band 19
7282          9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb,      &
7283          9.205529e-01_rb,9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb,      &
7284          8.843699e-01_rb,8.761992e-01_rb,8.683536e-01_rb,8.608204e-01_rb,      &
7285          8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,8.335635e-01_rb,      &
7286          8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb,      &
7287          8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb,      &
7288          7.856825e-01_rb,7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb,      &
7289          7.685711e-01_rb,7.645522e-01_rb,7.606126e-01_rb,7.567404e-01_rb,      &
7290          7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,7.416844e-01_rb,      &
7291          7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb,      &
7292          7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb,      &
7293          7.070811e-01_rb,7.028972e-01_rb /)
7294    ssaice3(:, 20) = (/                                                         &
7295 ! band 20
7296          9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb,      &
7297          9.813746e-01_rb,9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb,      &
7298          9.694553e-01_rb,9.666088e-01_rb,9.638123e-01_rb,9.610641e-01_rb,      &
7299          9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,9.505211e-01_rb,      &
7300          9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb,      &
7301          9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb,      &
7302          9.289731e-01_rb,9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb,      &
7303          9.201147e-01_rb,9.179496e-01_rb,9.158008e-01_rb,9.136667e-01_rb,      &
7304          9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,9.052436e-01_rb,      &
7305          9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb,      &
7306          8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb,      &
7307          8.864907e-01_rb,8.843843e-01_rb /)
7308    ssaice3(:, 21) = (/                                                         &
7309 ! band 21
7310          9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb,      &
7311          9.800523e-01_rb,9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb,      &
7312          9.680106e-01_rb,9.651862e-01_rb,9.624315e-01_rb,9.597439e-01_rb,      &
7313          9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,9.496177e-01_rb,      &
7314          9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb,      &
7315          9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb,      &
7316          9.298313e-01_rb,9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb,      &
7317          9.220198e-01_rb,9.201338e-01_rb,9.182700e-01_rb,9.164258e-01_rb,      &
7318          9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,9.091999e-01_rb,      &
7319          9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb,      &
7320          9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb,      &
7321          8.931888e-01_rb,8.913770e-01_rb /)
7322    ssaice3(:, 22) = (/                                                         &
7323 ! band 22
7324          9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb,      &
7325          9.983724e-01_rb,9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb,      &
7326          9.972623e-01_rb,9.969849e-01_rb,9.967077e-01_rb,9.964305e-01_rb,      &
7327          9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,9.953230e-01_rb,      &
7328          9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb,      &
7329          9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb,      &
7330          9.928390e-01_rb,9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb,      &
7331          9.917396e-01_rb,9.914652e-01_rb,9.911911e-01_rb,9.909171e-01_rb,      &
7332          9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,9.898237e-01_rb,      &
7333          9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb,      &
7334          9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb,      &
7335          9.873784e-01_rb,9.871081e-01_rb /)
7336    ssaice3(:, 23) = (/                                                         &
7337 ! band 23
7338          9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb,      &
7339          9.997642e-01_rb,9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb,      &
7340          9.995949e-01_rb,9.995528e-01_rb,9.995106e-01_rb,9.994686e-01_rb,      &
7341          9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,9.993007e-01_rb,      &
7342          9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb,      &
7343          9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb,      &
7344          9.989260e-01_rb,9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb,      &
7345          9.987606e-01_rb,9.987194e-01_rb,9.986782e-01_rb,9.986370e-01_rb,      &
7346          9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,9.984729e-01_rb,      &
7347          9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb,      &
7348          9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb,      &
7349          9.981059e-01_rb,9.980653e-01_rb /)
7350    ssaice3(:, 24) = (/                                                         &
7351 ! band 24
7352          9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb,      &
7353          9.999926e-01_rb,9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb,      &
7354          9.999873e-01_rb,9.999860e-01_rb,9.999847e-01_rb,9.999834e-01_rb,      &
7355          9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,9.999782e-01_rb,      &
7356          9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb,      &
7357          9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb,      &
7358          9.999665e-01_rb,9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb,      &
7359          9.999613e-01_rb,9.999600e-01_rb,9.999587e-01_rb,9.999574e-01_rb,      &
7360          9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,9.999522e-01_rb,      &
7361          9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb,      &
7362          9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb,      &
7363          9.999405e-01_rb,9.999392e-01_rb /)
7364    ssaice3(:, 25) = (/                                                         &
7365 ! band 25
7366          9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb,      &
7367          9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,      &
7368          9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999979e-01_rb,      &
7369          9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999973e-01_rb,      &
7370          9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb,      &
7371          9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb,      &
7372          9.999960e-01_rb,9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb,      &
7373          9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,9.999950e-01_rb,      &
7374          9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,9.999944e-01_rb,      &
7375          9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,      &
7376          9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb,      &
7377          9.999931e-01_rb,9.999930e-01_rb /)
7378    ssaice3(:, 26) = (/                                                         &
7379 ! band 26
7380          9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb,      &
7381          9.999987e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb,      &
7382          9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999971e-01_rb,      &
7383          9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,9.999963e-01_rb,      &
7384          9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb,      &
7385          9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb,      &
7386          9.999944e-01_rb,9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb,      &
7387          9.999935e-01_rb,9.999933e-01_rb,9.999931e-01_rb,9.999929e-01_rb,      &
7388          9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,9.999920e-01_rb,      &
7389          9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb,      &
7390          9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb,      &
7391          9.999900e-01_rb,9.999897e-01_rb /)
7392    ssaice3(:, 27) = (/                                                         &
7393 ! band 27
7394          9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb,      &
7395          9.999968e-01_rb,9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb,      &
7396          9.999946e-01_rb,9.999940e-01_rb,9.999934e-01_rb,9.999929e-01_rb,      &
7397          9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,9.999907e-01_rb,      &
7398          9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb,      &
7399          9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb,      &
7400          9.999858e-01_rb,9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb,      &
7401          9.999836e-01_rb,9.999831e-01_rb,9.999826e-01_rb,9.999820e-01_rb,      &
7402          9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,9.999798e-01_rb,      &
7403          9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb,      &
7404          9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb,      &
7405          9.999748e-01_rb,9.999742e-01_rb /)
7406    ssaice3(:, 28) = (/                                                         &
7407 ! band 28
7408          9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb,      &
7409          9.999917e-01_rb,9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb,      &
7410          9.999859e-01_rb,9.999845e-01_rb,9.999831e-01_rb,9.999816e-01_rb,      &
7411          9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,9.999759e-01_rb,      &
7412          9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb,      &
7413          9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb,      &
7414          9.999631e-01_rb,9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb,      &
7415          9.999574e-01_rb,9.999560e-01_rb,9.999546e-01_rb,9.999532e-01_rb,      &
7416          9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,9.999474e-01_rb,      &
7417          9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb,      &
7418          9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb,      &
7419          9.999345e-01_rb,9.999330e-01_rb /)
7420    ssaice3(:, 29) = (/                                                         &
7421 ! band 29
7422          4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb,      &
7423          5.485149e-01_rb,5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb,      &
7424          5.507364e-01_rb,5.503793e-01_rb,5.498090e-01_rb,5.490612e-01_rb,      &
7425          5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,5.447878e-01_rb,      &
7426          5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb,      &
7427          5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb,      &
7428          5.323140e-01_rb,5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb,      &
7429          5.276704e-01_rb,5.267680e-01_rb,5.260000e-01_rb,5.253823e-01_rb,      &
7430          5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,5.247434e-01_rb,      &
7431          5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb,      &
7432          5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb,      &
7433          5.388676e-01_rb,5.422146e-01_rb /)
7434 !
7435 ! asymmetry factor: unitless
7436 !
7437    asyice3(:, 16) = (/                                                         &
7438 ! band 16
7439          8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb,      &
7440          8.660387e-01_rb,8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb,      &
7441          8.882934e-01_rb,8.927662e-01_rb,8.968577e-01_rb,9.005914e-01_rb,      &
7442          9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,9.123836e-01_rb,      &
7443          9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb,      &
7444          9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb,      &
7445          9.256727e-01_rb,9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb,      &
7446          9.281156e-01_rb,9.285662e-01_rb,9.289806e-01_rb,9.293726e-01_rb,      &
7447          9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,9.309859e-01_rb,      &
7448          9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb,      &
7449          9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb,      &
7450          9.384329e-01_rb,9.398744e-01_rb /)
7451    asyice3(:, 17) = (/                                                         &
7452 ! band 17
7453          8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb,      &
7454          8.908785e-01_rb,8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb,      &
7455          9.050582e-01_rb,9.080739e-01_rb,9.108976e-01_rb,9.135388e-01_rb,      &
7456          9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,9.224620e-01_rb,      &
7457          9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb,      &
7458          9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb,      &
7459          9.353013e-01_rb,9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb,      &
7460          9.389939e-01_rb,9.398145e-01_rb,9.406092e-01_rb,9.413856e-01_rb,      &
7461          9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,9.444561e-01_rb,      &
7462          9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb,      &
7463          9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb,      &
7464          9.531294e-01_rb,9.544055e-01_rb /)
7465    asyice3(:, 18) = (/                                                         &
7466 ! band 18
7467          7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb,      &
7468          8.091495e-01_rb,8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb,      &
7469          8.258790e-01_rb,8.296792e-01_rb,8.333355e-01_rb,8.368524e-01_rb,      &
7470          8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,8.496143e-01_rb,      &
7471          8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb,      &
7472          8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb,      &
7473          8.718916e-01_rb,8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb,      &
7474          8.795734e-01_rb,8.813308e-01_rb,8.830315e-01_rb,8.846799e-01_rb,      &
7475          8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,8.908350e-01_rb,      &
7476          8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb,      &
7477          8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb,      &
7478          9.032765e-01_rb,9.046369e-01_rb /)
7479    asyice3(:, 19) = (/                                                         &
7480 ! band 19
7481          7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb,      &
7482          8.094109e-01_rb,8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb,      &
7483          8.328294e-01_rb,8.380166e-01_rb,8.429556e-01_rb,8.476556e-01_rb,      &
7484          8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,8.642481e-01_rb,      &
7485          8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb,      &
7486          8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb,      &
7487          8.910897e-01_rb,8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb,      &
7488          8.996311e-01_rb,9.015398e-01_rb,9.033745e-01_rb,9.051436e-01_rb,      &
7489          9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,9.117311e-01_rb,      &
7490          9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb,      &
7491          9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb,      &
7492          9.259476e-01_rb,9.276661e-01_rb /)
7493    asyice3(:, 20) = (/                                                         &
7494 ! band 20
7495          7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb,      &
7496          7.832998e-01_rb,7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb,      &
7497          8.001765e-01_rb,8.040551e-01_rb,8.078044e-01_rb,8.114280e-01_rb,      &
7498          8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,8.247344e-01_rb,      &
7499          8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb,      &
7500          8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb,      &
7501          8.486568e-01_rb,8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb,      &
7502          8.571122e-01_rb,8.590558e-01_rb,8.609378e-01_rb,8.627618e-01_rb,      &
7503          8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,8.695423e-01_rb,      &
7504          8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb,      &
7505          8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb,      &
7506          8.826854e-01_rb,8.840419e-01_rb /)
7507    asyice3(:, 21) = (/                                                         &
7508 ! band 21
7509          7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb,      &
7510          7.789452e-01_rb,7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb,      &
7511          7.953555e-01_rb,7.991290e-01_rb,8.027777e-01_rb,8.063049e-01_rb,      &
7512          8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,8.192645e-01_rb,      &
7513          8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb,      &
7514          8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb,      &
7515          8.425553e-01_rb,8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb,      &
7516          8.507412e-01_rb,8.526132e-01_rb,8.544210e-01_rb,8.561675e-01_rb,      &
7517          8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,8.625951e-01_rb,      &
7518          8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb,      &
7519          8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb,      &
7520          8.745255e-01_rb,8.756961e-01_rb /)
7521    asyice3(:, 22) = (/                                                         &
7522 ! band 22
7523          7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb,      &
7524          7.715402e-01_rb,7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb,      &
7525          7.847148e-01_rb,7.877892e-01_rb,7.907786e-01_rb,7.936846e-01_rb,      &
7526          7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,8.045011e-01_rb,      &
7527          8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb,      &
7528          8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb,      &
7529          8.244958e-01_rb,8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb,      &
7530          8.316580e-01_rb,8.332991e-01_rb,8.348831e-01_rb,8.364115e-01_rb,      &
7531          8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,8.419969e-01_rb,      &
7532          8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb,      &
7533          8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb,      &
7534          8.518561e-01_rb,8.527528e-01_rb /)
7535    asyice3(:, 23) = (/                                                         &
7536 ! band 23
7537          7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb,      &
7538          7.699306e-01_rb,7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb,      &
7539          7.815060e-01_rb,7.842654e-01_rb,7.869705e-01_rb,7.896211e-01_rb,      &
7540          7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,7.996726e-01_rb,      &
7541          8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb,      &
7542          8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb,      &
7543          8.190001e-01_rb,8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb,      &
7544          8.260924e-01_rb,8.277186e-01_rb,8.292856e-01_rb,8.307932e-01_rb,      &
7545          8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,8.362244e-01_rb,      &
7546          8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb,      &
7547          8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb,      &
7548          8.448755e-01_rb,8.455263e-01_rb /)
7549    asyice3(:, 24) = (/                                                         &
7550 ! band 24
7551          7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb,      &
7552          7.683337e-01_rb,7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb,      &
7553          7.792225e-01_rb,7.818494e-01_rb,7.844362e-01_rb,7.869819e-01_rb,      &
7554          7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,7.967337e-01_rb,      &
7555          7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb,      &
7556          8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb,      &
7557          8.158862e-01_rb,8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb,      &
7558          8.230149e-01_rb,8.246527e-01_rb,8.262308e-01_rb,8.277483e-01_rb,      &
7559          8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,8.331929e-01_rb,      &
7560          8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb,      &
7561          8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb,      &
7562          8.415240e-01_rb,8.420926e-01_rb /)
7563    asyice3(:, 25) = (/                                                         &
7564 ! band 25
7565          7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb,      &
7566          7.655067e-01_rb,7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb,      &
7567          7.758492e-01_rb,7.783750e-01_rb,7.808735e-01_rb,7.833430e-01_rb,      &
7568          7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,7.928983e-01_rb,      &
7569          7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb,      &
7570          8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb,      &
7571          8.120527e-01_rb,8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb,      &
7572          8.192776e-01_rb,8.209405e-01_rb,8.225427e-01_rb,8.240826e-01_rb,      &
7573          8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,8.295856e-01_rb,      &
7574          8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb,      &
7575          8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb,      &
7576          8.376710e-01_rb,8.381633e-01_rb /)
7577    asyice3(:, 26) = (/                                                         &
7578 ! band 26
7579          7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb,      &
7580          7.597839e-01_rb,7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb,      &
7581          7.701303e-01_rb,7.726639e-01_rb,7.751727e-01_rb,7.776548e-01_rb,      &
7582          7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,7.872804e-01_rb,      &
7583          7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb,      &
7584          7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb,      &
7585          8.066715e-01_rb,8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb,      &
7586          8.140150e-01_rb,8.157072e-01_rb,8.173382e-01_rb,8.189063e-01_rb,      &
7587          8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,8.245130e-01_rb,      &
7588          8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb,      &
7589          8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb,      &
7590          8.327385e-01_rb,8.332350e-01_rb /)
7591    asyice3(:, 27) = (/                                                         &
7592 ! band 27
7593          7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb,      &
7594          7.504362e-01_rb,7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb,      &
7595          7.609199e-01_rb,7.634888e-01_rb,7.660332e-01_rb,7.685512e-01_rb,      &
7596          7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,7.783229e-01_rb,      &
7597          7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb,      &
7598          7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb,      &
7599          7.980449e-01_rb,7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb,      &
7600          8.055311e-01_rb,8.072581e-01_rb,8.089235e-01_rb,8.105255e-01_rb,      &
7601          8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,8.162626e-01_rb,      &
7602          8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb,      &
7603          8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb,      &
7604          8.247399e-01_rb,8.252599e-01_rb /)
7605    asyice3(:, 28) = (/                                                         &
7606 ! band 28
7607          7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb,      &
7608          7.332444e-01_rb,7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb,      &
7609          7.437869e-01_rb,7.463702e-01_rb,7.489291e-01_rb,7.514616e-01_rb,      &
7610          7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,7.612933e-01_rb,      &
7611          7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb,      &
7612          7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb,      &
7613          7.811789e-01_rb,7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb,      &
7614          7.887597e-01_rb,7.905131e-01_rb,7.922062e-01_rb,7.938372e-01_rb,      &
7615          7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,7.997047e-01_rb,      &
7616          8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb,      &
7617          8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb,      &
7618          8.085768e-01_rb,8.091507e-01_rb /)
7619    asyice3(:, 29) = (/                                                         &
7620 ! band 29
7621          8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb,      &
7622          9.168987e-01_rb,9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb,      &
7623          9.323000e-01_rb,9.354235e-01_rb,9.382858e-01_rb,9.408985e-01_rb,      &
7624          9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,9.490871e-01_rb,      &
7625          9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb,      &
7626          9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb,      &
7627          9.576692e-01_rb,9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb,      &
7628          9.590851e-01_rb,9.593729e-01_rb,9.596632e-01_rb,9.599705e-01_rb,      &
7629          9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,9.616667e-01_rb,      &
7630          9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb,      &
7631          9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb,      &
7632          9.724337e-01_rb,9.746084e-01_rb /)
7633 !
7634 ! fdelta: unitless
7635 !
7636    fdlice3(:, 16) = (/                                                         &
7637 ! band 16
7638          4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb,      &
7639          3.950191e-02_rb,3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb,      &
7640          3.154697e-02_rb,2.985578e-02_rb,2.827395e-02_rb,2.679666e-02_rb,      &
7641          2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,2.183639e-02_rb,      &
7642          2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb,      &
7643          1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb,      &
7644          1.490917e-02_rb,1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb,      &
7645          1.300089e-02_rb,1.258006e-02_rb,1.217208e-02_rb,1.177212e-02_rb,      &
7646          1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,1.015596e-02_rb,      &
7647          9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb,      &
7648          7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb,      &
7649          5.106597e-03_rb,4.312183e-03_rb /)
7650    fdlice3(:, 17) = (/                                                         &
7651 ! band 17
7652          5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb,      &
7653          4.814380e-02_rb,4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb,      &
7654          4.622662e-02_rb,4.583426e-02_rb,4.547274e-02_rb,4.514007e-02_rb,      &
7655          4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,4.405844e-02_rb,      &
7656          4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb,      &
7657          4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb,      &
7658          4.254248e-02_rb,4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb,      &
7659          4.198564e-02_rb,4.183462e-02_rb,4.167494e-02_rb,4.150462e-02_rb,      &
7660          4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,4.067737e-02_rb,      &
7661          4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb,      &
7662          3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb,      &
7663          3.742316e-02_rb,3.689645e-02_rb /)
7664    fdlice3(:, 18) = (/                                                         &
7665 ! band 18
7666          1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb,      &
7667          1.073793e-01_rb,1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb,      &
7668          1.088364e-01_rb,1.092439e-01_rb,1.096647e-01_rb,1.100970e-01_rb,      &
7669          1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,1.119004e-01_rb,      &
7670          1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb,      &
7671          1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb,      &
7672          1.158540e-01_rb,1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb,      &
7673          1.172741e-01_rb,1.175738e-01_rb,1.178472e-01_rb,1.180926e-01_rb,      &
7674          1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,1.187538e-01_rb,      &
7675          1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb,      &
7676          1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb,      &
7677          1.178282e-01_rb,1.174731e-01_rb /)
7678    fdlice3(:, 19) = (/                                                         &
7679 ! band 19
7680          1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb,      &
7681          1.035099e-01_rb,1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb,      &
7682          1.000808e-01_rb,9.931116e-02_rb,9.857151e-02_rb,9.785939e-02_rb,      &
7683          9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,9.523623e-02_rb,      &
7684          9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb,      &
7685          9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb,      &
7686          8.996974e-02_rb,8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb,      &
7687          8.754323e-02_rb,8.689919e-02_rb,8.623517e-02_rb,8.554869e-02_rb,      &
7688          8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,8.252807e-02_rb,      &
7689          8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb,      &
7690          7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb,      &
7691          7.344227e-02_rb,7.217872e-02_rb /)
7692    fdlice3(:, 20) = (/                                                         &
7693 ! band 20
7694          1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb,      &
7695          1.135456e-01_rb,1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb,      &
7696          1.155623e-01_rb,1.161096e-01_rb,1.166703e-01_rb,1.172422e-01_rb,      &
7697          1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,1.196025e-01_rb,      &
7698          1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb,      &
7699          1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb,      &
7700          1.247926e-01_rb,1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb,      &
7701          1.267509e-01_rb,1.271836e-01_rb,1.275896e-01_rb,1.279669e-01_rb,      &
7702          1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,1.291486e-01_rb,      &
7703          1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb,      &
7704          1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb,      &
7705          1.293460e-01_rb,1.291109e-01_rb /)
7706    fdlice3(:, 21) = (/                                                         &
7707 ! band 21
7708          1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb,      &
7709          1.148934e-01_rb,1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb,      &
7710          1.168396e-01_rb,1.173706e-01_rb,1.179152e-01_rb,1.184715e-01_rb,      &
7711          1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,1.207720e-01_rb,      &
7712          1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb,      &
7713          1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb,      &
7714          1.258309e-01_rb,1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb,      &
7715          1.277257e-01_rb,1.281415e-01_rb,1.285300e-01_rb,1.288893e-01_rb,      &
7716          1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,1.299927e-01_rb,      &
7717          1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb,      &
7718          1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb,      &
7719          1.299638e-01_rb,1.296983e-01_rb /)
7720    fdlice3(:, 22) = (/                                                         &
7721 ! band 22
7722          1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb,      &
7723          1.178666e-01_rb,1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb,      &
7724          1.215796e-01_rb,1.225522e-01_rb,1.235383e-01_rb,1.245361e-01_rb,      &
7725          1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,1.286011e-01_rb,      &
7726          1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb,      &
7727          1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb,      &
7728          1.376198e-01_rb,1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb,      &
7729          1.412678e-01_rb,1.421212e-01_rb,1.429469e-01_rb,1.437430e-01_rb,      &
7730          1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,1.465899e-01_rb,      &
7731          1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb,      &
7732          1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb,      &
7733          1.504579e-01_rb,1.506227e-01_rb /)
7734    fdlice3(:, 23) = (/                                                         &
7735 ! band 23
7736          1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb,      &
7737          1.187738e-01_rb,1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb,      &
7738          1.226099e-01_rb,1.236141e-01_rb,1.246322e-01_rb,1.256621e-01_rb,      &
7739          1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,1.298584e-01_rb,      &
7740          1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb,      &
7741          1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb,      &
7742          1.391820e-01_rb,1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb,      &
7743          1.429671e-01_rb,1.438547e-01_rb,1.447146e-01_rb,1.455449e-01_rb,      &
7744          1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,1.485270e-01_rb,      &
7745          1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb,      &
7746          1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb,      &
7747          1.526880e-01_rb,1.528840e-01_rb /)
7748    fdlice3(:, 24) = (/                                                         &
7749 ! band 24
7750          1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb,      &
7751          1.195676e-01_rb,1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb,      &
7752          1.234349e-01_rb,1.244463e-01_rb,1.254712e-01_rb,1.265078e-01_rb,      &
7753          1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,1.307287e-01_rb,      &
7754          1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb,      &
7755          1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb,      &
7756          1.400984e-01_rb,1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb,      &
7757          1.439016e-01_rb,1.447936e-01_rb,1.456579e-01_rb,1.464925e-01_rb,      &
7758          1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,1.494923e-01_rb,      &
7759          1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb,      &
7760          1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb,      &
7761          1.536969e-01_rb,1.538984e-01_rb /)
7762    fdlice3(:, 25) = (/                                                         &
7763 ! band 25
7764          1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb,      &
7765          1.203867e-01_rb,1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb,      &
7766          1.242750e-01_rb,1.252903e-01_rb,1.263187e-01_rb,1.273583e-01_rb,      &
7767          1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,1.315870e-01_rb,      &
7768          1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb,      &
7769          1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb,      &
7770          1.409577e-01_rb,1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb,      &
7771          1.447577e-01_rb,1.456488e-01_rb,1.465123e-01_rb,1.473461e-01_rb,      &
7772          1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,1.503439e-01_rb,      &
7773          1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb,      &
7774          1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb,      &
7775          1.545575e-01_rb,1.547617e-01_rb /)
7776    fdlice3(:, 26) = (/                                                         &
7777 ! band 26
7778          1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb,      &
7779          1.216171e-01_rb,1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb,      &
7780          1.255363e-01_rb,1.265564e-01_rb,1.275888e-01_rb,1.286313e-01_rb,      &
7781          1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,1.328643e-01_rb,      &
7782          1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb,      &
7783          1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb,      &
7784          1.422165e-01_rb,1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb,      &
7785          1.460058e-01_rb,1.468947e-01_rb,1.477564e-01_rb,1.485888e-01_rb,      &
7786          1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,1.515864e-01_rb,      &
7787          1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb,      &
7788          1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb,      &
7789          1.558490e-01_rb,1.560645e-01_rb /)
7790    fdlice3(:, 27) = (/                                                         &
7791 ! band 27
7792          1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb,      &
7793          1.237059e-01_rb,1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb,      &
7794          1.276765e-01_rb,1.287041e-01_rb,1.297420e-01_rb,1.307883e-01_rb,      &
7795          1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,1.350207e-01_rb,      &
7796          1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb,      &
7797          1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb,      &
7798          1.443134e-01_rb,1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb,      &
7799          1.480681e-01_rb,1.489490e-01_rb,1.498032e-01_rb,1.506286e-01_rb,      &
7800          1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,1.536070e-01_rb,      &
7801          1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb,      &
7802          1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb,      &
7803          1.579093e-01_rb,1.581390e-01_rb /)
7804    fdlice3(:, 28) = (/                                                         &
7805 ! band 28
7806          1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb,      &
7807          1.283905e-01_rb,1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb,      &
7808          1.322964e-01_rb,1.333060e-01_rb,1.343252e-01_rb,1.353523e-01_rb,      &
7809          1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,1.395042e-01_rb,      &
7810          1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb,      &
7811          1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb,      &
7812          1.486157e-01_rb,1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb,      &
7813          1.523016e-01_rb,1.531673e-01_rb,1.540073e-01_rb,1.548197e-01_rb,      &
7814          1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,1.577576e-01_rb,      &
7815          1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb,      &
7816          1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb,      &
7817          1.620614e-01_rb,1.623011e-01_rb /)
7818    fdlice3(:, 29) = (/                                                         &
7819 ! band 29
7820          1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb,      &
7821          8.165612e-02_rb,7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb,      &
7822          6.638412e-02_rb,6.308156e-02_rb,5.996942e-02_rb,5.703979e-02_rb,      &
7823          5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,4.698880e-02_rb,      &
7824          4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb,      &
7825          3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb,      &
7826          3.197604e-02_rb,3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb,      &
7827          2.752050e-02_rb,2.652776e-02_rb,2.556772e-02_rb,2.463247e-02_rb,      &
7828          2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,2.098180e-02_rb,      &
7829          2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb,      &
7830          1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb,      &
7831          1.114319e-02_rb,9.727157e-03_rb /)
7832 !
7833    end subroutine swcldpr
7834 !-------------------------------------------------------------------------------
7835 !
7836 !
7837 !-------------------------------------------------------------------------------
7838    end module rrtmg_sw_init_k
7839 !-------------------------------------------------------------------------------
7840 !
7841 !
7842 !-------------------------------------------------------------------------------
7843    module rrtmg_sw_vrtqdr_k
7844 !-------------------------------------------------------------------------------
7845 !  --------------------------------------------------------------------------
7846 ! |                                                                          |
7847 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
7848 ! |  This software may be used, copied, or redistributed as long as it is    |
7849 ! |  not sold and this copyright notice is reproduced on each copy made.     |
7850 ! |  This model is provided as is without any express or implied warranties. |
7851 ! |                       (http://www.rtweb.aer.com/)                        |
7852 ! |                                                                          |
7853 !  --------------------------------------------------------------------------
7854 ! ------- Modules -------
7855 !
7856    use parkind_k, only: im => kind_im, rb => kind_rb
7857 !  use parrrsw, only: ngptsw
7858 !
7859    implicit none
7860 !
7861    contains
7862 !-------------------------------------------------------------------------------
7863 !
7864 !
7865 !-------------------------------------------------------------------------------
7866    subroutine vrtqdr_sw(klev, kw,                                              &
7867                            pref, prefd, ptra, ptrad,                           &
7868                            pdbt, prdnd, prup, prupd, ptdbt,                    &
7869                            pfd, pfu)
7870 !-------------------------------------------------------------------------------
7871 !
7872 ! abstract:
7873 !   This routine performs the vertical quadrature integration
7874 !
7875 ! Interface:  *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
7876 !
7877 ! history log
7878 !
7879 !           H. Barker  Original
7880 ! 2002-10  J.-J. Morcrette, ECMWF   Integrated with rrtmg_sw
7881 ! 2006-06  MJIacono, AER            Reformatted for consistency with rrtmg_lw
7882 !
7883 ! Input :
7884 !   klev : number of model layers
7885 !   kw : g-point index
7886 !   pref(nlayers+1) : direct beam reflectivity
7887 !   prefd(nlayers+1) : diffuse beam reflectivity
7888 !   ptra(nlayers+1) : direct beam transmissivity
7889 !   ptrad(nlayers+1) : diffuse beam transmissivity
7890 !   pdbt(nlayers+1) : layer mean direct beam transmittance
7891 !   ptdbt(nlayers+1) : total direct beam transmittance at levels
7892 !   prdnd(nlayers+1)
7893 !   prup(nlayers+1)
7894 !   prupd(nlayers+1)
7895 !
7896 ! Output :
7897 !   pfd(nlayers+1,ngptsw) : downwelling flux (W/m2),
7898 !                           unadjusted for earth/sun distance or zenith angle
7899 !   pfu(nlayers+1,ngptsw) : upwelling flux (W/m2)
7900 !                           unadjusted for earth/sun distance or zenith angle
7901 !
7902 !-------------------------------------------------------------------------------
7903 !
7904 ! ------- Declarations -------
7905 !
7906 ! Input
7907 !
7908    integer(kind=im),  intent(in   ) :: klev
7909    integer(kind=im),  intent(in   ) :: kw
7910    real(kind=rb), dimension(:), intent(in   ) :: pref
7911    real(kind=rb), dimension(:), intent(in   ) :: prefd
7912    real(kind=rb), dimension(:), intent(in   ) :: ptra
7913    real(kind=rb), dimension(:), intent(in   ) :: ptrad
7914    real(kind=rb), dimension(:), intent(in   ) :: pdbt
7915    real(kind=rb), dimension(:), intent(in   ) :: ptdbt
7916    real(kind=rb), dimension(:), intent(inout) :: prdnd
7917    real(kind=rb), dimension(:), intent(inout) :: prup
7918    real(kind=rb), dimension(:), intent(inout) :: prupd
7919 !
7920 ! Output
7921 !
7922    real(kind=rb), dimension(:,:), intent(  out) :: pfd
7923    real(kind=rb), dimension(:,:), intent(  out) :: pfu
7924 !
7925 ! Local
7926 !
7927    integer(kind=im) :: ikp, ikx, jk
7928 !
7929    real(kind=rb) :: zreflect
7930    real(kind=rb),dimension(klev+1) :: ztdn
7931 !
7932 !-----------------------------------------------------------------------------
7933 !
7934 ! Link lowest layer with surface
7935 !
7936    zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
7937    prup(klev) = pref(klev) + (ptrad(klev) *                                    &
7938                  ((ptra(klev) - pdbt(klev)) * prefd(klev+1) +                  &
7939                    pdbt(klev) * pref(klev+1))) * zreflect
7940    prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) *                     &
7941                     prefd(klev+1) * zreflect
7942 !
7943 ! Pass from bottom to top
7944 !
7945    do jk = 1,klev-1
7946      ikp = klev+1-jk
7947      ikx = ikp-1
7948      zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
7949      prup(ikx) = pref(ikx) + (ptrad(ikx) *                                     &
7950                    ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) +                     &
7951                      pdbt(ikx) * prup(ikp))) * zreflect
7952      prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) *                       &
7953                       prupd(ikp) * zreflect
7954    enddo
7955 !
7956 ! Upper boundary conditions
7957 !
7958    ztdn(1) = 1._rb
7959    prdnd(1) = 0._rb
7960    ztdn(2) = ptra(1)
7961    prdnd(2) = prefd(1)
7962 !
7963 ! Pass from top to bottom
7964 !
7965    do jk = 2,klev
7966      ikp = jk+1
7967      zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
7968      ztdn(ikp) = ptdbt(jk) * ptra(jk) +                                        &
7969                     (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) +                     &
7970                      ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
7971      prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) *                          &
7972                       prdnd(jk) * zreflect
7973    enddo
7974 !
7975 ! Up and down-welling fluxes at levels
7976 !
7977    do jk = 1,klev+1
7978      zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
7979      pfu(jk,kw) = (ptdbt(jk) * prup(jk) +                                      &
7980                       (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
7981      pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+                           &
7982                       ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
7983    enddo
7984 !
7985    end subroutine vrtqdr_sw
7986 !-------------------------------------------------------------------------------
7987 !
7988 !
7989 !-------------------------------------------------------------------------------
7990    end module rrtmg_sw_vrtqdr_k
7991 !-------------------------------------------------------------------------------
7992 !
7993 !
7994 !-------------------------------------------------------------------------------
7995    module rrtmg_sw_spcvmc_k
7996 !-------------------------------------------------------------------------------
7997 !  --------------------------------------------------------------------------
7998 ! |                                                                          |
7999 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
8000 ! |  This software may be used, copied, or redistributed as long as it is    |
8001 ! |  not sold and this copyright notice is reproduced on each copy made.     |
8002 ! |  This model is provided as is without any express or implied warranties. |
8003 ! |                       (http://www.rtweb.aer.com/)                        |
8004 ! |                                                                          |
8005 !  --------------------------------------------------------------------------
8006 ! ------- Modules -------
8007 !
8008    use parkind_k, only : im => kind_im, rb => kind_rb
8009    use parrrsw_k, only : nbndsw, ngptsw, mxmol, jpband
8010    use rrsw_tbl_k, only : tblint, bpade, od_lo, exp_tbl
8011    use rrsw_vsn_k, only : hvrspc, hnamspc
8012    use rrsw_wvn_k, only : ngc, ngs
8013    use rrtmg_sw_reftra_k, only: reftra_sw
8014    use rrtmg_sw_taumol_k, only: taumol_sw
8015    use rrtmg_sw_vrtqdr_k, only: vrtqdr_sw
8016 !
8017    implicit none
8018 !
8019    contains
8020 !-------------------------------------------------------------------------------
8021 !
8022 !
8023 !-------------------------------------------------------------------------------
8024    subroutine spcvmc_sw                                                        &
8025             (nlayers, istart, iend, icpr, iout,                                &
8026              pavel, tavel, pz, tz, tbound, palbd, palbp,                       &
8027              pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc,                      &
8028              ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux,                 &
8029              laytrop, layswtch, laylow, jp, jt, jt1,                           &
8030              co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3,    &
8031              fac00, fac01, fac10, fac11,                                       &
8032              selffac, selffrac, indself, forfac, forfrac, indfor,              &
8033              dtliq,dtice,dtsno,dwliq,dwice,dwsno,daliq,daice,dasno,            &
8034              pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd,           &
8035              pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir)
8036 !-------------------------------------------------------------------------------
8037 !
8038 ! abstract:
8039 !   Contains spectral loop to compute the shortwave radiative fluxes,
8040 !   using the two-stream method of H. Barker and McICA, the Monte-Carlo
8041 !   Independent Column Approximation, for the representation of
8042 !   sub-grid cloud variability (i.e. cloud overlap).
8043 !
8044 ! Interface:  *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
8045 !
8046 ! Method:
8047 !    Adapted from two-stream model of H. Barker;
8048 !    Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
8049 !        1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
8050 !
8051 ! history log :
8052 !
8053 !           H. Barker        Original
8054 !  2003-12  J.-J.Morcrette   Merge with RRTMG_SW
8055 !  2003-10  MJIacono, AER    Add adjustment for Earth/Sun distance
8056 !  2003-11  MJIacono, AER    Bug fix for use of PALBP and PALBD
8057 !  2004-12  MJIacono, AER    Bug fix to apply delta scaling to clear sky
8058 !  2005-01  MJIacono, AER    Code modified so that delta scaling is not done in
8059 !                            cloudy profiles if routine cldprop is used; delta
8060 !                            scaling can be applied by swithcing code below if
8061 !                            cldprop is used; delta scaling can be applied by
8062 !                            swithcing code below if cldprop is not used to get
8063 !                            cloud properties.
8064 !  2005-11  MJIacono, AER    Modified to use McICA
8065 !  2006-07  MJIacono, AER    Uniform formatting for RRTMG
8066 !  2007-08  MJIacono, AER    se exponential lookup table for transmittance
8067 !  2016-10  Sungghye Baek    Revised Two Stream Approximaiton (TSA)
8068 ! Input :
8069 !   indfor(nlayers)
8070 !   indself(nlayers)
8071 !   jp(nlayers)
8072 !   jt(nlayers)
8073 !   jt1(nlayers)
8074 !
8075 !   pavel(nlayers) : layer pressure (hPa, mb)
8076 !   tavel(nlayers) : layer temperature (K)
8077 !   pz(0:nlayers) : level (interface) pressure (hPa, mb)
8078 !   tz(0:nlayers) : level temperatures (hPa, mb)
8079 !   tbound : surface temperature (K)
8080 !   wkl(mxmol,nlayers) : molecular amounts (mol/cm2)
8081 !   coldry(nlayers) :  dry air column density (mol/cm2)
8082 !   colmol(nlayers)
8083 !   adjflux(jpband) : Earth/Sun distance adjustment
8084 !
8085 !   palbd(nbndsw) : surface albedo (diffuse)
8086 !   palbp(nbndsw) : surface albedo (direct)
8087 !   prmu0 : cosine of solar zenith angle
8088 !   pcldfmc(nlayers,ngptsw) : cloud fraction [mcica]
8089 !   ptaucmc(nlayers,ngptsw) : cloud optical depth [mcica]
8090 !   pasycmc(nlayers,ngptsw) : cloud asymmetry parameter [mcica]
8091 !   pomgcmc(nlayers,ngptsw) : cloud single scattering albedo [mcica]
8092 !   ptaormc(nlayers,ngptsw) : cloud optical depth, non-delta scaled [mcica]
8093 !   ptaua(nlayers,nbndsw) : aerosol optical depth
8094 !   pasya(nlayers,nbndsw) :  aerosol asymmetry parameter
8095 !   pomga(nlayers,nbndsw) :  aerosol single scattering albedo
8096 !
8097 !   colh2o(nlayers)
8098 !   colco2(nlayers)
8099 !   colch4(nlayers)
8100 !   co2mult(nlayers)
8101 !   colo3(nlayers)
8102 !   colo2(nlayers)
8103 !   coln2o(nlayers)
8104 !
8105 !   forfac(nlayers)
8106 !   forfrac(nlayers)
8107 !   selffac(nlayers)
8108 !   selffrac(nlayers)
8109 !   fac00(nlayers)
8110 !   fac01(nlayers)
8111 !   fac10(nlayers)
8112 !   fac11(nlayers)
8113 !
8114 !   dtliq (ngptsw,nlayers) : delta-scaled liquid cloud optical depth
8115 !   dtice (ngptsw,nlayers) : delta-scaled ice cloud optical depth
8116 !   dtsno (ngptsw,nlayers) : delta-scaled snow cloud optical depth
8117 !   dwliq (ngptsw,nlayers) : delta-scaled liquid cloud single scattering albedo
8118 !   dwice (ngptsw,nlayers) : delta-scaled ice cloud single scattering albedo
8119 !   dwsno (ngptsw,nlayers) : delta-scaled snow cloud single scattering albedo
8120 !   daliq (ngptsw,nlayers) : delta-scaled liquid cloud asymmetry factor
8121 !   daice (ngptsw,nlayers) : delta-scaled ice cloud asymmetry factor
8122 !   dasno (ngptsw,nlayers) : delta-scaled snow cloud asymmetry factor
8123 ! Output :
8124 !   pbbcd(nlayers+1)
8125 !   pbbcu(nlayers+1)
8126 !   pbbfd(nlayers+1)
8127 !   pbbfddir(nlayers+1)
8128 !   pbbcddir(nlayers+1)
8129 !   puvcd(nlayers+1)
8130 !   puvfd(nlayers+1)
8131 !   puvcddir(nlayers+1)
8132 !   puvfddir(nlayers+1)
8133 !   pnicd(nlayers+1)
8134 !   pnifd(nlayers+1)
8135 !   pnicddir(nlayers+1)
8136 !   pnifddir(nlayers+1)
8137 !-------------------------------------------------------------------------------
8138 ! ------- Declarations ------
8139 !
8140 ! ------- Input -------
8141 !
8142    integer(kind=im), intent(in   ) :: nlayers
8143    integer(kind=im), intent(in   ) :: istart
8144    integer(kind=im), intent(in   ) :: iend
8145    integer(kind=im), intent(in   ) :: icpr
8146    integer(kind=im), intent(in   ) :: iout
8147    integer(kind=im), intent(in   ) :: laytrop
8148    integer(kind=im), intent(in   ) :: layswtch
8149    integer(kind=im), intent(in   ) :: laylow
8150 !
8151    integer(kind=im), dimension(:), intent(in   ) :: indfor
8152    integer(kind=im), dimension(:), intent(in   ) :: indself
8153    integer(kind=im), dimension(:), intent(in   ) :: jp
8154    integer(kind=im), dimension(:), intent(in   ) :: jt
8155    integer(kind=im), dimension(:), intent(in   ) :: jt1
8156 !
8157    real(kind=rb), dimension(:),  intent(in   ) :: pavel
8158    real(kind=rb), dimension(:),  intent(in   ) :: tavel
8159    real(kind=rb), dimension(0:), intent(in   ) :: pz
8160    real(kind=rb), dimension(0:), intent(in   ) :: tz
8161    real(kind=rb),                intent(in   ) :: tbound
8162    real(kind=rb), dimension(:,:),intent(in   ) :: wkl
8163    real(kind=rb), dimension(:),  intent(in   ) :: coldry
8164    real(kind=rb), dimension(:),  intent(in   ) :: colmol
8165    real(kind=rb), dimension(:),  intent(in   ) :: adjflux
8166 !
8167    real(kind=rb), dimension(:),   intent(in   ) :: palbd
8168    real(kind=rb), dimension(:),   intent(in   ) :: palbp
8169    real(kind=rb),                 intent(in   ) :: prmu0
8170    real(kind=rb), dimension(:,:), intent(in   ) :: pcldfmc
8171    real(kind=rb), dimension(:,:), intent(in   ) :: ptaucmc
8172    real(kind=rb), dimension(:,:), intent(in   ) :: pasycmc
8173    real(kind=rb), dimension(:,:), intent(in   ) :: pomgcmc
8174    real(kind=rb), dimension(:,:), intent(in   ) :: ptaormc
8175    real(kind=rb), dimension(:,:), intent(in   ) :: ptaua
8176    real(kind=rb), dimension(:,:), intent(in   ) :: pasya
8177    real(kind=rb), dimension(:,:), intent(in   ) :: pomga
8178 !
8179    real(kind=rb), dimension(:),   intent(in   ) :: colh2o
8180    real(kind=rb), dimension(:),   intent(in   ) :: colco2
8181    real(kind=rb), dimension(:),   intent(in   ) :: colch4
8182    real(kind=rb), dimension(:),   intent(in   ) :: co2mult
8183    real(kind=rb), dimension(:),   intent(in   ) :: colo3
8184    real(kind=rb), dimension(:),   intent(in   ) :: colo2
8185    real(kind=rb), dimension(:),   intent(in   ) :: coln2o
8186 !
8187    real(kind=rb), dimension(:),   intent(in   ) :: forfac
8188    real(kind=rb), dimension(:),   intent(in   ) :: forfrac
8189    real(kind=rb), dimension(:),   intent(in   ) :: selffac
8190    real(kind=rb), dimension(:),   intent(in   ) :: selffrac
8191    real(kind=rb), dimension(:),   intent(in   ) :: fac00
8192    real(kind=rb), dimension(:),   intent(in   ) :: fac01
8193    real(kind=rb), dimension(:),   intent(in   ) :: fac10
8194    real(kind=rb), dimension(:),   intent(in   ) :: fac11
8195 !
8196    real(kind=rb), dimension(:,:), intent(in   ) :: dtliq, dtice, dtsno
8197    real(kind=rb), dimension(:,:), intent(in   ) :: dwliq, dwice, dwsno
8198    real(kind=rb), dimension(:,:), intent(in   ) :: daliq, daice, dasno
8199 !
8200 ! ------- Output -------
8201 !  All Dimensions: (nlayers+1)
8202 !
8203    real(kind=rb), dimension(:),  intent(  out) :: pbbcd
8204    real(kind=rb), dimension(:),  intent(  out) :: pbbcu
8205    real(kind=rb), dimension(:),  intent(  out) :: pbbfd
8206    real(kind=rb), dimension(:),  intent(  out) :: pbbfu
8207    real(kind=rb), dimension(:),  intent(  out) :: pbbfddir
8208    real(kind=rb), dimension(:),  intent(  out) :: pbbcddir
8209 !
8210    real(kind=rb), dimension(:),  intent(  out) :: puvcd
8211    real(kind=rb), dimension(:),  intent(  out) :: puvfd
8212    real(kind=rb), dimension(:),  intent(  out) :: puvcddir
8213    real(kind=rb), dimension(:),  intent(  out) :: puvfddir
8214 !
8215    real(kind=rb), dimension(:),  intent(  out) :: pnicd
8216    real(kind=rb), dimension(:),  intent(  out) :: pnifd
8217    real(kind=rb), dimension(:),  intent(  out) :: pnicddir
8218    real(kind=rb), dimension(:),  intent(  out) :: pnifddir
8219 !
8220 ! Output - inactive   All Dimensions: (nlayers+1)
8221 !      real(kind=rb), intent(out) :: puvcu(:)
8222 !      real(kind=rb), intent(out) :: puvfu(:)
8223 !      real(kind=rb), intent(out) :: pnicu(:)
8224 !      real(kind=rb), intent(out) :: pnifu(:)
8225 !      real(kind=rb), intent(out) :: pvscd(:)
8226 !      real(kind=rb), intent(out) :: pvscu(:)
8227 !      real(kind=rb), intent(out) :: pvsfd(:)
8228 !      real(kind=rb), intent(out) :: pvsfu(:)
8229 !
8230 ! ------- Local -------
8231 !
8232    logical, dimension(nlayers) :: lrtchkclr,lrtchkcld
8233 !
8234    integer(kind=im)  :: klev
8235    integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx
8236    integer(kind=im) :: iw, jb, jg, jl, jk
8237 !  integer(kind=im), parameter :: nuv = ??
8238 !  integer(kind=im), parameter :: nvs = ??
8239    integer(kind=im) :: itind
8240 !
8241    real(kind=rb) :: tblind, ze1
8242    real(kind=rb) :: zclear, zcloud
8243    real(kind=rb), dimension(nlayers+1) :: zdbt, zdbt_nodel
8244    real(kind=rb), dimension(nlayers  ) :: zgc, zgcc, zgco
8245    real(kind=rb), dimension(nlayers  ) :: zomc, zomcc, zomco
8246    real(kind=rb), dimension(nlayers+1) :: zrdnd, zrdndc
8247    real(kind=rb), dimension(nlayers+1) :: zref, zrefc, zrefo
8248    real(kind=rb), dimension(nlayers+1) :: zrefd, zrefdc, zrefdo
8249    real(kind=rb), dimension(nlayers+1) :: zrup, zrupd
8250    real(kind=rb), dimension(nlayers+1) :: zrupc, zrupdc
8251    real(kind=rb), dimension(nlayers+1) :: zs1
8252    real(kind=rb), dimension(nlayers  ) :: ztauc, ztauo
8253    real(kind=rb), dimension(nlayers+1) :: ztdn, ztdnd, ztdbt
8254    real(kind=rb), dimension(nlayers  ) :: ztoc, ztor
8255    real(kind=rb), dimension(nlayers+1) :: ztra, ztrac, ztrao
8256    real(kind=rb), dimension(nlayers+1) :: ztrad, ztradc, ztrado
8257    real(kind=rb), dimension(nlayers+1) :: zdbtc, ztdbtc, zdbtc_nodel
8258    real(kind=rb), dimension(ngptsw   ) :: zincflx
8259    real(kind=rb), dimension(nlayers+1) :: ztdbt_nodel, ztdbtc_nodel
8260 !
8261    real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect
8262    real(kind=rb) :: zwf, tauorig, repclc
8263 !  real(kind=rb) :: zincflux                                   ! inactive
8264 !
8265 ! Arrays from rrtmg_sw_taumoln routines
8266 !
8267 !  real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16)
8268 !  real(kind=rb) :: zsflxzen(16)
8269    real(kind=rb), dimension(nlayers,ngptsw) :: ztaug, ztaur
8270    real(kind=rb), dimension(ngptsw) :: zsflxzen
8271 !
8272 ! Arrays from rrtmg_sw_vrtqdr routine
8273 !
8274    real(kind=rb), dimension(nlayers+1,ngptsw) :: zcd, zcu, zfd, zfu
8275 !
8276 ! Inactive arrays
8277 !  real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1)
8278 !  real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1)
8279 !  real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1)
8280 !
8281    real(kind=rb), dimension(nlayers) :: al1c, al2c, al3c
8282    real(kind=rb), dimension(nlayers) :: al1o, al2o, al3o
8283 !
8284    real(kind=rb), dimension(nlayers) :: f_ray, f_aer
8285 !
8286    real(kind=rb), dimension(nlayers) :: ts_ray, ts_aer
8287    real(kind=rb), dimension(nlayers) :: ts_liq, ts_ice, ts_sno
8288    real(kind=rb), dimension(nlayers) :: ta_ray, ta_gas, ta_aer(nlayers)
8289    real(kind=rb), dimension(nlayers) :: ta_liq, ta_ice, ta_sno
8290    real(kind=rb), dimension(nlayers) :: tt_ray, tt_aer
8291 !
8292    real(kind=rb), dimension(nlayers) :: w_ray, w_aer
8293    real(kind=rb), dimension(nlayers) :: g_ray, g_aer
8294 !
8295    real(kind=rb), dimension(nlayers) :: b0_ray, b0_aer
8296    real(kind=rb), dimension(nlayers) :: b0_liq, b0_ice, b0_sno
8297 !
8298    real(kind=rb), dimension(nlayers) :: b0mu_ray, b0mu_aer
8299    real(kind=rb), dimension(nlayers) :: b0mu_liq, b0mu_ice, b0mu_sno
8300 !
8301    real(kind=rb) :: ua_aer=2., ua_gas=2., ua_ray=2.
8302    real(kind=rb) :: ua_liq=2., ua_ice=2., ua_sno=2.
8303 !
8304    real(kind=rb) :: us_aer=2., us_gas=2., us_ray=2.
8305    real(kind=rb) :: us_liq=2., us_ice=2., us_sno=2.
8306 !
8307    real(kind=rb) :: tt
8308    logical       :: kmodts_4 = .false.
8309 !
8310 ! ------------------------------------------------------------------------------
8311 !
8312 ! Initializations
8313 !
8314    ib1 = istart
8315    ib2 = iend
8316    klev = nlayers
8317    iw = 0
8318    repclc = 1.e-12_rb
8319 !  zincflux = 0.0_rb
8320 !
8321    do jk = 1,klev+1
8322      pbbcd(jk)=0._rb
8323      pbbcu(jk)=0._rb
8324      pbbfd(jk)=0._rb
8325      pbbfu(jk)=0._rb
8326      pbbcddir(jk)=0._rb
8327      pbbfddir(jk)=0._rb
8328      puvcd(jk)=0._rb
8329      puvfd(jk)=0._rb
8330      puvcddir(jk)=0._rb
8331      puvfddir(jk)=0._rb
8332      pnicd(jk)=0._rb
8333      pnifd(jk)=0._rb
8334      pnicddir(jk)=0._rb
8335      pnifddir(jk)=0._rb
8336    enddo
8337 !
8338 ! Calculate the optical depths for gaseous absorption and Rayleigh scattering
8339 !
8340    call taumol_sw(klev,                                                        &
8341                      colh2o, colco2, colch4, colo2, colo3, colmol,             &
8342                      laytrop, jp, jt, jt1,                                     &
8343                      fac00, fac01, fac10, fac11,                               &
8344                      selffac, selffrac, indself, forfac, forfrac, indfor,      &
8345                      zsflxzen, ztaug, ztaur)
8346 !
8347 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
8348 !
8349    do jb = ib1,ib2
8350      ibm = jb-15
8351      igt = ngc(ibm)
8352 !
8353 ! Reinitialize g-point counter for each band if output for each band is
8354 ! requested.
8355 !
8356      if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1)
8357 !
8358 !    do jk = 1,klev+1
8359 !      zbbcd(jk)=0.0_rb
8360 !      zbbcu(jk)=0.0_rb
8361 !      zbbfd(jk)=0.0_rb
8362 !      zbbfu(jk)=0.0_rb
8363 !    enddo
8364 !
8365 ! Top of g-point interval loop within each band (iw is cumulative counter)
8366 !
8367      do jg = 1,igt
8368        iw = iw+1
8369 !
8370 ! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming
8371 ! solar flux
8372 !
8373        zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0
8374 !      zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0      ! inactive
8375 !
8376 ! Compute layer reflectances and transmittances for direct and diffuse sources,
8377 ! first clear then cloudy
8378 !
8379 ! zrefc(jk)  direct albedo for clear
8380 ! zrefo(jk)  direct albedo for cloud
8381 ! zrefdc(jk) diffuse albedo for clear
8382 ! zrefdo(jk) diffuse albedo for cloud
8383 ! ztrac(jk)  direct transmittance for clear
8384 ! ztrao(jk)  direct transmittance for cloudy
8385 ! ztradc(jk) diffuse transmittance for clear
8386 ! ztrado(jk) diffuse transmittance for cloudy
8387 !
8388 ! zref(jk)   direct reflectance
8389 ! zrefd(jk)  diffuse reflectance
8390 ! ztra(jk)   direct transmittance
8391 ! ztrad(jk)  diffuse transmittance
8392 !
8393 ! zdbtc(jk)  clear direct beam transmittance
8394 ! zdbto(jk)  cloudy direct beam transmittance
8395 ! zdbt(jk)   layer mean direct beam transmittance
8396 ! ztdbt(jk)  total direct beam transmittance at levels
8397 !
8398 ! Clear-sky
8399 !
8400 !   TOA direct beam
8401 !
8402        ztdbtc(1)=1.0_rb
8403        ztdbtc_nodel(1)=1.0_rb
8404 !
8405 !   Surface values
8406 !
8407        zdbtc(klev+1) =0.0_rb
8408        ztrac(klev+1) =0.0_rb
8409        ztradc(klev+1)=0.0_rb
8410        zrefc(klev+1) =palbp(ibm)
8411        zrefdc(klev+1)=palbd(ibm)
8412        zrupc(klev+1) =palbp(ibm)
8413        zrupdc(klev+1)=palbd(ibm)
8414 !
8415 ! Total sky
8416 !   TOA direct beam
8417 !
8418        ztdbt(1)=1.0_rb
8419        ztdbt_nodel(1)=1.0_rb
8420 !
8421 !   Surface values
8422 !
8423        zdbt(klev+1) =0.0_rb
8424        ztra(klev+1) =0.0_rb
8425        ztrad(klev+1)=0.0_rb
8426        zref(klev+1) =palbp(ibm)
8427        zrefd(klev+1)=palbd(ibm)
8428        zrup(klev+1) =palbp(ibm)
8429        zrupd(klev+1)=palbd(ibm)
8430 !
8431 ! Top of layer loop
8432 !
8433        do jk = 1,klev
8434 !
8435 ! Note: two-stream calculations proceed from top to bottom;
8436 !   RRTMG_SW quantities are given bottom to top and are reversed here
8437 !
8438          ikl=klev+1-jk
8439 !
8440 ! Set logical flag to do REFTRA calculation
8441 !   Do REFTRA for all clear layers
8442 !
8443          lrtchkclr(jk)=.true.
8444 !
8445 !   Do REFTRA only for cloudy layers in profile, since already done for clear
8446 !   layers
8447 !
8448          lrtchkcld(jk)=.false.
8449          lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc)
8450 !
8451 ! Clear-sky optical parameters - this section inactive
8452 !   Original
8453 !          ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw)
8454 !          zomcc(jk) = ztaur(ikl,iw) / ztauc(jk)
8455 !          zgcc(jk) = 0.0001_rb
8456 !   Total sky optical parameters
8457 !          ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw)
8458 !          zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw)
8459 !          zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) +  &
8460 !                       ztaur(ikl,iw) * 0.0001_rb) / zomco(jk)
8461 !          zomco(jk) = zomco(jk) / ztauo(jk)
8462 !
8463 ! Clear-sky optical parameters including aerosols
8464 !
8465          if(ztaug(ikl,iw)<=0.) ztaug(ikl,iw)=0.
8466          ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm)
8467          zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
8468          zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
8469          zomcc(jk) = zomcc(jk) / ztauc(jk)
8470 !
8471          zf           = pasya(ikl,ibm)*pasya(ikl,ibm)
8472          if(prmu0<0.5) zf = pasya(ikl,ibm)**1.5
8473          zwf          = pomga(ikl,ibm)*zf
8474          f_aer(jk)  = zf
8475 !
8476          g_aer(jk)  = (pasya(ikl,ibm)-zf)/(1.e0-zf)
8477          tt_aer(jk) = (1.e0-zwf)*ptaua(ikl,ibm)
8478          w_aer(jk)  = (pomga(ikl,ibm)-zwf)/(1.e0-zwf)
8479 !
8480          ts_aer(jk) = tt_aer(jk)*w_aer(jk)
8481          ta_aer(jk) = tt_aer(jk)*(1.e0-w_aer(jk))
8482          b0mu_aer(jk) = 0.25e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8483 !        b0_aer(jk)   = 0.375e0*(1.e0-g_aer(jk))
8484 !
8485          ts_liq(jk) = dtliq(iw,ikl)*dwliq(iw,ikl)
8486          ta_liq(jk) = dtliq(iw,ikl)*(1.e0-dwliq(iw,ikl))
8487          b0mu_liq(jk) = 0.25e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8488          b0_liq(jk)   = 0.375e0*(1.e0-daliq(iw,ikl))
8489 !
8490          ts_ice(jk) = dtice(iw,ikl)*dwice(iw,ikl)
8491          ta_ice(jk) = dtice(iw,ikl)*(1.e0-dwice(iw,ikl))
8492          b0mu_ice(jk) = 0.25e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8493          b0_ice(jk)   = 0.375e0*(1.e0-daice(iw,ikl))
8494 !
8495          ts_sno(jk) = dtsno(iw,ikl)*dwsno(iw,ikl)
8496          ta_sno(jk) = dtsno(iw,ikl)*(1.e0-dwsno(iw,ikl))
8497          b0mu_sno(jk) = 0.25e0*(2.e0-3.e0*dasno(iw,ikl)*prmu0)
8498          b0_sno(jk)   = 0.375e0*(1.e0-dasno(iw,ikl))
8499 !
8500          !aerosol
8501          if(prmu0<0.3)then
8502            b0mu_aer(jk) = 0.35e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8503          elseif(prmu0<0.5)then
8504            b0mu_aer(jk) = 0.3e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8505          elseif(prmu0>0.7)then
8506            b0mu_aer(jk) = 0.22e0*(2.e0-3.e0*g_aer(jk)*prmu0)
8507          endif
8508          b0_aer(jk) = 0.5e0*(1.e0-g_aer(jk))
8509          !liquid
8510          if(prmu0<0.5)then
8511            b0mu_liq(jk) = 0.3e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8512          elseif(prmu0<0.8)then
8513            b0mu_liq(jk) = 0.28e0*(2.e0-3.e0*daliq(iw,ikl)*prmu0)
8514          endif
8515          !ice
8516          if(prmu0<0.4)then
8517            b0mu_ice(jk) =  0.3e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8518          elseif(prmu0>0.9)then
8519            b0mu_ice(jk) = 0.18e0*(2.e0-3.e0*daice(iw,ikl)*prmu0)
8520          endif
8521          !snow
8522          if(prmu0<0.4)then
8523            b0mu_sno(jk) = 0.3e0*(2.e0-3.e0*dasno(iw,ikl)*prmu0)
8524          endif
8525 !
8526 !
8527 ! Pre-delta-scaling clear and cloudy direct beam transmittance
8528 ! (must use 'orig', unscaled cloud OD)
8529 !   \/\/\/ This block of code is only needed for direct beam calculation
8530 !
8531          zclear = 1.0_rb - pcldfmc(ikl,iw)
8532          zcloud = pcldfmc(ikl,iw)
8533 !
8534 ! Clear
8535 !        zdbtmc = exp(-ztauc(jk) / prmu0)
8536 !
8537 ! Use exponential lookup table for transmittance, or expansion of
8538 ! exponential for low tau
8539 !
8540          ze1 = ztauc(jk) / prmu0
8541          if (ze1 .le. od_lo) then
8542            zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8543          else
8544            tblind = ze1 / (bpade + ze1)
8545            itind = tblint * tblind + 0.5_rb
8546            zdbtmc = exp_tbl(itind)
8547          endif
8548 !
8549          zdbtc_nodel(jk) = zdbtmc
8550          ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk)
8551 !
8552 ! Clear + Cloud
8553 !
8554          tauorig = ztauc(jk) + ptaormc(ikl,iw)
8555 !        zdbtmo = exp(-tauorig / prmu0)
8556 !
8557 ! Use exponential lookup table for transmittance, or expansion of
8558 ! exponential for low tau
8559 !
8560          ze1 = tauorig / prmu0
8561          if (ze1 .le. od_lo) then
8562            zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8563          else
8564            tblind = ze1 / (bpade + ze1)
8565            itind = tblint * tblind + 0.5_rb
8566            zdbtmo = exp_tbl(itind)
8567          endif
8568          zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo
8569          ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk)
8570 !
8571 !   /\/\/\ Above code only needed for direct beam calculation
8572 !
8573 ! Delta scaling - clear
8574 !
8575          ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + tt_aer(jk)
8576          zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + tt_aer(jk) * w_aer(jk)
8577          zgcc(jk)  = g_aer(jk) * w_aer(jk) * tt_aer(jk) / zomcc(jk)
8578          zomcc(jk) = zomcc(jk) / ztauc(jk)
8579 !
8580          tt = 1.e0 / ztauc(jk)
8581          al1c(jk) = (ua_gas*ztaug(ikl,iw)                                      &
8582                     + ua_aer*ta_aer(jk) + us_ray*0.375e0*ztaur(ikl,iw)         &
8583                     + us_aer*b0_aer(jk)*ts_aer(jk)) * tt
8584          al2c(jk) = (us_ray*0.375e0*ztaur(ikl,iw)                              &
8585                     + us_aer*b0_aer(jk)*ts_aer(jk)) * tt
8586          al3c(jk) = (0.5e0*ztaur(ikl,iw) + b0mu_aer(jk)*ts_aer(jk)) * tt
8587 !
8588 ! Total sky optical parameters (cloud properties already delta-scaled)
8589 !   Use this code if cloud properties are derived in rrtmg_sw_cldprop
8590 !
8591          if (icpr .ge. 1) then
8592            ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw)
8593            zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw)
8594            zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) +  &
8595                               ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk)
8596            zomco(jk) = zomco(jk) / ztauo(jk)
8597            tt = 1.e0/ztauo(jk)
8598 !
8599            al1o(jk) = (ua_gas*ztaug(ikl,iw) + ua_aer*ta_aer(jk)                &
8600                       + ua_liq*ta_liq(jk) + ua_ice*ta_ice(jk)                  &
8601                       + ua_sno*ta_sno(jk)                                      &
8602 !
8603                       + us_ray*0.375e0*ztaur(ikl,iw)                           &
8604                       + us_aer*b0_aer(jk)*ts_aer(jk)                           &
8605                       + us_liq*b0_liq(jk)*ts_liq(jk)                           &
8606                       + us_ice*b0_ice(jk)*ts_ice(jk)                           &
8607                       + us_sno*b0_sno(jk)*ts_sno(jk)) * tt
8608 !
8609            al2o(jk) = (us_ray*0.375e0*ztaur(ikl,iw)                            &
8610                       + us_aer*b0_aer(jk)*ts_aer(jk)                           &
8611                       + us_liq*b0_liq(jk)*ts_liq(jk)                           &
8612                       + us_ice*b0_ice(jk)*ts_ice(jk)                           &
8613                       + us_sno*b0_sno(jk)*ts_sno(jk)) * tt
8614 !
8615            al3o(jk) = (0.5e0*ztaur(ikl,iw) + b0mu_aer(jk)*ts_aer(jk)           &
8616                       + b0mu_liq(jk)*ts_liq(jk) + b0mu_ice(jk)*ts_ice(jk)      &
8617                       + b0mu_sno(jk)*ts_sno(jk) ) * tt
8618 !
8619 ! Total sky optical parameters (if cloud properties not delta scaled)
8620 !   Use this code if cloud properties are not derived in rrtmg_sw_cldprop
8621 !
8622          elseif (icpr .eq. 0) then
8623            ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) +                         &
8624                          ptaua(ikl,ibm) + ptaucmc(ikl,iw)
8625            zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) +                       &
8626                          ptaucmc(ikl,iw) * pomgcmc(ikl,iw) +                   &
8627                          ztaur(ikl,iw) * 1.0_rb
8628            zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) +  &
8629                        ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk)
8630            zomco(jk) = zomco(jk) / ztauo(jk)
8631 !
8632 ! Delta scaling - clouds
8633 !   Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties
8634 !   and to apply delta scaling
8635 !
8636            zf = zgco(jk) * zgco(jk)
8637            zwf = zomco(jk) * zf
8638            ztauo(jk) = (1._rb - zwf) * ztauo(jk)
8639            zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf)
8640            zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf)
8641          endif
8642 !
8643 ! End of layer loop
8644 !
8645        enddo
8646 !
8647 ! Clear sky reflectivities
8648 !
8649        call reftra_sw (klev,                                                   &
8650                             lrtchkclr, zgcc, prmu0, ztauc, zomcc,              &
8651                             al1c, al2c, al3c,                                  &
8652                             zrefc, zrefdc, ztrac, ztradc)
8653 !
8654 ! Total sky reflectivities
8655 !
8656        call reftra_sw (klev,                                                   &
8657                        lrtchkcld, zgco, prmu0, ztauo, zomco,                   &
8658                        al1o, al2o, al3o,                                       &
8659                        zrefo, zrefdo, ztrao, ztrado)
8660 !
8661        do jk = 1,klev
8662 !
8663 ! Combine clear and cloudy contributions for total sky
8664 !
8665          ikl = klev+1-jk
8666          zclear = 1.0_rb - pcldfmc(ikl,iw)
8667          zcloud = pcldfmc(ikl,iw)
8668 !
8669          zref(jk)  = zclear*zrefc(jk) + zcloud*zrefo(jk)
8670          zrefd(jk) = zclear*zrefdc(jk) + zcloud*zrefdo(jk)
8671          ztra(jk)  = zclear*ztrac(jk) + zcloud*ztrao(jk)
8672          ztrad(jk) = zclear*ztradc(jk) + zcloud*ztrado(jk)
8673 !
8674 ! Direct beam transmittance
8675 !
8676 ! Clear
8677 !                zdbtmc = exp(-ztauc(jk) / prmu0)
8678 !
8679 ! Use exponential lookup table for transmittance, or expansion of
8680 ! exponential for low tau
8681 !
8682          ze1 = ztauc(jk) / prmu0
8683          if (ze1 .le. od_lo) then
8684            zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8685          else
8686            tblind = ze1 / (bpade + ze1)
8687            itind = tblint * tblind + 0.5_rb
8688            zdbtmc = exp_tbl(itind)
8689          endif
8690 !
8691          zdbtc(jk) = zdbtmc
8692          ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk)
8693 !
8694 ! Clear + Cloud
8695 !                zdbtmo = exp(-ztauo(jk) / prmu0)
8696 ! Use exponential lookup table for transmittance, or expansion of
8697 ! exponential for low tau
8698 !
8699          ze1 = ztauo(jk) / prmu0
8700          if (ze1 .le. od_lo) then
8701            zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
8702          else
8703            tblind = ze1 / (bpade + ze1)
8704            itind = tblint * tblind + 0.5_rb
8705            zdbtmo = exp_tbl(itind)
8706          endif
8707          zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo
8708          ztdbt(jk+1) = zdbt(jk)*ztdbt(jk)
8709        enddo
8710 !
8711 ! Vertical quadrature for clear-sky fluxes
8712 !
8713        call vrtqdr_sw(klev, iw,                                                &
8714                            zrefc, zrefdc, ztrac, ztradc,                       &
8715                            zdbtc, zrdndc, zrupc, zrupdc, ztdbtc,               &
8716                            zcd, zcu)
8717 !
8718 ! Vertical quadrature for cloudy fluxes
8719 !
8720        call vrtqdr_sw(klev, iw,                                                &
8721                            zref, zrefd, ztra, ztrad,                           &
8722                            zdbt, zrdnd, zrup, zrupd, ztdbt,                    &
8723                            zfd, zfu)
8724 !
8725 ! Upwelling and downwelling fluxes at levels
8726 !   Two-stream calculations go from top to bottom;
8727 !   layer indexing is reversed to go bottom to top for output arrays
8728 !
8729        do jk = 1,klev+1
8730          ikl = klev+2-jk
8731 !
8732 ! Accumulate spectral fluxes over bands - inactive
8733 !               zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8734 !               zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8735 !               zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8736 !               zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8737 !               zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8738 !               zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8739 !
8740 ! Accumulate spectral fluxes over whole spectrum
8741 !
8742          pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
8743          pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
8744          pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
8745          pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
8746          pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8747          pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8748 !
8749 ! Accumulate direct fluxes for UV/visible bands
8750 !
8751          if (ibm >= 10 .and. ibm <= 13) then
8752            puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw)
8753            puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw)
8754            puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8755            puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8756 !
8757 ! Accumulate direct fluxes for near-IR bands
8758 !
8759          else if (ibm == 14 .or. ibm <= 9) then
8760            pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw)
8761            pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw)
8762            pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
8763            pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
8764          endif
8765        enddo
8766 !
8767 ! End loop on jg, g-point interval
8768 !
8769      enddo
8770 !
8771 ! End loop on jb, spectral band
8772 !
8773    enddo
8774 !
8775    end subroutine spcvmc_sw
8776 !-------------------------------------------------------------------------------
8777 !
8778 !
8779 !-------------------------------------------------------------------------------
8780    end module rrtmg_sw_spcvmc_k
8781 !-------------------------------------------------------------------------------
8782 !
8783 !
8784 !-------------------------------------------------------------------------------
8785    module rrtmg_sw_rad_k
8786 !-------------------------------------------------------------------------------
8787 !  --------------------------------------------------------------------------
8788 ! |                                                                          |
8789 ! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
8790 ! |  This software may be used, copied, or redistributed as long as it is    |
8791 ! |  not sold and this copyright notice is reproduced on each copy made.     |
8792 ! |  This model is provided as is without any express or implied warranties. |
8793 ! |                       (http://www.rtweb.aer.com/)                        |
8794 ! |                                                                          |
8795 !  --------------------------------------------------------------------------
8796 !
8797 ! ****************************************************************************
8798 ! *                                                                          *
8799 ! *                             RRTMG_SW                                     *
8800 ! *                                                                          *
8801 ! *                                                                          *
8802 ! *                                                                          *
8803 ! *                 a rapid radiative transfer model                         *
8804 ! *                  for the solar spectral region                           *
8805 ! *           for application to general circulation models                  *
8806 ! *                                                                          *
8807 ! *                                                                          *
8808 ! *           Atmospheric and Environmental Research, Inc.                   *
8809 ! *                       131 Hartwell Avenue                                *
8810 ! *                       Lexington, MA 02421                                *
8811 ! *                                                                          *
8812 ! *                                                                          *
8813 ! *                          Eli J. Mlawer                                   *
8814 ! *                       Jennifer S. Delamere                               *
8815 ! *                        Michael J. Iacono                                 *
8816 ! *                        Shepard A. Clough                                 *
8817 ! *                                                                          *
8818 ! *                                                                          *
8819 ! *                                                                          *
8820 ! *                                                                          *
8821 ! *                                                                          *
8822 ! *                                                                          *
8823 ! *                      email:  miacono@aer.com                             *
8824 ! *                      email:  emlawer@aer.com                             *
8825 ! *                      email:  jdelamer@aer.com                            *
8826 ! *                                                                          *
8827 ! *       The authors wish to acknowledge the contributions of the           *
8828 ! *       following people:  Steven J. Taubman, Patrick D. Brown,            *
8829 ! *       Ronald E. Farren, Luke Chen, Robert Bergstrom.                     *
8830 ! *                                                                          *
8831 ! ****************************************************************************
8832 !
8833 ! --------- Modules ---------
8834 !
8835    use parkind_k, only : im => kind_im, rb => kind_rb
8836    use rrsw_vsn_k
8837    use rrtmg_sw_cldprmc_k, only: cldprmc_sw
8838 !
8839 ! *** Move the required call to rrtmg_sw_ini below and the following
8840 ! use association to GCM initialization area ***
8841 !      use rrtmg_sw_init, only: rrtmg_sw_ini
8842 !
8843    use rrtmg_sw_setcoef_k, only: setcoef_sw
8844    use rrtmg_sw_spcvmc_k, only: spcvmc_sw
8845 !
8846    implicit none
8847 !
8848 ! public interfaces/functions/subroutines
8849 !
8850    public :: rrtmg_sw, inatm_sw, earth_sun
8851 !
8852    contains
8853 !-------------------------------------------------------------------------------
8854 !
8855 !
8856 !-------------------------------------------------------------------------------
8857 ! Public subroutines
8858 !-------------------------------------------------------------------------------
8859    subroutine rrtmg_sw                                                         &
8860             ( ncol    ,nlay    ,icld    ,                                      &
8861              play    ,plev    ,tlay    ,tlev    ,tsfc   ,                      &
8862              h2ovmr , o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr ,               &
8863              asdir   ,asdif   ,aldir   ,aldif   ,                              &
8864              coszen  ,adjes   ,dyofyr  ,scon    ,                              &
8865              inflgsw ,iceflgsw,liqflgsw,cldfmcl ,                              &
8866              taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl ,                              &
8867              ciwpmcl ,clwpmcl ,reicmcl ,relqmcl ,                              &
8868              cswpmcl, resnmcl,                                                 &
8869              tauaer  ,ssaaer  ,asmaer  ,ecaer   ,                              &
8870              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc,               &
8871              visdir  ,visdif  ,nirdir  ,nirdif                                 &
8872                  )
8873 !-------------------------------------------------------------------------------
8874 !
8875 ! ------- Description -------
8876 ! This program is the driver for RRTMG_SW, the AER SW radiation model for
8877 !  application to GCMs, that has been adapted from RRTM_SW for improved
8878 !  efficiency and to provide fractional cloudiness and cloud overlap
8879 !  capability using McICA.
8880 !
8881 ! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization
8882 !  area, since this has to be called only once.
8883 !
8884 ! This routine
8885 !    b) calls INATM_SW to read in the atmospheric profile;
8886 !       all layering in RRTMG is ordered from surface to toa.
8887 !    c) calls CLDPRMC_SW to set cloud optical depth for McICA based
8888 !       on input cloud properties
8889 !    d) calls SETCOEF_SW to calculate various quantities needed for
8890 !       the radiative transfer algorithm
8891 !    e) calls SPCVMC to call the two-stream model that in turn
8892 !       calls TAUMOL to calculate gaseous optical depths for each
8893 !       of the 16 spectral bands and to perform the radiative transfer
8894 !       using McICA, the Monte-Carlo Independent Column Approximation,
8895 !       to represent sub-grid scale cloud variability
8896 !    f) passes the calculated fluxes and cooling rates back to GCM
8897 !
8898 ! Two modes of operation are possible:
8899 !     The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use
8900 !     McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM.
8901 !
8902 !    1) Standard, single forward model calculation (imca = 0); this is
8903 !       valid only for clear sky or fully overcast clouds
8904 !    2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
8905 !       JC, 2003) method is applied to the forward model calculation (imca = 1)
8906 !       This method is valid for clear sky or partial cloud conditions.
8907 !
8908 ! This call to RRTMG_SW must be preceeded by a call to the module
8909 !     mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator,
8910 !     which will provide the cloud physical or cloud optical properties
8911 !     on the RRTMG quadrature point (ngptsw) dimension.
8912 !
8913 ! Two methods of cloud property input are possible:
8914 !     Cloud properties can be input in one of two ways (controlled by input
8915 !     flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions
8916 !     and subroutine rrtmg_sw_cldprop.f90 for further details):
8917 !
8918 !    1) Input cloud fraction, cloud optical depth, single scattering albedo
8919 !       and asymmetry parameter directly (inflgsw = 0)
8920 !    2) Input cloud fraction and cloud physical properties: ice fracion,
8921 !       ice and liquid particle sizes (inflgsw = 1 or 2);
8922 !       cloud optical properties are calculated by cldprop or cldprmc based
8923 !       on input settings of iceflgsw and liqflgsw
8924 !
8925 ! Two methods of aerosol property input are possible:
8926 !     Aerosol properties can be input in one of two ways (controlled by input
8927 !     flag iaer, see text file rrtmg_sw_instructions for further details):
8928 !
8929 !    1) Input aerosol optical depth, single scattering albedo and asymmetry
8930 !       parameter directly by layer and spectral band (iaer=10)
8931 !    2) Input aerosol optical depth and 0.55 micron directly by layer and use
8932 !       one or more of six ECMWF aerosol types (iaer=6)
8933 !
8934 !
8935 ! ------- Modifications -------
8936 !
8937 ! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced
8938 ! set of g-point intervals and a two-stream model for application to GCMs.
8939 !
8940 !-- Original version (derived from RRTM_SW)
8941 !     2002: AER. Inc.
8942 !-- Conversion to F90 formatting; addition of 2-stream radiative transfer
8943 !     Feb 2003: J.-J. Morcrette, ECMWF
8944 !-- Additional modifications for GCM application
8945 !     Aug 2003: M. J. Iacono, AER Inc.
8946 !-- Total number of g-points reduced from 224 to 112.  Original
8947 !   set of 224 can be restored by exchanging code in module parrrsw.f90
8948 !   and in file rrtmg_sw_init.f90.
8949 !     Apr 2004: M. J. Iacono, AER, Inc.
8950 !-- Modifications to include output for direct and diffuse
8951 !   downward fluxes.  There are output as "true" fluxes without
8952 !   any delta scaling applied.  Code can be commented to exclude
8953 !   this calculation in source file rrtmg_sw_spcvrt.f90.
8954 !     Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc.
8955 !-- Revised to add McICA capability.
8956 !     Nov 2005: M. J. Iacono, AER, Inc.
8957 !-- Reformatted for consistency with rrtmg_lw.
8958 !     Feb 2007: M. J. Iacono, AER, Inc.
8959 !-- Modifications to formatting to use assumed-shape arrays.
8960 !     Aug 2007: M. J. Iacono, AER, Inc.
8961 !
8962 !  Input :
8963 !    ncol -  Number of horizontal columns
8964 !    nlay -  Number of model layers
8965 !    icld - Cloud overlap method
8966 !           0: Clear only  1: Random   2: Maximum/random  3: Maximum
8967 !    play(ncol,nlay) - Layer pressures (hPa, mb)
8968 !    plev(ncol,nlay+1) - Interface pressures (hPa, mb)
8969 !    tlay(ncol,nlay) -  Layer temperatures (K)
8970 !    tlev(ncol,nlay+1) - Interface temperatures (K)
8971 !    tsfc(ncol) - Surface temperature (K)
8972 !    h2ovmr(ncol,nlay) - H2O volume mixing ratio
8973 !    o3vmr(ncol,nlay) -  O3 volume mixing ratio
8974 !    co2vmr(ncol,nlay) - co2 volume mixing ratio
8975 !    ch4vmr(ncol,nlay) - ch4 volume mixing ratio
8976 !    n2ovmr(ncol,nlay) - n2o volume mixing ratio
8977 !    o2vmr(ncol,nlay) - o2 volume mixing ratio
8978 !    asdir(ncol) - UV/vis surface albedo direct rad
8979 !    aldir(ncol) - Near-IR surface albedo direct rad
8980 !    asdif(ncol) - UV/vis surface albedo diffuse rad
8981 !    aldif(ncol) - Near-IR surface albedo diffuse rad
8982 !    dyofyr - Day of the year (used to get Earth/Sun distance if
8983 !             adjflx not provided)
8984 !
8985 !    adjes - Flux adjustment for Earth/Sun distance
8986 !    coszen(ncol) - Cosine of solar zenith angle
8987 !    scon - Solar constant (W/m2)
8988 !    inflgsw - Flag for cloud optical properties
8989 !    iceflgsw - Flag for ice particle specification
8990 !    liqflgsw - Flag for liquid droplet specification
8991 !
8992 !    cldfmcl(ngptsw,ncol,nlay) - Cloud fraction
8993 !    taucmcl(ngptsw,ncol,nlay) - In-cloud optical depth
8994 !    ssacmcl(ngptsw,ncol,nlay) - In-cloud single scattering albedo
8995 !    asmcmcl(ngptsw,ncol,nlay) - In-cloud asymmetry parameter
8996 !    fsfcmcl(ngptsw,ncol,nlay) - In-cloud  forward scattering fraction
8997 !    ciwpmcl(ngptsw,ncol,nlay) - In-cloud  water path (g/m2)
8998 !    clwpmcl(ngptsw,ncol,nlay) - In-cloud  liquid water path (g/m2)
8999 !    cswpmcl(ngptsw,ncol,nlay) - In-cloud snow water path (g/m2)
9000 !    reicmcl(ncol,nlay) -  Cloud ice effective radius (microns)
9001 !
9002 !    specific definition of reicmcl depends on setting of iceflglw:
9003 !    iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
9004 !                  r_ec must be >= 10.0 microns
9005 !    iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
9006 !                  r_ec range is limited to 13.0 to 130.0 microns
9007 !    iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
9008 !                  r_k range is limited to 5.0 to 131.0 microns
9009 !    iceflglw = 3: generalized effective size, dge, (Fu, 1996),
9010 !                  dge range is limited to 5.0 to 140.0 microns
9011 !                  [dge = 1.0315 * r_ec]
9012 !
9013 !    relqmcl(ncol,nlay) - Cloud water drop effective radius (microns)
9014 !    resnmcl(ncol,nlay) - Cloud snow effective radius (microns)
9015 !    tauaer(ncol,nlay,nbndsw) - Aerosol optical depth (iaer=10 only)
9016 !                               (non-delta scaled)
9017 !    ssaaer(ncol,nlay,nbndsw) - Aerosol Aerosol single scattering albedo
9018 !                               (iaer=10 only) (non-delta scaled)
9019 !    asmaer(ncol,nlay,nbndsw) - Aerosol Aerosol asymmetry parameters
9020 !                               (iaer=10 only) (non-delta scaled)
9021 !    ecaer(ncol,nlay,naerec) - Aerosol optical depth at 0.55 micron
9022 !                               (iaer=6 only) (non-delta scaled)
9023 !
9024 !  output :
9025 !    swuflx(ncol,nlay+1) - Total sky shortwave upward flux (W/m2)
9026 !    swdflx(ncol,nlay+1) - Total sky shortwave downward flux (W/m2)
9027 !    swhr(ncol,nlay) - Total sky shortwave radiative heating rate (K/d)
9028 !    swuflxc(ncol,nlay+1) -  Clear sky shortwave upward flux (W/m2)
9029 !    swdflxc(ncol,nlay+1) - Clear sky shortwave downward flux (W/m2)
9030 !    swhrc(ncol,nlay) - Clear sky shortwave radiative heating rate (K/d)
9031 !    sibvisdir(ncol,nlay+1) - visible direct downward flux  (W/m2)
9032 !    sibvisdif(ncol,nlay+1) - visible diffusion downward flux  (W/m2)
9033 !    sibnirdir(ncol,nlay+1) - Near IR direct downward flux  (W/m2)
9034 !    sibnirdif(ncol,nlay+1) - Near IR diffusion downward flux  (W/m2)
9035 !    swdkdir(ncol,nlay) - Total shortwave downward direct flux (W/m2)
9036 !    swdkdif(ncol,nlay) - Total shortwave downward diffuse flux (W/m2)
9037 !    visdir(ncol) - Direct downward surface shortwave flux, UV/vis
9038 !    visdif(ncol) - Diffuse downward surface shortwave flux, UV/vis
9039 !    nirdir(ncol) - Direct downward surface shortwave flux, Near-IR
9040 !    nirdif(ncol) - Diffuse downward surface shortwave flux, Near-IR
9041 !
9042 ! local :
9043 !   nlayers - total number of layers
9044 !   istart - beginning band of calculation
9045 !   iend - ending band of calculation
9046 !   icpr - cldprop/cldprmc use flag
9047 !   iout - output option flag (inactive)
9048 !   iaer - aerosol option flag
9049 !   idelm - delta-m scaling flag (inactive)
9050 !   isccos - instrumental cosine response flag (inactive)
9051 !   iplon - column loop index
9052 !   i - layer loop index                       ! jk
9053 !   ib - band loop index                        ! jsw
9054 !   ia, ig -  indices
9055 !   k - layer loop index
9056 !   ims - value for changing mcica permute seed
9057 !   imca - flag for mcica [0=off, 1=on]
9058 !   zepsec, zepzen-  epsilon
9059 !   zdpgcp - flux to heating conversion ratio
9060 !
9061 !   pavel(nlay+1)   - layer pressures (mb)
9062 !   tavel(nlay+1)   - layer temperatures (K)
9063 !   pz(0:nlay+1)    - level (interface) pressures (hPa, mb)
9064 !   tz(0:nlay+1)    - level (interface) temperatures (K)
9065 !   tbound          - surface temperature (K)
9066 !   pdp(nlay+1)     - layer pressure thickness (hPa, mb)
9067 !   coldry(nlay+1)   - dry air column amount
9068 !   wkl(mxmol,nlay+1)- molecular amounts (mol/cm-2)
9069 !   cossza              -  Cosine of solar zenith angle
9070 !   adjflux(jpband)     -  adjustment for current Earth/Sun distance
9071 !   solvar(jpband)      -  solar constant scaling factor from rrtmg_sw
9072 !                       -    default value of 1368.22 Wm-2 at 1 AU
9073 !   albdir(nbndsw)      -  surface albedo, direct          ! zalbp
9074 !   albdif(nbndsw)      -  surface albedo, diffuse         ! zalbd
9075 !
9076 !   taua(nlay+1,nbndsw) -  Aerosol optical depth
9077 !   ssaa(nlay+1,nbndsw) -  Aerosol single scattering albedo
9078 !   asma(nlay+1,nbndsw) -  Aerosol asymmetry parameter
9079 !
9080 !   laytrop             - tropopause layer index
9081 !   layswtch            - tropopause layer index
9082 !   laylow              - tropopause layer index
9083 !   jp(nlay+1)
9084 !   jt(nlay+1)
9085 !   jt1(nlay+1)
9086 !
9087 !   colh2o(nlay+1)      -  column amount (h2o)
9088 !   colco2(nlay+1)      -  column amount (co2)
9089 !   colo3(nlay+1)       -  column amount (o3)
9090 !   coln2o(nlay+1)      -  column amount (n2o)
9091 !   colch4(nlay+1)      -  column amount (ch4)
9092 !   colo2(nlay+1)       -  column amount (o2)
9093 !   colmol(nlay+1)      -  column amount
9094 !   co2mult(nlay+1)     -  column amount
9095 !
9096 !   ncbands             - number of cloud spectral bands
9097 !   inflag              - flag for cloud property method
9098 !   iceflag             - flag for ice cloud properties
9099 !   liqflag             - flag for liquid cloud properties
9100 !
9101 !   cldfrac(nlay+1)   -  layer cloud fraction
9102 !   tauc(nlay+1)      -  in-cloud optical depth (non-delta scaled)
9103 !   ssac(nlay+1)      -  in-cloud single scattering albedo (non-delta scaled)
9104 !   asmc(nlay+1)      -  in-cloud asymmetry parameter (non-delta scaled)
9105 !   fsfc(nlay+1)      -  in-cloud forward scattering fraction (non-delta scaled)
9106 !   ciwp(nlay+1)      -  in-cloud ice water path
9107 !   clwp(nlay+1)      -  in-cloud liquid water path
9108 !   rei(nlay+1)       -  cloud ice particle size
9109 !   rel(nlay+1)       -  cloud liquid particle size
9110 !
9111 !   taucloud(nlay+1,jpband)  - in-cloud optical depth
9112 !   taucldorig(nlay+1,jpband)- in-cloud optical depth (non-delta scaled)
9113 !   ssacloud(nlay+1,jpband)  - in-cloud single scattering albedo
9114 !   asmcloud(nlay+1,jpband)  - in-cloud asymmetry parameter
9115 !
9116 !   cldfmc(ngptsw,nlay+1)    - cloud fraction [mcica]
9117 !   ciwpmc(ngptsw,nlay+1)    - in-cloud ice water path [mcica]
9118 !   clwpmc(ngptsw,nlay+1)    - in-cloud liquid water path [mcica]
9119 !   cswpmc(ngptsw,nlay+1)    - in-cloud snow water path [mcica]
9120 !   relqmc(nlay+1)           - liquid particle effective radius (microns)
9121 !   reicmc(nlay+1)           - ice particle effective size (microns)
9122 !   resnmc(nlay+1)           - snow particle effective size (microns)
9123 !   taucmc(ngptsw,nlay+1)    - in-cloud optical depth [mcica]
9124 !   taormc(ngptsw,nlay+1)    - unscaled in-cloud optical depth [mcica]
9125 !   ssacmc(ngptsw,nlay+1)    - in-cloud single scattering albedo [mcica]
9126 !   asmcmc(ngptsw,nlay+1)    - in-cloud asymmetry parameter [mcica]
9127 !   fsfcmc(ngptsw,nlay+1)    - in-cloud forward scattering fraction [mcica]
9128 !
9129 !   ztauc(nlay+1,nbndsw)     - cloud optical depth
9130 !   ztaucorig(nlay+1,nbndsw) - unscaled cloud optical depth
9131 !   zasyc(nlay+1,nbndsw)     - cloud asymmetry parameter
9132 !                              (first moment of phase function)
9133 !   zomgc(nlay+1,nbndsw)     - cloud single scattering albedo
9134 !   ztaua(nlay+1,nbndsw)     - total aerosol optical depth
9135 !   zasya(nlay+1,nbndsw)     - total aerosol asymmetry parameter
9136 !   zomga(nlay+1,nbndsw)     - total aerosol single scattering albedo
9137 !
9138 !   zcldfmc(nlay+1,ngptsw)    -cloud fraction [mcica]
9139 !   ztaucmc(nlay+1,ngptsw)    -cloud optical depth [mcica]
9140 !   ztaormc(nlay+1,ngptsw)    -unscaled cloud optical depth [mcica]
9141 !   zasycmc(nlay+1,ngptsw)    -cloud asymmetry parameter [mcica]
9142 !   zomgcmc(nlay+1,ngptsw)    -cloud single scattering albedo [mcica]
9143 !
9144 !   zbbfu(nlay+2)   - temporary upward shortwave flux (w/m2)
9145 !   zbbfd(nlay+2)   - temporary downward shortwave flux (w/m2)
9146 !   zbbcu(nlay+2)   - temporary clear sky upward shortwave flux (w/m2)
9147 !   zbbcd(nlay+2)   - temporary clear sky downward shortwave flux (w/m2)
9148 !   zbbfddir(nlay+2)- temporary downward direct shortwave flux (w/m2)
9149 !   zbbcddir(nlay+2)- temporary clear sky downward direct shortwave flux (w/m2)
9150 !   zuvfd(nlay+2)   - temporary UV downward shortwave flux (w/m2)
9151 !   zuvcd(nlay+2)   - temporary clear sky UV downward shortwave flux (w/m2)
9152 !   zuvfddir(nlay+2)- temporary UV downward direct shortwave flux (w/m2)
9153 !   zuvcddir(nlay+2)- temporary clear sky UV downward direct shortwave flux
9154 !   znifd(nlay+2)   - temporary near-IR downward shortwave flux (w/m2)
9155 !   znicd(nlay+2)   - temporary clear sky near-IR downward shortwave flux (w/m2)
9156 !   znifddir(nlay+2)- temporary near-IR downward direct shortwave flux (w/m2)
9157 !   znicddir(nlay+2)- temporary clear sky near-IR downward direct shortwave flux
9158 !
9159 !   swnflx(nlay+2)         - Total sky shortwave net flux (W/m2)
9160 !   swnflxc(nlay+2)        - Clear sky shortwave net flux (W/m2)
9161 !   dirdflux(nlay+2)       - Direct downward shortwave surface flux
9162 !   difdflux(nlay+2)       - Diffuse downward shortwave surface flux
9163 !   uvdflx(nlay+2)         - Total sky downward shortwave flux, UV/vis
9164 !   nidflx(nlay+2)         - Total sky downward shortwave flux, near-IR
9165 !   dirdnuv(nlay+2)        - Direct downward shortwave flux, UV/vis
9166 !   difdnuv(nlay+2)        - Diffuse downward shortwave flux, UV/vis
9167 !   dirdnir(nlay+2)        - Direct downward shortwave flux, near-IR
9168 !   difdnir(nlay+2)        - Diffuse downward shortwave flux, near-IR
9169 !
9170 !   zuvfu(nlay+2)   - temporary upward UV shortwave flux (w/m2)
9171 !   zuvfd(nlay+2)   - temporary downward UV shortwave flux (w/m2)
9172 !   zuvcu(nlay+2)   - temporary clear sky upward UV shortwave flux (w/m2)
9173 !   zuvcd(nlay+2)   - temporary clear sky downward UV shortwave flux (w/m2)
9174 !   zvsfu(nlay+2)   - temporary upward visible shortwave flux (w/m2)
9175 !   zvsfd(nlay+2)   - temporary downward visible shortwave flux (w/m2)
9176 !   zvscu(nlay+2)   - temporary clear sky upward visible shortwave flux (w/m2)
9177 !   zvscd(nlay+2)   - temporary clear sky downward visible shortwave flux (w/m2)
9178 !   znifu(nlay+2)   - temporary upward near-IR shortwave flux (w/m2)
9179 !   znifd(nlay+2)   - temporary downward near-IR shortwave flux (w/m2)
9180 !   znicu(nlay+2)   - temporary clear sky upward near-IR shortwave flux (w/m2)
9181 !   znicd(nlay+2)   - temporary clear sky downward near-IR shortwave flux (w/m2)
9182 !
9183 !-------------------------------------------------------------------------------
9184 ! --------- Modules ---------
9185 !
9186    use parrrsw_k, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol,            &
9187                           jpband, jpb1, jpb2
9188    use rrsw_aer_k, only : rsrtaua, rsrpiza, rsrasya
9189    use rrsw_con_k, only : heatfac, oneminus, pi
9190    use rrsw_wvn_k, only : wavenum1, wavenum2
9191 !
9192 ! ------- Declarations
9193 !
9194 ! ----- Input -----
9195 !
9196    integer(kind=im),                 intent(in   ) :: ncol
9197    integer(kind=im),                 intent(in   ) :: nlay
9198    integer(kind=im),                 intent(inout) :: icld
9199    real(kind=rb), dimension(:,:),    intent(in   ) :: play
9200    real(kind=rb), dimension(:,:),    intent(in   ) :: plev
9201    real(kind=rb), dimension(:,:),    intent(in   ) :: tlay
9202    real(kind=rb), dimension(:,:),    intent(in   ) :: tlev
9203    real(kind=rb), dimension(:),      intent(in   ) :: tsfc
9204    real(kind=rb), dimension(:,:),    intent(in   ) :: h2ovmr
9205    real(kind=rb), dimension(:,:),    intent(in   ) :: o3vmr
9206    real(kind=rb), dimension(:,:),    intent(in   ) :: co2vmr
9207    real(kind=rb), dimension(:,:),    intent(in   ) :: ch4vmr
9208    real(kind=rb), dimension(:,:),    intent(in   ) :: n2ovmr
9209    real(kind=rb), dimension(:,:),    intent(in   ) :: o2vmr
9210    real(kind=rb), dimension(:),      intent(in   ) :: asdir
9211    real(kind=rb), dimension(:),      intent(in   ) :: aldir
9212    real(kind=rb), dimension(:),      intent(in   ) :: asdif
9213    real(kind=rb), dimension(:),      intent(in   ) :: aldif
9214    integer(kind=im),                 intent(in   ) :: dyofyr
9215    real(kind=rb),                    intent(in   ) :: adjes
9216    real(kind=rb), dimension(:),      intent(in   ) :: coszen
9217    real(kind=rb),                    intent(in   ) :: scon
9218    integer(kind=im),                 intent(in   ) :: inflgsw
9219    integer(kind=im),                 intent(in   ) :: iceflgsw
9220    integer(kind=im),                 intent(in   ) :: liqflgsw
9221    real(kind=rb), dimension(:,:,:),  intent(in   ) :: cldfmcl
9222    real(kind=rb), dimension(:,:,:),  intent(in   ) :: taucmcl
9223    real(kind=rb), dimension(:,:,:),  intent(in   ) :: ssacmcl
9224    real(kind=rb), dimension(:,:,:),  intent(in   ) :: asmcmcl
9225    real(kind=rb), dimension(:,:,:),  intent(in   ) :: fsfcmcl
9226    real(kind=rb), dimension(:,:,:),  intent(in   ) :: ciwpmcl
9227    real(kind=rb), dimension(:,:,:),  intent(in   ) :: clwpmcl
9228    real(kind=rb), dimension(:,:,:),  intent(in   ) :: cswpmcl
9229    real(kind=rb), dimension(:,:),    intent(in   ) :: reicmcl
9230    real(kind=rb), dimension(:,:),    intent(in   ) :: relqmcl
9231    real(kind=rb), dimension(:,:),    intent(in   ) :: resnmcl
9232    real(kind=rb), dimension(:,:,:),  intent(in   ) :: tauaer
9233    real(kind=rb), dimension(:,:,:),  intent(in   ) :: ssaaer
9234    real(kind=rb), dimension(:,:,:),  intent(in   ) :: asmaer
9235    real(kind=rb), dimension(:,:,:),  intent(in   ) :: ecaer
9236 !
9237 ! ----- Output -----
9238 !
9239    real(kind=rb), dimension(:,:), intent(  out) :: swuflx
9240    real(kind=rb), dimension(:,:), intent(  out) :: swdflx
9241    real(kind=rb), dimension(:,:), intent(  out) :: swhr
9242    real(kind=rb), dimension(:,:), intent(  out) :: swuflxc
9243    real(kind=rb), dimension(:,:), intent(  out) :: swdflxc
9244    real(kind=rb), dimension(:,:), intent(  out) :: swhrc
9245    real(kind=rb), dimension(:),   intent(  out) :: visdir
9246    real(kind=rb), dimension(:),   intent(  out) :: visdif
9247    real(kind=rb), dimension(:),   intent(  out) :: nirdir
9248    real(kind=rb), dimension(:),   intent(  out) :: nirdif
9249 !
9250 ! ----- Local -----
9251 !
9252 ! Control
9253 !
9254    integer(kind=im) :: nlayers
9255    integer(kind=im) :: istart
9256    integer(kind=im) :: iend
9257    integer(kind=im) :: icpr
9258    integer(kind=im) :: iout
9259    integer(kind=im) :: iaer
9260    integer(kind=im) :: idelm
9261    integer(kind=im) :: isccos
9262    integer(kind=im) :: iplon
9263    integer(kind=im) :: i
9264    integer(kind=im) :: ib
9265    integer(kind=im) :: ia, ig
9266    integer(kind=im) :: k
9267    integer(kind=im) :: ims
9268    integer(kind=im) :: imca
9269    real(kind=rb) :: zepsec, zepzen
9270    real(kind=rb) :: zdpgcp
9271 !
9272 ! Atmosphere
9273 !
9274    real(kind=rb), dimension(nlay+1)         :: pavel
9275    real(kind=rb), dimension(nlay+1)         :: tavel
9276    real(kind=rb), dimension(0:nlay+1)       :: pz
9277    real(kind=rb), dimension(0:nlay+1)       :: tz
9278    real(kind=rb)                            :: tbound
9279    real(kind=rb), dimension(nlay+1)         :: pdp
9280    real(kind=rb), dimension(nlay+1)         :: coldry
9281    real(kind=rb), dimension(mxmol,nlay+1)   :: wkl
9282 !
9283 !   real(kind=rb) :: earth_sun
9284    real(kind=rb) :: cossza
9285    real(kind=rb), dimension(jpband) :: adjflux
9286    real(kind=rb), dimension(jpband) :: solvar
9287    real(kind=rb), dimension(nbndsw) :: albdir
9288    real(kind=rb), dimension(nbndsw) :: albdif
9289 !
9290    real(kind=rb), dimension(nlay+1,nbndsw) :: taua
9291    real(kind=rb), dimension(nlay+1,nbndsw) :: ssaa
9292    real(kind=rb), dimension(nlay+1,nbndsw) :: asma
9293 !
9294 ! Atmosphere - setcoef
9295 !
9296    integer(kind=im) :: laytrop
9297    integer(kind=im) :: layswtch
9298    integer(kind=im) :: laylow
9299    integer(kind=im), dimension(nlay+1) :: jp
9300    integer(kind=im), dimension(nlay+1) :: jt
9301    integer(kind=im), dimension(nlay+1) :: jt1
9302 !
9303    real(kind=rb), dimension(nlay+1) :: colh2o
9304    real(kind=rb), dimension(nlay+1) :: colco2
9305    real(kind=rb), dimension(nlay+1) :: colo3
9306    real(kind=rb), dimension(nlay+1) :: coln2o
9307    real(kind=rb), dimension(nlay+1) :: colch4
9308    real(kind=rb), dimension(nlay+1) :: colo2
9309    real(kind=rb), dimension(nlay+1) :: colmol
9310    real(kind=rb), dimension(nlay+1) :: co2mult
9311 !
9312    integer(kind=im), dimension(nlay+1) :: indself
9313    integer(kind=im), dimension(nlay+1) :: indfor
9314    real(kind=rb), dimension(nlay+1) :: selffac
9315    real(kind=rb), dimension(nlay+1) :: selffrac
9316    real(kind=rb), dimension(nlay+1) :: forfac
9317    real(kind=rb), dimension(nlay+1):: forfrac
9318    real(kind=rb), dimension(nlay+1) :: fac00, fac01, fac10, fac11
9319 !
9320 ! Atmosphere/clouds - cldprop
9321 !
9322    integer(kind=im) :: ncbands
9323    integer(kind=im) :: inflag
9324    integer(kind=im) :: iceflag
9325    integer(kind=im) :: liqflag
9326 !
9327 !  real(kind=rb) :: cldfrac(nlay+1)
9328 !  real(kind=rb) :: tauc(nlay+1)
9329 !  real(kind=rb) :: ssac(nlay+1)
9330 !  real(kind=rb) :: asmc(nlay+1)
9331 !  real(kind=rb) :: fsfc(nlay+1)
9332 !  real(kind=rb) :: ciwp(nlay+1)
9333 !  real(kind=rb) :: clwp(nlay+1)
9334 !  real(kind=rb) :: rei(nlay+1)
9335 !  real(kind=rb) :: rel(nlay+1)
9336 !
9337 !  real(kind=rb) :: taucloud(nlay+1,jpband)
9338 !  real(kind=rb) :: taucldorig(nlay+1,jpband)
9339 !  real(kind=rb) :: ssacloud(nlay+1,jpband)
9340 !  real(kind=rb) :: asmcloud(nlay+1,jpband)
9341 !
9342 ! Atmosphere/clouds - cldprmc [mcica]
9343 !
9344    real(kind=rb), dimension(ngptsw,nlay+1) :: cldfmc
9345    real(kind=rb), dimension(ngptsw,nlay+1) :: ciwpmc
9346    real(kind=rb), dimension(ngptsw,nlay+1) :: clwpmc
9347    real(kind=rb), dimension(ngptsw,nlay+1) :: cswpmc
9348    real(kind=rb), dimension(nlay+1) :: relqmc
9349    real(kind=rb), dimension(nlay+1) :: reicmc
9350    real(kind=rb), dimension(nlay+1) :: resnmc
9351    real(kind=rb), dimension(ngptsw,nlay+1) :: taucmc
9352    real(kind=rb), dimension(ngptsw,nlay+1) :: taormc
9353    real(kind=rb), dimension(ngptsw,nlay+1) :: ssacmc
9354    real(kind=rb), dimension(ngptsw,nlay+1) :: asmcmc
9355    real(kind=rb), dimension(ngptsw,nlay+1) :: fsfcmc
9356    real(kind=rb), dimension(ngptsw,nlay+1) :: dtliq
9357    real(kind=rb), dimension(ngptsw,nlay+1) :: dtice
9358    real(kind=rb), dimension(ngptsw,nlay+1) :: dtsno
9359    real(kind=rb), dimension(ngptsw,nlay+1) :: dwliq
9360    real(kind=rb), dimension(ngptsw,nlay+1) :: dwice
9361    real(kind=rb), dimension(ngptsw,nlay+1) :: dwsno
9362    real(kind=rb), dimension(ngptsw,nlay+1) :: daliq
9363    real(kind=rb), dimension(ngptsw,nlay+1) :: daice
9364    real(kind=rb), dimension(ngptsw,nlay+1) :: dasno
9365 !
9366 ! Atmosphere/clouds/aerosol - spcvrt,spcvmc
9367 !
9368    real(kind=rb), dimension(nlay+1,nbndsw) :: ztauc
9369    real(kind=rb), dimension(nlay+1,nbndsw) :: ztaucorig
9370    real(kind=rb), dimension(nlay+1,nbndsw) :: zasyc
9371    real(kind=rb), dimension(nlay+1,nbndsw) :: zomgc
9372    real(kind=rb), dimension(nlay+1,nbndsw) :: ztaua
9373    real(kind=rb), dimension(nlay+1,nbndsw) :: zasya
9374    real(kind=rb), dimension(nlay+1,nbndsw) :: zomga
9375 !
9376    real(kind=rb), dimension(nlay+1,ngptsw) :: zcldfmc
9377    real(kind=rb), dimension(nlay+1,ngptsw) :: ztaucmc
9378    real(kind=rb), dimension(nlay+1,ngptsw) :: ztaormc
9379    real(kind=rb), dimension(nlay+1,ngptsw) :: zasycmc
9380    real(kind=rb), dimension(nlay+1,ngptsw) :: zomgcmc
9381 !
9382    real(kind=rb), dimension(nlay+2) :: zbbfu
9383    real(kind=rb), dimension(nlay+2) :: zbbfd
9384    real(kind=rb), dimension(nlay+2) :: zbbcu
9385    real(kind=rb), dimension(nlay+2) :: zbbcd
9386    real(kind=rb), dimension(nlay+2) :: zbbfddir
9387    real(kind=rb), dimension(nlay+2) :: zbbcddir
9388    real(kind=rb), dimension(nlay+2) :: zuvfd
9389    real(kind=rb), dimension(nlay+2) :: zuvcd
9390    real(kind=rb), dimension(nlay+2) :: zuvfddir
9391    real(kind=rb), dimension(nlay+2) :: zuvcddir
9392    real(kind=rb), dimension(nlay+2) :: znifd
9393    real(kind=rb), dimension(nlay+2) :: znicd
9394    real(kind=rb), dimension(nlay+2) :: znifddir
9395    real(kind=rb), dimension(nlay+2) :: znicddir
9396 !
9397 ! Optional output fields
9398 !
9399    real(kind=rb), dimension(nlay+2) :: swnflx
9400    real(kind=rb), dimension(nlay+2) :: swnflxc
9401    real(kind=rb), dimension(nlay+2) :: dirdflux
9402    real(kind=rb), dimension(nlay+2) :: difdflux
9403    real(kind=rb), dimension(nlay+2) :: uvdflx
9404    real(kind=rb), dimension(nlay+2) :: nidflx
9405    real(kind=rb), dimension(nlay+2) :: dirdnuv
9406    real(kind=rb), dimension(nlay+2) :: difdnuv
9407    real(kind=rb), dimension(nlay+2) :: dirdnir
9408    real(kind=rb), dimension(nlay+2) :: difdnir
9409 !
9410 ! Output - inactive
9411 !
9412 !  real(kind=rb) :: zuvfu(nlay+2)
9413 !  real(kind=rb) :: zuvfd(nlay+2)
9414 !  real(kind=rb) :: zuvcu(nlay+2)
9415 !  real(kind=rb) :: zuvcd(nlay+2)
9416 !  real(kind=rb) :: zvsfu(nlay+2)
9417 !  real(kind=rb) :: zvsfd(nlay+2)
9418 !  real(kind=rb) :: zvscu(nlay+2)
9419 !  real(kind=rb) :: zvscd(nlay+2)
9420 !  real(kind=rb) :: znifu(nlay+2)
9421 !  real(kind=rb) :: znifd(nlay+2)
9422 !  real(kind=rb) :: znicu(nlay+2)
9423 !  real(kind=rb) :: znicd(nlay+2)
9424 !
9425 !
9426 ! Initializations
9427 !
9428    zepsec = 1.e-06_rb
9429    zepzen = 1.e-10_rb
9430    oneminus = 1.0_rb - zepsec
9431    pi = 2._rb * asin(1._rb)
9432 !
9433    istart = jpb1
9434    iend = jpb2
9435    icpr = 0
9436    ims = 2
9437 !
9438 ! In a GCM with or without McICA, set nlon to the longitude dimension
9439 !
9440 ! Set imca to select calculation type:
9441 !  imca = 0, use standard forward model calculation (clear and overcast only)
9442 !  imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
9443 !            (clear, overcast or partial cloud conditions)
9444 !
9445 ! *** This version uses McICA (imca = 1) ***
9446 !
9447 ! Set icld to select of clear or cloud calculation and cloud
9448 ! overlap method (read by subroutine readprof from input file INPUT_RRTM):
9449 ! icld = 0, clear only
9450 ! icld = 1, with clouds using random cloud overlap (McICA only)
9451 ! icld = 2, with clouds using maximum/random cloud overlap (McICA only)
9452 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
9453    if (icld.lt.0.or.icld.gt.3) icld = 2
9454 !
9455 ! Set iaer to select aerosol option
9456 ! iaer = 0, no aerosols
9457 ! iaer = 6, use six ECMWF aerosol types
9458 !           input aerosol optical depth at 0.55 microns for each
9459 !           aerosol type (ecaer)
9460 ! iaer = 10, input total aerosol optical depth, single scattering albedo
9461 !            and asymmetry parameter (tauaer, ssaaer, asmaer) directly
9462      iaer = 6
9463 !
9464 ! Call model and data initialization, compute lookup tables, perform
9465 ! reduction of g-points from 224 to 112 for input absorption
9466 ! coefficient data and other arrays.
9467 !
9468 ! In a GCM this call should be placed in the model initialization
9469 ! area, since this has to be called only once.
9470 !      call rrtmg_sw_ini(cpdair)
9471 !
9472 ! This is the main longitude/column loop in RRTMG.
9473 ! Modify to loop over all columns (nlon) or over daylight columns
9474 !
9475    do iplon = 1,ncol
9476      if(coszen(iplon).gt.0.0)then
9477 !
9478 ! Prepare atmosphere profile from GCM for use in RRTMG, and define
9479 ! other input parameters
9480 !
9481      call inatm_sw (iplon, nlay, icld, iaer,                                   &
9482               play, plev, tlay, tlev, tsfc, h2ovmr,                            &
9483               o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr,                            &
9484               adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw,                &
9485               cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl,                     &
9486               ciwpmcl, clwpmcl, reicmcl, relqmcl,                              &
9487               cswpmcl, resnmcl,                                                &
9488               tauaer, ssaaer, asmaer,                                          &
9489               nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl,         &
9490               adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc,       &
9491               ssacmc, asmcmc, fsfcmc,                                          &
9492               ciwpmc, clwpmc, reicmc, relqmc,                                  &
9493               cswpmc, resnmc,                                                  &
9494               taua, ssaa, asma)
9495 !
9496 !  For cloudy atmosphere, use cldprop to set cloud optical properties based on
9497 !  input cloud physical properties.  Select method based on choices described
9498 !  in cldprop.  Cloud fraction, water path, liquid droplet and ice particle
9499 !  effective radius must be passed in cldprop.  Cloud fraction and cloud
9500 !  optical properties are transferred to rrtmg_sw arrays in cldprop.
9501 !
9502      dtliq=0._rb ; dtice=0._rb ; dtsno=0._rb
9503      dwliq=1._rb ; dwice=1._rb ; dwsno=1._rb
9504      daliq=0._rb ; daice=0._rb ; dasno=0._rb
9505      call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc,                &
9506                          ciwpmc, clwpmc, reicmc, relqmc,                       &
9507                          cswpmc, resnmc,                                       &
9508                          dtliq, dtice, dtsno, dwliq, dwice, dwsno,             &
9509                          daliq, daice, dasno,                                  &
9510                          taormc, taucmc, ssacmc, asmcmc, fsfcmc)
9511      icpr = 1
9512 !
9513 ! Calculate coefficients for the temperature and pressure dependence of the
9514 ! molecular absorption coefficients by interpolating data from stored
9515 ! reference atmospheres.
9516 !
9517      call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl,       &
9518                          laytrop, layswtch, laylow, jp, jt, jt1,               &
9519                          co2mult, colch4, colco2, colh2o, colmol, coln2o,      &
9520                          colo2, colo3, fac00, fac01, fac10, fac11,             &
9521                          selffac, selffrac, indself, forfac, forfrac, indfor)
9522 !
9523 ! Cosine of the solar zenith angle
9524 !  Prevent using value of zero; ideally,
9525 !  SW model is not called from host model when sun
9526 !  is below horizon
9527 !
9528      cossza = coszen(iplon)
9529      if (cossza .le. zepzen) cossza = zepzen
9530 !
9531 ! Transfer albedo, cloud and aerosol properties into arrays for
9532 ! 2-stream radiative transfer
9533 !
9534 ! Surface albedo
9535 !  Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns
9536 !
9537      do ib = 1,9
9538        albdir(ib) = aldir(iplon)
9539        albdif(ib) = aldif(iplon)
9540      enddo
9541      albdir(nbndsw) = aldir(iplon)
9542      albdif(nbndsw) = aldif(iplon)
9543 !
9544 !  UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
9545 !
9546      do ib = 10,13
9547        albdir(ib) = asdir(iplon)
9548        albdif(ib) = asdif(iplon)
9549      enddo
9550 !
9551 ! Clouds
9552 !
9553      if (icld.eq.0) then
9554        zcldfmc(:,:) = 0._rb
9555        ztaucmc(:,:) = 0._rb
9556        ztaormc(:,:) = 0._rb
9557        zasycmc(:,:) = 0._rb
9558        zomgcmc(:,:) = 1._rb
9559      elseif (icld.ge.1) then
9560        do i = 1,nlayers
9561          do ig = 1,ngptsw
9562            zcldfmc(i,ig) = cldfmc(ig,i)
9563            ztaucmc(i,ig) = taucmc(ig,i)
9564            ztaormc(i,ig) = taormc(ig,i)
9565            zasycmc(i,ig) = asmcmc(ig,i)
9566            zomgcmc(i,ig) = ssacmc(ig,i)
9567          enddo
9568        enddo
9569      endif
9570 !
9571 ! Aerosol
9572 ! IAER = 0: no aerosols
9573 !
9574      if(iaer.eq.0) then
9575        ztaua(:,:) = 0._rb
9576        zasya(:,:) = 0._rb
9577        zomga(:,:) = 1._rb
9578 !
9579 ! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details.
9580 ! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer),
9581 ! or set manually here for each aerosol and layer.
9582 !
9583      elseif(iaer.eq.6) then
9584 !      do i = 1,nlayers
9585 !        do ia = 1,naerec
9586 !          ecaer(iplon,i,ia) = 1.0e-15_rb
9587 !        enddo
9588 !      enddo
9589        do i = 1,nlayers
9590          do ib = 1,nbndsw
9591            ztaua(i,ib) = 0._rb
9592            zasya(i,ib) = 0._rb
9593            zomga(i,ib) = 0._rb
9594            do ia = 1,naerec
9595              ztaua(i,ib) = ztaua(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)
9596              zomga(i,ib) = zomga(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)*       &
9597                                    rsrpiza(ib,ia)
9598              zasya(i,ib) = zasya(i,ib)+rsrtaua(ib,ia)*ecaer(iplon,i,ia)*       &
9599                                    rsrpiza(ib,ia) * rsrasya(ib,ia)
9600            enddo
9601            if(zomga(i,ib).ne.0._rb) then
9602              zasya(i,ib) = zasya(i,ib)/zomga(i,ib)
9603            endif
9604            if(ztaua(i,ib).ne.0._rb) then
9605              zomga(i,ib) = zomga(i,ib)/ztaua(i,ib)
9606            endif
9607          enddo
9608        enddo
9609 !
9610 ! IAER=10: Direct specification of aerosol optical properties from GCM
9611 !
9612      elseif(iaer.eq.10) then
9613        do i = 1,nlayers
9614          do ib = 1,nbndsw
9615            ztaua(i,ib) = taua(i,ib)
9616            zasya(i,ib) = asma(i,ib)
9617            zomga(i,ib) = ssaa(i,ib)
9618          enddo
9619        enddo
9620      endif
9621 !
9622 ! Call the 2-stream radiation transfer model
9623 !
9624      do i = 1,nlayers+1
9625        zbbcu(i) = 0._rb
9626        zbbcd(i) = 0._rb
9627        zbbfu(i) = 0._rb
9628        zbbfd(i) = 0._rb
9629        zbbcddir(i) = 0._rb
9630        zbbfddir(i) = 0._rb
9631        zuvcd(i) = 0._rb
9632        zuvfd(i) = 0._rb
9633        zuvcddir(i) = 0._rb
9634        zuvfddir(i) = 0._rb
9635        znicd(i) = 0._rb
9636        znifd(i) = 0._rb
9637        znicddir(i) = 0._rb
9638        znifddir(i) = 0._rb
9639      enddo
9640 !
9641      call spcvmc_sw                                                            &
9642              (nlayers, istart, iend, icpr, iout,                               &
9643               pavel, tavel, pz, tz, tbound, albdif, albdir,                    &
9644               zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc,                     &
9645               ztaua, zasya, zomga, cossza, coldry, wkl, adjflux,               &
9646               laytrop, layswtch, laylow, jp, jt, jt1,                          &
9647               co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3,   &
9648               fac00, fac01, fac10, fac11,                                      &
9649               selffac, selffrac, indself, forfac, forfrac, indfor,             &
9650               dtliq,dtice,dtsno,dwliq,dwice,dwsno,daliq,daice,dasno,           &
9651               zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd,          &
9652               zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir)
9653 !
9654 ! Transfer up and down, clear and total sky fluxes to output arrays.
9655 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
9656 !
9657      do i = 1,nlayers+1
9658        swuflxc(iplon,i) = zbbcu(i)
9659        swdflxc(iplon,i) = zbbcd(i)
9660        swuflx(iplon,i) = zbbfu(i)
9661        swdflx(iplon,i) = zbbfd(i)
9662        uvdflx(i) = zuvfd(i)
9663        nidflx(i) = znifd(i)
9664 !
9665 !  Direct/diffuse fluxes
9666 !
9667        dirdflux(i) = zbbfddir(i)
9668        difdflux(i) = swdflx(iplon,i) - dirdflux(i)
9669 !
9670 !  UV/visible direct/diffuse fluxes
9671 !
9672        dirdnuv(i) = zuvfddir(i)
9673        difdnuv(i) = zuvfd(i) - dirdnuv(i)
9674 !
9675 !  Near-IR direct/diffuse fluxes
9676 !
9677        dirdnir(i) = znifddir(i)
9678        difdnir(i) = znifd(i) - dirdnir(i)
9679      enddo
9680 !
9681 !  Total and clear sky net fluxes
9682 !
9683      do i = 1,nlayers+1
9684        swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i)
9685        swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i)
9686      enddo
9687 !
9688 !  Total and clear sky heating rates
9689 !
9690      do i = 1,nlayers
9691        zdpgcp = heatfac / pdp(i)
9692        swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp
9693        swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp
9694      enddo
9695      swhrc(iplon,nlayers) = 0._rb
9696      swhr(iplon,nlayers) = 0._rb
9697 !
9698 ! End longitude loop
9699 !
9700      endif
9701    enddo
9702 !
9703    end subroutine rrtmg_sw
9704 !-------------------------------------------------------------------------------
9705 !
9706 !
9707 !-------------------------------------------------------------------------------
9708    real(kind=rb) function earth_sun(idn)
9709 !-------------------------------------------------------------------------------
9710 !
9711 !  abstract:
9712 !    Function to calculate the correction factor of Earth's orbit
9713 !    for current day of the year
9714 !
9715 !  idn        : Day of the year
9716 !  earth_sun  : square of the ratio of mean to actual Earth-Sun distance
9717 !
9718 !-------------------------------------------------------------------------------
9719 ! ------- Modules -------
9720 !
9721    use rrsw_con_k, only : pi
9722 !
9723    integer(kind=im), intent(in) :: idn
9724    real(kind=rb) :: gamma
9725 !-------------------------------------------------------------------------------
9726    gamma = 2._rb*pi*(idn-1)/365._rb
9727 !
9728 ! Use Iqbal's equation 1.2.1
9729 !
9730    earth_sun = 1.000110_rb+.034221_rb*cos(gamma) +                             &
9731                 .001289_rb*sin(gamma) +                                        &
9732                 .000719_rb*cos(2._rb*gamma)+.000077_rb*sin(2._rb*gamma)
9733 !
9734    end function earth_sun
9735 !-------------------------------------------------------------------------------
9736 !
9737 !
9738 !-------------------------------------------------------------------------------
9739    subroutine inatm_sw (iplon, nlay, icld, iaer,                               &
9740             play, plev, tlay, tlev, tsfc, h2ovmr,                              &
9741             o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr,                              &
9742             adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw,                  &
9743             cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl,                       &
9744             ciwpmcl, clwpmcl, reicmcl, relqmcl,                                &
9745             cswpmcl, resnmcl,                                                  &
9746             tauaer, ssaaer, asmaer,                                            &
9747             nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl,           &
9748             adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc,         &
9749             ssacmc, asmcmc, fsfcmc,                                            &
9750             ciwpmc, clwpmc, reicmc, relqmc,                                    &
9751             cswpmc, resnmc,                                                    &
9752             taua, ssaa, asma)
9753 !-------------------------------------------------------------------------------
9754 !
9755 !  abstract :
9756 !    Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
9757 !    Set other RRTMG_SW input parameters.
9758 !
9759 !  history log :
9760 !
9761 !  input :
9762 !    iplon - column loop index
9763 !    nlay - number of model layers
9764 !    icld - clear/cloud and cloud overlap flag
9765 !    iaer - aerosol option flag
9766 !    play(ncol,nlay) - Layer pressures (hPa, mb)
9767 !    plev(ncol,nlay+1) - Interface pressures (hPa, mb)
9768 !    tlay(ncol,nlay) - Layer temperatures (K)
9769 !    tlev(ncol,nlay+1) - Interface  temperatures (K)
9770 !    tsfc(ncol) - Surface temperature (K)
9771 !    h2ovmr(ncol,nlay) - H2O volume mixing ratio
9772 !    o3vmr(ncol,nlay) - o3 volume mixing ratio
9773 !    co2vmr(ncol,nlay) - co2 volume mixing ratio
9774 !    ch4vmr(ncol,nlay) - ch4 volume mixing ratio
9775 !    n2ovmr(ncol,nlay) - n2o volume mixing ratio
9776 !    o2vmr(ncol,nlay) - o2 volume mixing ratio
9777 !
9778 !    dyofyr -  Day of the year (used to get Earth/Sun distance
9779 !              if adjflx not provided)
9780 !    adjes - Flux adjustment for Earth/Sun distance
9781 !    scon - Solar constant (W/m2)
9782 !
9783 !    inflgsw - Flag for cloud optical properties
9784 !    iceflgsw - Flag for ice particle specification
9785 !    liqflgsw - Flag for liquid droplet specification
9786 !
9787 !    cldfmcl(ngptsw,ncol,nlay) - cloud fraction
9788 !    taucmcl(ngptsw,ncol,nlay) - In-cloud optical depth (optional)
9789 !    ssacmcl(ngptsw,ncol,nlay) - In-cloud single scattering albedo (optional)
9790 !    asmcmcl(ngptsw,ncol,nlay) - In-cloud asymmetry parameter (optional)
9791 !    fsfcmcl(ngptsw,ncol,nlay) - In-cloud forward scattering fraction (optional)
9792 !    ciwpmcl(ngptsw,ncol,nlay) - In-cloud ice water path (g/m2)
9793 !    clwpmcl(ngptsw,ncol,nlay) - In-cloud liquid water path (g/m2)
9794 !    cswpmcl(ngptsw,ncol,nlay) - In-cloud snow water path (g/m2)
9795 !    reicmcl(ncol,nlay) - Cloud ice effective size (microns)
9796 !    relqmcl(ncol,nlay) - Cloud water drop effective radius (microns)
9797 !    resnmcl(ncol,nlay) - Cloud snow effective radius (microns)
9798 !
9799 !    tauaer(ncol,nlay,nbndsw) -  Aerosol optical depth
9800 !    ssaaer(ncol,nlay,nbndsw) -  Aerosol single scattering albedo
9801 !    asmaer(ncol,nlay,nbndsw) -  Aerosol asymmetry parameters
9802 !
9803 !    nlayers - number of layers
9804 !    pavel(nlay) - layer pressures (mb)
9805 !    tavel(nlay) layer temperatures (K)
9806 !    pz(0:) - level (interface) pressures (hPa, mb)
9807 !    tz(0:) - level (interface) temperatures (K)
9808 !    tbound - surface temperature(K)
9809 !    pdp(nlay) - layer pressure thickness (hPa, mb)
9810 !    coldry(nlay) - dry air column density (mol/cm2)
9811 !    wkl(mxmol,nlay) - molecular amounts (mol/cm-2)
9812 !    adjflux(jpband) - adjustment for current Earth/Sun distance
9813 !    solvar(jpband) - solar constant scaling factor from rrtmg_sw
9814 !                     default value of 1368.22 Wm-2 at 1 AU
9815 !    taua(nlay,nbndsw) - Aerosol optical depth
9816 !    ssaa(nlay,nbndsw) - Aerosol single scattering albedo
9817 !    asma(nlay,nbndsw) - Aerosol asymmtry parameter
9818 !
9819 !    inflag -  flag for cloud property method
9820 !    iceflag -  flag for ice cloud properties
9821 !    liqflag - flag for liquid cloud properties
9822 !
9823 !    cldfmc(ngptsw,nlay) - layer cloud fraction
9824 !    taucmc(ngptsw,nlay) - in-cloud optical depth (non-delta scaled)
9825 !    ssacmc(ngptsw,nlay) - in-cloud single scattering albedo (non-delta scaled)
9826 !    asmcmc(ngptsw,nlay) - in-cloud asymmetry parameter (non-delta scaled)
9827 !    fsfcmc(ngptsw,nlay) - in-cloud forward scattering fraction
9828 !                          (non-delta scaled)
9829 !    ciwpmc(ngptsw,nlay) - in-cloud ice water path
9830 !    clwpmc(ngptsw,nlay) - in-cloud liquid water path
9831 !    cswpmc(ngptsw,nlay) - in-cloud snow water path
9832 !    relqmc(nlay) - liquid particle effective radius (microns)
9833 !    reicmc(nlay) - ice particle effective radius (microns)
9834 !    rescmc(nlay) - snow particle effective radius (microns)
9835 !
9836 !  local :
9837 !    amd - Effective molecular weight of dry air (g/mol)
9838 !    amw - Molecular weight of water vapor (g/mol)
9839 !    amc - Molecular weight of carbon dioxide (g/mol)
9840 !    amo - Molecular weight of ozone (g/mol)
9841 !    amo2 - Molecular weight of oxygen (g/mol)
9842 !    amch4 - Molecular weight of methane (g/mol)
9843 !    amn2o - Molecular weight of nitrous oxide (g/mol)
9844 !    amdw - Molecular weight of dry air / water vapor
9845 !    amdc - Molecular weight of dry air / carbon dioxide
9846 !    amdo -  Molecular weight of dry air / ozone
9847 !    amdm - Molecular weight of dry air / methane
9848 !    amdn -  Molecular weight of dry air / nitrous oxide
9849 !    amdo2 - Molecular weight of dry air / oxygen
9850 !    sbc - Stefan-Boltzmann constant (W/m2K4)
9851 !    isp, l, ix, n, imol, ib, ig - Loop indices
9852 !    adjflx - flux adjustment for Earth/Sun distance
9853 !    earth_sun - function for Earth/Sun distance adjustment
9854 !
9855 !-------------------------------------------------------------------------------
9856    use parrrsw_k, only : nbndsw, ngptsw, nstr, nmol, mxmol,                    &
9857                           jpband, jpb1, jpb2, rrsw_scon
9858    use rrsw_con_k, only : heatfac, oneminus, pi, grav, avogad
9859    use rrsw_wvn_k, only : ng, nspa, nspb, wavenum1, wavenum2, delwave
9860 !
9861 ! ------- Declarations -------
9862 !
9863 ! ----- Input -----
9864    integer(kind=im),              intent(in   ) :: iplon
9865    integer(kind=im),              intent(in   ) :: nlay
9866    integer(kind=im),              intent(in   ) :: icld
9867    integer(kind=im),              intent(in   ) :: iaer
9868    real(kind=rb), dimension(:,:), intent(in   ) :: play
9869    real(kind=rb), dimension(:,:), intent(in   ) :: plev
9870    real(kind=rb), dimension(:,:), intent(in   ) :: tlay
9871    real(kind=rb), dimension(:,:), intent(in   ) :: tlev
9872    real(kind=rb), dimension(:),   intent(in   ) :: tsfc
9873    real(kind=rb), dimension(:,:), intent(in   ) :: h2ovmr
9874    real(kind=rb), dimension(:,:), intent(in   ) :: o3vmr
9875    real(kind=rb), dimension(:,:), intent(in   ) :: co2vmr
9876    real(kind=rb), dimension(:,:), intent(in   ) :: ch4vmr
9877    real(kind=rb), dimension(:,:), intent(in   ) :: n2ovmr
9878    real(kind=rb), dimension(:,:), intent(in   ) :: o2vmr
9879    integer(kind=im),              intent(in   ) :: dyofyr
9880    real(kind=rb),                 intent(in   ) :: adjes
9881    real(kind=rb),                 intent(in   ) :: scon
9882 !
9883    integer(kind=im),              intent(in   ) :: inflgsw
9884    integer(kind=im),              intent(in   ) :: iceflgsw
9885    integer(kind=im),              intent(in   ) :: liqflgsw
9886 !
9887    real(kind=rb), dimension(:,:,:), intent(in   ) :: cldfmcl
9888    real(kind=rb), dimension(:,:,:), intent(in   ) :: taucmcl
9889    real(kind=rb), dimension(:,:,:), intent(in   ) :: ssacmcl
9890    real(kind=rb), dimension(:,:,:), intent(in   ) :: asmcmcl
9891    real(kind=rb), dimension(:,:,:), intent(in   ) :: fsfcmcl
9892    real(kind=rb), dimension(:,:,:), intent(in   ) :: ciwpmcl
9893    real(kind=rb), dimension(:,:,:), intent(in   ) :: clwpmcl
9894    real(kind=rb), dimension(:,:,:), intent(in   ) :: cswpmcl
9895    real(kind=rb), dimension(:,:),   intent(in   ) :: reicmcl
9896    real(kind=rb), dimension(:,:),   intent(in   ) :: relqmcl
9897    real(kind=rb), dimension(:,:),   intent(in   ) :: resnmcl
9898 !
9899    real(kind=rb), dimension(:,:,:), intent(in   ) :: tauaer
9900    real(kind=rb), dimension(:,:,:), intent(in   ) :: ssaaer
9901    real(kind=rb), dimension(:,:,:), intent(in   ) :: asmaer
9902 !
9903 ! Atmosphere
9904 !
9905    integer(kind=im),                intent(  out) :: nlayers
9906    real(kind=rb), dimension(:),     intent(  out) :: pavel
9907    real(kind=rb), dimension(:),     intent(  out) :: tavel
9908    real(kind=rb), dimension(0:),    intent(  out) :: pz
9909    real(kind=rb), dimension(0:),    intent(  out) :: tz
9910    real(kind=rb),                   intent(  out) :: tbound
9911    real(kind=rb), dimension(:),     intent(  out) :: pdp
9912    real(kind=rb), dimension(:),     intent(  out) :: coldry
9913    real(kind=rb), dimension(:,:),   intent(  out) :: wkl
9914    real(kind=rb), dimension(:),     intent(  out) :: adjflux
9915    real(kind=rb), dimension(:),     intent(  out) :: solvar
9916    real(kind=rb), dimension(:,:),   intent(  out) :: taua
9917    real(kind=rb), dimension(:,:),   intent(  out) :: ssaa
9918    real(kind=rb), dimension(:,:),   intent(  out) :: asma
9919 !
9920 ! Atmosphere/clouds - cldprop
9921 !
9922    integer(kind=im),                intent(  out) :: inflag
9923    integer(kind=im),                intent(  out) :: iceflag
9924    integer(kind=im),                intent(  out) :: liqflag
9925 !
9926    real(kind=rb), dimension(:,:),   intent(  out) :: cldfmc
9927    real(kind=rb), dimension(:,:),   intent(  out) :: taucmc
9928    real(kind=rb), dimension(:,:),   intent(  out) :: ssacmc
9929    real(kind=rb), dimension(:,:),   intent(  out) :: asmcmc
9930    real(kind=rb), dimension(:,:),   intent(  out) :: fsfcmc
9931    real(kind=rb), dimension(:,:),   intent(  out) :: ciwpmc
9932    real(kind=rb), dimension(:,:),   intent(  out) :: clwpmc
9933    real(kind=rb), dimension(:,:),   intent(  out) :: cswpmc
9934    real(kind=rb), dimension(:),     intent(  out) :: relqmc
9935    real(kind=rb), dimension(:),     intent(  out) :: reicmc
9936    real(kind=rb), dimension(:),     intent(  out) :: resnmc
9937 !
9938 ! ----- Local -----
9939 !
9940    real(kind=rb), parameter :: amd = 28.9660_rb
9941    real(kind=rb), parameter :: amw = 18.0160_rb
9942 !  real(kind=rb), parameter :: amc = 44.0098_rb
9943 !  real(kind=rb), parameter :: amo = 47.9998_rb
9944 !  real(kind=rb), parameter :: amo2 = 31.9999_rb
9945 !  real(kind=rb), parameter :: amch4 = 16.0430_rb
9946 !  real(kind=rb), parameter :: amn2o = 44.0128_rb
9947 !
9948 ! Set molecular weight ratios (for converting mmr to vmr)
9949 !  e.g. h2ovmr = h2ommr * amdw)
9950 !
9951    real(kind=rb), parameter :: amdw = 1.607793_rb
9952    real(kind=rb), parameter :: amdc = 0.658114_rb
9953    real(kind=rb), parameter :: amdo = 0.603428_rb
9954    real(kind=rb), parameter :: amdm = 1.805423_rb
9955    real(kind=rb), parameter :: amdn = 0.658090_rb
9956    real(kind=rb), parameter :: amdo2 = 0.905140_rb
9957 !
9958    real(kind=rb), parameter :: sbc = 5.67e-08_rb
9959 !
9960    integer(kind=im) :: isp, l, ix, n, imol, ib, ig
9961    real(kind=rb) :: amm, summol
9962    real(kind=rb) :: adjflx
9963 !  real(kind=rb) :: earth_sun
9964 !-------------------------------------------------------------------------------
9965    nlayers = nlay
9966 !
9967 !  Initialize all molecular amounts to zero here, then pass input amounts
9968 !  into RRTM array WKL below.
9969 !
9970    wkl(:,:) = 0.0_rb
9971    cldfmc(:,:) = 0.0_rb
9972    taucmc(:,:) = 0.0_rb
9973    ssacmc(:,:) = 1.0_rb
9974    asmcmc(:,:) = 0.0_rb
9975    fsfcmc(:,:) = 0.0_rb
9976    ciwpmc(:,:) = 0.0_rb
9977    clwpmc(:,:) = 0.0_rb
9978    cswpmc(:,:) = 0.0_rb
9979    reicmc(:) = 0.0_rb
9980    relqmc(:) = 0.0_rb
9981    resnmc(:) = 0.0_rb
9982    taua(:,:) = 0.0_rb
9983    ssaa(:,:) = 1.0_rb
9984    asma(:,:) = 0.0_rb
9985 !
9986 ! Set flux adjustment for current Earth/Sun distance (two options).
9987 ! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes);
9988 !
9989    adjflx = adjes
9990 !
9991 ! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year.
9992 !    (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU).
9993 !
9994    if (dyofyr .gt. 0) then
9995      adjflx = earth_sun(dyofyr)
9996    endif
9997 !
9998 ! Set incoming solar flux adjustment to include adjustment for
9999 ! current Earth/Sun distance (ADJFLX) and scaling of default internal
10000 ! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR).  SOLVAR can be set
10001 ! to a single scaling factor as needed, or to a different value in each
10002 ! band, which may be necessary for paleoclimate simulations.
10003 !
10004    do ib = jpb1,jpb2
10005 !    solvar(ib) = 1._rb
10006      solvar(ib) = scon / rrsw_scon
10007      adjflux(ib) = adjflx * solvar(ib)
10008    enddo
10009 !
10010 !  Set surface temperature.
10011 !
10012    tbound = tsfc(iplon)
10013 !
10014 !  Install input GCM arrays into RRTMG_SW arrays for pressure, temperature,
10015 !  and molecular amounts.
10016 !  Pressures are input in mb, or are converted to mb here.
10017 !  Molecular amounts are input in volume mixing ratio, or are converted from
10018 !  mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
10019 !  here. These are then converted to molecular amount (molec/cm2) below.
10020 !  The dry air column COLDRY (in molec/cm2) is calculated from the level
10021 !  pressures, pz (in mb), based on the hydrostatic equation and includes a
10022 !  correction to account for h2o in the layer.  The molecular weight of moist
10023 !  air (amm) is calculated for each layer.
10024 !  Note: In RRTMG, layer indexing goes from bottom to top, and coding below
10025 !  assumes GCM input fields are also bottom to top. Input layer indexing
10026 !  from GCM fields should be reversed here if necessary.
10027 !
10028    pz(0) = plev(iplon,1)
10029    tz(0) = tlev(iplon,1)
10030    do l = 1,nlayers
10031      pavel(l) = play(iplon,l)
10032      tavel(l) = tlay(iplon,l)
10033      pz(l) = plev(iplon,l+1)
10034      tz(l) = tlev(iplon,l+1)
10035      pdp(l) = pz(l-1) - pz(l)
10036 !
10037 ! For h2o input in vmr:
10038      wkl(1,l) = h2ovmr(iplon,l)
10039 ! For h2o input in mmr:
10040 !    wkl(1,l) = h2o(iplon,l)*amdw
10041 ! For h2o input in specific humidity;
10042 !    wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
10043 !
10044      wkl(2,l) = co2vmr(iplon,l)
10045      wkl(3,l) = o3vmr(iplon,l)
10046      wkl(4,l) = n2ovmr(iplon,l)
10047      wkl(6,l) = ch4vmr(iplon,l)
10048      wkl(7,l) = o2vmr(iplon,l)
10049      amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw
10050      coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad /                          &
10051                      (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
10052    enddo
10053 !
10054 ! The following section can be used to set values for an additional layer (from
10055 ! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes.
10056 ! Temperature and molecular amounts in the extra model layer are set to
10057 ! their values in the top GCM model layer, though these can be modified
10058 ! here if necessary.
10059 ! If this feature is utilized, increase nlayers by one above, limit the two
10060 ! loops above to (nlayers-1), and set the top most (nlayers) layer values here.
10061 !
10062 !      pavel(nlayers) = 0.5_rb * pz(nlayers-1)
10063 !      tavel(nlayers) = tavel(nlayers-1)
10064 !      pz(nlayers) = 1.e-4_rb
10065 !      tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
10066 !      tz(nlayers) = tz(nlayers-1)
10067 !      pdp(nlayers) = pz(nlayers-1) - pz(nlayers)
10068 !      wkl(1,nlayers) = wkl(1,nlayers-1)
10069 !      wkl(2,nlayers) = wkl(2,nlayers-1)
10070 !      wkl(3,nlayers) = wkl(3,nlayers-1)
10071 !      wkl(4,nlayers) = wkl(4,nlayers-1)
10072 !      wkl(6,nlayers) = wkl(6,nlayers-1)
10073 !      wkl(7,nlayers) = wkl(7,nlayers-1)
10074 !      amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
10075 !      coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad /                  &
10076 !                        (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
10077 !
10078 ! At this point all molecular amounts in wkl are in volume mixing ratio;
10079 ! convert to molec/cm2 based on coldry for use in rrtm.
10080 !
10081    do l = 1,nlayers
10082      do imol = 1,nmol
10083        wkl(imol,l) = coldry(l) * wkl(imol,l)
10084      enddo
10085    enddo
10086 !
10087 ! Transfer aerosol optical properties to RRTM variables;
10088 ! modify to reverse layer indexing here if necessary.
10089 !
10090    if (iaer .ge. 1) then
10091      do l = 1,nlayers
10092        do ib = 1,nbndsw
10093          taua(l,ib) = tauaer(iplon,l,ib)
10094          ssaa(l,ib) = ssaaer(iplon,l,ib)
10095          asma(l,ib) = asmaer(iplon,l,ib)
10096        enddo
10097      enddo
10098    endif
10099 !
10100 ! Transfer cloud fraction and cloud optical properties to RRTM variables;
10101 ! modify to reverse layer indexing here if necessary.
10102 !
10103    if (icld .ge. 1) then
10104      inflag = inflgsw
10105      iceflag = iceflgsw
10106      liqflag = liqflgsw
10107 !
10108 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
10109 ! For GCM input, incoming reicmcl is defined based on selected ice
10110 ! parameterization (inflgsw)
10111 !
10112      do l = 1,nlayers
10113        do ig = 1,ngptsw
10114          cldfmc(ig,l) = cldfmcl(ig,iplon,l)
10115          taucmc(ig,l) = taucmcl(ig,iplon,l)
10116          ssacmc(ig,l) = ssacmcl(ig,iplon,l)
10117          asmcmc(ig,l) = asmcmcl(ig,iplon,l)
10118          fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
10119          ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
10120          clwpmc(ig,l) = clwpmcl(ig,iplon,l)
10121          if(iceflag.eq.5) then
10122            cswpmc(ig,l) = cswpmcl(ig,iplon,l)
10123          endif
10124        enddo
10125        reicmc(l) = reicmcl(iplon,l)
10126        relqmc(l) = relqmcl(iplon,l)
10127        if(iceflag.eq.5) then
10128          resnmc(l) = resnmcl(iplon,l)
10129        endif
10130      enddo
10131 !
10132 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in
10133 ! the extra layer.
10134 !
10135 !         cldfmc(:,nlayers) = 0.0_rb
10136 !         taucmc(:,nlayers) = 0.0_rb
10137 !         ssacmc(:,nlayers) = 1.0_rb
10138 !         asmcmc(:,nlayers) = 0.0_rb
10139 !         fsfcmc(:,nlayers) = 0.0_rb
10140 !         ciwpmc(:,nlayers) = 0.0_rb
10141 !         clwpmc(:,nlayers) = 0.0_rb
10142 !         reicmc(nlayers) = 0.0_rb
10143 !         relqmc(nlayers) = 0.0_rb
10144 !
10145    endif
10146 !
10147    end subroutine inatm_sw
10148 !-------------------------------------------------------------------------------
10149 !
10150 !
10151 !-------------------------------------------------------------------------------
10152    end module rrtmg_sw_rad_k
10153 !-------------------------------------------------------------------------------
10154 !
10155 !
10156 !-------------------------------------------------------------------------------
10157    module module_ra_rrtmg_swk
10158 !-------------------------------------------------------------------------------
10159    use module_model_constants,  only: cp, rd=>r_d, t0c=>SVPT0
10160    use parrrsw_k, only : nbndsw, ngptsw, naerec
10161    use parrrtm_k, only : nbndlw, ngptlw
10162    use rrtmg_sw_init_k, only: rrtmg_sw_ini
10163    use rrtmg_sw_rad_k, only: rrtmg_sw
10164    use rrtmg_lw_rad_k, only :rrtmg_lw
10165    use mcica_subcol_gen_k, only: mcica_subcol
10166    use module_ra_rrtmg_lwk, only : inirad, relcalc, reicalc
10167    use module_ra_effective_radius
10168 !
10169 contains
10170 !-------------------------------------------------------------------------------
10171 !
10172 !
10173 !-------------------------------------------------------------------------------
10174    subroutine rad_rrtmg_driver(                                                &
10175                        rthratenlw,rthratensw,                                  &
10176                        rthratenlwc,rthratenswc,                                &
10177                        lwupflx, lwupflxc, lwdnflx, lwdnflxc,                   &
10178                        swupflx, swupflxc, swdnflx, swdnflxc,                   &
10179                        lwupt, lwuptc, lwdnt, lwdntc,                           &
10180                        lwupb, lwupbc, lwdnb, lwdnbc,                           &
10181                        glw, olr, lwcf,                                         &
10182                        swupt, swuptc, swdnt, swdntc,                           &
10183                        swupb, swupbc, swdnb, swdnbc,                           &
10184                        gsw, swcf, cosz, solcon,                                &
10185                        albedo,                                                 &
10186                        emiss,                                                  &
10187                        t3d, t8w, tsk,                                          &
10188                        rho3d,                                                  &
10189                        p3d, p8w, cldfra3d, r, g,                               &
10190                        nc3d, xland,                                            &
10191                        f_qnc, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,              &
10192                        qv3d, qc3d, qr3d, qi3d, qs3d, qg3d,                     &
10193 !sh
10194                        o3input, o33d,                                          &
10195                        aer_opt, aerod, no_src,                                 &
10196 !sh
10197                        ids,ide, jds,jde, kds,kde,                              &
10198                        ims,ime, jms,jme, kms,kme,                              &
10199                        its,ite, jts,jte, kts,kte                               )
10200 !-------------------------------------------------------------------------------
10201 ! abstract : unified rrtmg sw lw driver
10202 !
10203 ! history log :
10204 !  2016-3-10   sunghye baek initial setup
10205 !  2017-1-15   sunghye baek wrf format correction
10206 !-------------------------------------------------------------------------------
10207 !
10208    implicit none
10209 !
10210    integer, parameter :: natype=5
10211    real, parameter    :: qmin=0.
10212
10213    logical, intent(in   ) ::  f_qnc, f_qv, f_qc, f_qr, f_qi, f_qs, f_qg
10214    integer, intent(in   ) ::  ids,ide, jds,jde, kds,kde
10215    integer, intent(in   ) ::  ims,ime, jms,jme, kms,kme
10216    integer, intent(in   ) ::  its,ite, jts,jte, kts,kte
10217    integer, intent(in   ) ::  no_src
10218    integer, optional, intent(in   ) :: o3input, aer_opt
10219
10220    real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratensw
10221    real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenlw
10222    real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenswc
10223    real, dimension(ims:ime,kms:kme,jms:jme), intent(inout) :: rthratenlwc
10224    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwupflx
10225    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwupflxc
10226    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwdnflx
10227    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: lwdnflxc
10228    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swupflx
10229    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swupflxc
10230    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swdnflx
10231    real, dimension(ims:ime,kms:kme+2,jms:jme), optional, intent(inout) :: swdnflxc
10232    real, dimension(ims:ime,jms:jme),         intent(inout) :: lwupt, lwuptc
10233    real, dimension(ims:ime,jms:jme),         intent(inout) :: lwdnt, lwdntc
10234    real, dimension(ims:ime,jms:jme),         intent(inout) :: lwupb, lwupbc
10235    real, dimension(ims:ime,jms:jme),         intent(inout) :: lwdnb, lwdnbc
10236    real, dimension(ims:ime,jms:jme),         intent(inout) :: glw, olr, lwcf
10237    real, dimension(ims:ime,jms:jme),         intent(inout) :: swupt, swuptc
10238    real, dimension(ims:ime,jms:jme),         intent(inout) :: swdnt, swdntc
10239    real, dimension(ims:ime,jms:jme),         intent(inout) :: swupb, swupbc
10240    real, dimension(ims:ime,jms:jme),         intent(inout) :: swdnb, swdnbc
10241    real, dimension(ims:ime,jms:jme),         intent(inout) :: gsw, swcf
10242    real, dimension(ims:ime,jms:jme),         intent(in   ) :: cosz
10243    real,                                     intent(in   ) :: solcon
10244    real, dimension(ims:ime,jms:jme),         intent(in   ) :: albedo, emiss
10245    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: t8w, p8w
10246    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: t3d, p3d
10247    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: rho3d
10248    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: nc3d
10249    real, dimension(ims:ime,jms:jme),         intent(in   ) :: xland, tsk
10250    real,                                     intent(in   ) :: r,g
10251    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: cldfra3d
10252    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: qv3d, qc3d, qr3d
10253    real, dimension(ims:ime,kms:kme,jms:jme), intent(in   ) :: qi3d, qs3d, qg3d
10254    real, dimension(ims:ime,kms:kme,jms:jme), optional, intent(in   ) :: o33d
10255    real, dimension(ims:ime,kms:kme,jms:jme,1:no_src), optional, intent(in   )&
10256                                                            :: aerod
10257
10258
10259 !  xland 1 for land 2 for water
10260
10261 !   real, dimension(ims:ime,jms:jme),         intent(in   ) :: aluvb, aluvd
10262 !   real, dimension(ims:ime,jms:jme),         intent(in   ) :: alnirb, alnird
10263
10264 !
10265 ! Added local arrays for RRTMG
10266 !
10267    integer :: ncol, nlay, icld
10268    integer :: inflgsw, iceflgsw, liqflgsw
10269    integer :: inflglw, iceflglw, liqflglw
10270 !
10271 ! Dimension with extra layer from model top to TOA
10272 !
10273    real, dimension(1,kts:kte+2) :: plev
10274    real, dimension(1,kts:kte+2) :: tlev
10275    real, dimension(1,kts:kte+1) :: play
10276    real, dimension(1,kts:kte+1) :: tlay
10277    real, dimension(1,kts:kte+1) :: h2ovmr, o3vmr, co2vmr, o2vmr, ch4vmr, n2ovmr
10278    real, dimension(1,kts:kte+1) :: cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr
10279    real, dimension(kts:kte+1)   :: o3mmr
10280 !
10281 ! Surface albedo (for UV/visible and near-IR spectral regions,
10282 ! and for direct and diffuse radiation)
10283 !`
10284    real, dimension(1) :: asdir, asdif, aldir, aldif
10285    real, dimension(1) :: visdir, visdif, nirdir, nirdif
10286 !
10287 ! Surface emissivity (for 16 LW spectral bands)
10288 !
10289    real, dimension(1,nbndlw)    :: emis
10290 !
10291 ! Dimension with extra layer from model top to TOA,
10292 ! though no clouds are allowed in extra layer
10293 !
10294    real, dimension(1,kts:kte+1)  :: cldfrac
10295    real, dimension(1,kts:kte+1)  :: clwpth, ciwpth
10296    real, dimension(1,kts:kte+1)  :: rel, rei
10297    real, dimension(1,kts:kte+1)  :: cswpth, res
10298    real, dimension(ngptsw,1,kts:kte+1)  :: staucmcl, sssacmcl
10299    real, dimension(ngptsw,1,kts:kte+1)  :: sasmcmcl, sfsfcmcl
10300    real, dimension(ngptlw,1,kts:kte+1)  :: lcldfmcl, ltaucmcl
10301    real, dimension(ngptlw,1,kts:kte+1)  :: lclwpmcl, lciwpmcl
10302    real, dimension(ngptlw,1,kts:kte+1)  :: lcswpmcl
10303    real, dimension(1,kts:kte+1,nbndsw)  :: stauaer, ssaaer, asmaer
10304    real, dimension(1,kts:kte+1,nbndlw)  :: ltauaer
10305    real, dimension(1,kts:kte+1)         :: qo31d
10306    real, dimension(1,kts:kte+1,naerec)  :: ecaer
10307    real, dimension(1,kts:kte+1)           :: co2_t
10308    integer, parameter                   :: has_reqc = 1
10309    integer, parameter                   :: has_reqi = 1
10310    integer, parameter                   :: has_reqs = 1
10311    real                                 :: pi,third,relconst,lwpmin,rhoh2o
10312 !
10313 ! Output arrays contain extra layer from model top to TOA
10314 !
10315    real, dimension(1,kts:kte+2)         :: swuflx
10316    real, dimension(1,kts:kte+2)         :: swdflx
10317    real, dimension(1,kts:kte+2)         :: swuflxc
10318    real, dimension(1,kts:kte+2)         :: swdflxc
10319    real, dimension(1,kts:kte+1)         :: swhr
10320    real, dimension(1,kts:kte+1)         :: swhrc
10321    real, dimension(1)                   :: tsfc, ps, coszen
10322    real, dimension(1,kts:kte+2)         :: uflx
10323    real, dimension(1,kts:kte+2)         :: dflx
10324    real, dimension(1,kts:kte+2)         :: uflxc
10325    real, dimension(1,kts:kte+2)         :: dflxc
10326    real, dimension(1,kts:kte+1)         :: hr
10327    real, dimension(1,kts:kte+1)         :: hrc
10328    real                                 :: ro, dz, adjes
10329    real                                 :: landf, icef, snowd, scon
10330    real, dimension(kts:kte)             :: re_qc, re_qi, re_qs
10331    real, dimension(kts:kte)             :: o31d
10332    real                                 :: snow_mass_factor
10333    real, dimension(kts:kte)             :: qsum1d, qccps
10334    real, dimension(its:ite)             :: xice
10335    integer                              :: dyofyr
10336
10337
10338 !
10339 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
10340 ! carbon dioxide (379 ppmv)
10341 !
10342    real :: co2
10343    data co2 / 379.e-6 /
10344 !
10345 ! methane (1774 ppbv)
10346 !
10347    real :: ch4
10348    data ch4 / 1774.e-9 /
10349 !
10350 ! nitrous oxide (319 ppbv)
10351 !
10352    real :: n2o
10353    data n2o / 319.e-9 /
10354 !
10355 ! cfc-11 (251 ppt)
10356 !
10357    real :: cfc11
10358    data cfc11 / 0.251e-9 /
10359 !
10360 ! cfc-12 (538 ppt)
10361    real :: cfc12
10362    data cfc12 / 0.538e-9 /
10363 !
10364 ! cfc-22 (169 ppt)
10365 !
10366    real :: cfc22
10367    data cfc22 / 0.169e-9 /
10368 !
10369 ! ccl4 (93 ppt)
10370 !
10371    real :: ccl4
10372    data ccl4 / 0.093e-9 /
10373 !
10374 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
10375 !
10376    real :: o2
10377    data o2 / 0.209488 /
10378 !
10379    integer :: iplon, irng, permuteseed
10380    integer :: nb
10381 !
10382 ! For old cloud property specification for rrtm_lw
10383 ! Cloud and precipitation absorption coefficients
10384 !
10385    real :: abcw, abice, abrn, absn
10386    data abcw /0.144/
10387    data abice /0.0735/
10388    data abrn /0.330e-3/
10389    data absn /2.34e-3/
10390    real :: amdw     ! Molecular weight of dry air / water vapor
10391    real :: amdo     ! Molecular weight of dry air / ozone
10392    real :: amdo2    ! Molecular weight of dry air / oxygen
10393    data amdw /  1.607793 /
10394    data amdo /  0.603461 /
10395    data amdo2 / 0.905190 /
10396 !
10397    real, dimension(kts:kte) :: pdel  ! mb
10398    real, dimension(kts:kte) :: cicewp, cliqwp
10399    real, dimension(kts:kte) :: csnowp
10400    real, dimension(kts:kte) :: cldfra1d
10401    real :: gsnowp, gliqwp, gicewp, gravmks, gravdvd
10402    real :: fp
10403    real :: coszrs
10404    logical, dimension(its:ite, jts:jte) :: dorrsw
10405    integer :: pver
10406    real :: xt24, tloctm, hrang, xxlat
10407    integer :: i, j, k, na
10408    logical :: predicate
10409
10410 !-------------------------------------------------------------------------------
10411 !
10412 ! Zero out cloud optical properties here, calculated in radiation
10413 !
10414    staucmcl = 0.0
10415    sssacmcl = 1.0
10416    sasmcmcl = 0.0
10417    sfsfcmcl = 0.0
10418
10419 !
10420 ! Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
10421 !
10422    stauaer = 0.
10423    ssaaer = 1.
10424    asmaer = 0.
10425    ltauaer =0.
10426 !
10427    ltaucmcl = 0.
10428 !
10429    qo31d = 0.
10430    co2_t = 0.0
10431    ecaer = 0.0
10432    o31d = 0.0
10433 !
10434 !
10435 !---------------------------------------------------------------------------------
10436
10437 !
10438 !-----CALCULATE SHORT & LONG WAVE RADIATION
10439 !
10440 ! All fields are ordered vertically from bottom to top
10441 ! Pressures are in mb
10442 !
10443 !
10444 ! Set solar constant
10445 !
10446    scon = solcon
10447 !
10448 ! For Earth/Sun distance adjustment in RRTMG
10449 !         dyofyr = julday
10450 !         adjes = 0.0
10451 !  solar constant is already provided with eccentricity adjustment,
10452 ! so do not do this in RRTMG
10453 !
10454    dyofyr = 0
10455    adjes = 1.0
10456    ncol = 0
10457    pver = kte - kts + 1
10458 !SET CONST here for fast computation
10459    gravmks = g
10460    gravdvd = 1000./g
10461    dorrsw = .true.
10462 !
10463    do j = jts,jte
10464      do i = its,ite
10465       if(cosz(i,j).le.0.0) dorrsw(i,j) = .false.
10466      enddo
10467    enddo
10468 !
10469 ! Add extra layer from top of model to top of atmosphere
10470 !
10471    nlay = (kte - kts + 1) + 1
10472 !
10473 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
10474 !
10475    icld = 2
10476    inflgsw = 2
10477    iceflgsw = 3
10478    liqflgsw = 1
10479 !
10480    inflglw = 2
10481    iceflglw = 3
10482    liqflglw = 1
10483 !
10484 ! START LOOP FOR SETTING CLOUD PROPERTY
10485 !
10486    ncol=0
10487    do j = jts,jte
10488      do i = its,ite
10489 !
10490 !-------------------------------------------------
10491 !   1. SET SURFACE PROPERTY
10492 !----------------- --------------------------------
10493 !
10494
10495 !
10496 !-------------------------------------------------
10497 !   2. SET AEROSOL PROPERTY
10498 !-------------------------------------------------
10499 !
10500 !       do na = 1,natype
10501 !         aod_t(1,kts:kte,na) = aod_t3d(i,kts:kte,na)
10502 !         aod_t(1,kte+1,na) = 0.
10503 !       enddo
10504 !
10505 !-------------------------------------------------
10506 !   3. SET OZONE PROPERTY
10507 !-------------------------------------------------
10508 !
10509 !       do k = kts,kte
10510 !         qo31d(1,k) = qo3_3d(i,k,j)
10511 !       enddo
10512 !
10513 !       qo31d(1,kte+1) = qo31d(1,kte,j)
10514 !
10515 !-------------------------------------------------
10516 !   4. SET CO2 PROPERTY
10517 !-------------------------------------------------
10518 !
10519 !       do k = kts,kte
10520 !         co2_t(1,k) = co2_3d(i,k)
10521 !       enddo
10522 !
10523 !       co2_t(1,kte+1) = co2_t(1,kte)
10524 !
10525 !-------------------------------------------------
10526 !   5. SET OPTICAL CLOUD PROPERTY
10527 !-------------------------------------------------
10528 !
10529 !
10530 !
10531 !-------------------------------------------------
10532 !   5-1. SET EFFECTIVE RADIUS
10533 !-------------------------------------------------
10534 !
10535        do k = kts,kte
10536          qsum1d(k) = qi3d(i,k,j)+qc3d(i,k,j)+qs3d(i,k,j)
10537          cldfra1d(k) = cldfra3d(i,k,j)
10538        enddo
10539 !
10540        re_qc = 5.0e-6
10541        re_qi = 10.0e-6
10542        re_qs = 25.0e-6
10543 !
10544
10545        if(f_qc) then
10546          inflgsw = 3  ;  inflglw = 3
10547        endif
10548
10549        if(f_qi) then
10550          inflgsw  = 4 ;  iceflgsw = 4
10551          inflglw  = 4 ;  iceflglw = 4
10552        endif
10553
10554        if(f_qs) then
10555          inflgsw  = 5 ;  iceflgsw = 5
10556          inflglw  = 5 ;  iceflglw = 5
10557        endif
10558
10559
10560        qccps = 0.e0
10561
10562        call effectRad(t3d(i,kts:kte,j), qc3d(i,kts:kte,j), nc3d(i,kts:kte,j),  &
10563                       qi3d(i,kts:kte,j), qs3d(i,kts:kte,j), qg3d(i,kts:kte,j), &
10564                       rho3d(i,kts:kte,j), qmin, t0c, qccps, f_qnc,             &
10565                       re_qc, re_qi, re_qs, kts, kte)
10566
10567        re_qc = re_qc * 1.e+6
10568        re_qi = re_qi * 1.e+6
10569        re_qs = re_qs * 1.e+6
10570
10571        re_qc(kts:kte)  = max(2.51,  min(re_qc(kts:kte),  50.))
10572        re_qi(kts:kte)  = max(10.01, min(re_qi(kts:kte), 125.))
10573        re_qs(kts:kte)  = max(25.,   min(re_qs(kts:kte), 999.))
10574
10575 !-------------------------------------------------
10576 !   5-2. SET CLOUD HYDROMETEOR PROPERTY
10577 !-------------------------------------------------
10578 !
10579 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
10580 ! Water paths are in units of g/m2
10581 ! snow added as ice cloud (JD 091022)
10582 !
10583 !
10584 ! pdel is in Pa here <==========
10585 !
10586        do k = kts,kte
10587          pdel(k) = p8w(i,k,j)-p8w(i,k+1,j)
10588        enddo
10589 !
10590 !       if (p8w(i,kte+1).eq.0.) pdel(kte) = p8w(i,kte) - 1.e-2
10591 !
10592        do k = kts,kte
10593 !        Grid box ice water path.
10594          gicewp = (qi3d(i,k,j)+qs3d(i,k,j)) * pdel(k) * gravdvd
10595 !        Grid box liquid water path.
10596          gliqwp = qc3d(i,k,j) * pdel(k) * gravdvd
10597 !        in-cloud ice water path.
10598          cicewp(k) = gicewp / max(0.01,cldfra1d(k))
10599 !        In-cloud liquid water path.
10600          cliqwp(k) = gliqwp / max(0.01,cldfra1d(k))
10601          if(cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10602            gliqwp = 1.e-9* pdel(k) * gravdvd
10603            cliqwp(k) = gliqwp     ! In-cloud liquid water path.
10604          endif
10605        enddo
10606 ! The ice water path is already sum of cloud ice and snow, but when we have
10607 ! explicit ice effective radius, overwrite the ice path with only the cloud
10608 ! ice variable, leaving out the snow for its own effect.
10609 !
10610        if (iceflgsw .ge. 4) then
10611          do k = kts,kte
10612            gicewp = qi3d(i,k,j)*pdel(k)* gravdvd    ! Grid box ice water path.
10613            cicewp(k) = gicewp/max(0.01,cldfra1d(k))    ! In-cloud ice water path.
10614            if(cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10615              gicewp = 1.e-9*pdel(k)* gravdvd
10616              cicewp(k) = gicewp      ! In-cloud ice water path.
10617            endif
10618          enddo
10619        end if
10620 !
10621 !
10622 ! Here the snow path is adjusted if (radiation) effective radius of snow is
10623 ! larger than what we currently have in the lookup tables.  Since mass goes
10624 ! rather close to diameter squared, adjust the mixing ratio of snow used
10625 ! to compute its water path in combination with the max diameter.  Not a
10626 ! perfect fix, but certainly better than using all snow mass when diameter is
10627 ! far larger than table currently contains and crystal sizes much larger than
10628 ! about 140 microns have lesser impact than those much smaller sizes.
10629 !
10630 !
10631        if (iceflgsw.eq.5) then
10632          do k = kts,kte
10633            snow_mass_factor = 1.0
10634            if (re_qs(k).gt.130.)then
10635              snow_mass_factor =(130.0/re_qs(k))**2.
10636              re_qs(k)=130.
10637            endif
10638            ! Grid box snow water path.
10639            gsnowp = (qs3d(i,k,j)+qg3d(i,k,j))*snow_mass_factor*pdel(k)* gravdvd
10640            if (cldfra1d(k).gt.0. .and. qsum1d(k).lt.1.e-9) then
10641              gsnowp = 0.0
10642            endif
10643            csnowp(k) = gsnowp/max(0.01,cldfra1d(k))
10644          enddo
10645        endif
10646 !
10647 ! Limit upper bound of reice for Fu ice parameterization and convert
10648 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
10649 !
10650        if (iceflgsw.eq.3) then
10651          do k = kts,kte
10652            re_qi(k) = re_qi(k)*1.0315
10653            re_qi(k) = min(140.0,re_qi(k))
10654          enddo
10655        endif
10656 !
10657 !-------------------------------------------------
10658 !   6. FILLING ARRAYS FOR RRTMG_SW and RRTMG_LW
10659 !-------------------------------------------------
10660        ncol=1
10661        play(ncol, kts:kte )   = p3d(i,kts:kte,j)*1.e-2
10662        plev(ncol, kts:kte+1 ) = p8w(i,kts:kte+1,j)*1.e-2
10663        tlay(ncol, kts:kte )   = t3d(i,kts:kte,j)
10664        tlev(ncol, kts:kte+1)  = t8w(i,kts:kte+1,j)
10665        tsfc(ncol)             = tsk(i,j)
10666        h2ovmr(ncol, kts:kte ) = amax1(max(0.,qv3d(i,kts:kte,j)),3.0e-6) * amdw
10667        co2vmr(ncol, kts:kte ) = co2
10668        o2vmr(ncol, kts:kte )  = o2
10669        ch4vmr(ncol, kts:kte ) = ch4
10670        n2ovmr(ncol, kts:kte ) = n2o
10671        cfc11vmr(ncol,kts:kte) = cfc11
10672        cfc12vmr(ncol,kts:kte) = cfc12
10673        cfc22vmr(ncol,kts:kte) = cfc22
10674        ccl4vmr(ncol,kts:kte)  = ccl4
10675 !  Define profile values for extra layer from model top to top of atmosphere.
10676 !  The top layer temperature for all gridpoints is set to the top layer-1
10677 !  temperature plus a constant (0 K) that represents an isothermal layer
10678 !  above ptop.  Top layer interface temperatures are linearly interpolated
10679 !  from the layer temperatures.
10680        play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
10681        tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
10682        plev(ncol,kte+2) = 1.0e-5
10683        tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
10684        h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte)
10685        co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10686        o2vmr(ncol,kte+1) = o2vmr(ncol,kte)
10687        ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte)
10688        n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte)
10689        cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte)
10690        cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte)
10691        cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte)
10692        ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte)
10693 !
10694 !       do k = kts,kte
10695 !         o3vmr(ncol,k) = qo31d(1,k)*amdo              ! convert mmr to vmr
10696 !       enddo
10697 !
10698 !       o3vmr(ncol,kte+1) = o3vmr(ncol,kte)
10699 !
10700        call inirad(o3mmr,plev,kts,kte)
10701        do k = kts,kte+1
10702            o3vmr(ncol,k) = o3mmr(k)*amdo
10703        enddo
10704
10705        if(present(o33d).and.o3input.eq.2) then
10706          do k = kts,kte
10707             o31d(k) = o33d(i,k,j)
10708             o3vmr(ncol,k) = o31d(k)
10709          enddo
10710
10711          o3vmr(ncol,kte+1) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(kte+1)*amdo
10712          if(o3vmr(ncol,kte+1) .le. 0.) o3vmr(ncol,kte+1) = o3mmr(kte+1)*amdo
10713        endif
10714
10715
10716 !       do k = kts,kte
10717 !         co2vmr(ncol,k) = co2_t(1,k)
10718 !       enddo
10719 !       co2vmr(ncol,kte+1) = co2vmr(ncol,kte)
10720
10721 !
10722 !
10723 ! Set surface albedo for direct and diffuse radiation in UV/visible and
10724 ! near-IR spectral regions
10725 !
10726        asdir(ncol) = albedo(i,j)
10727        asdif(ncol) = albedo(i,j)
10728        aldir(ncol) = albedo(i,j)
10729        aldif(ncol) = albedo(i,j)
10730 !
10731 ! Set surface emissivity in each RRTMG longwave band
10732 !
10733        emis(ncol,:) = emiss(i,j)
10734 !
10735 ! Set cloud physical property arrays
10736 !
10737        clwpth(ncol,kts:kte) = cliqwp(kts:kte)
10738        ciwpth(ncol,kts:kte) = cicewp(kts:kte)
10739        rel(ncol,kts:kte) = re_qc(kts:kte)
10740        rei(ncol,kts:kte) = re_qi(kts:kte)
10741 !
10742        if (inflgsw .eq. 5) then
10743          cswpth(ncol,kts:kte) = csnowp(kts:kte)
10744          res(ncol,kts:kte) = re_qs(kts:kte)
10745        else
10746          cswpth(ncol,kts:kte) = 0.0
10747          res(ncol,kts:kte) = 10.0
10748        endif
10749 ! Set cosine of solar zenith angle
10750        coszen(ncol) = cosz(i,j)
10751 ! Layer indexing goes bottom to top here for all fields.
10752 ! Water vapor and ozone are converted from mmr to vmr.
10753 ! Pressures are in units of mb here.
10754        cldfrac(ncol,kts:kte) = cldfra1d(kts:kte)
10755 !
10756 ! No clouds are allowed in the extra layer from model top to TOA
10757 !
10758        clwpth(ncol,kte+1) = 0.
10759        ciwpth(ncol,kte+1) = 0.
10760        cswpth(ncol,kte+1) = 0.
10761        rel(ncol,kte+1) = 10.
10762        rei(ncol,kte+1) = 10.
10763        res(ncol,kte+1) = 10.
10764        cldfrac(ncol,kte+1) = 0.
10765        ecaer = 0.e0
10766        iplon = ncol
10767        irng = 0
10768
10769        permuteseed = 1
10770        call mcica_subcol (iplon, ncol, nlay, icld, permuteseed, irng, play,    &
10771                                                  cldfrac,   ciwpth, clwpth,    &
10772                                                         lciwpmcl, lclwpmcl,    &
10773                                                          cswpth,  lcswpmcl,    &
10774                                                                   lcldfmcl)
10775
10776 !
10777        if (dorrsw(i,j)) then
10778
10779          if (present(aerod)) then
10780            if (aer_opt.eq.1) then
10781              do na = 1,naerec
10782                 do k = kts, kte
10783                  ecaer(ncol,k,na) = aerod(i,k,j,na)
10784                 enddo
10785              enddo
10786            endif
10787          endif
10788
10789          call rrtmg_sw                                                         &
10790                 (ncol    ,nlay    ,icld    ,                                   &
10791                  play    ,plev    ,tlay    ,tlev    ,tsfc   ,                  &
10792                  h2ovmr , o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr ,           &
10793                  asdir   ,asdif   ,aldir   ,aldif   ,                          &
10794                  coszen  ,adjes   ,dyofyr  ,scon    ,                          &
10795                  inflgsw ,iceflgsw,liqflgsw,lcldfmcl(1:ngptsw,:,:) ,           &
10796                  staucmcl ,sssacmcl ,sasmcmcl ,sfsfcmcl ,                      &
10797                  lciwpmcl(1:ngptsw,:,:) ,lclwpmcl(1:ngptsw,:,:), rei ,rel,     &
10798                                               lcswpmcl(1:ngptsw,:,:), res,     &
10799                  stauaer  ,ssaaer  ,asmaer  ,ecaer   ,                         &
10800                  swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc ,          &
10801                  visdir  ,visdif  ,nirdir  ,nirdif )
10802
10803          rthratensw(i,kts:kte,j) = swhr(1,kts:kte)/86400.
10804          rthratenswc(i,kts:kte,j) = swhrc(1,kts:kte)/86400.
10805          if(present(swupflx))then
10806            swupflx(i,kts:kte+2,j) = swuflx(1,kts:kte+2)
10807            swupflxc(i,kts:kte+2,j) = swuflxc(1,kts:kte+2)
10808            swdnflx(i,kts:kte+2,j) = swdflx(1,kts:kte+2)
10809            swdnflxc(i,kts:kte+2,j) = swdflxc(1,kts:kte+2)
10810          endif
10811          gsw(i,j) = swdflx(1,1) - swuflx(1,1)
10812          swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2)   &
10813                      - swuflxc(1,kte+2))
10814          swupt(i,j)     = swuflx(1,kte+2)
10815          swuptc(i,j)    = swuflxc(1,kte+2)
10816          swdnt(i,j)     = swdflx(1,kte+2)
10817          swdntc(i,j)    = swdflxc(1,kte+2)
10818          swupb(i,j)     = swuflx(1,1)
10819          swupbc(i,j)    = swuflxc(1,1)
10820          swdnb(i,j)     = swdflx(1,1)
10821          swdnbc(i,j)    = swdflxc(1,1)
10822        endif ! do SW
10823 !
10824 ! Call RRTMG longwave radiation model
10825 !
10826        call rrtmg_lw                                                           &
10827                      (ncol, nlay, icld, play, plev , tlay,                     &
10828                       tlev ,tsfc, h2ovmr, o3vmr, co2vmr, ch4vmr,               &
10829                       n2ovmr, o2vmr, cfc11vmr, cfc12vmr, cfc22vmr, ccl4vmr,    &
10830                       emis, inflglw, iceflglw, liqflglw, lcldfmcl,             &
10831                       ltaucmcl, lciwpmcl, lclwpmcl, rei, rel,                  &
10832                       lcswpmcl, res,                                           &
10833                       ltauaer,                                                 &
10834                       uflx, dflx, hr, uflxc, dflxc, hrc)
10835 !
10836        rthratenlw(i,kts:kte,j) = hr(1,kts:kte)/86400.
10837        rthratenlwc(i,kts:kte,j) = hrc(1,kts:kte)/86400.
10838        if(present(lwupflx))then
10839          lwupflx(i,kts:kte+2,j) = uflx(1,kts:kte+2)
10840          lwupflxc(i,kts:kte+2,j) = uflxc(1,kts:kte+2)
10841          lwdnflx(i,kts:kte+2,j) = dflx(1,kts:kte+2)
10842          lwdnflxc(i,kts:kte+2,j) = dflxc(1,kts:kte+2)
10843        endif
10844        glw(i,j) = dflx(1,1)
10845        olr(i,j) = uflx(1,kte+2)
10846        lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
10847        lwupt(i,j)     = uflx(1,kte+2)
10848        lwuptc(i,j)    = uflxc(1,kte+2)
10849        lwdnt(i,j)     = dflx(1,kte+2)
10850        lwdntc(i,j)    = dflxc(1,kte+2)
10851        lwupb(i,j)     = uflx(1,1)
10852        lwupbc(i,j)    = uflxc(1,1)
10853        lwdnb(i,j)     = dflx(1,1)
10854        lwdnbc(i,j)    = dflxc(1,1)
10855      enddo ! jts:jte end j LOOP
10856    enddo ! its:ite end GRAND LOOP
10857    end subroutine rad_rrtmg_driver
10858 !-------------------------------------------------------------------------------
10859 !-------------------------------------------------------------------------------
10860    subroutine rrtmg_swinit_k(                                                  &
10861                                 allowed_to_read ,                              &
10862                                 ids, ide, jds, jde, kds, kde,                  &
10863                                 ims, ime, jms, jme, kms, kme,                  &
10864                                 its, ite, jts, jte, kts, kte  )
10865 !-------------------------------------------------------------------------------
10866    use rrtmg_sw_init_k
10867 !
10868    implicit none
10869 !
10870    logical, intent(in)            :: allowed_to_read
10871    integer, intent(in)             :: ids, ide, jds, jde, kds, kde,            &
10872                                      ims, ime, jms, jme, kms, kme,             &
10873                                      its, ite, jts, jte, kts, kte
10874 !-------------------------------------------------------------------------------
10875 !
10876 ! Read in absorption coefficients and other data
10877 !
10878    IF ( allowed_to_read ) then
10879      call rrtmg_swlookuptable
10880    endif
10881 !
10882 ! Perform g-point reduction and other initializations
10883 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
10884 !
10885    call rrtmg_sw_ini(cp)
10886 !
10887    end subroutine rrtmg_swinit_k
10888 !-------------------------------------------------------------------------------
10889 !
10890 !
10891 !-------------------------------------------------------------------------------
10892    subroutine rrtmg_swlookuptable
10893 !
10894    implicit none
10895 !
10896 ! Local
10897 !
10898    integer :: i
10899    logical                 :: opened
10900    logical , external      :: wrf_dm_on_monitor
10901    character*80 errmess
10902    integer rrtmg_unit
10903 !-------------------------------------------------------------------------------
10904    if ( wrf_dm_on_monitor() ) then
10905      do i = 10,99
10906        inquire ( i , opened = opened )
10907        if ( .not. opened ) then
10908          rrtmg_unit = i
10909          goto 2010
10910        endif
10911      enddo
10912      rrtmg_unit = -1
10913 2010   continue
10914    endif
10915    call wrf_dm_bcast_bytes ( rrtmg_unit , 4 )
10916
10917
10918    if ( wrf_dm_on_monitor() ) then
10919      open(rrtmg_unit,file='RRTMG_SW_DATA',                                     &
10920            form='UNFORMATTED',status='OLD',err=9009)
10921    endif
10922    call sw_kgb16(rrtmg_unit)
10923    call sw_kgb17(rrtmg_unit)
10924    call sw_kgb18(rrtmg_unit)
10925    call sw_kgb19(rrtmg_unit)
10926    call sw_kgb20(rrtmg_unit)
10927    call sw_kgb21(rrtmg_unit)
10928    call sw_kgb22(rrtmg_unit)
10929    call sw_kgb23(rrtmg_unit)
10930    call sw_kgb24(rrtmg_unit)
10931    call sw_kgb25(rrtmg_unit)
10932    call sw_kgb26(rrtmg_unit)
10933    call sw_kgb27(rrtmg_unit)
10934    call sw_kgb28(rrtmg_unit)
10935    call sw_kgb29(rrtmg_unit)
10936 !
10937    if ( wrf_dm_on_monitor() ) close (rrtmg_unit)
10938 !
10939    return
10940 9009 continue
10941    write( errmess , '(A,I4)' )                                                 &
10942         'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
10943 !
10944    end subroutine rrtmg_swlookuptable
10945 !-------------------------------------------------------------------------------
10946 !
10947 !
10948 !-------------------------------------------------------------------------------
10949 ! **************************************************************************
10950 !  RRTMG Shortwave Radiative Transfer Model
10951 !  Atmospheric and Environmental Research, Inc., Cambridge, MA
10952 !
10953 !  Original by J.Delamere, Atmospheric & Environmental Research.
10954 !  Reformatted for F90: JJMorcrette, ECMWF
10955 !  Revision for GCMs:  Michael J. Iacono, AER, July 2002
10956 !  Further F90 reformatting:  Michael J. Iacono, AER, June 2006
10957 !
10958 !  This file contains 14 READ statements that include the
10959 !  absorption coefficients and other data for each of the 14 shortwave
10960 !  spectral bands used in RRTMG_SW.  Here, the data are defined for 16
10961 !  g-points, or sub-intervals, per band.  These data are combined and
10962 !  weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
10963 !  the total number of g-points from 224 to 112 for use in the GCM.
10964 ! **************************************************************************
10965 !
10966 !-------------------------------------------------------------------------------
10967    subroutine sw_kgb16(rrtmg_unit)
10968 !-------------------------------------------------------------------------------
10969 !     Array sfluxrefo contains the Kurucz solar source function for this band.
10970 !
10971 !     Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
10972 !
10973 !     The array KAO contains absorption coefs at the 16 chosen g-values
10974 !     for a range of pressure levels> ~100mb, temperatures, and binary
10975 !     species parameters (see taumol.f for definition).  The first
10976 !     index in the array, JS, runs from 1 to 9, and corresponds to
10977 !     different values of the binary species parameter.  For instance,
10978 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
10979 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
10980 !     in the array, JT, which runs from 1 to 5, corresponds to different
10981 !     temperatures.  More specifically, JT = 3 means that the data are for
10982 !     the reference temperature TREF for this  pressure level, JT = 2 refers
10983 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
10984 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
10985 !     to the JPth reference pressure level (see taumol.f for these levels
10986 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
10987 !     which g-interval the absorption coefficients are for.
10988 !
10989 !     The array KBO contains absorption coefs at the 16 chosen g-values
10990 !     for a range of pressure levels < ~100mb and temperatures. The first
10991 !     index in the array, JT, which runs from 1 to 5, corresponds to
10992 !     different temperatures.  More specifically, JT = 3 means that the
10993 !     data are for the reference temperature TREF for this pressure
10994 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
10995 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
10996 !     The second index, JP, runs from 13 to 59 and refers to the JPth
10997 !     reference pressure level (see taumol.f for the value of these
10998 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
10999 !     and tells us which g-interval the absorption coefficients are for.
11000 !
11001 !     The array FORREFO contains the coefficient of the water vapor
11002 !     foreign-continuum (including the energy term).  The first
11003 !     index refers to reference temperature (296,260,224,260) and
11004 !     pressure (970,475,219,3 mbar) levels.  The second index
11005 !     runs over the g-channel (1 to 16).
11006 !
11007 !     The array SELFREFO contains the coefficient of the water vapor
11008 !     self-continuum (including the energy term).  The first index
11009 !     refers to temperature in 7.2 degree increments.  For instance,
11010 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11011 !     etc.  The second index runs over the g-channel (1 to 16).
11012 !-------------------------------------------------------------------------------
11013    use rrsw_kg16_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11014                             rayl, strrat1, layreffr
11015 !
11016   implicit none
11017 !
11018    save
11019 !
11020 ! Input
11021 !
11022    integer, intent(in) :: rrtmg_unit
11023 !
11024 ! Local
11025 !
11026    character*80 errmess
11027    logical, external  :: wrf_dm_on_monitor
11028 !-------------------------------------------------------------------------------
11029 !
11030    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11031      rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11032    call wrf_dm_bcast_real ( rayl , 1 )
11033    call wrf_dm_bcast_real ( strrat1 , 1 )
11034    call wrf_dm_bcast_integer ( layreffr , 1 )
11035    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11036    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11037    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11038    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11039    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11040 !
11041    return
11042 9010 continue
11043    write( errmess , '(A,I4)' )                                                 &
11044      'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11045 !
11046    end subroutine sw_kgb16
11047 !-------------------------------------------------------------------------------
11048 !
11049 !
11050 !-------------------------------------------------------------------------------
11051    subroutine sw_kgb17(rrtmg_unit)
11052 !-------------------------------------------------------------------------------
11053 !
11054 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11055 !
11056 !     Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
11057 !
11058 !     The array KAO contains absorption coefs at the 16 chosen g-values
11059 !     for a range of pressure levels> ~100mb, temperatures, and binary
11060 !     species parameters (see taumol.f for definition).  The first
11061 !     index in the array, JS, runs from 1 to 9, and corresponds to
11062 !     different values of the binary species parameter.  For instance,
11063 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11064 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11065 !     in the array, JT, which runs from 1 to 5, corresponds to different
11066 !     temperatures.  More specifically, JT = 3 means that the data are for
11067 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11068 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11069 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11070 !     to the JPth reference pressure level (see taumol.f for these levels
11071 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11072 !     which g-interval the absorption coefficients are for.
11073 !
11074 !     The array KBO contains absorption coefs at the 16 chosen g-values
11075 !     for a range of pressure levels < ~100mb and temperatures. The first
11076 !     index in the array, JT, which runs from 1 to 5, corresponds to
11077 !     different temperatures.  More specifically, JT = 3 means that the
11078 !     data are for the reference temperature TREF for this pressure
11079 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11080 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11081 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11082 !     reference pressure level (see taumol.f for the value of these
11083 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11084 !     and tells us which g-interval the absorption coefficients are for.
11085 !
11086 !     The array FORREFO contains the coefficient of the water vapor
11087 !     foreign-continuum (including the energy term).  The first
11088 !     index refers to reference temperature (296,260,224,260) and
11089 !     pressure (970,475,219,3 mbar) levels.  The second index
11090 !     runs over the g-channel (1 to 16).
11091 !
11092 !     The array SELFREFO contains the coefficient of the water vapor
11093 !     self-continuum (including the energy term).  The first index
11094 !     refers to temperature in 7.2 degree increments.  For instance,
11095 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11096 !     etc.  The second index runs over the g-channel (1 to 16).
11097 !-------------------------------------------------------------------------------
11098    use rrsw_kg17_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11099                             rayl, strrat, layreffr
11100 !
11101    implicit none
11102 !
11103    save
11104 !
11105 ! Input
11106 !
11107    integer, intent(in) :: rrtmg_unit
11108 !
11109 ! Local
11110 !
11111    character*80 errmess
11112    logical, external  :: wrf_dm_on_monitor
11113 !-------------------------------------------------------------------------------
11114 !
11115    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11116          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11117    call wrf_dm_bcast_real ( rayl , 1 )
11118    call wrf_dm_bcast_real ( strrat , 1 )
11119    call wrf_dm_bcast_integer ( layreffr , 1 )
11120    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11121    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11122    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11123    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11124    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11125 !
11126    return
11127 9010 continue
11128    write( errmess , '(A,I4)' )                                                 &
11129          'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11130 !
11131    end subroutine sw_kgb17
11132 !-------------------------------------------------------------------------------
11133 !
11134 !
11135 !-------------------------------------------------------------------------------
11136    subroutine sw_kgb18(rrtmg_unit)
11137 !-------------------------------------------------------------------------------
11138 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11139 !
11140 !     Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
11141 !
11142 !     The array KAO contains absorption coefs at the 16 chosen g-values
11143 !     for a range of pressure levels> ~100mb, temperatures, and binary
11144 !     species parameters (see taumol.f for definition).  The first
11145 !     index in the array, JS, runs from 1 to 9, and corresponds to
11146 !     different values of the binary species parameter.  For instance,
11147 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11148 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11149 !     in the array, JT, which runs from 1 to 5, corresponds to different
11150 !     temperatures.  More specifically, JT = 3 means that the data are for
11151 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11152 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11153 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11154 !     to the JPth reference pressure level (see taumol.f for these levels
11155 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11156 !     which g-interval the absorption coefficients are for.
11157 !
11158 !     The array KBO contains absorption coefs at the 16 chosen g-values
11159 !     for a range of pressure levels < ~100mb and temperatures. The first
11160 !     index in the array, JT, which runs from 1 to 5, corresponds to
11161 !     different temperatures.  More specifically, JT = 3 means that the
11162 !     data are for the reference temperature TREF for this pressure
11163 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11164 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11165 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11166 !     reference pressure level (see taumol.f for the value of these
11167 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11168 !     and tells us which g-interval the absorption coefficients are for.
11169 !
11170 !     The array FORREFO contains the coefficient of the water vapor
11171 !     foreign-continuum (including the energy term).  The first
11172 !     index refers to reference temperature (296,260,224,260) and
11173 !     pressure (970,475,219,3 mbar) levels.  The second index
11174 !     runs over the g-channel (1 to 16).
11175 !
11176 !     The array SELFREFO contains the coefficient of the water vapor
11177 !     self-continuum (including the energy term).  The first index
11178 !     refers to temperature in 7.2 degree increments.  For instance,
11179 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11180 !     etc.  The second index runs over the g-channel (1 to 16).
11181 !-------------------------------------------------------------------------------
11182   use rrsw_kg18_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,              &
11183                             rayl, strrat, layreffr
11184 !
11185    implicit none
11186 !
11187    save
11188 !
11189 ! Input
11190 !
11191    integer, intent(in) :: rrtmg_unit
11192 !
11193 ! Local
11194 !
11195    character*80 errmess
11196    logical, external  :: wrf_dm_on_monitor
11197 !-------------------------------------------------------------------------------
11198 !
11199    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11200      rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11201    call wrf_dm_bcast_real ( rayl , 1 )
11202    call wrf_dm_bcast_real ( strrat , 1 )
11203    call wrf_dm_bcast_integer ( layreffr , 1 )
11204    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11205    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11206    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11207    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11208    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11209 !
11210    return
11211 9010 continue
11212    write( errmess , '(A,I4)' )                                                 &
11213        'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11214 !
11215    end subroutine sw_kgb18
11216 !-------------------------------------------------------------------------------
11217 !
11218 !
11219 !-------------------------------------------------------------------------------
11220    subroutine sw_kgb19(rrtmg_unit)
11221 !-------------------------------------------------------------------------------
11222 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11223 !
11224 !     Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
11225 !
11226 !     The array KAO contains absorption coefs at the 16 chosen g-values
11227 !     for a range of pressure levels> ~100mb, temperatures, and binary
11228 !     species parameters (see taumol.f for definition).  The first
11229 !     index in the array, JS, runs from 1 to 9, and corresponds to
11230 !     different values of the binary species parameter.  For instance,
11231 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11232 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11233 !     in the array, JT, which runs from 1 to 5, corresponds to different
11234 !     temperatures.  More specifically, JT = 3 means that the data are for
11235 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11236 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11237 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11238 !     to the JPth reference pressure level (see taumol.f for these levels
11239 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11240 !     which g-interval the absorption coefficients are for.
11241 !
11242 !     The array KBO contains absorption coefs at the 16 chosen g-values
11243 !     for a range of pressure levels < ~100mb and temperatures. The first
11244 !     index in the array, JT, which runs from 1 to 5, corresponds to
11245 !     different temperatures.  More specifically, JT = 3 means that the
11246 !     data are for the reference temperature TREF for this pressure
11247 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11248 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11249 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11250 !     reference pressure level (see taumol.f for the value of these
11251 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11252 !     and tells us which g-interval the absorption coefficients are for.
11253 !
11254 !     The array FORREFO contains the coefficient of the water vapor
11255 !     foreign-continuum (including the energy term).  The first
11256 !     index refers to reference temperature (296,260,224,260) and
11257 !     pressure (970,475,219,3 mbar) levels.  The second index
11258 !     runs over the g-channel (1 to 16).
11259 !
11260 !     The array SELFREFO contains the coefficient of the water vapor
11261 !     self-continuum (including the energy term).  The first index
11262 !     refers to temperature in 7.2 degree increments.  For instance,
11263 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11264 !     etc.  The second index runs over the g-channel (1 to 16).
11265 !-------------------------------------------------------------------------------
11266    use rrsw_kg19_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11267                             rayl, strrat, layreffr
11268 !
11269    implicit none
11270 !
11271    save
11272 !
11273 ! Input
11274 !
11275    integer, intent(in) :: rrtmg_unit
11276 !
11277 ! Local
11278 !
11279    character*80 errmess
11280    logical, external  :: wrf_dm_on_monitor
11281 !-------------------------------------------------------------------------------
11282 !
11283    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11284      rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11285    call wrf_dm_bcast_real ( rayl , 1 )
11286    call wrf_dm_bcast_real ( strrat , 1 )
11287    call wrf_dm_bcast_integer ( layreffr , 1 )
11288    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11289    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11290    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11291    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11292    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11293 !
11294    return
11295 9010 continue
11296    write( errmess , '(A,I4)' )                                                 &
11297          'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11298 !
11299    end subroutine sw_kgb19
11300 !-------------------------------------------------------------------------------
11301 !
11302 !
11303 !-------------------------------------------------------------------------------
11304    subroutine sw_kgb20(rrtmg_unit)
11305 !-------------------------------------------------------------------------------
11306 !
11307 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11308 !
11309 !     Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
11310 !
11311 !     Array absch4o contains the absorption coefficients for methane.
11312 !
11313 !     The array KAO contains absorption coefs at the 16 chosen g-values
11314 !     for a range of pressure levels> ~100mb, temperatures, and binary
11315 !     species parameters (see taumol.f for definition).  The first
11316 !     index in the array, JS, runs from 1 to 9, and corresponds to
11317 !     different values of the binary species parameter.  For instance,
11318 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11319 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11320 !     in the array, JT, which runs from 1 to 5, corresponds to different
11321 !     temperatures.  More specifically, JT = 3 means that the data are for
11322 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11323 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11324 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11325 !     to the JPth reference pressure level (see taumol.f for these levels
11326 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11327 !     which g-interval the absorption coefficients are for.
11328 !
11329 !     The array KBO contains absorption coefs at the 16 chosen g-values
11330 !     for a range of pressure levels < ~100mb and temperatures. The first
11331 !     index in the array, JT, which runs from 1 to 5, corresponds to
11332 !     different temperatures.  More specifically, JT = 3 means that the
11333 !     data are for the reference temperature TREF for this pressure
11334 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11335 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11336 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11337 !     reference pressure level (see taumol.f for the value of these
11338 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11339 !     and tells us which g-interval the absorption coefficients are for.
11340 !
11341 !     The array FORREFO contains the coefficient of the water vapor
11342 !     foreign-continuum (including the energy term).  The first
11343 !     index refers to reference temperature (296,260,224,260) and
11344 !     pressure (970,475,219,3 mbar) levels.  The second index
11345 !     runs over the g-channel (1 to 16).
11346 !
11347 !     The array SELFREFO contains the coefficient of the water vapor
11348 !     self-continuum (including the energy term).  The first index
11349 !     refers to temperature in 7.2 degree increments.  For instance,
11350 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11351 !     etc.  The second index runs over the g-channel (1 to 16).
11352 !-------------------------------------------------------------------------------
11353    use rrsw_kg20_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11354                             absch4o, rayl, layreffr
11355 !
11356    implicit none
11357 !
11358    save
11359 !
11360 ! Input
11361 !
11362    integer, intent(in) :: rrtmg_unit
11363 !
11364 ! Local
11365 !
11366    character*80 errmess
11367    logical, external  :: wrf_dm_on_monitor
11368 !-------------------------------------------------------------------------------
11369 !
11370    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11371      rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
11372    call wrf_dm_bcast_real ( rayl , 1 )
11373    call wrf_dm_bcast_integer ( layreffr , 1 )
11374    call wrf_dm_bcast_bytes ( absch4o , size ( absch4o ) * 4 )
11375    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11376    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11377    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11378    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11379    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11380 !
11381    return
11382 9010 continue
11383    write( errmess , '(A,I4)' )                                                 &
11384        'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11385 !
11386    end subroutine sw_kgb20
11387 !-------------------------------------------------------------------------------
11388 !
11389 !
11390 !-------------------------------------------------------------------------------
11391    subroutine sw_kgb21(rrtmg_unit)
11392 !-------------------------------------------------------------------------------
11393 !
11394 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11395 !
11396 !     Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
11397 !
11398 !     The array KAO contains absorption coefs at the 16 chosen g-values
11399 !     for a range of pressure levels> ~100mb, temperatures, and binary
11400 !     species parameters (see taumol.f for definition).  The first
11401 !     index in the array, JS, runs from 1 to 9, and corresponds to
11402 !     different values of the binary species parameter.  For instance,
11403 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11404 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11405 !     in the array, JT, which runs from 1 to 5, corresponds to different
11406 !     temperatures.  More specifically, JT = 3 means that the data are for
11407 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11408 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11409 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11410 !     to the JPth reference pressure level (see taumol.f for these levels
11411 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11412 !     which g-interval the absorption coefficients are for.
11413 !
11414 !     The array KBO contains absorption coefs at the 16 chosen g-values
11415 !     for a range of pressure levels < ~100mb and temperatures. The first
11416 !     index in the array, JT, which runs from 1 to 5, corresponds to
11417 !     different temperatures.  More specifically, JT = 3 means that the
11418 !     data are for the reference temperature TREF for this pressure
11419 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11420 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11421 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11422 !     reference pressure level (see taumol.f for the value of these
11423 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11424 !     and tells us which g-interval the absorption coefficients are for.
11425 !
11426 !     The array FORREFO contains the coefficient of the water vapor
11427 !     foreign-continuum (including the energy term).  The first
11428 !     index refers to reference temperature (296,260,224,260) and
11429 !     pressure (970,475,219,3 mbar) levels.  The second index
11430 !     runs over the g-channel (1 to 16).
11431 !
11432 !     The array SELFREFO contains the coefficient of the water vapor
11433 !     self-continuum (including the energy term).  The first index
11434 !     refers to temperature in 7.2 degree increments.  For instance,
11435 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11436 !     etc.  The second index runs over the g-channel (1 to 16).
11437 !
11438 !-------------------------------------------------------------------------------
11439    use rrsw_kg21_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11440                             rayl, strrat, layreffr
11441 !
11442    implicit none
11443 !
11444    save
11445 !
11446 ! Input
11447 !
11448    integer, intent(in) :: rrtmg_unit
11449 !
11450 ! Local
11451 !
11452    character*80 errmess
11453    logical, external  :: wrf_dm_on_monitor
11454 !-------------------------------------------------------------------------------
11455 !
11456    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11457      rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11458    call wrf_dm_bcast_real ( rayl , 1 )
11459    call wrf_dm_bcast_real ( strrat , 1 )
11460    call wrf_dm_bcast_integer ( layreffr , 1 )
11461    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11462    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11463    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11464    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11465    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11466 !
11467    return
11468 9010 continue
11469    write( errmess , '(A,I4)' )                                                 &
11470        'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11471 !
11472    end subroutine sw_kgb21
11473 !-------------------------------------------------------------------------------
11474 !
11475 !
11476 !-------------------------------------------------------------------------------
11477    subroutine sw_kgb22(rrtmg_unit)
11478 !-------------------------------------------------------------------------------
11479 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11480 !
11481 !     Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
11482 !
11483 !     The array KAO contains absorption coefs at the 16 chosen g-values
11484 !     for a range of pressure levels> ~100mb, temperatures, and binary
11485 !     species parameters (see taumol.f for definition).  The first
11486 !     index in the array, JS, runs from 1 to 9, and corresponds to
11487 !     different values of the binary species parameter.  For instance,
11488 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11489 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11490 !     in the array, JT, which runs from 1 to 5, corresponds to different
11491 !     temperatures.  More specifically, JT = 3 means that the data are for
11492 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11493 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11494 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11495 !     to the JPth reference pressure level (see taumol.f for these levels
11496 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11497 !     which g-interval the absorption coefficients are for.
11498 !
11499 !     The array KBO contains absorption coefs at the 16 chosen g-values
11500 !     for a range of pressure levels < ~100mb and temperatures. The first
11501 !     index in the array, JT, which runs from 1 to 5, corresponds to
11502 !     different temperatures.  More specifically, JT = 3 means that the
11503 !     data are for the reference temperature TREF for this pressure
11504 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11505 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11506 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11507 !     reference pressure level (see taumol.f for the value of these
11508 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11509 !     and tells us which g-interval the absorption coefficients are for.
11510 !
11511 !     The array FORREFO contains the coefficient of the water vapor
11512 !     foreign-continuum (including the energy term).  The first
11513 !     index refers to reference temperature (296_rb,260_rb,224,260) and
11514 !     pressure (970,475,219,3 mbar) levels.  The second index
11515 !     runs over the g-channel (1 to 16).
11516 !
11517 !     The array SELFREFO contains the coefficient of the water vapor
11518 !     self-continuum (including the energy term).  The first index
11519 !     refers to temperature in 7.2 degree increments.  For instance,
11520 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11521 !     etc.  The second index runs over the g-channel (1 to 16).
11522 !-------------------------------------------------------------------------------
11523    use rrsw_kg22_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11524                             rayl, strrat, layreffr
11525 !
11526    implicit none
11527 !
11528    save
11529 !
11530 ! Input
11531 !
11532    integer, intent(in) :: rrtmg_unit
11533 !
11534 ! Local
11535 !
11536    character*80 errmess
11537    logical, external  :: wrf_dm_on_monitor
11538 !-------------------------------------------------------------------------------
11539 !
11540    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11541      rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
11542    call wrf_dm_bcast_real ( rayl , 1 )
11543    call wrf_dm_bcast_real ( strrat , 1 )
11544    call wrf_dm_bcast_integer ( layreffr , 1 )
11545    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11546    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11547    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11548    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11549    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11550 !
11551    return
11552 9010 continue
11553    write( errmess , '(A,I4)' )                                                 &
11554       'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11555 !
11556    end subroutine sw_kgb22
11557 !-------------------------------------------------------------------------------
11558 !
11559 !
11560 !-------------------------------------------------------------------------------
11561    subroutine sw_kgb23(rrtmg_unit)
11562 !-------------------------------------------------------------------------------
11563 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11564 !
11565 !     Array raylo contains the Rayleigh extinction coefficient at all v for
11566 !     this band
11567 !
11568 !     Array givfac is the average Giver et al. correction factor for this band.
11569 !
11570 !     The array KAO contains absorption coefs at the 16 chosen g-values
11571 !     for a range of pressure levels> ~100mb, temperatures, and binary
11572 !     species parameters (see taumol.f for definition).  The first
11573 !     index in the array, JS, runs from 1 to 9, and corresponds to
11574 !     different values of the binary species parameter.  For instance,
11575 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11576 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11577 !     in the array, JT, which runs from 1 to 5, corresponds to different
11578 !     temperatures.  More specifically, JT = 3 means that the data are for
11579 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11580 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11581 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11582 !     to the JPth reference pressure level (see taumol.f for these levels
11583 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11584 !     which g-interval the absorption coefficients are for.
11585 !
11586 !     The array FORREFO contains the coefficient of the water vapor
11587 !     foreign-continuum (including the energy term).  The first
11588 !     index refers to reference temperature (296,260,224,260) and
11589 !     pressure (970,475,219,3 mbar) levels.  The second index
11590 !     runs over the g-channel (1 to 16).
11591 !
11592 !     The array SELFREFO contains the coefficient of the water vapor
11593 !     self-continuum (including the energy term).  The first index
11594 !     refers to temperature in 7.2 degree increments.  For instance,
11595 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11596 !     etc.  The second index runs over the g-channel (1 to 16).
11597 !-------------------------------------------------------------------------------
11598    use rrsw_kg23_k, only : kao, selfrefo, forrefo, sfluxrefo,                  &
11599                             raylo, givfac, layreffr
11600 !
11601    implicit none
11602 !
11603    save
11604 !
11605 ! Input
11606 !
11607    integer, intent(in) :: rrtmg_unit
11608 !
11609 ! Local
11610 !
11611    character*80 errmess
11612    logical, external  :: wrf_dm_on_monitor
11613 !-------------------------------------------------------------------------------
11614 !
11615    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11616      raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
11617    call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11618    call wrf_dm_bcast_real ( givfac , 1 )
11619    call wrf_dm_bcast_integer ( layreffr , 1 )
11620    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11621    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11622    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11623    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11624    return
11625 9010 continue
11626    write( errmess , '(A,I4)' )                                                 &
11627      'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11628 !
11629    end subroutine sw_kgb23
11630 !-------------------------------------------------------------------------------
11631 !
11632 !
11633 !-------------------------------------------------------------------------------
11634    subroutine sw_kgb24(rrtmg_unit)
11635 !-------------------------------------------------------------------------------
11636 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11637 !
11638 !     Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
11639 !     all v for this band for the upper and lower atmosphere.
11640 !
11641 !     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
11642 !     all v for this band for the upper and lower atmosphere.
11643 !
11644 !     The array KAO contains absorption coefs at the 16 chosen g-values
11645 !     for a range of pressure levels> ~100mb, temperatures, and binary
11646 !     species parameters (see taumol.f for definition).  The first
11647 !     index in the array, JS, runs from 1 to 9, and corresponds to
11648 !     different values of the binary species parameter.  For instance,
11649 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11650 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11651 !     in the array, JT, which runs from 1 to 5, corresponds to different
11652 !     temperatures.  More specifically, JT = 3 means that the data are for
11653 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11654 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11655 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11656 !     to the JPth reference pressure level (see taumol.f for these levels
11657 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11658 !     which g-interval the absorption coefficients are for.
11659 !
11660 !     The array KBO contains absorption coefs at the 16 chosen g-values
11661 !     for a range of pressure levels < ~100mb and temperatures. The first
11662 !     index in the array, JT, which runs from 1 to 5, corresponds to
11663 !     different temperatures.  More specifically, JT = 3 means that the
11664 !     data are for the reference temperature TREF for this pressure
11665 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11666 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11667 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11668 !     reference pressure level (see taumol.f for the value of these
11669 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11670 !     and tells us which g-interval the absorption coefficients are for.
11671 !
11672 !     The array FORREFO contains the coefficient of the water vapor
11673 !     foreign-continuum (including the energy term).  The first
11674 !     index refers to reference temperature (296,260,224,260) and
11675 !     pressure (970,475,219,3 mbar) levels.  The second index
11676 !     runs over the g-channel (1 to 16).
11677 !
11678 !     The array SELFREFO contains the coefficient of the water vapor
11679 !     self-continuum (including the energy term).  The first index
11680 !     refers to temperature in 7.2 degree increments.  For instance,
11681 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
11682 !     etc.  The second index runs over the g-channel (1 to 16).
11683 !-------------------------------------------------------------------------------
11684    use rrsw_kg24_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11685                             raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
11686 !
11687    implicit none
11688 !
11689    save
11690 !
11691 ! Input
11692 !
11693    integer, intent(in) :: rrtmg_unit
11694 !
11695 ! Local
11696 !
11697    character*80 errmess
11698    logical, external  :: wrf_dm_on_monitor
11699 !-------------------------------------------------------------------------------
11700 !
11701    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11702      raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo,   &
11703          forrefo, sfluxrefo
11704    call wrf_dm_bcast_bytes ( raylao , size ( raylao ) * 4 )
11705    call wrf_dm_bcast_bytes ( raylbo , size ( raylbo ) * 4 )
11706    call wrf_dm_bcast_real ( strrat , 1 )
11707    call wrf_dm_bcast_integer ( layreffr , 1 )
11708    call wrf_dm_bcast_bytes ( abso3ao , size ( abso3ao ) * 4 )
11709    call wrf_dm_bcast_bytes ( abso3bo , size ( abso3bo ) * 4 )
11710    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11711    call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11712    call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
11713    call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
11714    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11715 !
11716    return
11717 9010 continue
11718    write( errmess , '(A,I4)' )                                                 &
11719      'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11720 !
11721    end subroutine sw_kgb24
11722 !-------------------------------------------------------------------------------
11723 !
11724 !
11725 !-------------------------------------------------------------------------------
11726    subroutine sw_kgb25(rrtmg_unit)
11727 !-------------------------------------------------------------------------------
11728 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11729 !
11730 !     Array raylo contains the Rayleigh extinction coefficient at all
11731 !     v = 2925 cm-1.
11732 !
11733 !     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
11734 !     all v for this band for the upper and lower atmosphere.
11735 !
11736 !     The array KAO contains absorption coefs at the 16 chosen g-values
11737 !     for a range of pressure levels> ~100mb, temperatures, and binary
11738 !     species parameters (see taumol.f for definition).  The first
11739 !     index in the array, JS, runs from 1 to 9, and corresponds to
11740 !     different values of the binary species parameter.  For instance,
11741 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11742 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11743 !     in the array, JT, which runs from 1 to 5, corresponds to different
11744 !     temperatures.  More specifically, JT = 3 means that the data are for
11745 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11746 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11747 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11748 !     to the JPth reference pressure level (see taumol.f for these levels
11749 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11750 !     which g-interval the absorption coefficients are for.
11751 !-------------------------------------------------------------------------------
11752    use rrsw_kg25_k, only : kao, sfluxrefo,                                     &
11753                             raylo, abso3ao, abso3bo, layreffr
11754 !
11755    implicit none
11756 !
11757    save
11758 !
11759 ! Input
11760 !
11761    integer, intent(in) :: rrtmg_unit
11762 !
11763 ! Local
11764 !
11765    character*80 errmess
11766    logical, external  :: wrf_dm_on_monitor
11767 !-------------------------------------------------------------------------------
11768 !
11769    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11770          raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
11771    call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11772    call wrf_dm_bcast_integer ( layreffr , 1 )
11773    call wrf_dm_bcast_bytes ( abso3ao , size ( abso3ao ) * 4 )
11774    call wrf_dm_bcast_bytes ( abso3bo , size ( abso3bo ) * 4 )
11775    call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11776    call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11777 !
11778    return
11779 9010 continue
11780    write( errmess , '(A,I4)' )                                                 &
11781         'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11782 !
11783    end subroutine sw_kgb25
11784 !-------------------------------------------------------------------------------
11785 !
11786 !
11787 !-------------------------------------------------------------------------------
11788    subroutine sw_kgb26(rrtmg_unit)
11789 !-------------------------------------------------------------------------------
11790    use rrsw_kg26_k, only : sfluxrefo, raylo
11791 !-------------------------------------------------------------------------------
11792 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11793 !
11794 !     Array raylo contains the Rayleigh extinction coefficient at all v for
11795 !     this band.
11796 !
11797 !-------------------------------------------------------------------------------
11798 !
11799    implicit none
11800 !
11801    save
11802 !
11803 ! Input
11804 !
11805    integer, intent(in) :: rrtmg_unit
11806 !
11807 ! Local
11808 !
11809    character*80 errmess
11810    logical, external  :: wrf_dm_on_monitor
11811 !-------------------------------------------------------------------------------
11812 !
11813    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11814          raylo, sfluxrefo
11815      call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11816      call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11817 !
11818    return
11819 9010 continue
11820    write( errmess , '(A,I4)' )                                                 &
11821       'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11822 !
11823    end subroutine sw_kgb26
11824 !-------------------------------------------------------------------------------
11825 !
11826 !
11827 !-------------------------------------------------------------------------------
11828    subroutine sw_kgb27(rrtmg_unit)
11829 !-------------------------------------------------------------------------------
11830    use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo,                         &
11831                             scalekur, layreffr
11832 !-------------------------------------------------------------------------------
11833 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11834 !     The values in array sfluxrefo were obtained using the "low resolution"
11835 !     version of the Kurucz solar source function.  For unknown reasons,
11836 !     the total irradiance in this band differs from the corresponding
11837 !     total in the "high-resolution" version of the Kurucz function.
11838 !     Therefore, these values are scaled by the factor SCALEKUR.
11839 !
11840 !     Array raylo contains the Rayleigh extinction coefficient at all v = 2925
11841 !     cm-1.
11842 !
11843 !     The array KAO contains absorption coefs at the 16 chosen g-values
11844 !     for a range of pressure levels> ~100mb, temperatures, and binary
11845 !     species parameters (see taumol.f for definition).  The first
11846 !     index in the array, JS, runs from 1 to 9, and corresponds to
11847 !     different values of the binary species parameter.  For instance,
11848 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11849 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11850 !     in the array, JT, which runs from 1 to 5, corresponds to different
11851 !     temperatures.  More specifically, JT = 3 means that the data are for
11852 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11853 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11854 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11855 !     to the JPth reference pressure level (see taumol.f for these levels
11856 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11857 !     which g-interval the absorption coefficients are for.
11858 !
11859 !     The array KBO contains absorption coefs at the 16 chosen g-values
11860 !     for a range of pressure levels < ~100mb and temperatures. The first
11861 !     index in the array, JT, which runs from 1 to 5, corresponds to
11862 !     different temperatures.  More specifically, JT = 3 means that the
11863 !     data are for the reference temperature TREF for this pressure
11864 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11865 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11866 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11867 !     reference pressure level (see taumol.f for the value of these
11868 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11869 !     and tells us which g-interval the absorption coefficients are for.
11870 !-------------------------------------------------------------------------------
11871    use rrsw_kg27_k, only : kao, kbo, sfluxrefo, raylo,                         &
11872                             scalekur, layreffr
11873 !
11874    implicit none
11875 !
11876    save
11877 !
11878 ! Input
11879 !
11880    integer, intent(in) :: rrtmg_unit
11881 !
11882 ! Local
11883 !
11884    character*80 errmess
11885    logical, external  :: wrf_dm_on_monitor
11886 !-------------------------------------------------------------------------------
11887 !
11888    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11889          raylo, scalekur, layreffr, kao, kbo, sfluxrefo
11890      call wrf_dm_bcast_bytes ( raylo , size ( raylo ) * 4 )
11891      call wrf_dm_bcast_real ( scalekur , 1 )
11892      call wrf_dm_bcast_integer ( layreffr , 1 )
11893      call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11894      call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11895      call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11896 !
11897    return
11898 9010 continue
11899    write( errmess , '(A,I4)' )                                                 &
11900        'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11901 !
11902    end subroutine sw_kgb27
11903 !-------------------------------------------------------------------------------
11904 !
11905 !
11906 !-------------------------------------------------------------------------------
11907    subroutine sw_kgb28(rrtmg_unit)
11908 !-------------------------------------------------------------------------------
11909 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11910 !
11911 !     Array raylo contains the Rayleigh extinction coefficient at
11912 !     all v = ???? cm-1.
11913 !
11914 !     The array KAO contains absorption coefs at the 16 chosen g-values
11915 !     for a range of pressure levels> ~100mb, temperatures, and binary
11916 !     species parameters (see taumol.f for definition).  The first
11917 !     index in the array, JS, runs from 1 to 9, and corresponds to
11918 !     different values of the binary species parameter.  For instance,
11919 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
11920 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
11921 !     in the array, JT, which runs from 1 to 5, corresponds to different
11922 !     temperatures.  More specifically, JT = 3 means that the data are for
11923 !     the reference temperature TREF for this  pressure level, JT = 2 refers
11924 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
11925 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
11926 !     to the JPth reference pressure level (see taumol.f for these levels
11927 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
11928 !     which g-interval the absorption coefficients are for.
11929 !
11930 !     The array KBO contains absorption coefs at the 16 chosen g-values
11931 !     for a range of pressure levels < ~100mb and temperatures. The first
11932 !     index in the array, JT, which runs from 1 to 5, corresponds to
11933 !     different temperatures.  More specifically, JT = 3 means that the
11934 !     data are for the reference temperature TREF for this pressure
11935 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
11936 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
11937 !     The second index, JP, runs from 13 to 59 and refers to the JPth
11938 !     reference pressure level (see taumol.f for the value of these
11939 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
11940 !     and tells us which g-interval the absorption coefficients are for.
11941 !-------------------------------------------------------------------------------
11942    use rrsw_kg28_k, only : kao, kbo, sfluxrefo,                                &
11943                             rayl, strrat, layreffr
11944 !
11945    implicit none
11946 !
11947    save
11948 !
11949 ! Input
11950 !
11951    integer, intent(in) :: rrtmg_unit
11952 !
11953 ! Local
11954 !
11955    character*80 errmess
11956    logical, external  :: wrf_dm_on_monitor
11957 !-------------------------------------------------------------------------------
11958 !
11959    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
11960          rayl, strrat, layreffr, kao, kbo, sfluxrefo
11961      call wrf_dm_bcast_real ( rayl , 1 )
11962      call wrf_dm_bcast_real ( strrat , 1 )
11963      call wrf_dm_bcast_integer ( layreffr , 1 )
11964      call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
11965      call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
11966      call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
11967 !
11968    return
11969 9010 continue
11970    write( errmess , '(A,I4)' )                                                 &
11971        'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
11972 !
11973    end subroutine sw_kgb28
11974 !-------------------------------------------------------------------------------
11975 !
11976 !
11977 !-------------------------------------------------------------------------------
11978    subroutine sw_kgb29(rrtmg_unit)
11979 !-------------------------------------------------------------------------------
11980    use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
11981                             absh2oo, absco2o, rayl, layreffr
11982 !-------------------------------------------------------------------------------
11983 !
11984 !     Array sfluxrefo contains the Kurucz solar source function for this band.
11985 !
11986 !     Array rayl contains the Rayleigh extinction coefficient at all
11987 !      v = 2200 cm-1.
11988 !
11989 !     Array absh2oo contains the water vapor absorption coefficient for
11990 !      this band.
11991 !
11992 !     Array absco2o contains the carbon dioxide absorption coefficient for
11993 !     this band.
11994 !
11995 !     The array KAO contains absorption coefs at the 16 chosen g-values
11996 !     for a range of pressure levels> ~100mb, temperatures, and binary
11997 !     species parameters (see taumol.f for definition).  The first
11998 !     index in the array, JS, runs from 1 to 9, and corresponds to
11999 !     different values of the binary species parameter.  For instance,
12000 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12001 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
12002 !     in the array, JT, which runs from 1 to 5, corresponds to different
12003 !     temperatures.  More specifically, JT = 3 means that the data are for
12004 !     the reference temperature TREF for this  pressure level, JT = 2 refers
12005 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12006 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12007 !     to the JPth reference pressure level (see taumol.f for these levels
12008 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
12009 !     which g-interval the absorption coefficients are for.
12010 !
12011 !     The array KBO contains absorption coefs at the 16 chosen g-values
12012 !     for a range of pressure levels < ~100mb and temperatures. The first
12013 !     index in the array, JT, which runs from 1 to 5, corresponds to
12014 !     different temperatures.  More specifically, JT = 3 means that the
12015 !     data are for the reference temperature TREF for this pressure
12016 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12017 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12018 !     The second index, JP, runs from 13 to 59 and refers to the JPth
12019 !     reference pressure level (see taumol.f for the value of these
12020 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
12021 !     and tells us which g-interval the absorption coefficients are for.
12022 !
12023 !     The array FORREFO contains the coefficient of the water vapor
12024 !     foreign-continuum (including the energy term).  The first
12025 !     index refers to reference temperature (296,260,224,260) and
12026 !     pressure (970,475,219,3 mbar) levels.  The second index
12027 !     runs over the g-channel (1 to 16).
12028 !
12029 !     The array SELFREFO contains the coefficient of the water vapor
12030 !     self-continuum (including the energy term).  The first index
12031 !     refers to temperature in 7.2 degree increments.  For instance,
12032 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12033 !     etc.  The second index runs over the g-channel (1 to 16).
12034 !-------------------------------------------------------------------------------
12035    use rrsw_kg29_k, only : kao, kbo, selfrefo, forrefo, sfluxrefo,             &
12036                             absh2oo, absco2o, rayl, layreffr
12037 !
12038    implicit none
12039 !
12040    save
12041 !
12042 ! Input
12043 !
12044     integer, intent(in) :: rrtmg_unit
12045 !
12046 ! Local
12047 !
12048     character*80 errmess
12049     logical, external  :: wrf_dm_on_monitor
12050 !-------------------------------------------------------------------------------
12051 !
12052    if ( wrf_dm_on_monitor() ) read (rrtmg_unit,err=9010)                       &
12053      rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
12054      call wrf_dm_bcast_real ( rayl , 1 )
12055      call wrf_dm_bcast_integer ( layreffr , 1 )
12056      call wrf_dm_bcast_bytes ( absh2oo , size ( absh2oo ) * 4 )
12057      call wrf_dm_bcast_bytes ( absco2o , size ( absco2o ) * 4 )
12058      call wrf_dm_bcast_bytes ( kao , size ( kao ) * 4 )
12059      call wrf_dm_bcast_bytes ( kbo , size ( kbo ) * 4 )
12060      call wrf_dm_bcast_bytes ( selfrefo , size ( selfrefo ) * 4 )
12061      call wrf_dm_bcast_bytes ( forrefo , size ( forrefo ) * 4 )
12062      call wrf_dm_bcast_bytes ( sfluxrefo , size ( sfluxrefo ) * 4 )
12063 !
12064    return
12065 9010 continue
12066    write( errmess , '(A,I4)' )                                                 &
12067      'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
12068 !
12069    end subroutine sw_kgb29
12070 !-------------------------------------------------------------------------------
12071 !
12072 !
12073 !-------------------------------------------------------------------------------
12074 !-------------------------------------------------------------------------------
12075 !
12076 !
12077 !-------------------------------------------------------------------------------
12078    end module module_ra_rrtmg_swk
12079 !-------------------------------------------------------------------------------
12080 #endif