phys/module_ra_rrtmg_swf.F

   1 #if( BUILD_RRTMG_FAST != 1)
   2       MODULE module_ra_rrtmg_swf
   3       CONTAINS
   4       SUBROUTINE RRTMG_SWRAD_FAST
   5          REAL :: dummy
   6          dummy = 1
   7       END SUBROUTINE RRTMG_SWRAD_FAST
   8       END MODULE module_ra_rrtmg_swf
   9 #else
  10 !!MODULE module_ra_rrtmg_swf
  11 #define CHNK 8
  12 !#define CHNK 1849
  13 !#define CHNK 43
  14 !#define CHNK 1
  15
  16 !  --------------------------------------------------------------------------
  17 ! |                                                                          |
  18 ! |  Copyright 2002-2013, Atmospheric & Environmental Research, Inc. (AER).  |
  19 ! |  This software may be used, copied, or redistributed as long as it is    |
  20 ! |  not sold and this copyright notice is reproduced on each copy made.     |
  21 ! |  This model is provided as is without any express or implied warranties. |
  22 ! |                       (http://www.rtweb.aer.com/)                        |
  23 ! |                                                                          |
  24 !  --------------------------------------------------------------------------
  25
  26 #ifndef _ACCEL
  27 ! this set of macros reverses the storage order of some of the array variables
  28 ! defined in rrtmg_sw_sub and used in various sections of the code.  Here is a
  29 ! correspondencet table for the variables as they are known in rrtmg_sw_sub and
  30 ! in the subroutines that rrtmg_sw_sub calls:
  31
  32 !jm     rrtmg_sw_sub
  33 !jm      |        mcica_sw
  34 !jm      |         |            cldprmc_sw
  35 !jm      |         |                |     spcvmc_sw
  36 !jm      |         |                |       |       reftra_sw
  37 !jm     tauc      tauc              |       |         |
  38 !jm     ssac      ssac              |       |         |
  39 !jm     asmc      asmc              |       |         |
  40 !jm     fsfc      fsfc              |       |         |
  41 !jm     taucmc    tauc_stoch        |     ptaucmc     |
  42 !jm     taormc     |                |     ptaormc     |
  43 !jm     ssacmc    ssac_stoch        |     pomgcmc     |
  44 !jm     asmcmc    asmc_stoch        |     pasycmc     |
  45 !jm     fsfcmc    fsfc_stoch        |       |         |
  46 !jm     cldfmcl   cld_stoch       cldmfc  pcldfmc   pcldfmc
  47 !jm     ciwpmcl   ciwp_stoch      ciwpmc    |
  48 !jm     clwpmcl   clwp_stoch      clwpmc    |
  49 !jm     cswpmcl   cswp_stoch      cswpmc    |
  50 !jm     ztauc                               |
  51 !jm     ztaucorig                           |
  52 !jm     zasyc                               |
  53 !jm     zomgc                               |
  54 !jm     taua                              ptaua
  55 !jm     asya                              pasya
  56 !jm     omga                              pomga
  57
  58 #define tauc(A,B,C)  TAUC(A,C,B)
  59 #define ssac(A,B,C)  SSAC(A,C,B)
  60 #define asmc(A,B,C)  ASMC(A,C,B)
  61 #define fsfc(A,B,C)  FSFC(A,C,B)
  62 #define taucmc(A,B,C)   TAUCMC(A,C,B)
  63 #define tauc_stoch(A,B,C) TAUC_STOCH(A,C,B)
  64 #define ptaucmc(A,B,C)  pTAUCMC(A,C,B)
  65 #define taormc(A,B,C)   TAORMC(A,C,B)
  66 #define ptaormc(A,B,C)  pTAORMC(A,C,B)
  67 #define ssacmc(A,B,C)   SSACMC(A,C,B)
  68 #define ssac_stoch(A,B,C)   SSAC_STOCH(A,C,B)
  69 #define pomgcmc(A,B,C)  pOMGCMC(A,C,B)
  70 #define asmcmc(A,B,C)   ASMCMC(A,C,B)
  71 #define asmc_stoch(A,B,C)   ASMC_STOCH(A,C,B)
  72 #define pasycmc(A,B,C)  pASYCMC(A,C,B)
  73 #define fsfcmc(A,B,C)   FSFCMC(A,C,B)
  74 #define fsfc_stoch(A,B,C)   FSFC_STOCH(A,C,B)
  75
  76 #define cldfmcl(A,B,C)   CLDFMCL(A,C,B)
  77 #define cld_stoch(A,B,C) CLD_STOCH(A,C,B)
  78 #define cldfmc(A,B,C)    CLDFMC(A,C,B)
  79 #define pcldfmc(A,B,C)   pCLDFMC(A,C,B)
  80
  81 #define ciwpmcl(A,B,C)    CIWPMCL(A,C,B)
  82 #define ciwp_stoch(A,B,C) CIWP_STOCH(A,C,B)
  83 #define ciwpmc(A,B,C)     CIWPMC(A,C,B)
  84
  85 #define clwpmcl(A,B,C)    CLWPMCL(A,C,B)
  86 #define clwp_stoch(A,B,C) CLWP_STOCH(A,C,B)
  87 #define clwpmc(A,B,C)     CLWPMC(A,C,B)
  88
  89 #define cswpmcl(A,B,C)    CSWPMCL(A,C,B)
  90 #define cswp_stoch(A,B,C) CSWP_STOCH(A,C,B)
  91 #define cswpmc(A,B,C)     CSWPMC(A,C,B)
  92
  93 #define taua(A,B,C)  TAUA(A,C,B)
  94 #define asya(A,B,C)  ASYA(A,C,B)
  95 #define omga(A,B,C)  OMGA(A,C,B)
  96 #define ptaua(A,B,C) pTAUA(A,C,B)
  97 #define pasya(A,B,C) pASYA(A,C,B)
  98 #define pomga(A,B,C) pOMGA(A,C,B)
  99
 100 #endif
 101
 102 ! Uncomment to use GPU, or comment to use CPU
 103 !#define _ACCEL
 104
 105 #ifdef _ACCEL
 106 #define gpu_device ,device
 107 #else
 108 #define gpu_device
 109 #endif
 110
 111       module parrrsw_f
 112
 113 !     implicit none
 114       save
 115
 116 !------------------------------------------------------------------
 117 ! rrtmg_sw main parameters
 118 !
 119 ! Initial version:  JJMorcrette, ECMWF, jul1998
 120 ! Revised: MJIacono, AER, jun2006
 121 ! Revised: MJIacono, AER, aug2008
 122 !------------------------------------------------------------------
 123
 124 !  name     type     purpose
 125 ! -----  :  ----   : ----------------------------------------------
 126 ! mxlay  :  integer: maximum number of layers
 127 ! mg     :  integer: number of original g-intervals per spectral band
 128 ! nbndsw :  integer: number of spectral bands
 129 ! naerec :  integer: number of aerosols (iaer=6, ecmwf aerosol option)
 130 ! ngptsw :  integer: total number of reduced g-intervals for rrtmg_lw
 131 ! ngNN   :  integer: number of reduced g-intervals per spectral band
 132 ! ngsNN  :  integer: cumulative number of g-intervals per band
 133 !------------------------------------------------------------------
 134
 135       integer , parameter :: mxlay  = 203   !jplay, klev
 136       integer , parameter :: mg     = 16     !jpg
 137       integer , parameter :: nbndsw = 14     !jpsw, ksw
 138       integer , parameter :: naerec  = 6     !jpaer
 139       integer , parameter :: mxmol  = 38
 140       integer , parameter :: nstr   = 2
 141       integer , parameter :: nmol   = 7
 142 ! Use for 112 g-point model
 143       integer , parameter :: ngptsw = 112    !jpgpt
 144 ! Use for 224 g-point model
 145 !      integer , parameter :: ngptsw = 224   !jpgpt
 146
 147 ! may need to rename these - from v2.6
 148       integer , parameter :: jpband   = 29
 149       integer , parameter :: jpb1     = 16   !istart
 150       integer , parameter :: jpb2     = 29   !iend
 151
 152       integer , parameter :: jmcmu    = 32
 153       integer , parameter :: jmumu    = 32
 154       integer , parameter :: jmphi    = 3
 155       integer , parameter :: jmxang   = 4
 156       integer , parameter :: jmxstr   = 16
 157 ! ^
 158
 159 ! Use for 112 g-point model
 160       integer , parameter :: ng16 = 6
 161       integer , parameter :: ng17 = 12
 162       integer , parameter :: ng18 = 8
 163       integer , parameter :: ng19 = 8
 164       integer , parameter :: ng20 = 10
 165       integer , parameter :: ng21 = 10
 166       integer , parameter :: ng22 = 2
 167       integer , parameter :: ng23 = 10
 168       integer , parameter :: ng24 = 8
 169       integer , parameter :: ng25 = 6
 170       integer , parameter :: ng26 = 6
 171       integer , parameter :: ng27 = 8
 172       integer , parameter :: ng28 = 6
 173       integer , parameter :: ng29 = 12
 174
 175       integer , parameter :: ngs16 = 6
 176       integer , parameter :: ngs17 = 18
 177       integer , parameter :: ngs18 = 26
 178       integer , parameter :: ngs19 = 34
 179       integer , parameter :: ngs20 = 44
 180       integer , parameter :: ngs21 = 54
 181       integer , parameter :: ngs22 = 56
 182       integer , parameter :: ngs23 = 66
 183       integer , parameter :: ngs24 = 74
 184       integer , parameter :: ngs25 = 80
 185       integer , parameter :: ngs26 = 86
 186       integer , parameter :: ngs27 = 94
 187       integer , parameter :: ngs28 = 100
 188       integer , parameter :: ngs29 = 112
 189
 190 ! Use for 224 g-point model
 191 !      integer , parameter :: ng16 = 16
 192 !      integer , parameter :: ng17 = 16
 193 !      integer , parameter :: ng18 = 16
 194 !      integer , parameter :: ng19 = 16
 195 !      integer , parameter :: ng20 = 16
 196 !      integer , parameter :: ng21 = 16
 197 !      integer , parameter :: ng22 = 16
 198 !      integer , parameter :: ng23 = 16
 199 !      integer , parameter :: ng24 = 16
 200 !      integer , parameter :: ng25 = 16
 201 !      integer , parameter :: ng26 = 16
 202 !      integer , parameter :: ng27 = 16
 203 !      integer , parameter :: ng28 = 16
 204 !      integer , parameter :: ng29 = 16
 205
 206 !      integer , parameter :: ngs16 = 16
 207 !      integer , parameter :: ngs17 = 32
 208 !      integer , parameter :: ngs18 = 48
 209 !      integer , parameter :: ngs19 = 64
 210 !      integer , parameter :: ngs20 = 80
 211 !      integer , parameter :: ngs21 = 96
 212 !      integer , parameter :: ngs22 = 112
 213 !      integer , parameter :: ngs23 = 128
 214 !      integer , parameter :: ngs24 = 144
 215 !      integer , parameter :: ngs25 = 160
 216 !      integer , parameter :: ngs26 = 176
 217 !      integer , parameter :: ngs27 = 192
 218 !      integer , parameter :: ngs28 = 208
 219 !      integer , parameter :: ngs29 = 224
 220
 221 ! Source function solar constant
 222       real , parameter :: rrsw_scon = 1.36822e+03     ! W/m2
 223
 224       end module parrrsw_f
 225
 226       module rrsw_aer_f
 227
 228       use parrrsw_f, only : nbndsw, naerec
 229
 230 !     implicit none
 231       save
 232
 233 !------------------------------------------------------------------
 234 ! rrtmg_sw aerosol optical properties
 235 !
 236 !  Data derived from six ECMWF aerosol types and defined for
 237 !  the rrtmg_sw spectral intervals
 238 !
 239 ! Initial: J.-J. Morcrette, ECMWF, mar2003
 240 ! Revised: MJIacono, AER, jul2006
 241 ! Revised: MJIacono, AER, aug2008
 242 !------------------------------------------------------------------
 243 !
 244 !-- The six ECMWF aerosol types are respectively:
 245 !
 246 !  1/ continental average                 2/ maritime
 247 !  3/ desert                              4/ urban
 248 !  5/ volcanic active                     6/ stratospheric background
 249 !
 250 ! computed from Hess and Koepke (con, mar, des, urb)
 251 !          from Bonnel et al.   (vol, str)
 252 !
 253 ! rrtmg_sw 14 spectral intervals (microns):
 254 !  3.846 -  3.077
 255 !  3.077 -  2.500
 256 !  2.500 -  2.150
 257 !  2.150 -  1.942
 258 !  1.942 -  1.626
 259 !  1.626 -  1.299
 260 !  1.299 -  1.242
 261 !  1.242 -  0.7782
 262 !  0.7782-  0.6250
 263 !  0.6250-  0.4415
 264 !  0.4415-  0.3448
 265 !  0.3448-  0.2632
 266 !  0.2632-  0.2000
 267 ! 12.195 -  3.846
 268 !
 269 !------------------------------------------------------------------
 270 !
 271 !  name     type     purpose
 272 ! -----   : ----   : ----------------------------------------------
 273 ! rsrtaua : real   : ratio of average optical thickness in
 274 !                    spectral band to that at 0.55 micron
 275 ! rsrpiza : real   : average single scattering albedo (unitless)
 276 ! rsrasya : real   : average asymmetry parameter (unitless)
 277 !------------------------------------------------------------------
 278
 279       real  :: rsrtaua(nbndsw,naerec)
 280       real  :: rsrpiza(nbndsw,naerec)
 281       real  :: rsrasya(nbndsw,naerec)
 282
 283       end module rrsw_aer_f
 284
 285       module rrsw_cld_f
 286
 287 !     implicit none
 288       save
 289
 290 !------------------------------------------------------------------
 291 ! rrtmg_sw cloud property coefficients
 292 !
 293 ! Initial: J.-J. Morcrette, ECMWF, oct1999
 294 ! Revised: J. Delamere/MJIacono, AER, aug2005
 295 ! Revised: MJIacono, AER, nov2005
 296 ! Revised: MJIacono, AER, jul2006
 297 ! Revised: MJIacono, AER, aug2008
 298 !------------------------------------------------------------------
 299 !
 300 !  name     type     purpose
 301 ! -----  :  ----   : ----------------------------------------------
 302 ! xxxliq1 : real   : optical properties (extinction coefficient, single
 303 !                    scattering albedo, assymetry factor) from
 304 !                    Hu & Stamnes, j. clim., 6, 728-742, 1993.
 305 ! xxxice2 : real   : optical properties (extinction coefficient, single
 306 !                    scattering albedo, assymetry factor) from streamer v3.0,
 307 !                    Key, streamer user's guide, cooperative institude
 308 !                    for meteorological studies, 95 pp., 2001.
 309 ! xxxice3 : real   : optical properties (extinction coefficient, single
 310 !                    scattering albedo, assymetry factor) from
 311 !                    Fu, j. clim., 9, 1996.
 312 ! xbari   : real   : optical property coefficients for five spectral
 313 !                    intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
 314 !                    and 14285-40000 wavenumbers) following
 315 !                    Ebert and Curry, jgr, 97, 3831-3836, 1992.
 316 !------------------------------------------------------------------
 317
 318       real  :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29)
 319       real  :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29)
 320       real  :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29)
 321       real  :: fdlice3(46,16:29)
 322       real  :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5)
 323
 324       end module rrsw_cld_f
 325
 326       module rrsw_con_f
 327
 328 !     implicit none
 329       save
 330
 331 !------------------------------------------------------------------
 332 ! rrtmg_sw constants
 333
 334 ! Initial version: MJIacono, AER, jun2006
 335 ! Revised: MJIacono, AER, aug2008
 336 !------------------------------------------------------------------
 337
 338 !  name     type     purpose
 339 ! -----  :  ----   : ----------------------------------------------
 340 ! fluxfac:  real   : radiance to flux conversion factor
 341 ! heatfac:  real   : flux to heating rate conversion factor
 342 !oneminus:  real   : 1.-1.e-6
 343 ! pi     :  real   : pi
 344 ! grav   :  real   : acceleration of gravity
 345 ! planck :  real   : planck constant
 346 ! boltz  :  real   : boltzmann constant
 347 ! clight :  real   : speed of light
 348 ! avogad :  real   : avogadro constant
 349 ! alosmt :  real   : loschmidt constant
 350 ! gascon :  real   : molar gas constant
 351 ! radcn1 :  real   : first radiation constant
 352 ! radcn2 :  real   : second radiation constant
 353 ! sbcnst :  real   : stefan-boltzmann constant
 354 !  secdy :  real   : seconds per day
 355 !------------------------------------------------------------------
 356
 357       real  :: fluxfac, heatfac
 358       real  :: oneminus, pi, grav
 359       real  :: planck, boltz, clight
 360       real  :: avogad, alosmt, gascon
 361       real  :: radcn1, radcn2
 362       real  :: sbcnst, secdy
 363
 364       end module rrsw_con_f
 365
 366       module rrsw_kg16_f
 367
 368       use parrrsw_f, only : ng16
 369
 370 !     implicit none
 371       save
 372
 373 !-----------------------------------------------------------------
 374 ! rrtmg_sw ORIGINAL abs. coefficients for interval 16
 375 ! band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
 376 !
 377 ! Initial version:  JJMorcrette, ECMWF, oct1999
 378 ! Revised: MJIacono, AER, jul2006
 379 ! Revised: MJIacono, AER, aug2008
 380 !-----------------------------------------------------------------
 381 !
 382 !  name     type     purpose
 383 !  ----   : ----   : ---------------------------------------------
 384 ! kao     : real
 385 ! kbo     : real
 386 ! selfrefo: real
 387 ! forrefo : real
 388 !sfluxrefo: real
 389 !-----------------------------------------------------------------
 390
 391       integer , parameter :: no16 = 16
 392
 393       real  :: kao(9,5,13,no16)
 394       real  :: kbo(5,13:59,no16)
 395       real  :: selfrefo(10,no16), forrefo(3,no16)
 396       real  :: sfluxrefo(no16)
 397
 398       integer :: layreffr
 399       real  :: rayl, strrat1
 400
 401 !-----------------------------------------------------------------
 402 ! rrtmg_sw COMBINED abs. coefficients for interval 16
 403 ! band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
 404 !
 405 ! Initial version:  JJMorcrette, ECMWF, oct1999
 406 ! Revised: MJIacono, AER, jul2006
 407 ! Revised: MJIacono, AER, aug2008
 408 !-----------------------------------------------------------------
 409 !
 410 !  name     type     purpose
 411 !  ----   : ----   : ---------------------------------------------
 412 ! ka      : real
 413 ! kb      : real
 414 ! absa    : real
 415 ! absb    : real
 416 ! selfref : real
 417 ! forref  : real
 418 ! sfluxref: real
 419 !-----------------------------------------------------------------
 420
 421       real  :: ka(9,5,13,ng16) , absa(585,ng16)
 422       real  :: kb(5,13:59,ng16), absb(235,ng16)
 423       real  :: selfref(10,ng16), forref(3,ng16)
 424       real  :: sfluxref(ng16)
 425
 426       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 427
 428       end module rrsw_kg16_f
 429
 430       module rrsw_kg17_f
 431
 432       use parrrsw_f, only : ng17
 433
 434 !     implicit none
 435       save
 436
 437 !-----------------------------------------------------------------
 438 ! rrtmg_sw ORIGINAL abs. coefficients for interval 17
 439 ! band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
 440 !
 441 ! Initial version:  JJMorcrette, ECMWF, oct1999
 442 ! Revised: MJIacono, AER, jul2006
 443 ! Revised: MJIacono, AER, aug2008
 444 !-----------------------------------------------------------------
 445 !
 446 !  name     type     purpose
 447 !  ----   : ----   : ---------------------------------------------
 448 ! kao     : real
 449 ! kbo     : real
 450 ! selfrefo: real
 451 ! forrefo : real
 452 !sfluxrefo: real
 453 !-----------------------------------------------------------------
 454
 455       integer , parameter :: no17 = 16
 456
 457       real  :: kao(9,5,13,no17)
 458       real  :: kbo(5,5,13:59,no17)
 459       real  :: selfrefo(10,no17), forrefo(4,no17)
 460       real  :: sfluxrefo(no17,5)
 461
 462       integer :: layreffr
 463       real  :: rayl, strrat
 464
 465 !-----------------------------------------------------------------
 466 ! rrtmg_sw COMBINED abs. coefficients for interval 17
 467 ! band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
 468 !
 469 ! Initial version:  JJMorcrette, ECMWF, oct1999
 470 ! Revised: MJIacono, AER, jul2006
 471 ! Revised: MJIacono, AER, aug2008
 472 !-----------------------------------------------------------------
 473 !
 474 !  name     type     purpose
 475 !  ----   : ----   : ---------------------------------------------
 476 ! ka      : real
 477 ! kb      : real
 478 ! absa    : real
 479 ! absb    : real
 480 ! selfref : real
 481 ! forref  : real
 482 ! sfluxref: real
 483 !-----------------------------------------------------------------
 484
 485       real  :: ka(9,5,13,ng17) , absa(585,ng17)
 486       real  :: kb(5,5,13:59,ng17), absb(1175,ng17)
 487       real  :: selfref(10,ng17), forref(4,ng17)
 488       real  :: sfluxref(ng17,5)
 489
 490       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
 491
 492       end module rrsw_kg17_f
 493
 494       module rrsw_kg18_f
 495
 496       use parrrsw_f, only : ng18
 497
 498 !     implicit none
 499       save
 500
 501 !-----------------------------------------------------------------
 502 ! rrtmg_sw ORIGINAL abs. coefficients for interval 18
 503 ! band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
 504 !
 505 ! Initial version:  JJMorcrette, ECMWF, oct1999
 506 ! Revised: MJIacono, AER, jul2006
 507 ! Revised: MJIacono, AER, aug2008
 508 !-----------------------------------------------------------------
 509 !
 510 !  name     type     purpose
 511 !  ----   : ----   : ---------------------------------------------
 512 ! kao     : real
 513 ! kbo     : real
 514 ! selfrefo: real
 515 ! forrefo : real
 516 !sfluxrefo: real
 517 !-----------------------------------------------------------------
 518
 519       integer , parameter :: no18 = 16
 520
 521       real  :: kao(9,5,13,no18)
 522       real  :: kbo(5,13:59,no18)
 523       real  :: selfrefo(10,no18), forrefo(3,no18)
 524       real  :: sfluxrefo(no18,9)
 525
 526       integer :: layreffr
 527       real  :: rayl, strrat
 528
 529 !-----------------------------------------------------------------
 530 ! rrtmg_sw COMBINED abs. coefficients for interval 18
 531 ! band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
 532 !
 533 ! Initial version:  JJMorcrette, ECMWF, oct1999
 534 ! Revised: MJIacono, AER, jul2006
 535 ! Revised: MJIacono, AER, aug2008
 536 !-----------------------------------------------------------------
 537 !
 538 !  name     type     purpose
 539 !  ----   : ----   : ---------------------------------------------
 540 ! ka      : real
 541 ! kb      : real
 542 ! absa    : real
 543 ! absb    : real
 544 ! selfref : real
 545 ! forref  : real
 546 ! sfluxref: real
 547 !-----------------------------------------------------------------
 548
 549       real  :: ka(9,5,13,ng18), absa(585,ng18)
 550       real  :: kb(5,13:59,ng18), absb(235,ng18)
 551       real  :: selfref(10,ng18), forref(3,ng18)
 552       real  :: sfluxref(ng18,9)
 553
 554       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 555
 556       end module rrsw_kg18_f
 557
 558       module rrsw_kg19_f
 559
 560       use parrrsw_f, only : ng19
 561
 562 !     implicit none
 563       save
 564
 565 !-----------------------------------------------------------------
 566 ! rrtmg_sw ORIGINAL abs. coefficients for interval 19
 567 ! band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
 568 !
 569 ! Initial version:  JJMorcrette, ECMWF, oct1999
 570 ! Revised: MJIacono, AER, jul2006
 571 ! Revised: MJIacono, AER, aug2008
 572 !-----------------------------------------------------------------
 573 !
 574 !  name     type     purpose
 575 !  ----   : ----   : ---------------------------------------------
 576 ! kao     : real
 577 ! kbo     : real
 578 ! selfrefo: real
 579 ! forrefo : real
 580 !sfluxrefo: real
 581 !-----------------------------------------------------------------
 582
 583       integer , parameter :: no19 = 16
 584
 585       real  :: kao(9,5,13,no19)
 586       real  :: kbo(5,13:59,no19)
 587       real  :: selfrefo(10,no19), forrefo(3,no19)
 588       real  :: sfluxrefo(no19,9)
 589
 590       integer :: layreffr
 591       real  :: rayl, strrat
 592
 593 !-----------------------------------------------------------------
 594 ! rrtmg_sw COMBINED abs. coefficients for interval 19
 595 ! band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
 596 !
 597 ! Initial version:  JJMorcrette, ECMWF, oct1999
 598 ! Revised: MJIacono, AER, jul2006
 599 ! Revised: MJIacono, AER, aug2008
 600 !-----------------------------------------------------------------
 601 !
 602 !  name     type     purpose
 603 !  ----   : ----   : ---------------------------------------------
 604 ! ka      : real
 605 ! kb      : real
 606 ! absa    : real
 607 ! absb    : real
 608 ! selfref : real
 609 ! forref  : real
 610 ! sfluxref: real
 611 !-----------------------------------------------------------------
 612
 613       real  :: ka(9,5,13,ng19), absa(585,ng19)
 614       real  :: kb(5,13:59,ng19), absb(235,ng19)
 615       real  :: selfref(10,ng19), forref(3,ng19)
 616       real  :: sfluxref(ng19,9)
 617
 618       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 619
 620       end module rrsw_kg19_f
 621
 622       module rrsw_kg20_f
 623
 624       use parrrsw_f, only : ng20
 625
 626 !     implicit none
 627       save
 628
 629 !-----------------------------------------------------------------
 630 ! rrtmg_sw ORIGINAL abs. coefficients for interval 20
 631 ! band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
 632 !
 633 ! Initial version:  JJMorcrette, ECMWF, oct1999
 634 ! Revised: MJIacono, AER, jul2006
 635 ! Revised: MJIacono, AER, aug2008
 636 !-----------------------------------------------------------------
 637 !
 638 !  name     type     purpose
 639 !  ----   : ----   : ---------------------------------------------
 640 ! kao     : real
 641 ! kbo     : real
 642 ! selfrefo: real
 643 ! forrefo : real
 644 !sfluxrefo: real
 645 ! absch4o : real
 646 !-----------------------------------------------------------------
 647
 648       integer , parameter :: no20 = 16
 649
 650       real  :: kao(5,13,no20)
 651       real  :: kbo(5,13:59,no20)
 652       real  :: selfrefo(10,no20), forrefo(4,no20)
 653       real  :: sfluxrefo(no20)
 654       real  :: absch4o(no20)
 655
 656       integer :: layreffr
 657       real  :: rayl
 658
 659 !-----------------------------------------------------------------
 660 ! rrtmg_sw COMBINED abs. coefficients for interval 20
 661 ! band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
 662 !
 663 ! Initial version:  JJMorcrette, ECMWF, oct1999
 664 ! Revised: MJIacono, AER, jul2006
 665 ! Revised: MJIacono, AER, aug2008
 666 !-----------------------------------------------------------------
 667 !
 668 !  name     type     purpose
 669 !  ----   : ----   : ---------------------------------------------
 670 ! ka      : real
 671 ! kb      : real
 672 ! absa    : real
 673 ! absb    : real
 674 ! selfref : real
 675 ! forref  : real
 676 ! sfluxref: real
 677 ! absch4  : real
 678 !-----------------------------------------------------------------
 679
 680       real  :: ka(5,13,ng20), absa(65,ng20)
 681       real  :: kb(5,13:59,ng20), absb(235,ng20)
 682       real  :: selfref(10,ng20), forref(4,ng20)
 683       real  :: sfluxref(ng20)
 684       real  :: absch4(ng20)
 685
 686       equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 687
 688       end module rrsw_kg20_f
 689
 690       module rrsw_kg21_f
 691
 692       use parrrsw_f, only : ng21
 693
 694 !     implicit none
 695       save
 696
 697 !-----------------------------------------------------------------
 698 ! rrtmg_sw ORIGINAL abs. coefficients for interval 21
 699 ! band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
 700 !
 701 ! Initial version:  JJMorcrette, ECMWF, oct1999
 702 ! Revised: MJIacono, AER, jul2006
 703 ! Revised: MJIacono, AER, aug2008
 704 !-----------------------------------------------------------------
 705 !
 706 !  name     type     purpose
 707 !  ----   : ----   : ---------------------------------------------
 708 ! kao     : real
 709 ! kbo     : real
 710 ! selfrefo: real
 711 ! forrefo : real
 712 !sfluxrefo: real
 713 !-----------------------------------------------------------------
 714
 715       integer , parameter :: no21 = 16
 716
 717       real  :: kao(9,5,13,no21)
 718       real  :: kbo(5,5,13:59,no21)
 719       real  :: selfrefo(10,no21), forrefo(4,no21)
 720       real  :: sfluxrefo(no21,9)
 721
 722       integer :: layreffr
 723       real  :: rayl, strrat
 724
 725 !-----------------------------------------------------------------
 726 ! rrtmg_sw COMBINED abs. coefficients for interval 21
 727 ! band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
 728 !
 729 ! Initial version:  JJMorcrette, ECMWF, oct1999
 730 ! Revised: MJIacono, AER, jul2006
 731 ! Revised: MJIacono, AER, aug2008
 732 !-----------------------------------------------------------------
 733 !
 734 !  name     type     purpose
 735 !  ----   : ----   : ---------------------------------------------
 736 ! ka      : real
 737 ! kb      : real
 738 ! absa    : real
 739 ! absb    : real
 740 ! selfref : real
 741 ! forref  : real
 742 ! sfluxref: real
 743 !-----------------------------------------------------------------
 744
 745       real  :: ka(9,5,13,ng21), absa(585,ng21)
 746       real  :: kb(5,5,13:59,ng21), absb(1175,ng21)
 747       real  :: selfref(10,ng21), forref(4,ng21)
 748       real  :: sfluxref(ng21,9)
 749
 750       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
 751
 752       end module rrsw_kg21_f
 753
 754       module rrsw_kg22_f
 755
 756       use parrrsw_f, only : ng22
 757
 758 !     implicit none
 759       save
 760
 761 !-----------------------------------------------------------------
 762 ! rrtmg_sw ORIGINAL abs. coefficients for interval 22
 763 ! band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
 764 !
 765 ! Initial version:  JJMorcrette, ECMWF, oct1999
 766 ! Revised: MJIacono, AER, jul2006
 767 ! Revised: MJIacono, AER, aug2008
 768 !-----------------------------------------------------------------
 769 !
 770 !  name     type     purpose
 771 !  ----   : ----   : ---------------------------------------------
 772 ! kao     : real
 773 ! kbo     : real
 774 ! selfrefo: real
 775 ! forrefo : real
 776 !sfluxrefo: real
 777 !-----------------------------------------------------------------
 778
 779       integer , parameter :: no22 = 16
 780
 781       real  :: kao(9,5,13,no22)
 782       real  :: kbo(5,13:59,no22)
 783       real  :: selfrefo(10,no22), forrefo(3,no22)
 784       real  :: sfluxrefo(no22,9)
 785
 786       integer :: layreffr
 787       real  :: rayl, strrat
 788
 789 !-----------------------------------------------------------------
 790 ! rrtmg_sw COMBINED abs. coefficients for interval 22
 791 ! band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
 792 !
 793 ! Initial version:  JJMorcrette, ECMWF, oct1999
 794 ! Revised: MJIacono, AER, jul2006
 795 ! Revised: MJIacono, AER, aug2008
 796 !-----------------------------------------------------------------
 797 !
 798 !  name     type     purpose
 799 !  ----   : ----   : ---------------------------------------------
 800 ! ka      : real
 801 ! kb      : real
 802 ! absa    : real
 803 ! absb    : real
 804 ! selfref : real
 805 ! forref  : real
 806 ! sfluxref: real
 807 !-----------------------------------------------------------------
 808
 809       real  :: ka(9,5,13,ng22), absa(585,ng22)
 810       real  :: kb(5,13:59,ng22), absb(235,ng22)
 811       real  :: selfref(10,ng22), forref(3,ng22)
 812       real  :: sfluxref(ng22,9)
 813
 814       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 815
 816       end module rrsw_kg22_f
 817
 818       module rrsw_kg23_f
 819
 820       use parrrsw_f, only : ng23
 821
 822 !     implicit none
 823       save
 824
 825 !-----------------------------------------------------------------
 826 ! rrtmg_sw ORIGINAL abs. coefficients for interval 23
 827 ! band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
 828 !
 829 ! Initial version:  JJMorcrette, ECMWF, oct1999
 830 ! Revised: MJIacono, AER, jul2006
 831 ! Revised: MJIacono, AER, aug2008
 832 !-----------------------------------------------------------------
 833 !
 834 !  name     type     purpose
 835 !  ----   : ----   : ---------------------------------------------
 836 ! kao     : real
 837 ! kbo     : real
 838 ! selfrefo: real
 839 ! forrefo : real
 840 !sfluxrefo: real
 841 !-----------------------------------------------------------------
 842
 843       integer , parameter :: no23 = 16
 844
 845       real  :: kao(5,13,no23)
 846       real  :: selfrefo(10,no23), forrefo(3,no23)
 847       real  :: sfluxrefo(no23)
 848       real  :: raylo(no23)
 849
 850       integer :: layreffr
 851       real :: givfac
 852
 853 !-----------------------------------------------------------------
 854 ! rrtmg_sw COMBINED abs. coefficients for interval 23
 855 ! band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
 856 !
 857 ! Initial version:  JJMorcrette, ECMWF, oct1999
 858 ! Revised: MJIacono, AER, jul2006
 859 ! Revised: MJIacono, AER, aug2008
 860 !-----------------------------------------------------------------
 861 !
 862 !  name     type     purpose
 863 !  ----   : ----   : ---------------------------------------------
 864 ! ka      : real
 865 ! kb      : real
 866 ! absa    : real
 867 ! absb    : real
 868 ! selfref : real
 869 ! forref  : real
 870 ! sfluxref: real
 871 !-----------------------------------------------------------------
 872
 873       real  :: ka(5,13,ng23), absa(65,ng23)
 874       real  :: selfref(10,ng23), forref(3,ng23)
 875       real  :: sfluxref(ng23), rayl(ng23)
 876
 877       equivalence (ka(1,1,1),absa(1,1))
 878
 879       end module rrsw_kg23_f
 880
 881       module rrsw_kg24_f
 882
 883       use parrrsw_f, only : ng24
 884
 885 !     implicit none
 886       save
 887
 888 !-----------------------------------------------------------------
 889 ! rrtmg_sw ORIGINAL abs. coefficients for interval 24
 890 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
 891 !
 892 ! Initial version:  JJMorcrette, ECMWF, oct1999
 893 ! Revised: MJIacono, AER, jul2006
 894 ! Revised: MJIacono, AER, aug2008
 895 !-----------------------------------------------------------------
 896 !
 897 !  name     type     purpose
 898 !  ----   : ----   : ---------------------------------------------
 899 ! kao     : real
 900 ! kbo     : real
 901 ! selfrefo: real
 902 ! forrefo : real
 903 !sfluxrefo: real
 904 ! abso3ao : real
 905 ! abso3bo : real
 906 ! raylao  : real
 907 ! raylbo  : real
 908 !-----------------------------------------------------------------
 909
 910       integer , parameter :: no24 = 16
 911
 912       real  :: kao(9,5,13,no24)
 913       real  :: kbo(5,13:59,no24)
 914       real  :: selfrefo(10,no24), forrefo(3,no24)
 915       real  :: sfluxrefo(no24,9)
 916       real  :: abso3ao(no24), abso3bo(no24)
 917       real  :: raylao(no24,9), raylbo(no24)
 918
 919       integer :: layreffr
 920       real :: strrat
 921
 922 !-----------------------------------------------------------------
 923 ! rrtmg_sw COMBINED abs. coefficients for interval 24
 924 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
 925 !
 926 ! Initial version:  JJMorcrette, ECMWF, oct1999
 927 ! Revised: MJIacono, AER, jul2006
 928 ! Revised: MJIacono, AER, aug2008
 929 !-----------------------------------------------------------------
 930 !
 931 !  name     type     purpose
 932 !  ----   : ----   : ---------------------------------------------
 933 ! ka      : real
 934 ! kb      : real
 935 ! absa    : real
 936 ! absb    : real
 937 ! selfref : real
 938 ! forref  : real
 939 ! sfluxref: real
 940 ! abso3a  : real
 941 ! abso3b  : real
 942 ! rayla   : real
 943 ! raylb   : real
 944 !-----------------------------------------------------------------
 945
 946       real  :: ka(9,5,13,ng24), absa(585,ng24)
 947       real  :: kb(5,13:59,ng24), absb(235,ng24)
 948       real  :: selfref(10,ng24), forref(3,ng24)
 949       real  :: sfluxref(ng24,9)
 950       real  :: abso3a(ng24), abso3b(ng24)
 951       real  :: rayla(ng24,9), raylb(ng24)
 952
 953       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
 954
 955       end module rrsw_kg24_f
 956
 957       module rrsw_kg25_f
 958
 959       use parrrsw_f, only : ng25
 960
 961 !     implicit none
 962       save
 963
 964 !-----------------------------------------------------------------
 965 ! rrtmg_sw ORIGINAL abs. coefficients for interval 25
 966 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
 967 !
 968 ! Initial version:  JJMorcrette, ECMWF, oct1999
 969 ! Revised: MJIacono, AER, jul2006
 970 ! Revised: MJIacono, AER, aug2008
 971 !-----------------------------------------------------------------
 972 !
 973 !  name     type     purpose
 974 !  ----   : ----   : ---------------------------------------------
 975 ! kao     : real
 976 !sfluxrefo: real
 977 ! abso3ao : real
 978 ! abso3bo : real
 979 ! raylo   : real
 980 !-----------------------------------------------------------------
 981
 982       integer , parameter :: no25 = 16
 983
 984       real  :: kao(5,13,no25)
 985       real  :: sfluxrefo(no25)
 986       real  :: abso3ao(no25), abso3bo(no25)
 987       real  :: raylo(no25)
 988
 989       integer :: layreffr
 990
 991 !-----------------------------------------------------------------
 992 ! rrtmg_sw COMBINED abs. coefficients for interval 25
 993 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
 994 !
 995 ! Initial version:  JJMorcrette, ECMWF, oct1999
 996 ! Revised: MJIacono, AER, jul2006
 997 ! Revised: MJIacono, AER, aug2008
 998 !-----------------------------------------------------------------
 999 !
1000 !  name     type     purpose
1001 !  ----   : ----   : ---------------------------------------------
1002 ! ka      : real
1003 ! absa    : real
1004 ! sfluxref: real
1005 ! abso3a  : real
1006 ! abso3b  : real
1007 ! rayl    : real
1008 !-----------------------------------------------------------------
1009
1010       real  :: ka(5,13,ng25), absa(65,ng25)
1011       real  :: sfluxref(ng25)
1012       real  :: abso3a(ng25), abso3b(ng25)
1013       real  :: rayl(ng25)
1014
1015       equivalence (ka(1,1,1),absa(1,1))
1016
1017       end module rrsw_kg25_f
1018
1019       module rrsw_kg26_f
1020
1021       use parrrsw_f, only : ng26
1022
1023 !     implicit none
1024       save
1025
1026 !-----------------------------------------------------------------
1027 ! rrtmg_sw ORIGINAL abs. coefficients for interval 26
1028 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1029 !
1030 ! Initial version:  JJMorcrette, ECMWF, oct1999
1031 ! Revised: MJIacono, AER, jul2006
1032 ! Revised: MJIacono, AER, aug2008
1033 !-----------------------------------------------------------------
1034 !
1035 !  name     type     purpose
1036 !  ----   : ----   : ---------------------------------------------
1037 !sfluxrefo: real
1038 ! raylo   : real
1039 !-----------------------------------------------------------------
1040
1041       integer , parameter :: no26 = 16
1042
1043       real  :: sfluxrefo(no26)
1044       real  :: raylo(no26)
1045
1046 !-----------------------------------------------------------------
1047 ! rrtmg_sw COMBINED abs. coefficients for interval 26
1048 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
1049 !
1050 ! Initial version:  JJMorcrette, ECMWF, oct1999
1051 ! Revised: MJIacono, AER, jul2006
1052 ! Revised: MJIacono, AER, aug2008
1053 !-----------------------------------------------------------------
1054 !
1055 !  name     type     purpose
1056 !  ----   : ----   : ---------------------------------------------
1057 ! sfluxref: real
1058 ! rayl    : real
1059 !-----------------------------------------------------------------
1060
1061       real  :: sfluxref(ng26)
1062       real  :: rayl(ng26)
1063
1064       end module rrsw_kg26_f
1065
1066       module rrsw_kg27_f
1067
1068       use parrrsw_f, only : ng27
1069
1070 !     implicit none
1071       save
1072
1073 !-----------------------------------------------------------------
1074 ! rrtmg_sw ORIGINAL abs. coefficients for interval 27
1075 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1076 !
1077 ! Initial version:  JJMorcrette, ECMWF, oct1999
1078 ! Revised: MJIacono, AER, jul2006
1079 ! Revised: MJIacono, AER, aug2008
1080 !-----------------------------------------------------------------
1081 !
1082 !  name     type     purpose
1083 !  ----   : ----   : ---------------------------------------------
1084 ! kao     : real
1085 ! kbo     : real
1086 !sfluxrefo: real
1087 ! raylo   : real
1088 !-----------------------------------------------------------------
1089
1090       integer , parameter :: no27 = 16
1091
1092       real  :: kao(5,13,no27)
1093       real  :: kbo(5,13:59,no27)
1094       real  :: sfluxrefo(no27)
1095       real  :: raylo(no27)
1096
1097       integer :: layreffr
1098       real :: scalekur
1099
1100 !-----------------------------------------------------------------
1101 ! rrtmg_sw COMBINED abs. coefficients for interval 27
1102 ! band 27: 29000-38000 cm-1 (low - o3; high - o3)
1103 !
1104 ! Initial version:  JJMorcrette, ECMWF, oct1999
1105 ! Revised: MJIacono, AER, jul2006
1106 ! Revised: MJIacono, AER, aug2008
1107 !-----------------------------------------------------------------
1108 !
1109 !  name     type     purpose
1110 !  ----   : ----   : ---------------------------------------------
1111 ! ka      : real
1112 ! kb      : real
1113 ! absa    : real
1114 ! absb    : real
1115 ! sfluxref: real
1116 ! rayl    : real
1117 !-----------------------------------------------------------------
1118
1119       real  :: ka(5,13,ng27), absa(65,ng27)
1120       real  :: kb(5,13:59,ng27), absb(235,ng27)
1121       real  :: sfluxref(ng27)
1122       real  :: rayl(ng27)
1123
1124       equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1125
1126       end module rrsw_kg27_f
1127
1128       module rrsw_kg28_f
1129
1130       use parrrsw_f, only : ng28
1131
1132 !     implicit none
1133       save
1134
1135 !-----------------------------------------------------------------
1136 ! rrtmg_sw ORIGINAL abs. coefficients for interval 28
1137 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1138 !
1139 ! Initial version:  JJMorcrette, ECMWF, oct1999
1140 ! Revised: MJIacono, AER, jul2006
1141 ! Revised: MJIacono, AER, aug2008
1142 !-----------------------------------------------------------------
1143 !
1144 !  name     type     purpose
1145 !  ----   : ----   : ---------------------------------------------
1146 ! kao     : real
1147 ! kbo     : real
1148 !sfluxrefo: real
1149 !-----------------------------------------------------------------
1150
1151       integer , parameter :: no28 = 16
1152
1153       real  :: kao(9,5,13,no28)
1154       real  :: kbo(5,5,13:59,no28)
1155       real  :: sfluxrefo(no28,5)
1156
1157       integer :: layreffr
1158       real  :: rayl, strrat
1159
1160 !-----------------------------------------------------------------
1161 ! rrtmg_sw COMBINED abs. coefficients for interval 28
1162 ! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
1163 !
1164 ! Initial version:  JJMorcrette, ECMWF, oct1999
1165 ! Revised: MJIacono, AER, jul2006
1166 ! Revised: MJIacono, AER, aug2008
1167 !-----------------------------------------------------------------
1168 !
1169 !  name     type     purpose
1170 !  ----   : ----   : ---------------------------------------------
1171 ! ka      : real
1172 ! kb      : real
1173 ! sfluxref: real
1174 !-----------------------------------------------------------------
1175
1176       real  :: ka(9,5,13,ng28), absa(585,ng28)
1177       real  :: kb(5,5,13:59,ng28), absb(1175,ng28)
1178       real  :: sfluxref(ng28,5)
1179
1180       equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
1181
1182       end module rrsw_kg28_f
1183
1184       module rrsw_kg29_f
1185
1186       use parrrsw_f, only : ng29
1187
1188 !     implicit none
1189       save
1190
1191 !-----------------------------------------------------------------
1192 ! rrtmg_sw ORIGINAL abs. coefficients for interval 29
1193 ! band 29:  820-2600 cm-1 (low - h2o; high - co2)
1194 !
1195 ! Initial version:  JJMorcrette, ECMWF, oct1999
1196 ! Revised: MJIacono, AER, jul2006
1197 ! Revised: MJIacono, AER, aug2008
1198 !-----------------------------------------------------------------
1199 !
1200 !  name     type     purpose
1201 !  ----   : ----   : ---------------------------------------------
1202 ! kao     : real
1203 ! kbo     : real
1204 ! selfrefo: real
1205 ! forrefo : real
1206 !sfluxrefo: real
1207 ! absh2oo : real
1208 ! absco2o : real
1209 !-----------------------------------------------------------------
1210
1211       integer , parameter :: no29 = 16
1212
1213       real  :: kao(5,13,no29)
1214       real  :: kbo(5,13:59,no29)
1215       real  :: selfrefo(10,no29), forrefo(4,no29)
1216       real  :: sfluxrefo(no29)
1217       real  :: absh2oo(no29), absco2o(no29)
1218
1219       integer :: layreffr
1220       real  :: rayl
1221
1222 !-----------------------------------------------------------------
1223 ! rrtmg_sw COMBINED abs. coefficients for interval 29
1224 ! band 29:  820-2600 cm-1 (low - h2o; high - co2)
1225 !
1226 ! Initial version:  JJMorcrette, ECMWF, oct1999
1227 ! Revised: MJIacono, AER, jul2006
1228 ! Revised: MJIacono, AER, aug2008
1229 !-----------------------------------------------------------------
1230 !
1231 !  name     type     purpose
1232 !  ----   : ----   : ---------------------------------------------
1233 ! ka      : real
1234 ! kb      : real
1235 ! selfref : real
1236 ! forref  : real
1237 ! sfluxref: real
1238 ! absh2o  : real
1239 ! absco2  : real
1240 !-----------------------------------------------------------------
1241
1242       real  :: ka(5,13,ng29), absa(65,ng29)
1243       real  :: kb(5,13:59,ng29), absb(235,ng29)
1244       real  :: selfref(10,ng29), forref(4,ng29)
1245       real  :: sfluxref(ng29)
1246       real  :: absh2o(ng29), absco2(ng29)
1247
1248       equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
1249
1250       end module rrsw_kg29_f
1251
1252       module rrsw_ref_f
1253
1254 !      implicit none
1255       save
1256
1257 !------------------------------------------------------------------
1258 ! rrtmg_sw reference atmosphere
1259 ! Based on standard mid-latitude summer profile
1260 !
1261 ! Initial version:  JJMorcrette, ECMWF, jul1998
1262 ! Revised: MJIacono, AER, jun2006
1263 ! Revised: MJIacono, AER, aug2008
1264 !------------------------------------------------------------------
1265
1266 !  name     type     purpose
1267 ! -----  :  ----   : ----------------------------------------------
1268 ! pref   :  real   : Reference pressure levels
1269 ! preflog:  real   : Reference pressure levels, ln(pref)
1270 ! tref   :  real   : Reference temperature levels for MLS profile
1271 !------------------------------------------------------------------
1272
1273       real  , dimension(59) :: pref
1274       real  , dimension(59) :: preflog
1275       real  , dimension(59) :: tref
1276
1277       end module rrsw_ref_f
1278
1279       module rrsw_tbl_f
1280
1281 !     implicit none
1282       save
1283
1284 !------------------------------------------------------------------
1285 ! rrtmg_sw lookup table arrays
1286
1287 ! Initial version: MJIacono, AER, may2007
1288 ! Revised: MJIacono, AER, aug2007
1289 ! Revised: MJIacono, AER, aug2008
1290 !------------------------------------------------------------------
1291
1292 !  name     type     purpose
1293 ! -----  :  ----   : ----------------------------------------------
1294 ! ntbl   :  integer: Lookup table dimension
1295 ! tblint :  real   : Lookup table conversion factor
1296 ! tau_tbl:  real   : Clear-sky optical depth
1297 ! exp_tbl:  real   : Exponential lookup table for transmittance
1298 ! od_lo  :  real   : Value of tau below which expansion is used
1299 !                  : in place of lookup table
1300 ! pade   :  real   : Pade approximation constant
1301 ! bpade  :  real   : Inverse of Pade constant
1302 !------------------------------------------------------------------
1303
1304       integer , parameter :: ntbl = 10000
1305
1306       real , parameter :: tblint = 10000.0
1307
1308       real , parameter :: od_lo = 0.06
1309
1310       real :: tau_tbl
1311       real , dimension(0:ntbl) :: exp_tbl
1312
1313       real , parameter :: pade = 0.278
1314       real :: bpade
1315
1316       end module rrsw_tbl_f
1317
1318       module rrsw_vsn_f
1319
1320 !     implicit none
1321       save
1322
1323 !------------------------------------------------------------------
1324 ! rrtmg_sw version information
1325
1326 ! Initial version:  JJMorcrette, ECMWF, jul1998
1327 ! Revised: MJIacono, AER, jul2006
1328 ! Revised: MJIacono, AER, aug2008
1329 !------------------------------------------------------------------
1330
1331 !  name     type     purpose
1332 ! -----  :  ----   : ----------------------------------------------
1333 !hnamrtm :character:
1334 !hnamini :character:
1335 !hnamcld :character:
1336 !hnamclc :character:
1337 !hnamrft :character:
1338 !hnamspv :character:
1339 !hnamspc :character:
1340 !hnamset :character:
1341 !hnamtau :character:
1342 !hnamvqd :character:
1343 !hnamatm :character:
1344 !hnamutl :character:
1345 !hnamext :character:
1346 !hnamkg  :character:
1347 !
1348 ! hvrrtm :character:
1349 ! hvrini :character:
1350 ! hvrcld :character:
1351 ! hvrclc :character:
1352 ! hvrrft :character:
1353 ! hvrspv :character:
1354 ! hvrspc :character:
1355 ! hvrset :character:
1356 ! hvrtau :character:
1357 ! hvrvqd :character:
1358 ! hvratm :character:
1359 ! hvrutl :character:
1360 ! hvrext :character:
1361 ! hvrkg  :character:
1362 !------------------------------------------------------------------
1363
1364       character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
1365                    hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
1366       character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
1367                    hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
1368
1369       character*18 hvrkg
1370       character*20 hnamkg
1371
1372       end module rrsw_vsn_f
1373
1374       module rrsw_wvn_f
1375
1376       use parrrsw_f, only : nbndsw, mg, ngptsw, jpb1, jpb2
1377
1378 !     implicit none
1379       save
1380
1381 !------------------------------------------------------------------
1382 ! rrtmg_sw spectral information
1383
1384 ! Initial version:  JJMorcrette, ECMWF, jul1998
1385 ! Revised: MJIacono, AER, jul2006
1386 ! Revised: MJIacono, AER, aug2008
1387 !------------------------------------------------------------------
1388
1389 !  name     type     purpose
1390 ! -----  :  ----   : ----------------------------------------------
1391 ! ng     :  integer: Number of original g-intervals in each spectral band
1392 ! nspa   :  integer:
1393 ! nspb   :  integer:
1394 !wavenum1:  real   : Spectral band lower boundary in wavenumbers
1395 !wavenum2:  real   : Spectral band upper boundary in wavenumbers
1396 ! delwave:  real   : Spectral band width in wavenumbers
1397 !
1398 ! ngc    :  integer: The number of new g-intervals in each band
1399 ! ngs    :  integer: The cumulative sum of new g-intervals for each band
1400 ! ngm    :  integer: The index of each new g-interval relative to the
1401 !                    original 16 g-intervals in each band
1402 ! ngn    :  integer: The number of original g-intervals that are
1403 !                    combined to make each new g-intervals in each band
1404 ! ngb    :  integer: The band index for each new g-interval
1405 ! wt     :  real   : RRTM weights for the original 16 g-intervals
1406 ! rwgt   :  real   : Weights for combining original 16 g-intervals
1407 !                    (224 total) into reduced set of g-intervals
1408 !                    (112 total)
1409 !------------------------------------------------------------------
1410
1411       integer  :: ng(jpb1:jpb2)
1412       integer  :: nspa(jpb1:jpb2)
1413       integer  :: nspb(jpb1:jpb2)
1414
1415       real  :: wavenum1(jpb1:jpb2)
1416       real  :: wavenum2(jpb1:jpb2)
1417       real  :: delwave(jpb1:jpb2)
1418       integer :: icxa(jpb1:jpb2)
1419
1420       integer  :: ngc(nbndsw)
1421       integer  :: ngs(nbndsw)
1422       integer  :: ngn(ngptsw)
1423       integer  :: ngb(ngptsw)
1424       integer  :: ngm(nbndsw*mg)
1425
1426       real  :: wt(mg)
1427       real  :: rwgt(nbndsw*mg)
1428
1429       end module rrsw_wvn_f
1430
1431
1432       module mcica_subcol_gen_sw_f
1433
1434       use parrrsw_f, only : nbndsw, ngptsw
1435       use rrsw_con_f, only: grav
1436       use rrsw_wvn_f, only: ngb
1437       use rrsw_vsn_f
1438
1439       implicit none
1440
1441       public :: mcica_sw
1442
1443       contains
1444 !-------------------------------------------------------------------------------------------------
1445       subroutine mcica_sw(ncol, nlay, nsubcol, icld, irng, play, cld, ciwp, clwp, cswp, &
1446                           tauc, ssac, asmc, fsfc, cld_stoch, ciwp_stoch, clwp_stoch, cswp_stoch, &
1447                           tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed )
1448 !-------------------------------------------------------------------------------------------------
1449
1450   !----------------------------------------------------------------------------------------------------------------
1451   ! ---------------------
1452   ! Contact: Cecile Hannay (hannay@ucar.edu)
1453   !
1454   ! Original code: Based on Raisanen et al., QJRMS, 2004.
1455   !
1456   ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
1457   !   random number generator, which can be changed to the optional kissvec random number generator
1458   !   with flag 'irng'. Some extra functionality has been commented or removed.
1459   !   Michael J. Iacono, AER, Inc., February 2007
1460   !
1461   ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
1462   ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
1463   ! and uniform cloud liquid and cloud ice concentration.
1464   ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
1465   ! and obeys an overlap assumption in the vertical.
1466   !
1467   ! Overlap assumption:
1468   !  The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
1469   !  The default option is maximum-random (option 3)
1470   !  The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
1471   !  This is set with the variable "overlap"
1472   !mji - Exponential overlap option (overlap=4) has been deactivated in this version
1473   !  The exponential overlap uses also a length scale, Zo. (real,    parameter  :: Zo = 2500. )
1474   !
1475   ! Seed:
1476   !  If the stochastic cloud generator is called several times during the same timestep,
1477   !  one should change the seed between the call to insure that the subcolumns are different.
1478   !  This is done by changing the argument 'changeSeed'
1479   !  For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
1480   !  use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
1481   !
1482   ! PDF assumption:
1483   !  We can use arbitrary complicated PDFS.
1484   !  In the present version, we produce homogeneuous clouds (the simplest case).
1485   !  Future developments include using the PDF scheme of Ben Johnson.
1486   !
1487   ! History file:
1488   !  Option to add diagnostics variables in the history file. (using FINCL in the namelist)
1489   !  nsubcol = number of subcolumns
1490   !  overlap = overlap type (1-3)
1491   !  Zo = length scale
1492   !  CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
1493   !  CLDLIQ_S = mean of the subcolumn cloud water
1494   !  CLDICE_S = mean of the subcolumn cloud ice
1495   !
1496   ! Note:
1497   !   Here: we force that the cloud condensate to be consistent with the cloud fraction
1498   !   i.e we only have cloud condensate when the cell is cloudy.
1499   !   In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
1500   !   and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
1501   !   without cloud condensate or the opposite).
1502   !---------------------------------------------------------------------------------------------------------------
1503
1504       use mcica_random_numbers_f
1505 ! The Mersenne Twister random number engine
1506       !use MersenneTwister, only: randomNumberSequence, &
1507       !                           new_RandomNumberSequence, getRandomReal
1508
1509       !type(randomNumberSequence) :: randomNumbers
1510
1511 ! -- Arguments
1512
1513       integer , intent(in) :: ncol            ! number of layers
1514       integer , intent(in) :: nlay            ! number of layers
1515       integer , intent(in) :: icld            ! clear/cloud, cloud overlap flag
1516       integer , intent(inout) :: irng         ! flag for random number generator
1517                                                       !  0 = kissvec
1518                                                       !  1 = Mersenne Twister
1519       integer , intent(in) :: nsubcol         ! number of sub-columns (g-point intervals)
1520       integer , optional, intent(in) :: changeSeed     ! allows permuting seed
1521
1522 ! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
1523       real , intent(in) :: play(:,:)          ! layer pressure (Pa)
1524                                                       !    Dimensions: (ncol,nlay)
1525       real , intent(in) :: cld(:,:)           ! cloud fraction
1526                                                       !    Dimensions: (ncol,nlay)
1527       real , intent(in) :: clwp(:,:)          ! in-cloud liquid water path (g/m2)
1528                                                       !    Dimensions: (ncol,nlay)
1529       real , intent(in) :: ciwp(:,:)          ! in-cloud ice water path (g/m2)
1530                                                       !    Dimensions: (ncol,nlay)
1531       real , intent(in) :: cswp(:,:)          ! in-cloud snow water path (g/m2)
1532                                                       !    Dimensions: (ncol,nlay)
1533       real , intent(in) :: tauc(:,:,:)        ! in-cloud optical depth (non-delta scaled)
1534                                                       !    Dimensions: (ncol,nlay,nbndsw)
1535       real , intent(in) :: ssac(:,:,:)        ! in-cloud single scattering albedo (non-delta scaled)
1536                                                       !    Dimensions: (ncol,nlay,nbndsw)
1537       real , intent(in) :: asmc(:,:,:)        ! in-cloud asymmetry parameter (non-delta scaled)
1538                                                       !    Dimensions: (ncol,nlay,nbndsw)
1539       real , intent(in) :: fsfc(:,:,:)        ! in-cloud forward scattering fraction (non-delta scaled)
1540                                                       !    Dimensions: (ncol,nlay,nbndsw)
1541
1542       real , intent(out) :: cld_stoch(:,:,:)  ! subcolumn cloud fraction
1543                                                       !    Dimensions: (ngptsw,ncol,nlay)
1544       real , intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
1545                                                       !    Dimensions: (ngptsw,ncol,nlay)
1546       real , intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
1547                                                       !    Dimensions: (ngptsw,ncol,nlay)
1548       real , intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
1549                                                       !    Dimensions: (ngptsw,ncol,nlay)
1550       real , intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
1551                                                       !    Dimensions: (ncol,nlay,ngptsw)
1552       real , intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
1553                                                       !    Dimensions: (ncol,nlay,ngptsw)
1554       real , intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter
1555                                                       !    Dimensions: (ncol,nlay,ngptsw)
1556       real , intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction
1557                                                       !    Dimensions: (ncol,nlay,ngptsw)
1558
1559 ! -- Local variables
1560
1561 ! Constants (min value for cloud fraction and cloud water and ice)
1562       real , parameter :: cldmin = 1.0e-20  ! min cloud fraction
1563
1564 #ifndef _ACCEL
1565 # define ncol CHNK
1566 #endif
1567
1568 ! Variables related to random number and seed
1569
1570       real, dimension(ncol, nlay, nsubcol) gpu_device :: CDF
1571 #ifdef _ACCEL
1572       integer :: seed1, seed2, seed3, seed4  ! seed to create random number
1573 #else
1574       integer, dimension(ncol) :: seed1, seed2, seed3, seed4  ! seed to create random number
1575 #endif
1576
1577       integer  :: iseed                        ! seed to create random number (Mersenne Twister)
1578 !      real  :: rand_num_mt                     ! random number (Mersenne Twister)
1579       real  :: kiss
1580
1581
1582 ! Indices
1583       integer  :: ilev, isubcol, i, n, ngbm, iplon   ! indices
1584 #ifndef _ACCEL
1585       integer :: m, k
1586 ! inline function
1587       m(k, n) = ieor (k, ishft (k, n) )
1588 #endif
1589 !------------------------------------------------------------------------------------------
1590
1591 ! Check that irng is in bounds; if not, set to default
1592 ! Note: in GPU version of code, only kissvec method is used, Mersenne Twister not installed
1593
1594 ! Pass input cloud overlap setting to local variable
1595
1596
1597 ! ------ Apply overlap assumption --------
1598
1599 ! generate the random numbers
1600
1601 ! Random cloud overlap
1602       if (icld==1) then
1603 !$acc kernels
1604
1605 #ifdef _ACCEL
1606             do ilev = 1,nlay
1607                do i = 1, ncol
1608                   seed1 = (play(i,1) - int(play(i,1)))  * 100000000 - ilev
1609                   seed2 = (play(i,2) - int(play(i,2)))  * 100000000 + ilev
1610                   seed3 = (play(i,3) - int(play(i,3)))  * 100000000 + ilev * 6.2
1611                   seed4 = (play(i,4) - int(play(i,4)))  * 100000000
1612                   do isubcol = 1,nsubcol
1613                      seed1 = 69069  * seed1 + 132721785
1614                      seed2 = 11002  * iand (seed2, 65535 ) + ishft (seed2, - 16 )
1615                      seed3 = 18000  * iand (seed3, 65535 ) + ishft (seed3, - 16 )
1616                      seed4 = 30903  * iand (seed4, 65535 ) + ishft (seed4, - 16 )
1617                      kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
1618                      CDF(i,ilev,isubcol) = kiss*2.328306e-10  + 0.5
1619                   end do
1620                end do
1621             end do
1622 #else
1623          CALL wrf_error_fatal("icld == 1 not supported in module_ra_rrtmg_swf.F")
1624 #endif
1625
1626 !$acc end kernels
1627       endif
1628
1629 ! Maximum-Random cloud overlap
1630       if (icld==2) then
1631 #ifdef _ACCEL
1632 !$acc kernels
1633
1634             do ilev = 1,nlay
1635                do i = 1, ncol
1636                   seed1 = (play(i,1) - int(play(i,1)))  * 100000000 - ilev
1637                   seed2 = (play(i,2) - int(play(i,2)))  * 100000000 + ilev
1638                   seed3 = (play(i,3) - int(play(i,3)))  * 100000000 + ilev * 6.2
1639                   seed4 = (play(i,4) - int(play(i,4)))  * 100000000
1640                   do isubcol = 1,nsubcol
1641                      seed1 = 69069  * seed1 + 132721785
1642                      seed2 = 11002  * iand (seed2, 65535 ) + ishft (seed2, - 16 )
1643                      seed3 = 18000  * iand (seed3, 65535 ) + ishft (seed3, - 16 )
1644                      seed4 = 30903  * iand (seed4, 65535 ) + ishft (seed4, - 16 )
1645                      kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
1646                      CDF(i,ilev,isubcol) = kiss*2.328306e-10  + 0.5
1647                   end do
1648                end do
1649             end do
1650
1651             do ilev = 2,nlay
1652                do i = 1, ncol
1653                   do isubcol = 1,nsubcol
1654                      if (CDF(i,ilev-1,isubcol) > 1.  - cld(i, ilev-1)) then
1655                         CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol)
1656                      else
1657                         CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1))
1658                      end if
1659                   end do
1660                end do
1661             end do
1662
1663 !$acc end kernels
1664 #else
1665 !jm set up to match the ra_sw_physics=4 random number generator '
1666
1667 !jm moved isubcol loop out of here and put in the ilev.eq.1 conditional for initial
1668 !jm computation of seeds so we get the same results as the ra_sw_physics=4 option
1669            do isubcol = 1,nsubcol
1670            do ilev = 1,nlay
1671                do i = 1, ncol
1672                 if (ilev.eq.1.and.isubcol.eq.1)then
1673                   seed1(i) = (play(i,1)*100 - int(play(i,1)*100))  * 1000000000  !jm
1674                   seed2(i) = (play(i,2)*100 - int(play(i,2)*100))  * 1000000000  !jm
1675                   seed3(i) = (play(i,3)*100 - int(play(i,3)*100))  * 1000000000  !jm
1676                   seed4(i) = (play(i,4)*100 - int(play(i,4)*100))  * 1000000000
1677                      seed1(i) = 69069  * seed1(i) + 1327217885
1678                      seed2(i) = m (m (m (seed2(i), 13), - 17), 5)
1679                      seed3(i) = 18000  * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 )
1680                      seed4(i) = 30903  * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 )
1681                      kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i)
1682                  endif
1683
1684                  seed1(i) = 69069  * seed1(i) + 1327217885
1685                  seed2(i) = m (m (m (seed2(i), 13), - 17), 5)
1686                  seed3(i) = 18000  * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 )
1687                  seed4(i) = 30903  * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 )
1688                  kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i)
1689
1690                  CDF(i,ilev,isubcol) = kiss*2.328306e-10  + 0.5
1691                end do
1692             end do
1693             end do
1694
1695             do ilev = 2,nlay
1696                do i = 1, ncol
1697                   do isubcol = 1,nsubcol
1698                      if (CDF(i,ilev-1,isubcol) > 1.  - cld(i, ilev-1)) then
1699                         CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol)
1700                      else
1701                         CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1))
1702                      end if
1703                   end do
1704                end do
1705             end do
1706 #endif
1707       endif
1708
1709 ! Maximum cloud overlap
1710       if (icld==3) then
1711 !$acc kernels
1712
1713 #ifdef _ACCEL
1714             do i = 1, ncol
1715                seed1 = (play(i,1) - int(play(i,1)))  * 100000000 - ilev
1716                seed2 = (play(i,2) - int(play(i,2)))  * 100000000 + ilev
1717                seed3 = (play(i,3) - int(play(i,3)))  * 100000000 + ilev * 6.2
1718                seed4 = (play(i,4) - int(play(i,4)))  * 100000000
1719                do isubcol = 1,nsubcol
1720                   seed1 = 69069  * seed1 + 132721785
1721                   seed2 = 11002  * iand (seed2, 65535 ) + ishft (seed2, - 16 )
1722                   seed3 = 18000  * iand (seed3, 65535 ) + ishft (seed3, - 16 )
1723                   seed4 = 30903  * iand (seed4, 65535 ) + ishft (seed4, - 16 )
1724                   kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
1725                   do ilev = 1,nlay
1726                      CDF(i,ilev,isubcol) = kiss*2.328306e-10  + 0.5
1727                   end do
1728                end do
1729             end do
1730 #else
1731          CALL wrf_error_fatal("icld == 3 not supported in module_ra_rrtmg_swf.F")
1732 #endif
1733
1734 !$acc end kernels
1735       endif
1736
1737       ngbm = ngb(1) - 1
1738 !$acc kernels
1739       do ilev = 1,nlay
1740          do i = 1, ncol
1741             do isubcol = 1, nsubcol
1742
1743                if ( CDF(i,ilev,isubcol)>=(1.0 - cld(i,ilev)) ) then
1744                   cld_stoch(i,ilev,isubcol) = 1.0
1745                   clwp_stoch(i,ilev,isubcol) = clwp(i,ilev)
1746                   ciwp_stoch(i,ilev,isubcol) = ciwp(i,ilev)
1747                   cswp_stoch(i,ilev,isubcol) = cswp(i,ilev)
1748                   n = ngb(isubcol) - ngbm
1749                   tauc_stoch(i,ilev,isubcol) = tauc(i,ilev,n)
1750                   ssac_stoch(i,ilev,isubcol) = ssac(i,ilev,n)
1751                   asmc_stoch(i,ilev,isubcol) = asmc(i,ilev,n)
1752                   fsfc_stoch(i,ilev,isubcol) = fsfc(i,ilev,n)
1753                else
1754                   cld_stoch(i,ilev,isubcol) = 0.
1755                   clwp_stoch(i,ilev,isubcol) = 0.
1756                   ciwp_stoch(i,ilev,isubcol) = 0.
1757                   cswp_stoch(i,ilev,isubcol) = 0.
1758                   tauc_stoch(i,ilev,isubcol) = 0.
1759                   ssac_stoch(i,ilev,isubcol) = 1.
1760                   asmc_stoch(i,ilev,isubcol) = 0.
1761                   fsfc_stoch(i,ilev,isubcol) = 0.
1762                endif
1763             enddo
1764          enddo
1765       enddo
1766 !$acc end kernels
1767 #ifndef _ACCEL
1768 # undef ncol
1769 #endif
1770
1771       end subroutine mcica_sw
1772
1773       end module mcica_subcol_gen_sw_f
1774
1775       module rrtmg_sw_cldprmc_f
1776
1777 ! ------- Modules -------
1778
1779       use parrrsw_f, only : ngptsw, jpband, jpb1, jpb2
1780       use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
1781                            extice2, ssaice2, asyice2, &
1782                            extice3, ssaice3, asyice3, fdlice3, &
1783                            abari, bbari, cbari, dbari, ebari, fbari
1784       use rrsw_wvn_f, only : wavenum2, ngb, icxa
1785       use rrsw_vsn_f, only : hvrclc, hnamclc
1786
1787       implicit none
1788
1789       contains
1790
1791 ! ----------------------------------------------------------------------------
1792       subroutine cldprmc_sw(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, &
1793                             ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
1794                             taormc, taucmc, ssacmc, asmcmc, fsfcmc)
1795 ! ----------------------------------------------------------------------------
1796
1797 ! Purpose: Compute the cloud optical properties for each cloudy layer
1798 ! and g-point interval for use by the McICA method.
1799 ! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=1,2,3 are available;
1800 ! (Hu & Stamnes, Ebert and Curry, Key, and Fu) are implemented.
1801
1802 ! ------- Input -------
1803
1804       integer , intent(in) :: nlayers         ! total number of layers
1805       integer , intent(in) :: inflag          ! see definitions
1806       integer , intent(in) :: iceflag         ! see definitions
1807       integer , intent(in) :: liqflag         ! see definitions
1808       integer , intent(in) :: ncol
1809
1810       real , intent(in) :: cldfmc(:,:,:)          ! cloud fraction [mcica]
1811                                                       !    Dimensions: (ngptsw,nlayers)
1812       real , intent(in) :: ciwpmc(:,:,:)          ! cloud ice water path [mcica]
1813                                                       !    Dimensions: (ngptsw,nlayers)
1814       real , intent(in) :: clwpmc(:,:,:)          ! cloud liquid water path [mcica]
1815                                                       !    Dimensions: (ngptsw,nlayers)
1816       real , intent(in) :: cswpmc(:,:,:)          ! cloud snow water path [mcica]
1817                                                       !    Dimensions: (ngptsw,nlayers)
1818       real , intent(in) :: relqmc(:,:)           ! cloud liquid particle effective radius (microns)
1819                                                       !    Dimensions: (nlayers)
1820       real , intent(in) :: resnmc(:,:)           ! cloud snow particle effective radius (microns)
1821                                                       !    Dimensions: (nlayers)
1822       real , intent(in) :: reicmc(:,:)           ! cloud ice particle effective radius (microns)
1823                                                       !    Dimensions: (nlayers)
1824                                                       ! specific definition of reicmc depends on setting of iceflag:
1825                                                       ! iceflag = 0: (inactive)
1826                                                       !
1827                                                       ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
1828                                                       !              r_ec range is limited to 13.0 to 130.0 microns
1829                                                       ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
1830                                                       !              r_k range is limited to 5.0 to 131.0 microns
1831                                                       ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
1832                                                       !              dge range is limited to 5.0 to 140.0 microns
1833                                                       !              [dge = 1.0315 * r_ec]
1834       real , intent(in) :: fsfcmc(:,:,:)          ! cloud forward scattering fraction
1835                                                       !    Dimensions: (ngptsw,nlayers)
1836
1837 ! ------- Output -------
1838
1839       real , intent(inout) :: taucmc(:,:,:)       ! cloud optical depth (delta scaled)
1840                                                       !    Dimensions: (ncol,nlayers,ngptsw)
1841       real , intent(inout) :: ssacmc(:,:,:)       ! single scattering albedo (delta scaled)
1842                                                       !    Dimensions: (ncol,nlayers,ngptsw)
1843       real , intent(inout) :: asmcmc(:,:,:)       ! asymmetry parameter (delta scaled)
1844                                                       !    Dimensions: (ncol,nlayers,ngptsw)
1845       real , intent(out) :: taormc(:,:,:)         ! cloud optical depth (non-delta scaled)
1846                                                       !    Dimensions: (ncol,nlayers,ngptsw)
1847
1848 ! ------- Local -------
1849
1850 !      integer  :: ncbands
1851       integer  :: ib, lay, istr, index, icx, ig, iplon
1852
1853       real , parameter :: eps = 1.e-06      ! epsilon
1854       real , parameter :: cldmin = 1.e-20   ! minimum value for cloud quantities
1855       real  :: cwp                            ! total cloud water path
1856       real  :: radliq                         ! cloud liquid droplet radius (microns)
1857       real  :: radice                         ! cloud ice effective size (microns)
1858       real  :: radsno                         ! cloud snow effective size (microns)
1859       real  :: factor
1860       real  :: fint
1861
1862       real  :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
1863       real  :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
1864       real  :: tausnoorig, scatsno, ssasno, tausno
1865
1866       real  :: fdelta
1867       real  :: extcoice, gice
1868       real  :: ssacoice, forwice
1869       real  :: extcoliq, gliq
1870       real  :: ssacoliq, forwliq
1871       real  :: extcosno, gsno
1872       real  :: ssacosno, forwsno
1873
1874 ! Initialize
1875
1876
1877 !$acc kernels
1878
1879       taormc   = taucmc
1880
1881 !$acc end kernels
1882
1883 #ifndef _ACCEL
1884 #  define ncol CHNK
1885 #endif
1886
1887 ! Main layer loop
1888
1889 !$acc kernels loop present(cldfmc, ciwpmc, clwpmc, cswpmc, relqmc, reicmc, resnmc, fsfcmc,taucmc, ssacmc, asmcmc, taormc)
1890     do iplon = 1, ncol
1891       !$acc loop
1892       do lay = 1, nlayers
1893
1894          !$acc loop private(fdelta,extcoice,gice,ssacoice,forwice,extcoliq,gliq,ssacoliq,forwliq,gsno,forwsno,scatsno)
1895          do ig = 1, ngptsw
1896             cwp = ciwpmc(iplon,lay,ig) + clwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig)
1897
1898             if (cldfmc(iplon,lay,ig)   .ge. cldmin .and. &
1899                (cwp .ge. cldmin .or. taucmc(iplon,lay,ig)   .ge. cldmin)) then
1900
1901 ! (inflag=0): Cloud optical properties input directly
1902                if (inflag .eq. 0) then
1903 ! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled;
1904 ! Apply delta-M scaling here (using Henyey-Greenstein approximation)
1905                   taucldorig_a = taucmc(iplon,lay,ig)
1906                   ffp = fsfcmc(iplon,lay,ig)
1907                   ffp1 = 1.0  - ffp
1908                   ffpssa = 1.0  - ffp * ssacmc(iplon,lay,ig)
1909                   ssacloud_a = ffp1 * ssacmc(iplon,lay,ig)   / ffpssa
1910                   taucloud_a = ffpssa * taucldorig_a
1911
1912                   taormc(iplon,lay,ig)   = taucldorig_a
1913                   ssacmc(iplon,lay,ig)   = ssacloud_a
1914                   taucmc(iplon,lay,ig)   = taucloud_a
1915                   asmcmc(iplon,lay,ig)   = (asmcmc(iplon,lay,ig)   - ffp) / (ffp1)
1916
1917 ! (inflag=2): Separate treatement of ice clouds and water clouds.
1918                elseif (inflag .ge. 2) then
1919                   radice = reicmc(iplon,lay)
1920
1921 ! Calculation of absorption coefficients due to ice clouds.
1922                   if (ciwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig) .eq. 0.0 ) then
1923                      extcoice = 0.0
1924                      ssacoice = 0.0
1925                      gice     = 0.0
1926                      forwice  = 0.0
1927
1928                      extcosno = 0.0
1929                      ssacosno = 0.0
1930                      gsno     = 0.0
1931                      forwsno  = 0.0
1932
1933 ! (iceflag = 1):
1934 ! Note: This option uses Ebert and Curry approach for all particle sizes similar to
1935 ! CAM3 implementation, though this is somewhat unjustified for large ice particles
1936                   elseif (iceflag .eq. 1) then
1937
1938                      ib = ngb(ig )
1939                      ib = icxa(ib)
1940
1941                      extcoice = (abari(ib) + bbari(ib)/radice)
1942                      ssacoice = 1.  - cbari(ib) - dbari(ib) * radice
1943                      gice = ebari(ib) + fbari(ib) * radice
1944 ! Check to ensure upper limit of gice is within physical limits for large particles
1945                      if (gice.ge.1. ) gice = 1.  - eps
1946                      forwice = gice*gice
1947 ! Check to ensure all calculated quantities are within physical limits.
1948 ! mji - added checks below
1949                      if (extcoice .lt. 0.0) extcoice = 0.0
1950                      if (ssacoice .gt. 1.0) ssacoice = 1.0
1951                      if (ssacoice .lt. 0.0) ssacoice = 0.0
1952                      if (gice .gt. 1.0) gice = 1.0
1953                      if (gice .lt. 0.0) gice = 0.0
1954
1955
1956 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
1957
1958                   elseif (iceflag .eq. 2) then
1959
1960                      factor = (radice - 2. )/3.
1961                      index = int(factor)
1962 ! mji - temporary fix to prevent out of range subscripts
1963                      if (index .le. 0) index = 1
1964                      if (index .ge. 43) index = 42
1965 !                     if (index .eq. 43) index = 42
1966                      fint = factor - float(index)
1967                      ib = ngb(ig)
1968                      extcoice = extice2(index,ib) + fint * &
1969                                    (extice2(index+1,ib) -  extice2(index,ib))
1970                      ssacoice = ssaice2(index,ib) + fint * &
1971                                    (ssaice2(index+1,ib) -  ssaice2(index,ib))
1972                      gice = asyice2(index,ib) + fint * &
1973                                    (asyice2(index+1,ib) -  asyice2(index,ib))
1974                      forwice = gice*gice
1975 ! Check to ensure all calculated quantities are within physical limits.
1976 ! mji - added checks below
1977                      if (extcoice .lt. 0.0) extcoice = 0.0
1978                      if (ssacoice .gt. 1.0) ssacoice = 1.0
1979                      if (ssacoice .lt. 0.0) ssacoice = 0.0
1980                      if (gice .gt. 1.0) gice = 1.0
1981                      if (gice .lt. 0.0) gice = 0.0
1982
1983
1984 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
1985
1986                   elseif (iceflag .ge. 3) then
1987
1988                      factor = (radice - 2. )/3.
1989                      index = int(factor)
1990 ! mji - temporary fix to prevent out of range subscripts
1991                      if (index .le. 0) index = 1
1992                      if (index .ge. 46) index = 45
1993 !                     if (index .eq. 46) index = 45
1994                      fint = factor - float(index)
1995                      ib = ngb(ig)
1996                      extcoice = extice3(index,ib) + fint * &
1997                                    (extice3(index+1,ib) - extice3(index,ib))
1998                      ssacoice = ssaice3(index,ib) + fint * &
1999                                    (ssaice3(index+1,ib) - ssaice3(index,ib))
2000                      gice = asyice3(index,ib) + fint * &
2001                                (asyice3(index+1,ib) - asyice3(index,ib))
2002                      fdelta = fdlice3(index,ib) + fint * &
2003                                  (fdlice3(index+1,ib) - fdlice3(index,ib))
2004
2005                      forwice = fdelta + 0.5  / ssacoice
2006 ! See Fu 1996 p. 2067
2007                      if (forwice .gt. gice) forwice = gice
2008 ! Check to ensure all calculated quantities are within physical limits.
2009 ! mji - added checks below
2010                      if (extcoice .lt. 0.0) extcoice = 0.0
2011                      if (ssacoice .gt. 1.0) ssacoice = 1.0
2012                      if (ssacoice .lt. 0.0) ssacoice = 0.0
2013                      if (gice .gt. 1.0) gice = 1.0
2014                      if (gice .lt. 0.0) gice = 0.0
2015
2016                   endif
2017
2018 !!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2019 !!!!  INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
2020 !!!! Although far from perfect, the snow will utilize the
2021 !!!! same lookup table constants as cloud ice.  Changes
2022 !!!! to those constants for larger particle snow would be
2023 !!!! an improvement.
2024 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2025
2026                   if (cswpmc(iplon,lay,ig).gt.0.0 .and. iceflag .eq. 5) then
2027                      radsno = resnmc(iplon,lay)
2028                      factor = (radsno - 2.)/3.
2029                      index = int(factor)
2030 ! mji - temporary fix to prevent out of range subscripts
2031                      if (index .le. 0) index = 1
2032                      if (index .ge. 46) index = 45
2033 !                     if (index .eq. 46) index = 45
2034                      fint = factor - float(index)
2035                      ib = ngb(ig)
2036                      extcosno = extice3(index,ib) + fint * &
2037                                    (extice3(index+1,ib) - extice3(index,ib))
2038                      ssacosno = ssaice3(index,ib) + fint * &
2039                                    (ssaice3(index+1,ib) - ssaice3(index,ib))
2040                      gsno = asyice3(index,ib) + fint * &
2041                                (asyice3(index+1,ib) - asyice3(index,ib))
2042                      fdelta = fdlice3(index,ib) + fint * &
2043                                  (fdlice3(index+1,ib) - fdlice3(index,ib))
2044                      forwsno = fdelta + 0.5 / ssacosno
2045 ! See Fu 1996 p. 2067
2046                      if (forwsno .gt. gsno) forwsno = gsno
2047 ! Check to ensure all calculated quantities are within physical limits.
2048 ! mji - added checks below
2049                      if (extcosno .lt. 0.0) extcosno = 0.0
2050                      if (ssacosno .gt. 1.0) ssacosno = 1.0
2051                      if (ssacosno .lt. 0.0) ssacosno = 0.0
2052                      if (gsno .gt. 1.0) gsno = 1.0
2053                      if (gsno .lt. 0.0) gsno = 0.0
2054 !
2055                   else
2056                      extcosno = 0.0
2057                      ssacosno = 0.0
2058                      gsno     = 0.0
2059                      forwsno  = 0.0
2060                   endif
2061
2062 ! Calculation of absorption coefficients due to water clouds.
2063                   if (clwpmc(iplon,lay,ig)   .eq. 0.0 ) then
2064                      extcoliq = 0.0
2065                      ssacoliq = 0.0
2066                      gliq = 0.0
2067                      forwliq = 0.0
2068
2069                   elseif (liqflag .eq. 1) then
2070                      radliq = relqmc(iplon,lay)
2071
2072                      index = int(radliq - 1.5 )
2073 ! mji - temporary fix to prevent out of range subscripts
2074                      if (index .le. 0) index = 1
2075                      if (index .ge. 58) index = 57
2076 !                     if (index .eq. 0) index = 1
2077 !                     if (index .eq. 58) index = 57
2078                      fint = radliq - 1.5  - float(index)
2079                      ib = ngb(ig)
2080                      extcoliq = extliq1(index,ib) + fint * &
2081                                    (extliq1(index+1,ib) - extliq1(index,ib))
2082                      ssacoliq = ssaliq1(index,ib) + fint * &
2083                                    (ssaliq1(index+1,ib) - ssaliq1(index,ib))
2084                      if (fint .lt. 0.  .and. ssacoliq .gt. 1. ) &
2085                                     ssacoliq = ssaliq1(index,ib)
2086                      gliq = asyliq1(index,ib) + fint * &
2087                                (asyliq1(index+1,ib) - asyliq1(index,ib))
2088                      forwliq = gliq*gliq
2089 ! Check to ensure all calculated quantities are within physical limits.
2090 ! mji - added checks below
2091                      if (extcoliq .lt. 0.0) extcoliq = 0.0
2092                      if (ssacoliq .gt. 1.0) ssacoliq = 1.0
2093                      if (ssacoliq .lt. 0.0) ssacoliq = 0.0
2094                      if (gliq .gt. 1.0) gliq = 1.0
2095                      if (gliq .lt. 0.0) gliq = 0.0
2096 !
2097                   endif
2098
2099                   if (iceflag .lt. 5) then
2100                      tauliqorig = clwpmc(iplon,lay,ig)   * extcoliq
2101                      tauiceorig = ciwpmc(iplon,lay,ig)   * extcoice
2102                      taormc(iplon,lay,ig)   = tauliqorig + tauiceorig
2103
2104                      ssaliq = ssacoliq * (1.  - forwliq) / &
2105                              (1.  - forwliq * ssacoliq)
2106                      tauliq = (1.  - forwliq * ssacoliq) * tauliqorig
2107                      ssaice = ssacoice * (1.  - forwice) / &
2108                              (1.  - forwice * ssacoice)
2109                      tauice = (1.  - forwice * ssacoice) * tauiceorig
2110
2111                      scatliq = ssaliq * tauliq
2112                      scatice = ssaice * tauice
2113                      taucmc(iplon,lay,ig)   = tauliq + tauice
2114                   else
2115                      tauliqorig = clwpmc(iplon,lay,ig)   * extcoliq
2116                      tauiceorig = ciwpmc(iplon,lay,ig)   * extcoice
2117                      tausnoorig = cswpmc(iplon,lay,ig)   * extcosno
2118                      taormc(iplon,lay,ig)   = tauliqorig + tauiceorig + tausnoorig
2119
2120                      ssaliq = ssacoliq * (1.  - forwliq) / &
2121                              (1.  - forwliq * ssacoliq)
2122                      tauliq = (1.  - forwliq * ssacoliq) * tauliqorig
2123                      ssaice = ssacoice * (1.  - forwice) / &
2124                              (1.  - forwice * ssacoice)
2125                      tauice = (1.  - forwice * ssacoice) * tauiceorig
2126                      ssasno = ssacosno * (1.  - forwsno) / &
2127                              (1.  - forwsno * ssacosno)
2128                      tausno = (1.  - forwsno * ssacosno) * tausnoorig
2129
2130                      scatliq = ssaliq * tauliq
2131                      scatice = ssaice * tauice
2132                      scatsno = ssasno * tausno
2133                      taucmc(iplon,lay,ig)   = tauliq + tauice + tausno
2134                   endif
2135
2136 ! Ensure non-zero taucmc and scatice
2137                   if(taucmc(iplon,lay,ig)  .eq.0.) taucmc(iplon,lay,ig)   = cldmin
2138                   if(scatice.eq.0.) scatice = cldmin
2139                   if(scatsno.eq.0.) scatsno = cldmin
2140
2141                   if (iceflag .lt. 5) then
2142                      ssacmc(iplon,lay,ig)   = (scatliq + scatice) / taucmc(iplon,lay,ig)
2143                   else
2144                      ssacmc(iplon,lay,ig)   = (scatliq + scatice + scatsno) / taucmc(iplon,lay,ig)
2145                   endif
2146
2147                   if (iceflag .eq. 3 .or. iceflag.eq.4) then
2148 ! In accordance with the 1996 Fu paper, equation A.3,
2149 ! the moments for ice were calculated depending on whether using spheres
2150 ! or hexagonal ice crystals.
2151 ! Set asymetry parameter to first moment (istr=1)
2152                      istr = 1
2153                      asmcmc(iplon,lay,ig)   = (1.0 /(scatliq+scatice))* &
2154                         (scatliq*(gliq**istr - forwliq) / &
2155                         (1.0  - forwliq) + scatice * ((gice-forwice)/ &
2156                         (1.0  - forwice))**istr)
2157
2158                   elseif (iceflag .eq. 5) then
2159                      istr = 1
2160                      asmcmc(iplon,lay,ig) = (1.0 /(scatliq+scatice+scatsno)) * &
2161                                     (scatliq*(gliq**istr - forwliq)/(1.0 - forwliq)  &
2162                                     + scatice * ((gice-forwice)/(1.0 - forwice))        &
2163                                     + scatsno * ((gsno-forwsno)/(1.0 - forwsno))**istr)
2164
2165                   else
2166 ! This code is the standard method for delta-m scaling.
2167 ! Set asymetry parameter to first moment (istr=1)
2168                      istr = 1
2169                      asmcmc(iplon,lay,ig)   = (scatliq *  &
2170                         (gliq**istr - forwliq) / &
2171                         (1.0  - forwliq) + scatice * (gice**istr - forwice) / &
2172                         (1.0  - forwice))/(scatliq + scatice)
2173                   endif
2174
2175                endif
2176
2177             endif
2178
2179 ! End g-point interval loop
2180          enddo
2181
2182 ! End layer loop
2183       enddo
2184 ! End column loop
2185       enddo
2186 !$acc end kernels
2187 #ifndef _ACCEL
2188 #  undef ncol
2189 #endif
2190
2191       end subroutine cldprmc_sw
2192
2193       end module rrtmg_sw_cldprmc_f
2194
2195       module rrtmg_sw_setcoef_f
2196
2197 ! ------- Modules -------
2198
2199       use parrrsw_f, only : mxmol
2200       use rrsw_ref_f, only : pref, preflog, tref
2201       use rrsw_vsn_f, only : hvrset, hnamset
2202
2203       implicit none
2204
2205       contains
2206
2207 !----------------------------------------------------------------------------
2208       subroutine setcoef_sw(ncol, nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
2209                             laytrop, layswtch, laylow, jp, jt, jt1, &
2210                             co2mult, colch4, colco2, colh2o, colmol, coln2o, &
2211                             colo2, colo3, fac00, fac01, fac10, fac11, &
2212                             selffac, selffrac, indself, forfac, forfrac, indfor)
2213 !----------------------------------------------------------------------------
2214 !
2215 ! Purpose:  For a given atmosphere, calculate the indices and
2216 ! fractions related to the pressure and temperature interpolations.
2217
2218 ! Modifications:
2219 ! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01)
2220 ! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224
2221 ! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006
2222
2223 ! ------ Declarations -------
2224
2225 ! ----- Input -----
2226       integer, intent(in) :: ncol
2227
2228       integer , intent(in) :: nlayers         ! total number of layers
2229
2230       real , intent(in) :: pavel(:,:)            ! layer pressures (mb)
2231                                                       !    Dimensions: (nlayers)
2232       real , intent(in) :: tavel(:,:)            ! layer temperatures (K)
2233                                                       !    Dimensions: (nlayers)
2234       real , intent(in) :: pz(:,0:)              ! level (interface) pressures (hPa, mb)
2235                                                       !    Dimensions: (0:nlayers)
2236       real , intent(in) :: tz(:,0:)              ! level (interface) temperatures (K)
2237                                                       !    Dimensions: (0:nlayers)
2238       real , intent(in) :: tbound(:)             ! surface temperature (K)
2239       real , intent(in) :: coldry(:,:)           ! dry air column density (mol/cm2)
2240                                                       !    Dimensions: (nlayers)
2241       real , intent(in) :: wkl(:,:,:)            ! molecular amounts (mol/cm-2)
2242                                                       !    Dimensions: (mxmol,nlayers)
2243
2244 ! ----- Output -----
2245       integer , intent(out) :: laytrop(:)        ! tropopause layer index
2246       integer , intent(out) :: layswtch(:)       !
2247       integer , intent(out) :: laylow(:)         !
2248
2249       integer , intent(out) :: jp(:,:)           !
2250                                                       !    Dimensions: (nlayers)
2251       integer , intent(out) :: jt(:,:)           !
2252                                                       !    Dimensions: (nlayers)
2253       integer , intent(out) :: jt1(:,:)          !
2254                                                       !    Dimensions: (nlayers)
2255
2256       real , intent(out) :: colh2o(:,:)          ! column amount (h2o)
2257                                                       !    Dimensions: (nlayers)
2258       real , intent(out) :: colco2(:,:)          ! column amount (co2)
2259                                                       !    Dimensions: (nlayers)
2260       real , intent(out) :: colo3(:,:)           ! column amount (o3)
2261                                                       !    Dimensions: (nlayers)
2262       real , intent(out) :: coln2o(:,:)          ! column amount (n2o)
2263                                                       !    Dimensions: (nlayers)
2264       real , intent(out) :: colch4(:,:)          ! column amount (ch4)
2265                                                       !    Dimensions: (nlayers)
2266       real , intent(out) :: colo2(:,:)           ! column amount (o2)
2267                                                       !    Dimensions: (nlayers)
2268       real , intent(out) :: colmol(:,:)          !
2269                                                       !    Dimensions: (nlayers)
2270       real , intent(out) :: co2mult(:,:)         !
2271                                                       !    Dimensions: (nlayers)
2272
2273       integer , intent(out) :: indself(:,:)
2274                                                       !    Dimensions: (nlayers)
2275       integer , intent(out) :: indfor(:,:)
2276                                                       !    Dimensions: (nlayers)
2277       real , intent(out) :: selffac(:,:)
2278                                                       !    Dimensions: (nlayers)
2279       real , intent(out) :: selffrac(:,:)
2280                                                       !    Dimensions: (nlayers)
2281       real , intent(out) :: forfac(:,:)
2282                                                       !    Dimensions: (nlayers)
2283       real , intent(out) :: forfrac(:,:)
2284                                                       !    Dimensions: (nlayers)
2285
2286       real , intent(out) :: fac00(:,:) , fac01(:,:) , fac10(:,:) , fac11(:,:)
2287
2288 ! ----- Local -----
2289
2290       integer  :: indbound
2291       integer  :: indlev0
2292       integer  :: lay
2293       integer  :: jp1
2294       integer  :: iplon
2295
2296       real  :: stpfac
2297       real  :: tbndfrac
2298       real  :: t0frac
2299       real  :: plog
2300       real  :: fp
2301       real  :: ft
2302       real  :: ft1
2303       real  :: water
2304       real  :: scalefac
2305       real  :: factor
2306       real  :: co2reg
2307       real  :: compfp
2308
2309 #ifndef _ACCEL
2310 #  define ncol CHNK
2311 #endif
2312
2313
2314 ! Initializations
2315       stpfac = 296. /1013.
2316
2317
2318 !$acc kernels present(pavel, layswtch, laytrop, laylow)
2319       layswtch = 0
2320       laytrop = 0
2321       laylow = 0
2322       do iplon = 1, ncol
2323          do lay = 1, nlayers
2324             plog = log(pavel(iplon,lay) )
2325             if (plog .ge. 4.56) laytrop(iplon) = laytrop(iplon) + 1
2326             if (plog .ge. 6.62) laylow(iplon) = laylow(iplon) + 1
2327          end do
2328       end do
2329 !$acc end kernels
2330
2331
2332 !$acc kernels loop present(pavel, tavel, pz, tz, tbound) &
2333 !$acc present(coldry, wkl, jp, jt, jt1, colh2o, colco2) &
2334 !$acc present(colo3, coln2o, colch4, colo2, colmol, co2mult, indself) &
2335 !$acc present(indfor, selffac, selffrac, forfac, forfrac, fac00, fac01, fac10, fac11)
2336
2337 ! Begin column loop
2338       do iplon = 1, ncol
2339
2340       indbound = tbound(iplon) - 159.
2341       tbndfrac = tbound(iplon) - int(tbound(iplon))
2342
2343       indlev0  = tz(iplon,0)  - 159.
2344       t0frac   = tz(iplon,0)  - int(tz(iplon,0) )
2345
2346 ! Begin layer loop
2347
2348        do lay = 1, nlayers
2349 ! Find the two reference pressures on either side of the
2350 ! layer pressure.  Store them in JP and JP1.  Store in FP the
2351 ! fraction of the difference (in ln(pressure)) between these
2352 ! two values that the layer pressure lies.
2353
2354          plog = log(pavel(iplon,lay) )
2355          jp(iplon,lay)  = int(36.  - 5*(plog+0.04 ))
2356          if (jp(iplon,lay)  .lt. 1) then
2357             jp(iplon,lay)  = 1
2358          elseif (jp(iplon,lay)  .gt. 58) then
2359             jp(iplon,lay)  = 58
2360          endif
2361          jp1 = jp(iplon,lay)  + 1
2362          fp = 5.  * (preflog(jp(iplon,lay) ) - plog)
2363
2364 ! Determine, for each reference pressure (JP and JP1), which
2365 ! reference temperature (these are different for each
2366 ! reference pressure) is nearest the layer temperature but does
2367 ! not exceed it.  Store these indices in JT and JT1, resp.
2368 ! Store in FT (resp. FT1) the fraction of the way between JT
2369 ! (JT1) and the next highest reference temperature that the
2370 ! layer temperature falls.
2371
2372          jt(iplon,lay)  = int(3.  + (tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. )
2373          if (jt(iplon,lay)  .lt. 1) then
2374             jt(iplon,lay)  = 1
2375          elseif (jt(iplon,lay)  .gt. 4) then
2376             jt(iplon,lay)  = 4
2377          endif
2378          ft = ((tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. ) - float(jt(iplon,lay) -3)
2379          jt1(iplon,lay)  = int(3.  + (tavel(iplon,lay) -tref(jp1))/15. )
2380          if (jt1(iplon,lay)  .lt. 1) then
2381             jt1(iplon,lay)  = 1
2382          elseif (jt1(iplon,lay)  .gt. 4) then
2383             jt1(iplon,lay)  = 4
2384          endif
2385          ft1 = ((tavel(iplon,lay) -tref(jp1))/15. ) - float(jt1(iplon,lay) -3)
2386
2387          water = wkl(iplon,1,lay) /coldry(iplon,lay)
2388          scalefac = pavel(iplon,lay)  * stpfac / tavel(iplon,lay)
2389
2390 ! If the pressure is less than ~100mb, perform a different
2391 ! set of species interpolations.
2392
2393          if (plog .le. 4.56 ) then
2394
2395          forfac(iplon,lay)  = scalefac / (1.+water)
2396          factor = (tavel(iplon,lay) -188.0 )/36.0
2397          indfor(iplon,lay)  = 3
2398          forfrac(iplon,lay)  = factor - 1.0
2399
2400 ! Calculate needed column amounts.
2401
2402          colh2o(iplon,lay)  = 1.e-20  * wkl(iplon,1,lay)
2403          colco2(iplon,lay)  = 1.e-20  * wkl(iplon,2,lay)
2404          colo3(iplon,lay)   = 1.e-20  * wkl(iplon,3,lay)
2405          coln2o(iplon,lay)  = 1.e-20  * wkl(iplon,4,lay)
2406          colch4(iplon,lay)  = 1.e-20  * wkl(iplon,6,lay)
2407          colo2(iplon,lay)   = 1.e-20  * wkl(iplon,7,lay)
2408          colmol(iplon,lay)  = 1.e-20  * coldry(iplon,lay)  + colh2o(iplon,lay)
2409          if (colco2(iplon,lay)  .eq. 0. ) colco2(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2410          if (coln2o(iplon,lay)  .eq. 0. ) coln2o(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2411          if (colch4(iplon,lay)  .eq. 0. ) colch4(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2412          if (colo2(iplon,lay)   .eq. 0. ) colo2(iplon,lay)   = 1.e-32  * coldry(iplon,lay)
2413          co2reg = 3.55e-24  * coldry(iplon,lay)
2414          co2mult(iplon,lay) = (colco2(iplon,lay)  - co2reg) * &
2415                272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) )
2416
2417          selffac(iplon,lay)  = 0.
2418          selffrac(iplon,lay) = 0.
2419          indself(iplon,lay)  = 0
2420
2421
2422          else
2423
2424
2425 ! Set up factors needed to separately include the water vapor
2426 ! foreign-continuum in the calculation of absorption coefficient.
2427
2428          forfac(iplon,lay)  = scalefac / (1.+water)
2429          factor = (332.0 -tavel(iplon,lay) )/36.0
2430          indfor(iplon,lay)  = min(2, max(1, int(factor)))
2431          forfrac(iplon,lay)  = factor - float(indfor(iplon,lay) )
2432
2433 ! Set up factors needed to separately include the water vapor
2434 ! self-continuum in the calculation of absorption coefficient.
2435
2436          selffac(iplon,lay)  = water * forfac(iplon,lay)
2437          factor = (tavel(iplon,lay) -188.0 )/7.2
2438          indself(iplon,lay)  = min(9, max(1, int(factor)-7))
2439          selffrac(iplon,lay)  = factor - float(indself(iplon,lay)  + 7)
2440
2441 ! Calculate needed column amounts.
2442
2443          colh2o(iplon,lay)  = 1.e-20  * wkl(iplon,1,lay)
2444          colco2(iplon,lay)  = 1.e-20  * wkl(iplon,2,lay)
2445          colo3(iplon,lay)  = 1.e-20  * wkl(iplon,3,lay)
2446 !           colo3(lay) = 0.
2447 !           colo3(lay) = colo3(lay)/1.16
2448          coln2o(iplon,lay)  = 1.e-20  * wkl(iplon,4,lay)
2449          colch4(iplon,lay)  = 1.e-20  * wkl(iplon,6,lay)
2450          colo2(iplon,lay)  = 1.e-20  * wkl(iplon,7,lay)
2451          colmol(iplon,lay)  = 1.e-20  * coldry(iplon,lay)  + colh2o(iplon,lay)
2452 !           colco2(lay) = 0.
2453 !           colo3(lay) = 0.
2454 !           coln2o(lay) = 0.
2455 !           colch4(lay) = 0.
2456 !           colo2(lay) = 0.
2457 !           colmol(lay) = 0.
2458          if (colco2(iplon,lay)  .eq. 0. ) colco2(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2459          if (coln2o(iplon,lay)  .eq. 0. ) coln2o(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2460          if (colch4(iplon,lay)  .eq. 0. ) colch4(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2461          if (colo2(iplon,lay)  .eq. 0. ) colo2(iplon,lay)  = 1.e-32  * coldry(iplon,lay)
2462 ! Using E = 1334.2 cm-1.
2463          co2reg = 3.55e-24  * coldry(iplon,lay)
2464          co2mult(iplon,lay) = (colco2(iplon,lay)  - co2reg) * &
2465                272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) )
2466
2467          end if
2468 ! We have now isolated the layer ln pressure and temperature,
2469 ! between two reference pressures and two reference temperatures
2470 ! (for each reference pressure).  We multiply the pressure
2471 ! fraction FP with the appropriate temperature fractions to get
2472 ! the factors that will be needed for the interpolation that yields
2473 ! the optical depths (performed in routines TAUGBn for band n).
2474
2475          compfp = 1.  - fp
2476          fac10(iplon,lay)  = compfp * ft
2477          fac00(iplon,lay)  = compfp * (1.  - ft)
2478          fac11(iplon,lay)  = fp * ft1
2479          fac01(iplon,lay)  = fp * (1.  - ft1)
2480
2481 ! End layer loop
2482        end do
2483
2484 ! End column loop
2485       end do
2486 !$acc end kernels
2487 #ifndef _ACCEL
2488 #  undef ncol
2489 #endif
2490
2491 end subroutine setcoef_sw
2492
2493 !***************************************************************************
2494       subroutine swatmref
2495 !***************************************************************************
2496
2497       save
2498
2499 ! These pressures are chosen such that the ln of the first pressure
2500 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
2501 ! each subsequent ln(pressure) differs from the previous one by 0.2.
2502
2503       pref(:) = (/ &
2504           1.05363e+03 ,8.62642e+02 ,7.06272e+02 ,5.78246e+02 ,4.73428e+02 , &
2505           3.87610e+02 ,3.17348e+02 ,2.59823e+02 ,2.12725e+02 ,1.74164e+02 , &
2506           1.42594e+02 ,1.16746e+02 ,9.55835e+01 ,7.82571e+01 ,6.40715e+01 , &
2507           5.24573e+01 ,4.29484e+01 ,3.51632e+01 ,2.87892e+01 ,2.35706e+01 , &
2508           1.92980e+01 ,1.57998e+01 ,1.29358e+01 ,1.05910e+01 ,8.67114e+00 , &
2509           7.09933e+00 ,5.81244e+00 ,4.75882e+00 ,3.89619e+00 ,3.18993e+00 , &
2510           2.61170e+00 ,2.13828e+00 ,1.75067e+00 ,1.43333e+00 ,1.17351e+00 , &
2511           9.60789e-01 ,7.86628e-01 ,6.44036e-01 ,5.27292e-01 ,4.31710e-01 , &
2512           3.53455e-01 ,2.89384e-01 ,2.36928e-01 ,1.93980e-01 ,1.58817e-01 , &
2513           1.30029e-01 ,1.06458e-01 ,8.71608e-02 ,7.13612e-02 ,5.84256e-02 , &
2514           4.78349e-02 ,3.91639e-02 ,3.20647e-02 ,2.62523e-02 ,2.14936e-02 , &
2515           1.75975e-02 ,1.44076e-02 ,1.17959e-02 ,9.65769e-03  /)
2516
2517       preflog(:) = (/ &
2518            6.9600e+00 , 6.7600e+00 , 6.5600e+00 , 6.3600e+00 , 6.1600e+00 , &
2519            5.9600e+00 , 5.7600e+00 , 5.5600e+00 , 5.3600e+00 , 5.1600e+00 , &
2520            4.9600e+00 , 4.7600e+00 , 4.5600e+00 , 4.3600e+00 , 4.1600e+00 , &
2521            3.9600e+00 , 3.7600e+00 , 3.5600e+00 , 3.3600e+00 , 3.1600e+00 , &
2522            2.9600e+00 , 2.7600e+00 , 2.5600e+00 , 2.3600e+00 , 2.1600e+00 , &
2523            1.9600e+00 , 1.7600e+00 , 1.5600e+00 , 1.3600e+00 , 1.1600e+00 , &
2524            9.6000e-01 , 7.6000e-01 , 5.6000e-01 , 3.6000e-01 , 1.6000e-01 , &
2525           -4.0000e-02 ,-2.4000e-01 ,-4.4000e-01 ,-6.4000e-01 ,-8.4000e-01 , &
2526           -1.0400e+00 ,-1.2400e+00 ,-1.4400e+00 ,-1.6400e+00 ,-1.8400e+00 , &
2527           -2.0400e+00 ,-2.2400e+00 ,-2.4400e+00 ,-2.6400e+00 ,-2.8400e+00 , &
2528           -3.0400e+00 ,-3.2400e+00 ,-3.4400e+00 ,-3.6400e+00 ,-3.8400e+00 , &
2529           -4.0400e+00 ,-4.2400e+00 ,-4.4400e+00 ,-4.6400e+00  /)
2530
2531 ! These are the temperatures associated with the respective
2532 ! pressures for the MLS standard atmosphere.
2533
2534       tref(:) = (/ &
2535            2.9420e+02 , 2.8799e+02 , 2.7894e+02 , 2.6925e+02 , 2.5983e+02 , &
2536            2.5017e+02 , 2.4077e+02 , 2.3179e+02 , 2.2306e+02 , 2.1578e+02 , &
2537            2.1570e+02 , 2.1570e+02 , 2.1570e+02 , 2.1706e+02 , 2.1858e+02 , &
2538            2.2018e+02 , 2.2174e+02 , 2.2328e+02 , 2.2479e+02 , 2.2655e+02 , &
2539            2.2834e+02 , 2.3113e+02 , 2.3401e+02 , 2.3703e+02 , 2.4022e+02 , &
2540            2.4371e+02 , 2.4726e+02 , 2.5085e+02 , 2.5457e+02 , 2.5832e+02 , &
2541            2.6216e+02 , 2.6606e+02 , 2.6999e+02 , 2.7340e+02 , 2.7536e+02 , &
2542            2.7568e+02 , 2.7372e+02 , 2.7163e+02 , 2.6955e+02 , 2.6593e+02 , &
2543            2.6211e+02 , 2.5828e+02 , 2.5360e+02 , 2.4854e+02 , 2.4348e+02 , &
2544            2.3809e+02 , 2.3206e+02 , 2.2603e+02 , 2.2000e+02 , 2.1435e+02 , &
2545            2.0887e+02 , 2.0340e+02 , 1.9792e+02 , 1.9290e+02 , 1.8809e+02 , &
2546            1.8329e+02 , 1.7849e+02 , 1.7394e+02 , 1.7212e+02  /)
2547
2548       end subroutine swatmref
2549
2550       end module rrtmg_sw_setcoef_f
2551
2552       module rrtmg_sw_taumol_f
2553
2554 ! ------- Modules -------
2555
2556       use rrsw_con_f, only: oneminus
2557       use rrsw_wvn_f, only: nspa, nspb
2558       use rrsw_vsn_f, only: hvrtau, hnamtau
2559
2560       implicit none
2561
2562       contains
2563
2564 !----------------------------------------------------------------------------
2565       subroutine taumol_sw(ncol, nlayers, &
2566                            colh2o, colco2, colch4, colo2, colo3, colmol, &
2567                            laytrop, jp, jt, jt1, &
2568                            fac00, fac01, fac10, fac11, &
2569                            selffac, selffrac, indself, forfac, forfrac, indfor, &
2570                            sfluxzen, taug, taur)
2571 !----------------------------------------------------------------------------
2572
2573       integer , intent(in) :: ncol
2574       integer , intent(in) :: nlayers               ! total number of layers
2575
2576       integer , intent(in) :: laytrop(:)            ! tropopause layer index
2577       integer , intent(in) :: jp(:,:)               !
2578       integer , intent(in) :: jt(:,:)               !
2579       integer , intent(in) :: jt1(:,:)              !
2580                                                     !   Dimensions: (ncol,nlayers)
2581
2582       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
2583       real , intent(in) :: colco2(:,:)              ! column amount (co2)
2584       real , intent(in) :: colo3(:,:)               ! column amount (o3)
2585       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
2586       real , intent(in) :: colo2(:,:)               ! column amount (o2)
2587       real , intent(in) :: colmol(:,:)              !
2588                                                     !   Dimensions: (ncol,nlayers)
2589
2590       integer , intent(in) :: indself(:,:)
2591       integer , intent(in) :: indfor(:,:)
2592       real , intent(in) :: selffac(:,:)
2593       real , intent(in) :: selffrac(:,:)
2594       real , intent(in) :: forfac(:,:)
2595       real , intent(in) :: forfrac(:,:)
2596                                                     !   Dimensions: (ncol,nlayers)
2597
2598       real , intent(in) :: &                        !
2599                        fac00(:,:) , fac01(:,:) , &
2600                        fac10(:,:) , fac11(:,:)
2601                                                     !   Dimensions: (ncol,nlayers)
2602
2603 ! ----- Output -----
2604       real , intent(inout) gpu_device :: sfluxzen(:,:)   ! solar source function
2605                                                          !   Dimensions: (ncol,ngptsw)
2606       real , intent(inout) gpu_device :: taug(:,:,:)     ! gaseous optical depth
2607                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2608       real , intent(inout) gpu_device :: taur(:,:,:)     ! Rayleigh
2609                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2610
2611 ! Calculate gaseous optical depth and planck fractions for each spectral band.
2612
2613       call taumol16(ncol, nlayers, &
2614                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2615                     laytrop, jp, jt, jt1, &
2616                     fac00, fac01, fac10, fac11, &
2617                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2618                     sfluxzen, taug, taur)
2619
2620       call taumol17(ncol, nlayers, &
2621                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2622                     laytrop, jp, jt, jt1, &
2623                     fac00, fac01, fac10, fac11, &
2624                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2625                     sfluxzen, taug, taur)
2626
2627       call taumol18(ncol, nlayers, &
2628                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2629                     laytrop, jp, jt, jt1, &
2630                     fac00, fac01, fac10, fac11, &
2631                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2632                     sfluxzen, taug, taur)
2633
2634       call taumol19(ncol, nlayers, &
2635                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2636                     laytrop, jp, jt, jt1, &
2637                     fac00, fac01, fac10, fac11, &
2638                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2639                     sfluxzen, taug, taur)
2640
2641       call taumol20(ncol, nlayers, &
2642                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2643                     laytrop, jp, jt, jt1, &
2644                     fac00, fac01, fac10, fac11, &
2645                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2646                     sfluxzen, taug, taur)
2647
2648       call taumol21(ncol, nlayers, &
2649                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2650                     laytrop, jp, jt, jt1, &
2651                     fac00, fac01, fac10, fac11, &
2652                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2653                     sfluxzen, taug, taur)
2654
2655       call taumol22(ncol, nlayers, &
2656                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2657                     laytrop, jp, jt, jt1, &
2658                     fac00, fac01, fac10, fac11, &
2659                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2660                     sfluxzen, taug, taur)
2661
2662       call taumol23(ncol, nlayers, &
2663                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2664                     laytrop, jp, jt, jt1, &
2665                     fac00, fac01, fac10, fac11, &
2666                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2667                     sfluxzen, taug, taur)
2668
2669       call taumol24(ncol, nlayers, &
2670                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2671                     laytrop, jp, jt, jt1, &
2672                     fac00, fac01, fac10, fac11, &
2673                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2674                     sfluxzen, taug, taur)
2675
2676       call taumol25(ncol, nlayers, &
2677                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2678                     laytrop, jp, jt, jt1, &
2679                     fac00, fac01, fac10, fac11, &
2680                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2681                     sfluxzen, taug, taur)
2682
2683       call taumol26(ncol, nlayers, &
2684                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2685                     laytrop, jp, jt, jt1, &
2686                     fac00, fac01, fac10, fac11, &
2687                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2688                     sfluxzen, taug, taur)
2689
2690       call taumol27(ncol, nlayers, &
2691                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2692                     laytrop, jp, jt, jt1, &
2693                     fac00, fac01, fac10, fac11, &
2694                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2695                     sfluxzen, taug, taur)
2696
2697       call taumol28(ncol, nlayers, &
2698                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2699                     laytrop, jp, jt, jt1, &
2700                     fac00, fac01, fac10, fac11, &
2701                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2702                     sfluxzen, taug, taur)
2703
2704       call taumol29(ncol, nlayers, &
2705                     colh2o, colco2, colch4, colo2, colo3, colmol, &
2706                     laytrop, jp, jt, jt1, &
2707                     fac00, fac01, fac10, fac11, &
2708                     selffac, selffrac, indself, forfac, forfrac, indfor, &
2709                     sfluxzen, taug, taur)
2710
2711       end subroutine
2712
2713
2714 !----------------------------------------------------------------------------
2715       subroutine taumol16(ncol, nlayers, &
2716                           colh2o, colco2, colch4, colo2, colo3, colmol, &
2717                           laytrop, jp, jt, jt1, &
2718                           fac00, fac01, fac10, fac11, &
2719                           selffac, selffrac, indself, forfac, forfrac, indfor, &
2720                           sfluxzen, taug, taur)
2721 !----------------------------------------------------------------------------
2722 !
2723 !     band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
2724 !
2725 !----------------------------------------------------------------------------
2726
2727 ! ------- Modules -------
2728
2729       use parrrsw_f, only : ng16
2730       use rrsw_kg16_f, only : absa, ka, absb, kb, forref, selfref, &
2731                             sfluxref, rayl, layreffr, strrat1
2732 !                            sfluxref, rayl
2733
2734 ! ------- Declarations -------
2735       integer , intent(in) :: ncol
2736       integer , intent(in) :: nlayers               ! total number of layers
2737
2738       integer , intent(in) :: laytrop(:)            ! tropopause layer index
2739       integer , intent(in) :: jp(:,:)               !
2740       integer , intent(in) :: jt(:,:)               !
2741       integer , intent(in) :: jt1(:,:)              !
2742                                                     !   Dimensions: (ncol,nlayers)
2743
2744       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
2745       real , intent(in) :: colco2(:,:)              ! column amount (co2)
2746       real , intent(in) :: colo3(:,:)               ! column amount (o3)
2747       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
2748       real , intent(in) :: colo2(:,:)               ! column amount (o2)
2749       real , intent(in) :: colmol(:,:)              !
2750                                                     !   Dimensions: (ncol,nlayers)
2751
2752       integer , intent(in) :: indself(:,:)
2753       integer , intent(in) :: indfor(:,:)
2754       real , intent(in) :: selffac(:,:)
2755       real , intent(in) :: selffrac(:,:)
2756       real , intent(in) :: forfac(:,:)
2757       real , intent(in) :: forfrac(:,:)
2758                                                     !   Dimensions: (ncol,nlayers)
2759
2760       real , intent(in) :: &                        !
2761                        fac00(:,:) , fac01(:,:) , &
2762                        fac10(:,:) , fac11(:,:)
2763                                                     !   Dimensions: (ncol,nlayers)
2764
2765 ! ----- Output -----
2766       real, intent(inout) gpu_device :: sfluxzen(:,:)    ! solar source function
2767                                                          !   Dimensions: (ncol,ngptsw)
2768       real, intent(inout) gpu_device :: taug(:,:,:)             ! gaseous optical depth
2769                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2770       real, intent(inout) gpu_device :: taur(:,:,:)             ! Rayleigh
2771                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2772
2773 ! Local
2774 #ifdef _ACCEL
2775 # define IKLOOP1_S do iplon=1,ncol;do lay=1,nlayers
2776 # define IKLOOP1_E enddo;enddo
2777 # define IKLOOP2_S do iplon=1,ncol;laysolfr=nlayers;do lay=laytrop(iplon)+1,nlayers;if(jp(iplon,lay-1).lt.layreffr.and.jp(iplon,lay).ge.layreffr)laysolfr=lay
2778 # define IKLOOP2_E
2779 #else
2780 # define ncol CHNK
2781 # define IKLOOP1_S do lay = 1, nlayers ; do iplon = 1, ncol
2782 # define IKLOOP1_E enddo;enddo
2783 # define IKLOOP2_S do lay=2,nlayers;do iplon=1,ncol;if(lay>laytrop(iplon))then;laysolfr=nlayers
2784 # define IKLOOP2_E endif;enddo;enddo
2785 #endif
2786
2787
2788       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2789       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
2790                        fac110, fac111, fs, speccomb, specmult, specparm, &
2791                        tauray
2792 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
2793 !                          layreffr
2794 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
2795 !                       fac110, fac111, fs, speccomb, specmult, specparm, &
2796 !                       tauray, strrat1
2797       integer :: iplon
2798 !      strrat1 = 252.131
2799 !      layreffr = 18
2800 !$acc kernels
2801 #ifdef _ACCEL
2802       do iplon=1,ncol
2803 ! Compute the optical depth by interpolating in ln(pressure),
2804 ! temperature, and appropriate species.  Below LAYTROP, the water
2805 ! vapor self-continuum is interpolated (in temperature) separately.
2806
2807 ! Lower atmosphere loop
2808       do lay = 1, nlayers
2809 #else
2810 IKLOOP1_S
2811 #endif
2812          if (lay <= laytrop(iplon)) then
2813          speccomb = colh2o(iplon,lay)  + strrat1*colch4(iplon,lay)
2814          specparm = colh2o(iplon,lay) /speccomb
2815          if (specparm .ge. oneminus) specparm = oneminus
2816          specmult = 8. *(specparm)
2817          js = 1 + int(specmult)
2818          fs = mod(specmult, 1.  )
2819          fac000 = (1.  - fs) * fac00(iplon,lay)
2820          fac010 = (1.  - fs) * fac10(iplon,lay)
2821          fac100 = fs * fac00(iplon,lay)
2822          fac110 = fs * fac10(iplon,lay)
2823          fac001 = (1.  - fs) * fac01(iplon,lay)
2824          fac011 = (1.  - fs) * fac11(iplon,lay)
2825          fac101 = fs * fac01(iplon,lay)
2826          fac111 = fs * fac11(iplon,lay)
2827          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(16) + js
2828          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(16) + js
2829          inds = indself(iplon,lay)
2830          indf = indfor(iplon,lay)
2831          tauray = colmol(iplon,lay)  * rayl
2832
2833          do ig = 1, ng16
2834             taug(iplon,lay,ig)  = speccomb * &
2835                 (fac000 * absa(ind0   ,ig) + &
2836                  fac100 * absa(ind0 +1,ig) + &
2837                  fac010 * absa(ind0 +9,ig) + &
2838                  fac110 * absa(ind0+10,ig) + &
2839                  fac001 * absa(ind1   ,ig) + &
2840                  fac101 * absa(ind1 +1,ig) + &
2841                  fac011 * absa(ind1 +9,ig) + &
2842                  fac111 * absa(ind1+10,ig)) + &
2843                  colh2o(iplon,lay)  * &
2844                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
2845                  selffrac(iplon,lay)  * &
2846                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
2847                  forfac(iplon,lay)  * (forref(indf,ig) + &
2848                  forfrac(iplon,lay)  * &
2849                  (forref(indf+1,ig) - forref(indf,ig))))
2850 !            ssa(lay,ig) = tauray/taug(lay,ig)
2851             taur(iplon,lay,ig)  = tauray
2852          enddo
2853          end if
2854 #ifdef _ACCEL
2855       enddo
2856       enddo
2857 !$acc end kernels
2858
2859 ! Upper atmosphere loop
2860 !$acc kernels
2861       do iplon=1,ncol
2862         laysolfr = nlayers
2863 ! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL
2864       do lay = laytrop(iplon)+1, nlayers
2865 !        if (lay > laytrop(iplon)) then
2866 !          !do lay = laytrop(iplon) +1, nlayers
2867          if (jp(iplon,lay-1)  .lt. layreffr .and. jp(iplon,lay)  .ge.  layreffr) then
2868             laysolfr = lay
2869          end if
2870 #else
2871 IKLOOP1_E
2872 IKLOOP2_S
2873 #endif
2874
2875 !#ifdef _ACCEL
2876 !      do iplon=1,ncol
2877 !        laysolfr = nlayers
2878 !! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL
2879 !      do lay = laytrop(iplon)+1, nlayers
2880 !!        if (lay > laytrop(iplon)) then
2881 !!          !do lay = laytrop(iplon) +1, nlayers
2882 !         if (jp(iplon,lay-1)  .lt. layreffr .and. jp(iplon,lay)  .ge. layreffr) then
2883 !            laysolfr = lay
2884 !         end if
2885 !#else
2886 !      do lay = minval(laytrop(1:ncol)),nlayers
2887 !       do iplon=1,ncol
2888 !        if (lay > laytrop(iplon)) then
2889 !         laysolfr = nlayers
2890 !
2891 !#endif
2892          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(16) + 1
2893          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(16) + 1
2894          tauray = colmol(iplon,lay)  * rayl
2895
2896          do ig = 1, ng16
2897             taug(iplon,lay,ig)  = colch4(iplon,lay)  * &
2898                 (fac00(iplon,lay)  * absb(ind0  ,ig) + &
2899                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
2900                  fac01(iplon,lay)  * absb(ind1  ,ig) + &
2901                  fac11(iplon,lay)  * absb(ind1+1,ig))
2902
2903             if (laysolfr == lay) sfluxzen(iplon,ig)  = sfluxref(ig)
2904             taur(iplon,lay,ig)  = tauray
2905          enddo
2906 #ifdef _ACCEL
2907          enddo
2908          enddo
2909 #else
2910 IKLOOP2_E
2911 #endif
2912 !$acc end kernels
2913 # undef ncol
2914  end subroutine taumol16
2915
2916 !----------------------------------------------------------------------------
2917       subroutine taumol17(ncol, nlayers, &
2918                           colh2o, colco2, colch4, colo2, colo3, colmol, &
2919                           laytrop, jp, jt, jt1, &
2920                           fac00, fac01, fac10, fac11, &
2921                           selffac, selffrac, indself, forfac, forfrac, indfor, &
2922                           sfluxzen, taug, taur)
2923 !----------------------------------------------------------------------------
2924 !
2925 !     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
2926 !
2927 !----------------------------------------------------------------------------
2928
2929 ! ------- Modules -------
2930
2931       use parrrsw_f, only : ng17, ngs16
2932       use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, &
2933                             sfluxref, rayl, layreffr, strrat
2934 !      use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, &
2935 !                            sfluxref, rayl
2936
2937 ! ------- Declarations -------
2938       integer , intent(in) :: ncol
2939       integer , intent(in) :: nlayers               ! total number of layers
2940
2941       integer , intent(in) :: laytrop(:)            ! tropopause layer index
2942       integer , intent(in) :: jp(:,:)               !
2943       integer , intent(in) :: jt(:,:)               !
2944       integer , intent(in) :: jt1(:,:)              !
2945                                                     !   Dimensions: (ncol,nlayers)
2946
2947       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
2948       real , intent(in) :: colco2(:,:)              ! column amount (co2)
2949       real , intent(in) :: colo3(:,:)               ! column amount (o3)
2950       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
2951       real , intent(in) :: colo2(:,:)               ! column amount (o2)
2952       real , intent(in) :: colmol(:,:)              !
2953                                                     !   Dimensions: (ncol,nlayers)
2954
2955       integer , intent(in) :: indself(:,:)
2956       integer , intent(in) :: indfor(:,:)
2957       real , intent(in) :: selffac(:,:)
2958       real , intent(in) :: selffrac(:,:)
2959       real , intent(in) :: forfac(:,:)
2960       real , intent(in) :: forfrac(:,:)
2961                                                     !   Dimensions: (ncol,nlayers)
2962
2963       real , intent(in) :: &                        !
2964                        fac00(:,:) , fac01(:,:) , &
2965                        fac10(:,:) , fac11(:,:)
2966                                                     !   Dimensions: (ncol,nlayers)
2967
2968 ! ----- Output -----
2969       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
2970                                                          !   Dimensions: (ncol,ngptsw)
2971       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
2972                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2973       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
2974                                                          !   Dimensions: (ncol,nlayers,ngptsw)
2975
2976 ! Local
2977 #ifndef _ACCEL
2978 # define ncol CHNK
2979 #endif
2980
2981       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
2982       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
2983                        fac110, fac111, fs, speccomb, specmult, specparm, &
2984                        tauray
2985 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
2986 !                          layreffr
2987 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
2988 !                       fac110, fac111, fs, speccomb, specmult, specparm, &
2989 !                       tauray, strrat
2990       integer :: iplon
2991
2992 !      layreffr = 30
2993 !      strrat = 0.364641
2994
2995 #ifdef _ACCEL
2996 !$acc kernels loop
2997       do iplon=1,ncol
2998 ! Compute the optical depth by interpolating in ln(pressure),
2999 ! temperature, and appropriate species.  Below LAYTROP, the water
3000 ! vapor self-continuum is interpolated (in temperature) separately.
3001
3002 ! Lower atmosphere loop
3003 !$acc loop private(js, fs)
3004       do lay = 1, nlayers
3005 #else
3006 IKLOOP1_S
3007 #endif
3008         if (lay <= laytrop(iplon)) then
3009           !do lay = 1, laytrop(iplon)
3010          speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3011          specparm = colh2o(iplon,lay) /speccomb
3012          if (specparm .ge. oneminus) specparm = oneminus
3013          specmult = 8. *(specparm)
3014          js = 1 + int(specmult)
3015          fs = mod(specmult, 1.  )
3016          fac000 = (1.  - fs) * fac00(iplon,lay)
3017          fac010 = (1.  - fs) * fac10(iplon,lay)
3018          fac100 = fs * fac00(iplon,lay)
3019          fac110 = fs * fac10(iplon,lay)
3020          fac001 = (1.  - fs) * fac01(iplon,lay)
3021          fac011 = (1.  - fs) * fac11(iplon,lay)
3022          fac101 = fs * fac01(iplon,lay)
3023          fac111 = fs * fac11(iplon,lay)
3024          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(17) + js
3025          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(17) + js
3026          inds = indself(iplon,lay)
3027          indf = indfor(iplon,lay)
3028          tauray = colmol(iplon,lay)  * rayl
3029
3030          do ig = 1, ng17
3031             taug(iplon,lay,ngs16+ig)  = speccomb * &
3032                 (fac000 * absa(ind0,ig) + &
3033                  fac100 * absa(ind0+1,ig) + &
3034                  fac010 * absa(ind0+9,ig) + &
3035                  fac110 * absa(ind0+10,ig) + &
3036                  fac001 * absa(ind1,ig) + &
3037                  fac101 * absa(ind1+1,ig) + &
3038                  fac011 * absa(ind1+9,ig) + &
3039                  fac111 * absa(ind1+10,ig)) + &
3040                  colh2o(iplon,lay)  * &
3041                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
3042                  selffrac(iplon,lay)  * &
3043                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
3044                  forfac(iplon,lay)  * (forref(indf,ig) + &
3045                  forfrac(iplon,lay)  * &
3046                  (forref(indf+1,ig) - forref(indf,ig))))
3047             taur(iplon,lay,ngs16+ig)  = tauray
3048          enddo
3049
3050          else
3051
3052
3053          speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3054          specparm = colh2o(iplon,lay) /speccomb
3055          if (specparm .ge. oneminus) specparm = oneminus
3056          specmult = 4. *(specparm)
3057          js = 1 + int(specmult)
3058          fs = mod(specmult, 1.  )
3059          fac000 = (1.  - fs) * fac00(iplon,lay)
3060          fac010 = (1.  - fs) * fac10(iplon,lay)
3061          fac100 = fs * fac00(iplon,lay)
3062          fac110 = fs * fac10(iplon,lay)
3063          fac001 = (1.  - fs) * fac01(iplon,lay)
3064          fac011 = (1.  - fs) * fac11(iplon,lay)
3065          fac101 = fs * fac01(iplon,lay)
3066          fac111 = fs * fac11(iplon,lay)
3067          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(17) + js
3068          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(17) + js
3069          indf = indfor(iplon,lay)
3070          tauray = colmol(iplon,lay)  * rayl
3071
3072          do ig = 1, ng17
3073             taug(iplon,lay,ngs16+ig)  = speccomb * &
3074                 (fac000 * absb(ind0,ig) + &
3075                  fac100 * absb(ind0+1,ig) + &
3076                  fac010 * absb(ind0+5,ig) + &
3077                  fac110 * absb(ind0+6,ig) + &
3078                  fac001 * absb(ind1,ig) + &
3079                  fac101 * absb(ind1+1,ig) + &
3080                  fac011 * absb(ind1+5,ig) + &
3081                  fac111 * absb(ind1+6,ig)) + &
3082                  colh2o(iplon,lay)  * &
3083                  forfac(iplon,lay)  * (forref(indf,ig) + &
3084                  forfrac(iplon,lay)  * &
3085                  (forref(indf+1,ig) - forref(indf,ig)))
3086 !            ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
3087
3088             taur(iplon,lay,ngs16+ig)  = tauray
3089          enddo
3090         endif
3091       enddo
3092       enddo
3093 !$acc end kernels
3094
3095 !$acc kernels
3096 #ifdef _ACCEL
3097       do iplon = 1, ncol
3098 ! Upper atmosphere loop
3099         laysolfr = nlayers
3100       do lay = 2, nlayers
3101         if (lay > laytrop(iplon)) then
3102 #else
3103 IKLOOP2_S
3104 #endif
3105
3106         if ((jp(iplon,lay-1)  .lt. layreffr) .and. (jp(iplon,lay)  .ge. layreffr)) then
3107             laysolfr = lay
3108         end if
3109
3110         if (lay == laysolfr) then
3111
3112           speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3113           specparm = colh2o(iplon,lay) /speccomb
3114           if (specparm .ge. oneminus) specparm = oneminus
3115           specmult = 4. *(specparm)
3116           js = 1 + int(specmult)
3117           fs = mod(specmult, 1.  )
3118           do ig = 1, ng17
3119             sfluxzen(iplon,ngs16+ig)  = sfluxref(ig,js) &
3120                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3121           end do
3122         end if
3123 #ifdef _ACCEL
3124         end if
3125       enddo
3126       enddo
3127 #else
3128 IKLOOP2_E
3129 #endif
3130 !$acc end kernels
3131 # undef ncol
3132       end subroutine taumol17
3133
3134 !----------------------------------------------------------------------------
3135       subroutine taumol18(ncol, nlayers, &
3136                           colh2o, colco2, colch4, colo2, colo3, colmol, &
3137                           laytrop, jp, jt, jt1, &
3138                           fac00, fac01, fac10, fac11, &
3139                           selffac, selffrac, indself, forfac, forfrac, indfor, &
3140                           sfluxzen, taug, taur)
3141 !----------------------------------------------------------------------------
3142 !
3143 !     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
3144 !
3145 !----------------------------------------------------------------------------
3146
3147 ! ------- Modules -------
3148
3149       use parrrsw_f, only : ng18, ngs17
3150       use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, &
3151                             sfluxref, rayl, layreffr, strrat
3152 !      use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, &
3153 !                            sfluxref, rayl
3154
3155 ! ------- Declarations -------
3156       integer , intent(in) :: ncol
3157       integer , intent(in) :: nlayers               ! total number of layers
3158
3159       integer , intent(in) :: laytrop(:)            ! tropopause layer index
3160       integer , intent(in) :: jp(:,:)               !
3161       integer , intent(in) :: jt(:,:)               !
3162       integer , intent(in) :: jt1(:,:)              !
3163                                                     !   Dimensions: (ncol,nlayers)
3164
3165       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
3166       real , intent(in) :: colco2(:,:)              ! column amount (co2)
3167       real , intent(in) :: colo3(:,:)               ! column amount (o3)
3168       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
3169       real , intent(in) :: colo2(:,:)               ! column amount (o2)
3170       real , intent(in) :: colmol(:,:)              !
3171                                                     !   Dimensions: (ncol,nlayers)
3172
3173       integer , intent(in) :: indself(:,:)
3174       integer , intent(in) :: indfor(:,:)
3175       real , intent(in) :: selffac(:,:)
3176       real , intent(in) :: selffrac(:,:)
3177       real , intent(in) :: forfac(:,:)
3178       real , intent(in) :: forfrac(:,:)
3179                                                     !   Dimensions: (ncol,nlayers)
3180
3181       real , intent(in) :: &                        !
3182                        fac00(:,:) , fac01(:,:) , &
3183                        fac10(:,:) , fac11(:,:)
3184                                                     !   Dimensions: (ncol,nlayers)
3185
3186 ! ----- Output -----
3187       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
3188                                                          !   Dimensions: (ncol,ngptsw)
3189       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
3190                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3191       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
3192                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3193
3194 ! Local
3195 #ifndef _ACCEL
3196 # define ncol CHNK
3197 #endif
3198
3199 #ifdef _ACCEL
3200       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3201 #else
3202       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
3203 #endif
3204       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3205                        fac110, fac111, fs, speccomb, specmult, specparm, &
3206                        tauray
3207 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
3208 !                          layreffr
3209 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3210 !                       fac110, fac111, fs, speccomb, specmult, specparm, &
3211 !                       tauray, strrat
3212       integer :: iplon
3213
3214
3215 !      strrat = 38.9589
3216 !      layreffr = 6
3217 !$acc kernels
3218
3219 #ifdef _ACCEL
3220       do iplon = 1, ncol
3221           laysolfr = laytrop(iplon)
3222           do lay = 1, laytrop(iplon)
3223 #else
3224       laysolfr = laytrop
3225 #define laysolfr LAYSOLFR(iplon)
3226       do lay = 1, nlayers
3227         do iplon = 1, ncol
3228           if (lay <= laytrop(iplon)) then
3229 #endif
3230               speccomb = colh2o(iplon,lay)  + strrat*colch4(iplon,lay)
3231               specparm = colh2o(iplon,lay) /speccomb
3232               if (specparm .ge. oneminus) specparm = oneminus
3233               specmult = 8. *(specparm)
3234               js = 1 + int(specmult)
3235               fs = mod(specmult, 1.  )
3236               if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
3237               laysolfr = min(lay+1,laytrop(iplon) )
3238               do ig = 1, ng18
3239                 if (lay .eq. laysolfr) sfluxzen(iplon,ngs17+ig)  = sfluxref(ig,js) &
3240                   + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3241               end do
3242 #ifdef _ACCEL
3243 #else
3244 # undef laysolfr
3245          endif
3246 #endif
3247           end do
3248       end do
3249 !$acc end kernels
3250
3251 !$acc kernels
3252 IKLOOP1_S
3253         if (lay <= laytrop(iplon)) then
3254           !do lay = 1, laytrop(iplon)
3255
3256          speccomb = colh2o(iplon,lay)  + strrat*colch4(iplon,lay)
3257          specparm = colh2o(iplon,lay) /speccomb
3258          if (specparm .ge. oneminus) specparm = oneminus
3259          specmult = 8. *(specparm)
3260          js = 1 + int(specmult)
3261          fs = mod(specmult, 1.  )
3262          fac000 = (1.  - fs) * fac00(iplon,lay)
3263          fac010 = (1.  - fs) * fac10(iplon,lay)
3264          fac100 = fs * fac00(iplon,lay)
3265          fac110 = fs * fac10(iplon,lay)
3266          fac001 = (1.  - fs) * fac01(iplon,lay)
3267          fac011 = (1.  - fs) * fac11(iplon,lay)
3268          fac101 = fs * fac01(iplon,lay)
3269          fac111 = fs * fac11(iplon,lay)
3270          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(18) + js
3271          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(18) + js
3272          inds = indself(iplon,lay)
3273          indf = indfor(iplon,lay)
3274          tauray = colmol(iplon,lay)  * rayl
3275
3276          do ig = 1, ng18
3277             taug(iplon,lay,ngs17+ig)  = speccomb * &
3278                 (fac000 * absa(ind0,ig) + &
3279                  fac100 * absa(ind0+1,ig) + &
3280                  fac010 * absa(ind0+9,ig) + &
3281                  fac110 * absa(ind0+10,ig) + &
3282                  fac001 * absa(ind1,ig) + &
3283                  fac101 * absa(ind1+1,ig) + &
3284                  fac011 * absa(ind1+9,ig) + &
3285                  fac111 * absa(ind1+10,ig)) + &
3286                  colh2o(iplon,lay)  * &
3287                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
3288                  selffrac(iplon,lay)  * &
3289                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
3290                  forfac(iplon,lay)  * (forref(indf,ig) + &
3291                  forfrac(iplon,lay)  * &
3292                  (forref(indf+1,ig) - forref(indf,ig))))
3293 !            ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3294
3295             taur(iplon,lay,ngs17+ig)  = tauray
3296          enddo
3297
3298         else
3299
3300 ! Upper atmosphere loop
3301
3302 !do lay = laytrop(iplon) +1, nlayers
3303          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(18) + 1
3304          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(18) + 1
3305          tauray = colmol(iplon,lay)  * rayl
3306
3307          do ig = 1, ng18
3308             taug(iplon,lay,ngs17+ig)  = colch4(iplon,lay)  * &
3309                 (fac00(iplon,lay)  * absb(ind0,ig) + &
3310                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
3311                  fac01(iplon,lay)  * absb(ind1,ig) + &
3312                  fac11(iplon,lay)  * absb(ind1+1,ig))
3313 !           ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
3314            taur(iplon,lay,ngs17+ig)  = tauray
3315          enddo
3316         end if
3317 IKLOOP1_E
3318
3319 !$acc end kernels
3320 # undef ncol
3321       end subroutine taumol18
3322
3323 !----------------------------------------------------------------------------
3324       subroutine taumol19(ncol, nlayers, &
3325                           colh2o, colco2, colch4, colo2, colo3, colmol, &
3326                           laytrop, jp, jt, jt1, &
3327                           fac00, fac01, fac10, fac11, &
3328                           selffac, selffrac, indself, forfac, forfrac, indfor, &
3329                           sfluxzen, taug, taur)
3330 !----------------------------------------------------------------------------
3331 !
3332 !     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
3333 !
3334 !----------------------------------------------------------------------------
3335
3336 ! ------- Modules -------
3337
3338       use parrrsw_f, only : ng19, ngs18
3339       use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, &
3340                             sfluxref, rayl, layreffr, strrat
3341 !      use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, &
3342 !                            sfluxref, rayl
3343
3344 ! ------- Declarations -------
3345       integer , intent(in) :: ncol
3346       integer , intent(in) :: nlayers               ! total number of layers
3347
3348       integer , intent(in) :: laytrop(:)            ! tropopause layer index
3349       integer , intent(in) :: jp(:,:)               !
3350       integer , intent(in) :: jt(:,:)               !
3351       integer , intent(in) :: jt1(:,:)              !
3352                                                     !   Dimensions: (ncol,nlayers)
3353
3354       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
3355       real , intent(in) :: colco2(:,:)              ! column amount (co2)
3356       real , intent(in) :: colo3(:,:)               ! column amount (o3)
3357       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
3358       real , intent(in) :: colo2(:,:)               ! column amount (o2)
3359       real , intent(in) :: colmol(:,:)              !
3360                                                     !   Dimensions: (ncol,nlayers)
3361
3362       integer , intent(in) :: indself(:,:)
3363       integer , intent(in) :: indfor(:,:)
3364       real , intent(in) :: selffac(:,:)
3365       real , intent(in) :: selffrac(:,:)
3366       real , intent(in) :: forfac(:,:)
3367       real , intent(in) :: forfrac(:,:)
3368                                                     !   Dimensions: (ncol,nlayers)
3369
3370       real , intent(in) :: &                        !
3371                        fac00(:,:) , fac01(:,:) , &
3372                        fac10(:,:) , fac11(:,:)
3373                                                     !   Dimensions: (ncol,nlayers)
3374
3375 ! ----- Output -----
3376       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
3377                                                          !   Dimensions: (ncol,ngptsw)
3378       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
3379                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3380       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
3381                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3382
3383 ! Local
3384 #ifdef _ACCEL
3385 #else
3386 # define ncol CHNK
3387 #endif
3388
3389 #ifdef _ACCEL
3390       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3391 #else
3392       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
3393 #endif
3394       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3395                   fac110, fac111, fs, speccomb, specmult, specparm, &
3396                   tauray
3397 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
3398 !                  layreffr
3399 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3400 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
3401 !                  tauray, strrat
3402       integer :: iplon
3403
3404
3405       strrat = 5.49281
3406       layreffr = 3
3407
3408 #ifdef _ACCEL
3409 !$acc kernels
3410       do iplon=1,ncol
3411
3412 ! Compute the optical depth by interpolating in ln(pressure),
3413 ! temperature, and appropriate species.  Below LAYTROP, the water
3414 ! vapor self-continuum is interpolated (in temperature) separately.
3415       laysolfr = laytrop(iplon)
3416
3417 ! Lower atmosphere loop
3418       do lay = 1, laytrop(iplon)
3419 #else
3420       laysolfr = laytrop
3421 # define laysolfr LAYSOLFR(iplon)
3422       do lay = 1, nlayers
3423         do iplon = 1, ncol
3424           if (lay <= laytrop(iplon)) then
3425 #endif
3426
3427         if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
3428             laysolfr = min(lay+1,laytrop(iplon) )
3429
3430          if (lay .eq. laysolfr) then
3431                  speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3432          specparm = colh2o(iplon,lay) /speccomb
3433          if (specparm .ge. oneminus) specparm = oneminus
3434          specmult = 8. *(specparm)
3435          js = 1 + int(specmult)
3436          fs = mod(specmult, 1.  )
3437
3438          do ig = 1 , ng19
3439             sfluxzen(iplon,ngs18+ig)  = sfluxref(ig,js) &
3440                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3441          end do
3442          endif
3443 #ifdef _ACCEL
3444 #else
3445 # undef laysolfr
3446          endif
3447 #endif
3448
3449       end do
3450       end do
3451 !$acc end kernels
3452
3453
3454 !$acc kernels
3455 IKLOOP1_S
3456
3457 ! Compute the optical depth by interpolating in ln(pressure),
3458 ! temperature, and appropriate species.  Below LAYTROP, the water
3459 ! vapor self-continuum is interpolated (in temperature) separately.
3460
3461 ! Lower atmosphere loop
3462          if (lay <= laytrop(iplon)) then
3463
3464          speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3465          specparm = colh2o(iplon,lay) /speccomb
3466          if (specparm .ge. oneminus) specparm = oneminus
3467          specmult = 8. *(specparm)
3468          js = 1 + int(specmult)
3469          fs = mod(specmult, 1.  )
3470          fac000 = (1.  - fs) * fac00(iplon,lay)
3471          fac010 = (1.  - fs) * fac10(iplon,lay)
3472          fac100 = fs * fac00(iplon,lay)
3473          fac110 = fs * fac10(iplon,lay)
3474          fac001 = (1.  - fs) * fac01(iplon,lay)
3475          fac011 = (1.  - fs) * fac11(iplon,lay)
3476          fac101 = fs * fac01(iplon,lay)
3477          fac111 = fs * fac11(iplon,lay)
3478          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(19) + js
3479          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(19) + js
3480          inds = indself(iplon,lay)
3481          indf = indfor(iplon,lay)
3482          tauray = colmol(iplon,lay)  * rayl
3483
3484          do ig = 1 , ng19
3485             taug(iplon,lay,ngs18+ig)  = speccomb * &
3486                 (fac000 * absa(ind0,ig) + &
3487                  fac100 * absa(ind0+1,ig) + &
3488                  fac010 * absa(ind0+9,ig) + &
3489                  fac110 * absa(ind0+10,ig) + &
3490                  fac001 * absa(ind1,ig) + &
3491                  fac101 * absa(ind1+1,ig) + &
3492                  fac011 * absa(ind1+9,ig) + &
3493                  fac111 * absa(ind1+10,ig)) + &
3494                  colh2o(iplon,lay)  * &
3495                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
3496                  selffrac(iplon,lay)  * &
3497                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
3498                  forfac(iplon,lay)  * (forref(indf,ig) + &
3499                  forfrac(iplon,lay)  * &
3500                  (forref(indf+1,ig) - forref(indf,ig))))
3501 !            ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3502             taur(iplon,lay,ngs18+ig)  = tauray
3503          enddo
3504         else
3505
3506 ! Upper atmosphere loop
3507
3508          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(19) + 1
3509          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(19) + 1
3510          tauray = colmol(iplon,lay)  * rayl
3511
3512          do ig = 1 , ng19
3513             taug(iplon,lay,ngs18+ig)  = colco2(iplon,lay)  * &
3514                 (fac00(iplon,lay)  * absb(ind0,ig) + &
3515                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
3516                  fac01(iplon,lay)  * absb(ind1,ig) + &
3517                  fac11(iplon,lay)  * absb(ind1+1,ig))
3518 !            ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
3519             taur(iplon,lay,ngs18+ig)  = tauray
3520          enddo
3521         end if
3522 IKLOOP1_E
3523 !$acc end kernels
3524 # undef ncol
3525       end subroutine taumol19
3526
3527 !----------------------------------------------------------------------------
3528       subroutine taumol20(ncol, nlayers, &
3529                           colh2o, colco2, colch4, colo2, colo3, colmol, &
3530                           laytrop, jp, jt, jt1, &
3531                           fac00, fac01, fac10, fac11, &
3532                           selffac, selffrac, indself, forfac, forfrac, indfor, &
3533                           sfluxzen, taug, taur)
3534 !----------------------------------------------------------------------------
3535 !
3536 !     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
3537 !
3538 !----------------------------------------------------------------------------
3539
3540 ! ------- Modules -------
3541
3542       use parrrsw_f, only : ng20, ngs19
3543       use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, &
3544                             sfluxref, absch4, rayl, layreffr
3545 !      use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, &
3546 !                            sfluxref, absch4, rayl
3547
3548       implicit none
3549
3550 ! ------- Declarations -------
3551       integer , intent(in) :: ncol
3552       integer , intent(in) :: nlayers               ! total number of layers
3553
3554       integer , intent(in) :: laytrop(:)            ! tropopause layer index
3555       integer , intent(in) :: jp(:,:)               !
3556       integer , intent(in) :: jt(:,:)               !
3557       integer , intent(in) :: jt1(:,:)              !
3558                                                     !   Dimensions: (ncol,nlayers)
3559
3560       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
3561       real , intent(in) :: colco2(:,:)              ! column amount (co2)
3562       real , intent(in) :: colo3(:,:)               ! column amount (o3)
3563       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
3564       real , intent(in) :: colo2(:,:)               ! column amount (o2)
3565       real , intent(in) :: colmol(:,:)              !
3566                                                     !   Dimensions: (ncol,nlayers)
3567
3568       integer , intent(in) :: indself(:,:)
3569       integer , intent(in) :: indfor(:,:)
3570       real , intent(in) :: selffac(:,:)
3571       real , intent(in) :: selffrac(:,:)
3572       real , intent(in) :: forfac(:,:)
3573       real , intent(in) :: forfrac(:,:)
3574                                                     !   Dimensions: (ncol,nlayers)
3575
3576       real , intent(in) :: &                        !
3577                        fac00(:,:) , fac01(:,:) , &
3578                        fac10(:,:) , fac11(:,:)
3579                                                     !   Dimensions: (ncol,nlayers)
3580
3581 ! ----- Output -----
3582       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
3583                                                          !   Dimensions: (ncol,ngptsw)
3584       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
3585                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3586       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
3587                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3588
3589 ! Local
3590 #ifdef _ACCEL
3591       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3592 #else
3593 # define ncol CHNK
3594       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
3595 #endif
3596
3597 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
3598 !                  layreffr
3599       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3600                   fac110, fac111, fs, speccomb, specmult, specparm, &
3601                   tauray
3602       integer :: iplon
3603
3604 !      layreffr = 3
3605
3606 #ifdef _ACCEL
3607 !$acc kernels loop independent private(laysolfr)
3608       do iplon = 1, ncol
3609       laysolfr = laytrop(iplon)
3610       do lay = 1, laytrop(iplon)
3611 #else
3612       laysolfr = laytrop
3613 # define laysolfr LAYSOLFR(iplon)
3614       do lay = 1, nlayers
3615         do iplon = 1, ncol
3616           if (lay <= laytrop(iplon)) then
3617 #endif
3618
3619          if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
3620             laysolfr = min(lay+1,laytrop(iplon) )
3621          if (lay .eq. laysolfr) then
3622              do ig = 1, ng20
3623                  sfluxzen(iplon,ngs19+ig)  = sfluxref(ig)
3624              end do
3625          end if
3626 #ifdef _ACCEL
3627 #else
3628 # undef laysolfr
3629          endif
3630 #endif
3631       end do
3632       end do
3633 !$acc end kernels
3634
3635 !$acc kernels
3636 IKLOOP1_S
3637          if (lay <= laytrop(iplon)) then
3638
3639          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(20) + 1
3640          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(20) + 1
3641          inds = indself(iplon,lay)
3642          indf = indfor(iplon,lay)
3643          tauray = colmol(iplon,lay)  * rayl
3644
3645          do ig = 1, ng20
3646             taug(iplon,lay,ngs19+ig)  = colh2o(iplon,lay)  * &
3647                ((fac00(iplon,lay)  * absa(ind0,ig) + &
3648                  fac10(iplon,lay)  * absa(ind0+1,ig) + &
3649                  fac01(iplon,lay)  * absa(ind1,ig) + &
3650                  fac11(iplon,lay)  * absa(ind1+1,ig)) + &
3651                  selffac(iplon,lay)  * (selfref(inds,ig) + &
3652                  selffrac(iplon,lay)  * &
3653                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
3654                  forfac(iplon,lay)  * (forref(indf,ig) + &
3655                  forfrac(iplon,lay)  * &
3656                  (forref(indf+1,ig) - forref(indf,ig)))) &
3657                  + colch4(iplon,lay)  * absch4(ig)
3658 !            ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3659             taur(iplon,lay,ngs19+ig)  = tauray
3660
3661          enddo
3662          else
3663
3664 ! Upper atmosphere loop
3665
3666          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(20) + 1
3667          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(20) + 1
3668          indf = indfor(iplon,lay)
3669          tauray = colmol(iplon,lay)  * rayl
3670
3671          do ig = 1, ng20
3672             taug(iplon,lay,ngs19+ig)  = colh2o(iplon,lay)  * &
3673                 (fac00(iplon,lay)  * absb(ind0,ig) + &
3674                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
3675                  fac01(iplon,lay)  * absb(ind1,ig) + &
3676                  fac11(iplon,lay)  * absb(ind1+1,ig) + &
3677                  forfac(iplon,lay)  * (forref(indf,ig) + &
3678                  forfrac(iplon,lay)  * &
3679                  (forref(indf+1,ig) - forref(indf,ig)))) + &
3680                  colch4(iplon,lay)  * absch4(ig)
3681 !            ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
3682             taur(iplon,lay,ngs19+ig)  = tauray
3683          enddo
3684          end if
3685 IKLOOP1_E
3686
3687 !$acc end kernels
3688 # undef ncol
3689       end subroutine taumol20
3690
3691 !----------------------------------------------------------------------------
3692       subroutine taumol21(ncol, nlayers, &
3693                           colh2o, colco2, colch4, colo2, colo3, colmol, &
3694                           laytrop, jp, jt, jt1, &
3695                           fac00, fac01, fac10, fac11, &
3696                           selffac, selffrac, indself, forfac, forfrac, indfor, &
3697                           sfluxzen, taug, taur)
3698 !----------------------------------------------------------------------------
3699 !
3700 !     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
3701 !
3702 !----------------------------------------------------------------------------
3703
3704 ! ------- Modules -------
3705
3706       use parrrsw_f, only : ng21, ngs20
3707       use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, &
3708                             sfluxref, rayl, layreffr, strrat
3709 !      use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, &
3710 !                            sfluxref, rayl
3711
3712 ! ------- Declarations -------
3713       integer , intent(in) :: ncol
3714       integer , intent(in) :: nlayers               ! total number of layers
3715
3716       integer , intent(in) :: laytrop(:)            ! tropopause layer index
3717       integer , intent(in) :: jp(:,:)               !
3718       integer , intent(in) :: jt(:,:)               !
3719       integer , intent(in) :: jt1(:,:)              !
3720                                                     !   Dimensions: (ncol,nlayers)
3721
3722       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
3723       real , intent(in) :: colco2(:,:)              ! column amount (co2)
3724       real , intent(in) :: colo3(:,:)               ! column amount (o3)
3725       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
3726       real , intent(in) :: colo2(:,:)               ! column amount (o2)
3727       real , intent(in) :: colmol(:,:)              !
3728                                                     !   Dimensions: (ncol,nlayers)
3729
3730       integer , intent(in) :: indself(:,:)
3731       integer , intent(in) :: indfor(:,:)
3732       real , intent(in) :: selffac(:,:)
3733       real , intent(in) :: selffrac(:,:)
3734       real , intent(in) :: forfac(:,:)
3735       real , intent(in) :: forfrac(:,:)
3736                                                     !   Dimensions: (ncol,nlayers)
3737
3738       real , intent(in) :: &                        !
3739                        fac00(:,:) , fac01(:,:) , &
3740                        fac10(:,:) , fac11(:,:)
3741                                                     !   Dimensions: (ncol,nlayers)
3742
3743 ! ----- Output -----
3744       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
3745                                                          !   Dimensions: (ncol,ngptsw)
3746       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
3747                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3748       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
3749                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3750
3751 ! Local
3752 #ifdef _ACCEL
3753       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3754 #else
3755 # define ncol CHNK
3756       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
3757 #endif
3758
3759       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3760                   fac110, fac111, fs, speccomb, specmult, specparm, &
3761                   tauray
3762 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
3763 !                  layreffr
3764 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3765 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
3766 !                  tauray, strrat
3767       integer :: iplon
3768
3769 !      strrat = 0.0045321
3770 !      layreffr = 8
3771
3772 #ifdef _ACCEL
3773 !$acc kernels loop independent private(laysolfr)
3774       do iplon = 1, ncol
3775       laysolfr = laytrop(iplon)
3776       do lay = 1, laytrop(iplon)
3777 #else
3778       laysolfr = laytrop
3779 # define laysolfr LAYSOLFR(iplon)
3780       do lay = 1, nlayers
3781         do iplon = 1, ncol
3782           if (lay <= laytrop(iplon)) then
3783 #endif
3784
3785          if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
3786             laysolfr = min(lay+1,laytrop(iplon) )
3787          if (lay .eq. laysolfr) then
3788                 speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3789          specparm = colh2o(iplon,lay) /speccomb
3790          if (specparm .ge. oneminus) specparm = oneminus
3791          specmult = 8. *(specparm)
3792          js = 1 + int(specmult)
3793          fs = mod(specmult, 1.  )
3794                do ig = 1, ng21
3795               sfluxzen(iplon,ngs20+ig)  = sfluxref(ig,js) &
3796                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
3797                end do
3798           end if
3799
3800 #ifdef _ACCEL
3801 #else
3802 # undef laysolfr
3803          endif
3804 #endif
3805       end do
3806       end do
3807 !$acc end kernels
3808
3809 ! Compute the optical depth by interpolating in ln(pressure),
3810 ! temperature, and appropriate species.  Below LAYTROP, the water
3811 ! vapor self-continuum is interpolated (in temperature) separately.
3812
3813 ! Lower atmosphere loop
3814
3815 !$acc kernels
3816 IKLOOP1_S
3817          if (lay <= laytrop(iplon)) then
3818          speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3819          specparm = colh2o(iplon,lay) /speccomb
3820          if (specparm .ge. oneminus) specparm = oneminus
3821          specmult = 8. *(specparm)
3822          js = 1 + int(specmult)
3823          fs = mod(specmult, 1.  )
3824          fac000 = (1.  - fs) * fac00(iplon,lay)
3825          fac010 = (1.  - fs) * fac10(iplon,lay)
3826          fac100 = fs * fac00(iplon,lay)
3827          fac110 = fs * fac10(iplon,lay)
3828          fac001 = (1.  - fs) * fac01(iplon,lay)
3829          fac011 = (1.  - fs) * fac11(iplon,lay)
3830          fac101 = fs * fac01(iplon,lay)
3831          fac111 = fs * fac11(iplon,lay)
3832          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(21) + js
3833          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(21) + js
3834          inds = indself(iplon,lay)
3835          indf = indfor(iplon,lay)
3836          tauray = colmol(iplon,lay)  * rayl
3837
3838          do ig = 1, ng21
3839             taug(iplon,lay,ngs20+ig)  = speccomb * &
3840                 (fac000 * absa(ind0,ig) + &
3841                  fac100 * absa(ind0+1,ig) + &
3842                  fac010 * absa(ind0+9,ig) + &
3843                  fac110 * absa(ind0+10,ig) + &
3844                  fac001 * absa(ind1,ig) + &
3845                  fac101 * absa(ind1+1,ig) + &
3846                  fac011 * absa(ind1+9,ig) + &
3847                  fac111 * absa(ind1+10,ig)) + &
3848                  colh2o(iplon,lay)  * &
3849                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
3850                  selffrac(iplon,lay)  * &
3851                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
3852                  forfac(iplon,lay)  * (forref(indf,ig) + &
3853                  forfrac(iplon,lay)  * &
3854                  (forref(indf+1,ig) - forref(indf,ig))))
3855 !            ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3856
3857             taur(iplon,lay,ngs20+ig)  = tauray
3858          enddo
3859         else
3860
3861 ! Upper atmosphere loop
3862
3863          speccomb = colh2o(iplon,lay)  + strrat*colco2(iplon,lay)
3864          specparm = colh2o(iplon,lay) /speccomb
3865          if (specparm .ge. oneminus) specparm = oneminus
3866          specmult = 4. *(specparm)
3867          js = 1 + int(specmult)
3868          fs = mod(specmult, 1.  )
3869          fac000 = (1.  - fs) * fac00(iplon,lay)
3870          fac010 = (1.  - fs) * fac10(iplon,lay)
3871          fac100 = fs * fac00(iplon,lay)
3872          fac110 = fs * fac10(iplon,lay)
3873          fac001 = (1.  - fs) * fac01(iplon,lay)
3874          fac011 = (1.  - fs) * fac11(iplon,lay)
3875          fac101 = fs * fac01(iplon,lay)
3876          fac111 = fs * fac11(iplon,lay)
3877          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(21) + js
3878          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(21) + js
3879          indf = indfor(iplon,lay)
3880          tauray = colmol(iplon,lay)  * rayl
3881
3882          do ig = 1, ng21
3883             taug(iplon,lay,ngs20+ig)  = speccomb * &
3884                 (fac000 * absb(ind0,ig) + &
3885                  fac100 * absb(ind0+1,ig) + &
3886                  fac010 * absb(ind0+5,ig) + &
3887                  fac110 * absb(ind0+6,ig) + &
3888                  fac001 * absb(ind1,ig) + &
3889                  fac101 * absb(ind1+1,ig) + &
3890                  fac011 * absb(ind1+5,ig) + &
3891                  fac111 * absb(ind1+6,ig)) + &
3892                  colh2o(iplon,lay)  * &
3893                  forfac(iplon,lay)  * (forref(indf,ig) + &
3894                  forfrac(iplon,lay)  * &
3895                  (forref(indf+1,ig) - forref(indf,ig)))
3896 !            ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
3897             taur(iplon,lay,ngs20+ig)  = tauray
3898          enddo
3899         end if
3900 IKLOOP1_E
3901
3902 !$acc end kernels
3903 # undef ncol
3904       end subroutine taumol21
3905
3906 !----------------------------------------------------------------------------
3907       subroutine taumol22(ncol, nlayers, &
3908                           colh2o, colco2, colch4, colo2, colo3, colmol, &
3909                           laytrop, jp, jt, jt1, &
3910                           fac00, fac01, fac10, fac11, &
3911                           selffac, selffrac, indself, forfac, forfrac, indfor, &
3912                           sfluxzen, taug, taur)
3913 !----------------------------------------------------------------------------
3914 !
3915 !     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
3916 !
3917 !----------------------------------------------------------------------------
3918
3919 ! ------- Modules -------
3920
3921       use parrrsw_f, only : ng22, ngs21
3922       use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, &
3923                             sfluxref, rayl, layreffr, strrat
3924 !      use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, &
3925 !                            sfluxref, rayl
3926
3927 ! ------- Declarations -------
3928       integer , intent(in) :: ncol
3929       integer , intent(in) :: nlayers               ! total number of layers
3930
3931       integer , intent(in) :: laytrop(:)            ! tropopause layer index
3932       integer , intent(in) :: jp(:,:)               !
3933       integer , intent(in) :: jt(:,:)               !
3934       integer , intent(in) :: jt1(:,:)              !
3935                                                     !   Dimensions: (ncol,nlayers)
3936
3937       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
3938       real , intent(in) :: colco2(:,:)              ! column amount (co2)
3939       real , intent(in) :: colo3(:,:)               ! column amount (o3)
3940       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
3941       real , intent(in) :: colo2(:,:)               ! column amount (o2)
3942       real , intent(in) :: colmol(:,:)              !
3943                                                     !   Dimensions: (ncol,nlayers)
3944
3945       integer , intent(in) :: indself(:,:)
3946       integer , intent(in) :: indfor(:,:)
3947       real , intent(in) :: selffac(:,:)
3948       real , intent(in) :: selffrac(:,:)
3949       real , intent(in) :: forfac(:,:)
3950       real , intent(in) :: forfrac(:,:)
3951                                                     !   Dimensions: (ncol,nlayers)
3952
3953       real , intent(in) :: &                        !
3954                        fac00(:,:) , fac01(:,:) , &
3955                        fac10(:,:) , fac11(:,:)
3956                                                     !   Dimensions: (ncol,nlayers)
3957
3958 ! ----- Output -----
3959       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
3960                                                          !   Dimensions: (ncol,ngptsw)
3961       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
3962                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3963       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
3964                                                          !   Dimensions: (ncol,nlayers,ngptsw)
3965
3966 ! Local
3967 #ifdef _ACCEL
3968       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
3969 #else
3970 # define ncol CHNK
3971       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
3972 #endif
3973
3974       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3975                   fac110, fac111, fs, speccomb, specmult, specparm, &
3976                   tauray, o2adj, o2cont
3977 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
3978 !                  layreffr
3979 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
3980 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
3981 !                  tauray, o2adj, o2cont, strrat
3982       integer :: iplon
3983
3984 ! The following factor is the ratio of total O2 band intensity (lines
3985 ! and Mate continuum) to O2 band intensity (line only).  It is needed
3986 ! to adjust the optical depths since the k's include only lines.
3987       o2adj = 1.6
3988
3989 ! Compute the optical depth by interpolating in ln(pressure),
3990 ! temperature, and appropriate species.  Below LAYTROP, the water
3991 ! vapor self-continuum is interpolated (in temperature) separately.
3992
3993 !      strrat = 0.022708
3994 !      layreffr = 2
3995
3996 #ifdef _ACCEL
3997 !$acc kernels loop independent private(laysolfr)
3998       do iplon=1,ncol
3999
4000       laysolfr = laytrop(iplon)
4001
4002 ! Lower atmosphere loop
4003 !$acc loop seq
4004          do lay = 1, laytrop(iplon)
4005 #else
4006       laysolfr = laytrop
4007 # define laysolfr LAYSOLFR(iplon)
4008       do lay = 1, nlayers
4009         do iplon = 1, ncol
4010           if (lay <= laytrop(iplon)) then
4011 #endif
4012
4013             if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
4014             laysolfr = min(lay+1,laytrop(iplon) )
4015
4016             if (lay .eq. laysolfr) then
4017             speccomb = colh2o(iplon,lay)  + o2adj*strrat*colo2(iplon,lay)
4018             specparm = colh2o(iplon,lay) /speccomb
4019             if (specparm .ge. oneminus) specparm = oneminus
4020             specmult = 8. *(specparm)
4021     !         odadj = specparm + o2adj * (1.  - specparm)
4022             js = 1 + int(specmult)
4023             fs = mod(specmult, 1.  )
4024             do ig = 1, ng22
4025
4026                sfluxzen(iplon,ngs21+ig)  = sfluxref(ig,js) &
4027                 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4028             end do
4029             end if
4030 #ifdef _ACCEL
4031 #else
4032 # undef laysolfr
4033          endif
4034 #endif
4035          end do
4036       end do
4037  !$acc end kernels
4038
4039 ! Lower atmosphere loop
4040 !$acc kernels
4041 IKLOOP1_S
4042
4043          if (lay<=laytrop(iplon)) then
4044
4045          o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 )
4046          speccomb = colh2o(iplon,lay)  + o2adj*strrat*colo2(iplon,lay)
4047          specparm = colh2o(iplon,lay) /speccomb
4048          if (specparm .ge. oneminus) specparm = oneminus
4049          specmult = 8. *(specparm)
4050 !         odadj = specparm + o2adj * (1.  - specparm)
4051          js = 1 + int(specmult)
4052          fs = mod(specmult, 1.  )
4053          fac000 = (1.  - fs) * fac00(iplon,lay)
4054          fac010 = (1.  - fs) * fac10(iplon,lay)
4055          fac100 = fs * fac00(iplon,lay)
4056          fac110 = fs * fac10(iplon,lay)
4057          fac001 = (1.  - fs) * fac01(iplon,lay)
4058          fac011 = (1.  - fs) * fac11(iplon,lay)
4059          fac101 = fs * fac01(iplon,lay)
4060          fac111 = fs * fac11(iplon,lay)
4061          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(22) + js
4062          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(22) + js
4063          inds = indself(iplon,lay)
4064          indf = indfor(iplon,lay)
4065          tauray = colmol(iplon,lay)  * rayl
4066
4067          do ig = 1, ng22
4068             taug(iplon,lay,ngs21+ig)  = speccomb * &
4069                 (fac000 * absa(ind0,ig) + &
4070                  fac100 * absa(ind0+1,ig) + &
4071                  fac010 * absa(ind0+9,ig) + &
4072                  fac110 * absa(ind0+10,ig) + &
4073                  fac001 * absa(ind1,ig) + &
4074                  fac101 * absa(ind1+1,ig) + &
4075                  fac011 * absa(ind1+9,ig) + &
4076                  fac111 * absa(ind1+10,ig)) + &
4077                  colh2o(iplon,lay)  * &
4078                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
4079                  selffrac(iplon,lay)  * &
4080                   (selfref(inds+1,ig) - selfref(inds,ig))) + &
4081                  forfac(iplon,lay)  * (forref(indf,ig) + &
4082                  forfrac(iplon,lay)  * &
4083                  (forref(indf+1,ig) - forref(indf,ig)))) &
4084                  + o2cont
4085 !            ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
4086
4087             taur(iplon,lay,ngs21+ig)  = tauray
4088          enddo
4089
4090          else
4091
4092 ! Upper atmosphere loop
4093
4094          o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 )
4095          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(22) + 1
4096          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(22) + 1
4097          tauray = colmol(iplon,lay)  * rayl
4098
4099          do ig = 1, ng22
4100             taug(iplon,lay,ngs21+ig)  = colo2(iplon,lay)  * o2adj * &
4101                 (fac00(iplon,lay)  * absb(ind0,ig) + &
4102                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
4103                  fac01(iplon,lay)  * absb(ind1,ig) + &
4104                  fac11(iplon,lay)  * absb(ind1+1,ig)) + &
4105                  o2cont
4106 !            ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
4107             taur(iplon,lay,ngs21+ig)  = tauray
4108          enddo
4109          end if
4110 IKLOOP1_E
4111
4112 !$acc end kernels
4113 # undef ncol
4114       end subroutine taumol22
4115
4116 !----------------------------------------------------------------------------
4117       subroutine taumol23(ncol, nlayers, &
4118                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4119                           laytrop, jp, jt, jt1, &
4120                           fac00, fac01, fac10, fac11, &
4121                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4122                           sfluxzen, taug, taur)
4123 !----------------------------------------------------------------------------
4124 !
4125 !     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
4126 !
4127 !----------------------------------------------------------------------------
4128
4129 ! ------- Modules -------
4130
4131       use parrrsw_f, only : ng23, ngs22
4132       use rrsw_kg23_f, only : absa, ka, forref, selfref, &
4133                             sfluxref, rayl, layreffr, givfac
4134 !      use rrsw_kg23_f, only : absa, ka, forref, selfref, &
4135 !                            sfluxref, rayl
4136
4137 ! ------- Declarations -------
4138       integer , intent(in) :: ncol
4139       integer , intent(in) :: nlayers               ! total number of layers
4140
4141       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4142       integer , intent(in) :: jp(:,:)               !
4143       integer , intent(in) :: jt(:,:)               !
4144       integer , intent(in) :: jt1(:,:)              !
4145                                                     !   Dimensions: (ncol,nlayers)
4146
4147       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4148       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4149       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4150       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4151       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4152       real , intent(in) :: colmol(:,:)              !
4153                                                     !   Dimensions: (ncol,nlayers)
4154
4155       integer , intent(in) :: indself(:,:)
4156       integer , intent(in) :: indfor(:,:)
4157       real , intent(in) :: selffac(:,:)
4158       real , intent(in) :: selffrac(:,:)
4159       real , intent(in) :: forfac(:,:)
4160       real , intent(in) :: forfrac(:,:)
4161                                                     !   Dimensions: (ncol,nlayers)
4162
4163       real , intent(in) :: &                        !
4164                        fac00(:,:) , fac01(:,:) , &
4165                        fac10(:,:) , fac11(:,:)
4166                                                     !   Dimensions: (ncol,nlayers)
4167
4168 ! ----- Output -----
4169       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4170                                                          !   Dimensions: (ncol,ngptsw)
4171       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4172                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4173       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4174                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4175
4176 ! Local
4177 #ifdef _ACCEL
4178       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4179 #else
4180 # define ncol CHNK
4181       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4182 #endif
4183
4184       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4185                   fac110, fac111, fs, speccomb, specmult, specparm, &
4186                   tauray
4187 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
4188 !                  layreffr
4189 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4190 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
4191 !                  tauray, givfac
4192       integer :: iplon
4193
4194
4195 ! Average Giver et al. correction factor for this band.
4196 !      givfac = 1.029
4197
4198 ! Compute the optical depth by interpolating in ln(pressure),
4199 ! temperature, and appropriate species.  Below LAYTROP, the water
4200 ! vapor self-continuum is interpolated (in temperature) separately.
4201
4202 !      layreffr = 6
4203
4204 #ifdef _ACCEL
4205 !$acc kernels loop independent private(laysolfr)
4206       do iplon=1,ncol
4207
4208       laysolfr = laytrop(iplon)
4209
4210 ! Lower atmosphere loop
4211 !$acc loop seq
4212       do lay = 1, laytrop(iplon)
4213 #else
4214       laysolfr = laytrop
4215 # define laysolfr LAYSOLFR(iplon)
4216       do lay = 1, nlayers
4217         do iplon = 1, ncol
4218           if (lay <= laytrop(iplon)) then
4219 #endif
4220
4221           if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
4222             laysolfr = min(lay+1,laytrop(iplon) )
4223
4224           if (lay .eq. laysolfr) then
4225             do ig = 1, ng23
4226               sfluxzen(iplon,ngs22+ig)  = sfluxref(ig)
4227             end do
4228           end if
4229 #ifdef _ACCEL
4230 #else
4231 # undef laysolfr
4232          endif
4233 #endif
4234       end do
4235       end do
4236 !$acc end kernels
4237
4238
4239 ! Lower atmosphere loop
4240 !$acc kernels
4241 IKLOOP1_S
4242          if (lay <= laytrop(iplon)) then
4243          if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
4244             laysolfr = min(lay+1,laytrop(iplon) )
4245          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(23) + 1
4246          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(23) + 1
4247          inds = indself(iplon,lay)
4248          indf = indfor(iplon,lay)
4249
4250          do ig = 1, ng23
4251             tauray = colmol(iplon,lay)  * rayl(ig)
4252             taug(iplon,lay,ngs22+ig)  = colh2o(iplon,lay)  * &
4253                 (givfac * (fac00(iplon,lay)  * absa(ind0,ig) + &
4254                  fac10(iplon,lay)  * absa(ind0+1,ig) + &
4255                  fac01(iplon,lay)  * absa(ind1,ig) + &
4256                  fac11(iplon,lay)  * absa(ind1+1,ig)) + &
4257                  selffac(iplon,lay)  * (selfref(inds,ig) + &
4258                  selffrac(iplon,lay)  * &
4259                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
4260                  forfac(iplon,lay)  * (forref(indf,ig) + &
4261                  forfrac(iplon,lay)  * &
4262                  (forref(indf+1,ig) - forref(indf,ig))))
4263 !            ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
4264
4265             taur(iplon,lay,ngs22+ig)  = tauray
4266          enddo
4267
4268          else
4269
4270 ! Upper atmosphere loop
4271
4272          do ig = 1, ng23
4273 !            taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
4274 !            ssa(lay,ngs22+ig) = 1.0
4275             taug(iplon,lay,ngs22+ig)  = 0.
4276             taur(iplon,lay,ngs22+ig)  = colmol(iplon,lay)  * rayl(ig)
4277          enddo
4278          end if
4279
4280 IKLOOP1_E
4281
4282 !$acc end kernels
4283 # undef ncol
4284       end subroutine taumol23
4285
4286 !----------------------------------------------------------------------------
4287       subroutine taumol24(ncol, nlayers, &
4288                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4289                           laytrop, jp, jt, jt1, &
4290                           fac00, fac01, fac10, fac11, &
4291                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4292                           sfluxzen, taug, taur)
4293 !----------------------------------------------------------------------------
4294 !
4295 !     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
4296 !
4297 !----------------------------------------------------------------------------
4298
4299 ! ------- Modules -------
4300
4301       use parrrsw_f, only : ng24, ngs23
4302       use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, &
4303                             sfluxref, abso3a, abso3b, rayla, raylb, &
4304                             layreffr, strrat
4305 !      use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, &
4306 !                            sfluxref, abso3a, abso3b, rayla, raylb
4307
4308 ! ------- Declarations -------
4309       integer , intent(in) :: ncol
4310       integer , intent(in) :: nlayers               ! total number of layers
4311
4312       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4313       integer , intent(in) :: jp(:,:)               !
4314       integer , intent(in) :: jt(:,:)               !
4315       integer , intent(in) :: jt1(:,:)              !
4316                                                     !   Dimensions: (ncol,nlayers)
4317
4318       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4319       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4320       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4321       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4322       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4323       real , intent(in) :: colmol(:,:)              !
4324                                                     !   Dimensions: (ncol,nlayers)
4325
4326       integer , intent(in) :: indself(:,:)
4327       integer , intent(in) :: indfor(:,:)
4328       real , intent(in) :: selffac(:,:)
4329       real , intent(in) :: selffrac(:,:)
4330       real , intent(in) :: forfac(:,:)
4331       real , intent(in) :: forfrac(:,:)
4332                                                     !   Dimensions: (ncol,nlayers)
4333
4334       real , intent(in) :: &                        !
4335                        fac00(:,:) , fac01(:,:) , &
4336                        fac10(:,:) , fac11(:,:)
4337                                                     !   Dimensions: (ncol,nlayers)
4338
4339 ! ----- Output -----
4340       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4341                                                          !   Dimensions: (ncol,ngptsw)
4342       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4343                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4344       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4345                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4346
4347 ! Local
4348 #ifdef _ACCEL
4349       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4350 #else
4351 # define ncol CHNK
4352       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4353 #endif
4354
4355       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4356                   fac110, fac111, fs, speccomb, specmult, specparm, &
4357                   tauray
4358 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
4359 !                  layreffr
4360 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4361 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
4362 !                  tauray, strrat
4363       integer :: iplon
4364
4365 !      strrat = 0.124692
4366 !      layreffr = 1
4367
4368 #ifdef _ACCEL
4369 !$acc kernels loop independent private(laysolfr)
4370       do iplon=1,ncol
4371 ! Compute the optical depth by interpolating in ln(pressure),
4372 ! temperature, and appropriate species.  Below LAYTROP, the water
4373 ! vapor self-continuum is interpolated (in temperature) separately.
4374
4375       laysolfr = laytrop(iplon)
4376
4377 ! Lower atmosphere loop
4378 !$acc loop independent
4379       do lay = 1, laytrop(iplon)
4380 #else
4381       laysolfr = laytrop
4382 # define laysolfr LAYSOLFR(iplon)
4383       do lay = 1, nlayers
4384         do iplon = 1, ncol
4385           if (lay <= laytrop(iplon)) then
4386 #endif
4387
4388           if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
4389             laysolfr = min(lay+1,laytrop(iplon) )
4390           if (lay .eq. laysolfr) then
4391                  speccomb = colh2o(iplon,lay)  + strrat*colo2(iplon,lay)
4392             specparm = colh2o(iplon,lay) /speccomb
4393             if (specparm .ge. oneminus) specparm = oneminus
4394             specmult = 8. *(specparm)
4395             js = 1 + int(specmult)
4396             fs = mod(specmult, 1.  )
4397           do ig = 1, ng24
4398            sfluxzen(iplon,ngs23+ig)  = sfluxref(ig,js) &
4399                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
4400           end do
4401           end if
4402 #ifdef _ACCEL
4403 #else
4404 # undef laysolfr
4405          endif
4406 #endif
4407       end do
4408       end do
4409 !$acc end kernels
4410
4411 !$acc kernels
4412 IKLOOP1_S
4413 ! Compute the optical depth by interpolating in ln(pressure),
4414 ! temperature, and appropriate species.  Below LAYTROP, the water
4415 ! vapor self-continuum is interpolated (in temperature) separately.
4416
4417 ! Lower atmosphere loop
4418          if (lay <= laytrop(iplon)) then
4419
4420          speccomb = colh2o(iplon,lay)  + strrat*colo2(iplon,lay)
4421          specparm = colh2o(iplon,lay) /speccomb
4422          if (specparm .ge. oneminus) specparm = oneminus
4423          specmult = 8. *(specparm)
4424          js = 1 + int(specmult)
4425          fs = mod(specmult, 1.  )
4426          fac000 = (1.  - fs) * fac00(iplon,lay)
4427          fac010 = (1.  - fs) * fac10(iplon,lay)
4428          fac100 = fs * fac00(iplon,lay)
4429          fac110 = fs * fac10(iplon,lay)
4430          fac001 = (1.  - fs) * fac01(iplon,lay)
4431          fac011 = (1.  - fs) * fac11(iplon,lay)
4432          fac101 = fs * fac01(iplon,lay)
4433          fac111 = fs * fac11(iplon,lay)
4434          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(24) + js
4435          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(24) + js
4436          inds = indself(iplon,lay)
4437          indf = indfor(iplon,lay)
4438
4439          do ig = 1, ng24
4440             tauray = colmol(iplon,lay)  * (rayla(ig,js) + &
4441                fs * (rayla(ig,js+1) - rayla(ig,js)))
4442             taug(iplon,lay,ngs23+ig)  = speccomb * &
4443                 (fac000 * absa(ind0,ig) + &
4444                  fac100 * absa(ind0+1,ig) + &
4445                  fac010 * absa(ind0+9,ig) + &
4446                  fac110 * absa(ind0+10,ig) + &
4447                  fac001 * absa(ind1,ig) + &
4448                  fac101 * absa(ind1+1,ig) + &
4449                  fac011 * absa(ind1+9,ig) + &
4450                  fac111 * absa(ind1+10,ig)) + &
4451                  colo3(iplon,lay)  * abso3a(ig) + &
4452                  colh2o(iplon,lay)  * &
4453                  (selffac(iplon,lay)  * (selfref(inds,ig) + &
4454                  selffrac(iplon,lay)  * &
4455                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
4456                  forfac(iplon,lay)  * (forref(indf,ig) + &
4457                  forfrac(iplon,lay)  * &
4458                  (forref(indf+1,ig) - forref(indf,ig))))
4459 !            ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
4460
4461             taur(iplon,lay,ngs23+ig)  = tauray
4462          enddo
4463
4464          else
4465
4466 ! Upper atmosphere loop
4467
4468          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(24) + 1
4469          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(24) + 1
4470
4471          do ig = 1, ng24
4472             tauray = colmol(iplon,lay)  * raylb(ig)
4473             taug(iplon,lay,ngs23+ig)  = colo2(iplon,lay)  * &
4474                 (fac00(iplon,lay)  * absb(ind0,ig) + &
4475                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
4476                  fac01(iplon,lay)  * absb(ind1,ig) + &
4477                  fac11(iplon,lay)  * absb(ind1+1,ig)) + &
4478                  colo3(iplon,lay)  * abso3b(ig)
4479 !            ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
4480             taur(iplon,lay,ngs23+ig)  = tauray
4481          enddo
4482          endif
4483
4484 IKLOOP1_E
4485
4486 !$acc end kernels
4487 # undef ncol
4488       end subroutine taumol24
4489
4490 !----------------------------------------------------------------------------
4491       subroutine taumol25(ncol, nlayers, &
4492                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4493                           laytrop, jp, jt, jt1, &
4494                           fac00, fac01, fac10, fac11, &
4495                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4496                           sfluxzen, taug, taur)
4497 !----------------------------------------------------------------------------
4498 !
4499 !     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
4500 !
4501 !----------------------------------------------------------------------------
4502
4503 ! ------- Modules -------
4504
4505       use parrrsw_f, only : ng25, ngs24
4506       use rrsw_kg25_f, only : absa, ka, &
4507                             sfluxref, abso3a, abso3b, rayl, layreffr
4508 !      use rrsw_kg25_f, only : absa, ka, &
4509 !                            sfluxref, abso3a, abso3b, rayl
4510
4511 ! ------- Declarations -------
4512       integer , intent(in) :: ncol
4513       integer , intent(in) :: nlayers               ! total number of layers
4514
4515       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4516       integer , intent(in) :: jp(:,:)               !
4517       integer , intent(in) :: jt(:,:)               !
4518       integer , intent(in) :: jt1(:,:)              !
4519                                                     !   Dimensions: (ncol,nlayers)
4520
4521       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4522       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4523       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4524       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4525       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4526       real , intent(in) :: colmol(:,:)              !
4527                                                     !   Dimensions: (ncol,nlayers)
4528
4529       integer , intent(in) :: indself(:,:)
4530       integer , intent(in) :: indfor(:,:)
4531       real , intent(in) :: selffac(:,:)
4532       real , intent(in) :: selffrac(:,:)
4533       real , intent(in) :: forfac(:,:)
4534       real , intent(in) :: forfrac(:,:)
4535                                                     !   Dimensions: (ncol,nlayers)
4536
4537       real , intent(in) :: &                        !
4538                        fac00(:,:) , fac01(:,:) , &
4539                        fac10(:,:) , fac11(:,:)
4540                                                     !   Dimensions: (ncol,nlayers)
4541
4542 ! ----- Output -----
4543       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4544                                                          !   Dimensions: (ncol,ngptsw)
4545       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4546                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4547       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4548                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4549
4550 ! Local
4551 #ifdef _ACCEL
4552       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4553 #else
4554 # define ncol CHNK
4555       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4556 #endif
4557
4558
4559 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
4560 !                  layreffr
4561       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4562                   fac110, fac111, fs, speccomb, specmult, specparm, &
4563                   tauray
4564       integer :: iplon
4565
4566 #ifdef _ACCEL
4567 !$acc kernels
4568       do iplon=1,ncol
4569 ! Compute the optical depth by interpolating in ln(pressure),
4570 ! temperature, and appropriate species.  Below LAYTROP, the water
4571 ! vapor self-continuum is interpolated (in temperature) separately.
4572
4573 !      layreffr = 2
4574       laysolfr = laytrop(iplon)
4575
4576 ! Lower atmosphere loop
4577       do lay = 1, laytrop(iplon)
4578 #else
4579       laysolfr = laytrop
4580 # define laysolfr LAYSOLFR(iplon)
4581       do lay = 1, nlayers
4582         do iplon = 1, ncol
4583           if (lay <= laytrop(iplon)) then
4584 #endif
4585          if (jp(iplon,lay)  .lt. layreffr .and. jp(iplon,lay+1)  .ge. layreffr) &
4586             laysolfr = min(lay+1,laytrop(iplon) )
4587          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(25) + 1
4588          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(25) + 1
4589
4590          do ig = 1, ng25
4591             tauray = colmol(iplon,lay)  * rayl(ig)
4592             taug(iplon,lay,ngs24+ig)  = colh2o(iplon,lay)  * &
4593                 (fac00(iplon,lay)  * absa(ind0,ig) + &
4594                  fac10(iplon,lay)  * absa(ind0+1,ig) + &
4595                  fac01(iplon,lay)  * absa(ind1,ig) + &
4596                  fac11(iplon,lay)  * absa(ind1+1,ig)) + &
4597                  colo3(iplon,lay)  * abso3a(ig)
4598 !            ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
4599             if (lay .eq. laysolfr) sfluxzen(iplon,ngs24+ig)  = sfluxref(ig)
4600             taur(iplon,lay,ngs24+ig)  = tauray
4601          enddo
4602 #ifdef _ACCEL
4603       enddo
4604 ! Upper atmosphere loop
4605       do lay = laytrop(iplon) +1, nlayers
4606 #else
4607       else
4608 #endif
4609
4610          do ig = 1, ng25
4611             tauray = colmol(iplon,lay)  * rayl(ig)
4612             taug(iplon,lay,ngs24+ig)  = colo3(iplon,lay)  * abso3b(ig)
4613 !            ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
4614             taur(iplon,lay,ngs24+ig)  = tauray
4615          enddo
4616 #ifdef _ACCEL
4617 #else
4618 # undef laysolfr
4619       endif
4620 #endif
4621       enddo
4622       enddo
4623
4624 !$acc end kernels
4625 # undef ncol
4626       end subroutine taumol25
4627
4628 !----------------------------------------------------------------------------
4629       subroutine taumol26(ncol, nlayers, &
4630                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4631                           laytrop, jp, jt, jt1, &
4632                           fac00, fac01, fac10, fac11, &
4633                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4634                           sfluxzen, taug, taur)
4635 !----------------------------------------------------------------------------
4636 !
4637 !     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
4638 !
4639 !----------------------------------------------------------------------------
4640
4641 ! ------- Modules -------
4642
4643       use parrrsw_f, only : ng26, ngs25
4644       use rrsw_kg26_f, only : sfluxref, rayl
4645
4646 ! ------- Declarations -------
4647       integer , intent(in) :: ncol
4648       integer , intent(in) :: nlayers               ! total number of layers
4649
4650       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4651       integer , intent(in) :: jp(:,:)               !
4652       integer , intent(in) :: jt(:,:)               !
4653       integer , intent(in) :: jt1(:,:)              !
4654                                                     !   Dimensions: (ncol,nlayers)
4655
4656       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4657       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4658       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4659       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4660       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4661       real , intent(in) :: colmol(:,:)              !
4662                                                     !   Dimensions: (ncol,nlayers)
4663
4664       integer , intent(in) :: indself(:,:)
4665       integer , intent(in) :: indfor(:,:)
4666       real , intent(in) :: selffac(:,:)
4667       real , intent(in) :: selffrac(:,:)
4668       real , intent(in) :: forfac(:,:)
4669       real , intent(in) :: forfrac(:,:)
4670                                                     !   Dimensions: (ncol,nlayers)
4671
4672       real , intent(in) :: &                        !
4673                        fac00(:,:) , fac01(:,:) , &
4674                        fac10(:,:) , fac11(:,:)
4675                                                     !   Dimensions: (ncol,nlayers)
4676
4677 ! ----- Output -----
4678       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4679                                                          !   Dimensions: (ncol,ngptsw)
4680       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4681                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4682       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4683                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4684
4685 ! Local
4686 #ifdef _ACCEL
4687       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4688 #else
4689 # define ncol CHNK
4690       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4691 #endif
4692
4693       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4694                   fac110, fac111, fs, speccomb, specmult, specparm, &
4695                   tauray
4696       integer :: iplon
4697
4698 #ifdef _ACCEL
4699 !$acc kernels
4700       do iplon=1,ncol
4701 ! Compute the optical depth by interpolating in ln(pressure),
4702 ! temperature, and appropriate species.  Below LAYTROP, the water
4703 ! vapor self-continuum is interpolated (in temperature) separately.
4704
4705       laysolfr = laytrop(iplon)
4706
4707 ! Lower atmosphere loop
4708       do lay = 1, laytrop(iplon)
4709 #else
4710       laysolfr = laytrop
4711 # define laysolfr LAYSOLFR(iplon)
4712       do lay = 1, nlayers
4713         do iplon = 1, ncol
4714           if (lay <= laytrop(iplon)) then
4715 #endif
4716          do ig = 1, ng26
4717 !            taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4718 !            ssa(lay,ngs25+ig) = 1.0
4719             if (lay .eq. laysolfr) sfluxzen(iplon,ngs25+ig)  = sfluxref(ig)
4720             taug(iplon,lay,ngs25+ig)  = 0.
4721             taur(iplon,lay,ngs25+ig)  = colmol(iplon,lay)  * rayl(ig)
4722          enddo
4723 #ifdef _ACCEL
4724       enddo
4725       do lay = laytrop(iplon) +1, nlayers
4726 #else
4727       else
4728 #endif
4729
4730 ! Upper atmosphere loop
4731          do ig = 1, ng26
4732 !            taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
4733 !            ssa(lay,ngs25+ig) = 1.0
4734             taug(iplon,lay,ngs25+ig)  = 0.
4735             taur(iplon,lay,ngs25+ig)  = colmol(iplon,lay)  * rayl(ig)
4736          enddo
4737 #ifdef _ACCEL
4738 #else
4739 # undef laysolfr
4740       endif
4741 #endif
4742       enddo
4743       enddo
4744
4745 !$acc end kernels
4746 # undef ncol
4747       end subroutine taumol26
4748
4749 !----------------------------------------------------------------------------
4750       subroutine taumol27(ncol, nlayers, &
4751                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4752                           laytrop, jp, jt, jt1, &
4753                           fac00, fac01, fac10, fac11, &
4754                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4755                           sfluxzen, taug, taur)
4756 !----------------------------------------------------------------------------
4757 !
4758 !     band 27:  29000-38000 cm-1 (low - o3; high - o3)
4759 !
4760 !----------------------------------------------------------------------------
4761
4762 ! ------- Modules -------
4763
4764       use parrrsw_f, only : ng27, ngs26
4765       use rrsw_kg27_f, only : absa, ka, absb, kb, &
4766                             sfluxref, rayl, layreffr, scalekur
4767 !      use rrsw_kg27_f, only : absa, ka, absb, kb, sfluxref, rayl
4768
4769 ! ------- Declarations -------
4770       integer , intent(in) :: ncol
4771       integer , intent(in) :: nlayers               ! total number of layers
4772
4773       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4774       integer , intent(in) :: jp(:,:)               !
4775       integer , intent(in) :: jt(:,:)               !
4776       integer , intent(in) :: jt1(:,:)              !
4777                                                     !   Dimensions: (ncol,nlayers)
4778
4779       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4780       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4781       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4782       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4783       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4784       real , intent(in) :: colmol(:,:)              !
4785                                                     !   Dimensions: (ncol,nlayers)
4786
4787       integer , intent(in) :: indself(:,:)
4788       integer , intent(in) :: indfor(:,:)
4789       real , intent(in) :: selffac(:,:)
4790       real , intent(in) :: selffrac(:,:)
4791       real , intent(in) :: forfac(:,:)
4792       real , intent(in) :: forfrac(:,:)
4793                                                     !   Dimensions: (ncol,nlayers)
4794
4795       real , intent(in) :: &                        !
4796                        fac00(:,:) , fac01(:,:) , &
4797                        fac10(:,:) , fac11(:,:)
4798                                                     !   Dimensions: (ncol,nlayers)
4799
4800 ! ----- Output -----
4801       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4802                                                          !   Dimensions: (ncol,ngptsw)
4803       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4804                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4805       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4806                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4807
4808 ! Local
4809 #ifdef _ACCEL
4810       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4811 #else
4812 # define ncol CHNK
4813       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4814 #endif
4815
4816       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4817                   fac110, fac111, fs, speccomb, specmult, specparm, &
4818                   tauray
4819 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
4820 !                  layreffr
4821 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4822 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
4823 !                  tauray, scalekur
4824       integer :: iplon
4825
4826 #ifdef _ACCEL
4827 !$acc kernels
4828       do iplon=1,ncol
4829 ! Kurucz solar source function
4830 ! The values in sfluxref were obtained using the "low resolution"
4831 ! version of the Kurucz solar source function.  For unknown reasons,
4832 ! the total irradiance in this band differs from the corresponding
4833 ! total in the "high-resolution" version of the Kurucz function.
4834 ! Therefore, these values are scaled below by the factor SCALEKUR.
4835
4836 !      scalekur = 50.15 /48.37
4837
4838 ! Compute the optical depth by interpolating in ln(pressure),
4839 ! temperature, and appropriate species.  Below LAYTROP, the water
4840 ! vapor self-continuum is interpolated (in temperature) separately.
4841
4842 !      layreffr = 32
4843
4844 ! Lower atmosphere loop
4845       do lay = 1, laytrop(iplon)
4846 #else
4847       laysolfr = nlayers
4848 # define laysolfr LAYSOLFR(iplon)
4849       do lay = 1, nlayers
4850         do iplon = 1, ncol
4851           if (lay <= laytrop(iplon)) then
4852 #endif
4853          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(27) + 1
4854          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(27) + 1
4855
4856          do ig = 1, ng27
4857             tauray = colmol(iplon,lay)  * rayl(ig)
4858             taug(iplon,lay,ngs26+ig)  = colo3(iplon,lay)  * &
4859                 (fac00(iplon,lay)  * absa(ind0,ig) + &
4860                  fac10(iplon,lay)  * absa(ind0+1,ig) + &
4861                  fac01(iplon,lay)  * absa(ind1,ig) + &
4862                  fac11(iplon,lay)  * absa(ind1+1,ig))
4863 !            ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
4864             taur(iplon,lay,ngs26+ig)  = tauray
4865          enddo
4866 #ifdef _ACCEL
4867       enddo
4868
4869       laysolfr = nlayers
4870
4871 ! Upper atmosphere loop
4872       do lay = laytrop(iplon) +1, nlayers
4873 #else
4874       else
4875 #endif
4876          if (jp(iplon,lay-1)  .lt. layreffr .and. jp(iplon,lay)  .ge. layreffr) &
4877             laysolfr = lay
4878          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(27) + 1
4879          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(27) + 1
4880
4881          do ig = 1, ng27
4882             tauray = colmol(iplon,lay)  * rayl(ig)
4883             taug(iplon,lay,ngs26+ig)  = colo3(iplon,lay)  * &
4884                 (fac00(iplon,lay)  * absb(ind0,ig) + &
4885                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
4886                  fac01(iplon,lay)  * absb(ind1,ig) + &
4887                  fac11(iplon,lay)  * absb(ind1+1,ig))
4888 !            ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
4889             if (lay.eq.laysolfr) sfluxzen(iplon,ngs26+ig)  = scalekur * sfluxref(ig)
4890             taur(iplon,lay,ngs26+ig)  = tauray
4891          enddo
4892 #ifdef _ACCEL
4893 #else
4894 # undef laysolfr
4895       endif
4896 #endif
4897       enddo
4898       enddo
4899
4900 !$acc end kernels
4901 # undef ncol
4902       end subroutine taumol27
4903
4904 !----------------------------------------------------------------------------
4905       subroutine taumol28(ncol, nlayers, &
4906                           colh2o, colco2, colch4, colo2, colo3, colmol, &
4907                           laytrop, jp, jt, jt1, &
4908                           fac00, fac01, fac10, fac11, &
4909                           selffac, selffrac, indself, forfac, forfrac, indfor, &
4910                           sfluxzen, taug, taur)
4911 !----------------------------------------------------------------------------
4912 !
4913 !     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
4914 !
4915 !----------------------------------------------------------------------------
4916
4917 ! ------- Modules -------
4918
4919       use parrrsw_f, only : ng28, ngs27
4920       use rrsw_kg28_f, only : absa, ka, absb, kb, &
4921                             sfluxref, rayl, layreffr, strrat
4922 !      use rrsw_kg28_f, only : absa, ka, absb, kb, sfluxref, rayl
4923
4924 ! ------- Declarations -------
4925       integer , intent(in) :: ncol
4926       integer , intent(in) :: nlayers               ! total number of layers
4927
4928       integer , intent(in) :: laytrop(:)            ! tropopause layer index
4929       integer , intent(in) :: jp(:,:)               !
4930       integer , intent(in) :: jt(:,:)               !
4931       integer , intent(in) :: jt1(:,:)              !
4932                                                     !   Dimensions: (ncol,nlayers)
4933
4934       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
4935       real , intent(in) :: colco2(:,:)              ! column amount (co2)
4936       real , intent(in) :: colo3(:,:)               ! column amount (o3)
4937       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
4938       real , intent(in) :: colo2(:,:)               ! column amount (o2)
4939       real , intent(in) :: colmol(:,:)              !
4940                                                     !   Dimensions: (ncol,nlayers)
4941
4942       integer , intent(in) :: indself(:,:)
4943       integer , intent(in) :: indfor(:,:)
4944       real , intent(in) :: selffac(:,:)
4945       real , intent(in) :: selffrac(:,:)
4946       real , intent(in) :: forfac(:,:)
4947       real , intent(in) :: forfrac(:,:)
4948                                                     !   Dimensions: (ncol,nlayers)
4949
4950       real , intent(in) :: &                        !
4951                        fac00(:,:) , fac01(:,:) , &
4952                        fac10(:,:) , fac11(:,:)
4953                                                     !   Dimensions: (ncol,nlayers)
4954
4955 ! ----- Output -----
4956       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
4957                                                          !   Dimensions: (ncol,ngptsw)
4958       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
4959                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4960       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
4961                                                          !   Dimensions: (ncol,nlayers,ngptsw)
4962
4963 ! Local
4964 #ifdef _ACCEL
4965       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
4966 #else
4967 # define ncol CHNK
4968       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
4969 #endif
4970
4971       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4972                   fac110, fac111, fs, speccomb, specmult, specparm, &
4973                   tauray
4974 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
4975 !                  layreffr
4976 !      real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
4977 !                  fac110, fac111, fs, speccomb, specmult, specparm, &
4978 !                  tauray, strrat
4979       integer :: iplon
4980
4981 #ifdef _ACCEL
4982 !$acc kernels
4983       do iplon=1,ncol
4984 ! Compute the optical depth by interpolating in ln(pressure),
4985 ! temperature, and appropriate species.  Below LAYTROP, the water
4986 ! vapor self-continuum is interpolated (in temperature) separately.
4987
4988 !      strrat = 6.67029e-07
4989 !      layreffr = 58
4990
4991 ! Lower atmosphere loop
4992       do lay = 1, laytrop(iplon)
4993 #else
4994       laysolfr = nlayers
4995 # define laysolfr LAYSOLFR(iplon)
4996       do lay = 1, nlayers
4997         do iplon = 1, ncol
4998           if (lay <= laytrop(iplon)) then
4999 #endif
5000          speccomb = colo3(iplon,lay)  + strrat*colo2(iplon,lay)
5001          specparm = colo3(iplon,lay) /speccomb
5002          if (specparm .ge. oneminus) specparm = oneminus
5003          specmult = 8. *(specparm)
5004          js = 1 + int(specmult)
5005          fs = mod(specmult, 1.  )
5006          fac000 = (1.  - fs) * fac00(iplon,lay)
5007          fac010 = (1.  - fs) * fac10(iplon,lay)
5008          fac100 = fs * fac00(iplon,lay)
5009          fac110 = fs * fac10(iplon,lay)
5010          fac001 = (1.  - fs) * fac01(iplon,lay)
5011          fac011 = (1.  - fs) * fac11(iplon,lay)
5012          fac101 = fs * fac01(iplon,lay)
5013          fac111 = fs * fac11(iplon,lay)
5014          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(28) + js
5015          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(28) + js
5016          tauray = colmol(iplon,lay)  * rayl
5017
5018          do ig = 1, ng28
5019             taug(iplon,lay,ngs27+ig)  = speccomb * &
5020                 (fac000 * absa(ind0,ig) + &
5021                  fac100 * absa(ind0+1,ig) + &
5022                  fac010 * absa(ind0+9,ig) + &
5023                  fac110 * absa(ind0+10,ig) + &
5024                  fac001 * absa(ind1,ig) + &
5025                  fac101 * absa(ind1+1,ig) + &
5026                  fac011 * absa(ind1+9,ig) + &
5027                  fac111 * absa(ind1+10,ig))
5028 !            ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
5029             taur(iplon,lay,ngs27+ig)  = tauray
5030          enddo
5031 #ifdef _ACCEL
5032       enddo
5033
5034       laysolfr = nlayers
5035
5036 ! Upper atmosphere loop
5037       do lay = laytrop(iplon) +1, nlayers
5038 #else
5039       else
5040 #endif
5041          if (jp(iplon,lay-1)  .lt. layreffr .and. jp(iplon,lay)  .ge. layreffr) &
5042             laysolfr = lay
5043          speccomb = colo3(iplon,lay)  + strrat*colo2(iplon,lay)
5044          specparm = colo3(iplon,lay) /speccomb
5045          if (specparm .ge. oneminus) specparm = oneminus
5046          specmult = 4. *(specparm)
5047          js = 1 + int(specmult)
5048          fs = mod(specmult, 1.  )
5049          fac000 = (1.  - fs) * fac00(iplon,lay)
5050          fac010 = (1.  - fs) * fac10(iplon,lay)
5051          fac100 = fs * fac00(iplon,lay)
5052          fac110 = fs * fac10(iplon,lay)
5053          fac001 = (1.  - fs) * fac01(iplon,lay)
5054          fac011 = (1.  - fs) * fac11(iplon,lay)
5055          fac101 = fs * fac01(iplon,lay)
5056          fac111 = fs * fac11(iplon,lay)
5057          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(28) + js
5058          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(28) + js
5059          tauray = colmol(iplon,lay)  * rayl
5060
5061          do ig = 1, ng28
5062             taug(iplon,lay,ngs27+ig)  = speccomb * &
5063                 (fac000 * absb(ind0,ig) + &
5064                  fac100 * absb(ind0+1,ig) + &
5065                  fac010 * absb(ind0+5,ig) + &
5066                  fac110 * absb(ind0+6,ig) + &
5067                  fac001 * absb(ind1,ig) + &
5068                  fac101 * absb(ind1+1,ig) + &
5069                  fac011 * absb(ind1+5,ig) + &
5070                  fac111 * absb(ind1+6,ig))
5071 !            ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
5072             if (lay .eq. laysolfr) sfluxzen(iplon,ngs27+ig)  = sfluxref(ig,js) &
5073                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
5074             taur(iplon,lay,ngs27+ig)  = tauray
5075          enddo
5076 #ifdef _ACCEL
5077 #else
5078 # undef laysolfr
5079       endif
5080 #endif
5081       enddo
5082       enddo
5083
5084 !$acc end kernels
5085 # undef ncol
5086       end subroutine taumol28
5087
5088 !----------------------------------------------------------------------------
5089       subroutine taumol29(ncol, nlayers, &
5090                           colh2o, colco2, colch4, colo2, colo3, colmol, &
5091                           laytrop, jp, jt, jt1, &
5092                           fac00, fac01, fac10, fac11, &
5093                           selffac, selffrac, indself, forfac, forfrac, indfor, &
5094                           sfluxzen, taug, taur)
5095 !----------------------------------------------------------------------------
5096 !
5097 !     band 29:  820-2600 cm-1 (low - h2o; high - co2)
5098 !
5099 !----------------------------------------------------------------------------
5100
5101 ! ------- Modules -------
5102
5103       use parrrsw_f, only : ng29, ngs28
5104       use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, &
5105                             sfluxref, absh2o, absco2, rayl, layreffr
5106 !      use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, &
5107 !                            sfluxref, absh2o, absco2, rayl
5108
5109 ! ------- Declarations -------
5110       integer , intent(in) :: ncol
5111       integer , intent(in) :: nlayers               ! total number of layers
5112
5113       integer , intent(in) :: laytrop(:)            ! tropopause layer index
5114       integer , intent(in) :: jp(:,:)               !
5115       integer , intent(in) :: jt(:,:)               !
5116       integer , intent(in) :: jt1(:,:)              !
5117                                                     !   Dimensions: (ncol,nlayers)
5118
5119       real , intent(in) :: colh2o(:,:)              ! column amount (h2o)
5120       real , intent(in) :: colco2(:,:)              ! column amount (co2)
5121       real , intent(in) :: colo3(:,:)               ! column amount (o3)
5122       real , intent(in) :: colch4(:,:)              ! column amount (ch4)
5123       real , intent(in) :: colo2(:,:)               ! column amount (o2)
5124       real , intent(in) :: colmol(:,:)              !
5125                                                     !   Dimensions: (ncol,nlayers)
5126
5127       integer , intent(in) :: indself(:,:)
5128       integer , intent(in) :: indfor(:,:)
5129       real , intent(in) :: selffac(:,:)
5130       real , intent(in) :: selffrac(:,:)
5131       real , intent(in) :: forfac(:,:)
5132       real , intent(in) :: forfrac(:,:)
5133                                                     !   Dimensions: (ncol,nlayers)
5134
5135       real , intent(in) :: &                        !
5136                        fac00(:,:) , fac01(:,:) , &
5137                        fac10(:,:) , fac11(:,:)
5138                                                     !   Dimensions: (ncol,nlayers)
5139
5140 ! ----- Output -----
5141       real, intent(out) gpu_device :: sfluxzen(:,:)      ! solar source function
5142                                                          !   Dimensions: (ncol,ngptsw)
5143       real, intent(out) gpu_device :: taug(:,:,:)        ! gaseous optical depth
5144                                                          !   Dimensions: (ncol,nlayers,ngptsw)
5145       real, intent(out) gpu_device :: taur(:,:,:)        ! Rayleigh
5146                                                          !   Dimensions: (ncol,nlayers,ngptsw)
5147
5148 ! Local
5149 #ifdef _ACCEL
5150       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
5151 #else
5152 # define ncol CHNK
5153       integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
5154 #endif
5155
5156 !      integer  :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
5157 !                  layreffr
5158       real  :: fac000, fac001, fac010, fac011, fac100, fac101, &
5159                   fac110, fac111, fs, speccomb, specmult, specparm, &
5160                   tauray
5161       integer :: iplon
5162
5163 !      layreffr = 49
5164
5165 #ifdef _ACCEL
5166 !$acc kernels loop independent private (laysolfr)
5167       do iplon=1,ncol
5168
5169         laysolfr = nlayers
5170 !$acc loop seq
5171         do lay = laytrop(iplon) +1, nlayers
5172 #else
5173       laysolfr = nlayers
5174 # define laysolfr LAYSOLFR(iplon)
5175       do lay = 1, nlayers
5176         do iplon = 1, ncol
5177           if (lay > laytrop(iplon)) then
5178 #endif
5179          if (jp(iplon,lay-1)  .lt. layreffr .and. jp(iplon,lay)  .ge. layreffr) &
5180             laysolfr = lay
5181
5182             if (lay .eq. laysolfr) then
5183                 do ig = 1, ng29
5184                 sfluxzen(iplon,ngs28+ig)  = sfluxref(ig)
5185                 end do
5186             end if
5187 #ifdef _ACCEL
5188 #else
5189 # undef laysolfr
5190          endif
5191 #endif
5192         end do
5193       end do
5194 !$acc end kernels
5195
5196 #ifdef _ACCEL
5197 !$acc kernels
5198       do iplon=1,ncol
5199 ! Compute the optical depth by interpolating in ln(pressure),
5200 ! temperature, and appropriate species.  Below LAYTROP, the water
5201 ! vapor self-continuum is interpolated (in temperature) separately.
5202
5203 ! Lower atmosphere loop
5204       do lay = 1, nlayers
5205 #else
5206     do lay = 1, nlayers
5207       do iplon=1,ncol
5208 #endif
5209          if (lay <= laytrop(iplon)) then
5210          ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(29) + 1
5211          ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(29) + 1
5212          inds = indself(iplon,lay)
5213          indf = indfor(iplon,lay)
5214          tauray = colmol(iplon,lay)  * rayl
5215
5216          do ig = 1, ng29
5217             taug(iplon,lay,ngs28+ig)  = colh2o(iplon,lay)  * &
5218                ((fac00(iplon,lay)  * absa(ind0,ig) + &
5219                  fac10(iplon,lay)  * absa(ind0+1,ig) + &
5220                  fac01(iplon,lay)  * absa(ind1,ig) + &
5221                  fac11(iplon,lay)  * absa(ind1+1,ig)) + &
5222                  selffac(iplon,lay)  * (selfref(inds,ig) + &
5223                  selffrac(iplon,lay)  * &
5224                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
5225                  forfac(iplon,lay)  * (forref(indf,ig) + &
5226                  forfrac(iplon,lay)  * &
5227                  (forref(indf+1,ig) - forref(indf,ig)))) &
5228                  + colco2(iplon,lay)  * absco2(ig)
5229 !            ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
5230             taur(iplon,lay,ngs28+ig)  = tauray
5231          enddo
5232
5233          else
5234
5235 ! Upper atmosphere loop
5236          ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(29) + 1
5237          ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(29) + 1
5238          tauray = colmol(iplon,lay)  * rayl
5239
5240          do ig = 1, ng29
5241             taug(iplon,lay,ngs28+ig)  = colco2(iplon,lay)  * &
5242                 (fac00(iplon,lay)  * absb(ind0,ig) + &
5243                  fac10(iplon,lay)  * absb(ind0+1,ig) + &
5244                  fac01(iplon,lay)  * absb(ind1,ig) + &
5245                  fac11(iplon,lay)  * absb(ind1+1,ig)) &
5246                  + colh2o(iplon,lay)  * absh2o(ig)
5247 !            ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
5248
5249             taur(iplon,lay,ngs28+ig)  = tauray
5250          enddo
5251          end if
5252
5253       enddo
5254       enddo
5255
5256 !$acc end kernels
5257 # undef ncol
5258       end subroutine taumol29
5259
5260 # undef IKLOOP1_S
5261 # undef IKLOOP1_E
5262 # undef IKLOOP2_S
5263 # undef IKLOOP2_E
5264
5265       end module rrtmg_sw_taumol_f
5266
5267       module rrtmg_sw_init_f
5268
5269 ! ------- Modules -------
5270
5271       use rrsw_wvn_f
5272       use rrtmg_sw_setcoef_f, only: swatmref
5273
5274       implicit none
5275
5276       public rrtmg_sw_ini
5277
5278       contains
5279
5280 ! **************************************************************************
5281       subroutine rrtmg_sw_ini(cpdair)
5282 ! **************************************************************************
5283 !
5284 !  Original version:   Michael J. Iacono; February, 2004
5285 !  Revision for F90 formatting:  M. J. Iacono, July, 2006
5286 !
5287 !  This subroutine performs calculations necessary for the initialization
5288 !  of the shortwave model.  Lookup tables are computed for use in the SW
5289 !  radiative transfer, and input absorption coefficient data for each
5290 !  spectral band are reduced from 224 g-point intervals to 112.
5291 ! **************************************************************************
5292
5293       use parrrsw_f, only : mg, nbndsw, ngptsw
5294       use rrsw_tbl_f, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
5295       use rrsw_vsn_f, only: hvrini, hnamini
5296
5297       real , intent(in) :: cpdair     ! Specific heat capacity of dry air
5298                                       ! at constant pressure at 273 K
5299                                       ! (J kg-1 K-1)
5300
5301 ! ------- Local -------
5302
5303       integer  :: ibnd, igc, ig, ind, ipr
5304       integer  :: igcsm, iprsm
5305       integer  :: itr
5306
5307       real  :: wtsum, wtsm(mg)
5308       real  :: tfn
5309
5310       real , parameter :: expeps = 1.e-20    ! Smallest value for exponential table
5311
5312 ! ------- Definitions -------
5313 !     Arrays for 10000-point look-up tables:
5314 !     TAU_TBL  Clear-sky optical depth
5315 !     EXP_TBL  Exponential lookup table for transmittance
5316 !     PADE     Pade approximation constant (= 0.278)
5317 !     BPADE    Inverse of the Pade approximation constant
5318 !
5319
5320       hvrini = '$Revision: 1.5 $'
5321
5322 ! Initialize model data
5323       call swdatinit(cpdair)
5324       call swcmbdat              ! g-point interval reduction data
5325       call swaerpr               ! aerosol optical properties
5326       call swcldpr               ! cloud optical properties
5327       call swatmref              ! reference MLS profile
5328 ! Moved to module_ra_rrtmg_swf for WRF
5329 !      call sw_kgb16              ! molecular absorption coefficients
5330 !      call sw_kgb17
5331 !      call sw_kgb18
5332 !      call sw_kgb19
5333 !      call sw_kgb20
5334 !      call sw_kgb21
5335 !      call sw_kgb22
5336 !      call sw_kgb23
5337 !      call sw_kgb24
5338 !      call sw_kgb25
5339 !      call sw_kgb26
5340 !      call sw_kgb27
5341 !      call sw_kgb28
5342 !      call sw_kgb29
5343
5344 ! Define exponential lookup tables for transmittance. Tau is
5345 ! computed as a function of the tau transition function, and transmittance
5346 ! is calculated as a function of tau.  All tables are computed at intervals
5347 ! of 0.0001.  The inverse of the constant used in the Pade approximation to
5348 ! the tau transition function is set to bpade.
5349
5350       exp_tbl(0) = 1.0
5351       exp_tbl(ntbl) = expeps
5352       bpade = 1.0  / pade
5353       do itr = 1, ntbl-1
5354          tfn = float(itr) / float(ntbl)
5355          tau_tbl = bpade * tfn / (1.  - tfn)
5356          exp_tbl(itr) = exp(-tau_tbl)
5357          if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
5358       enddo
5359
5360 ! Perform g-point reduction from 16 per band (224 total points) to
5361 ! a band dependent number (112 total points) for all absorption
5362 ! coefficient input data and Planck fraction input data.
5363 ! Compute relative weighting for new g-point combinations.
5364
5365       igcsm = 0
5366       do ibnd = 1,nbndsw
5367          iprsm = 0
5368          if (ngc(ibnd).lt.mg) then
5369             do igc = 1,ngc(ibnd)
5370                igcsm = igcsm + 1
5371                wtsum = 0.
5372                do ipr = 1, ngn(igcsm)
5373                   iprsm = iprsm + 1
5374                   wtsum = wtsum + wt(iprsm)
5375                enddo
5376                wtsm(igc) = wtsum
5377             enddo
5378             do ig = 1, ng(ibnd+15)
5379                ind = (ibnd-1)*mg + ig
5380                rwgt(ind) = wt(ig)/wtsm(ngm(ind))
5381             enddo
5382          else
5383             do ig = 1, ng(ibnd+15)
5384                igcsm = igcsm + 1
5385                ind = (ibnd-1)*mg + ig
5386                rwgt(ind) = 1.0
5387             enddo
5388          endif
5389       enddo
5390
5391 ! Reduce g-points for absorption coefficient data in each LW spectral band.
5392
5393       call cmbgb16s
5394       call cmbgb17
5395       call cmbgb18
5396       call cmbgb19
5397       call cmbgb20
5398       call cmbgb21
5399       call cmbgb22
5400       call cmbgb23
5401       call cmbgb24
5402       call cmbgb25
5403       call cmbgb26
5404       call cmbgb27
5405       call cmbgb28
5406       call cmbgb29
5407
5408       end subroutine rrtmg_sw_ini
5409
5410 !***************************************************************************
5411       subroutine swdatinit(cpdair)
5412 !***************************************************************************
5413
5414 ! --------- Modules ----------
5415
5416       use rrsw_con_f, only: heatfac, grav, planck, boltz, &
5417                           clight, avogad, alosmt, gascon, radcn1, radcn2, &
5418                           sbcnst, secdy
5419       use rrsw_vsn_f
5420
5421       save
5422
5423       real , intent(in) :: cpdair     ! Specific heat capacity of dry air
5424                                       ! at constant pressure at 273 K
5425                                       ! (J kg-1 K-1)
5426
5427 ! Shortwave spectral band limits (wavenumbers)
5428       wavenum1(:) = (/2600. , 3250. , 4000. , 4650. , 5150. , 6150. , 7700. , &
5429                       8050. ,12850. ,16000. ,22650. ,29000. ,38000. ,  820. /)
5430       wavenum2(:) = (/3250. , 4000. , 4650. , 5150. , 6150. , 7700. , 8050. , &
5431                      12850. ,16000. ,22650. ,29000. ,38000. ,50000. , 2600. /)
5432       delwave(:) =  (/ 650. ,  750. ,  650. ,  500. , 1000. , 1550. ,  350. , &
5433                       4800. , 3150. , 6650. , 6350. , 9000. ,12000. , 1780. /)
5434
5435 ! Spectral band information
5436       ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
5437       nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
5438       nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
5439       icxa(:) = (/ 5 ,5 ,4 ,4 ,3 ,3 ,2 ,2 ,1 ,1 ,1 ,1 ,1 ,5/)
5440
5441 ! Fundamental physical constants from NIST 2002
5442
5443       grav = 9.8066                         ! Acceleration of gravity
5444                                               ! (m s-2)
5445       planck = 6.62606876e-27               ! Planck constant
5446                                               ! (ergs s; g cm2 s-1)
5447       boltz = 1.3806503e-16                 ! Boltzmann constant
5448                                               ! (ergs K-1; g cm2 s-2 K-1)
5449       clight = 2.99792458e+10               ! Speed of light in a vacuum
5450                                               ! (cm s-1)
5451       avogad = 6.02214199e+23               ! Avogadro constant
5452                                               ! (mol-1)
5453       alosmt = 2.6867775e+19                ! Loschmidt constant
5454                                               ! (cm-3)
5455       gascon = 8.31447200e+07               ! Molar gas constant
5456                                               ! (ergs mol-1 K-1)
5457       radcn1 = 1.191042772e-12              ! First radiation constant
5458                                               ! (W cm2 sr-1)
5459       radcn2 = 1.4387752                    ! Second radiation constant
5460                                               ! (cm K)
5461       sbcnst = 5.670400e-04                 ! Stefan-Boltzmann constant
5462                                               ! (W cm-2 K-4)
5463       secdy = 8.6400e4                      ! Number of seconds per day
5464                                               ! (s d-1)
5465 !
5466 !     units are generally cgs
5467 !
5468 !     The first and second radiation constants are taken from NIST.
5469 !     They were previously obtained from the relations:
5470 !          radcn1 = 2.*planck*clight*clight*1.e-07
5471 !          radcn2 = planck*clight/boltz
5472
5473 !     Heatfac is the factor by which delta-flux / delta-pressure is
5474 !     multiplied, with flux in W/m-2 and pressure in mbar, to get
5475 !     the heating rate in units of degrees/day.  It is equal to:
5476 !     Original value:
5477 !           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
5478 !           Here, cpdair (1.004) is in units of J g-1 K-1, and the
5479 !           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
5480 !        =  (9.8066)(86400)(1e-5)/(1.004)
5481 !      heatfac = 8.4391
5482 !
5483 !     Modified value for consistency with CAM3:
5484 !           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
5485 !           Here, cpdair (1.00464) is in units of J g-1 K-1, and the
5486 !           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
5487 !        =  (9.80616)(86400)(1e-5)/(1.00464)
5488 !      heatfac = 8.43339130434
5489 !
5490 !     Calculated value (from constants above and input cpdair)
5491 !        (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
5492 !           Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
5493 !           converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
5494       heatfac = grav * secdy / (cpdair * 1.e2 )
5495
5496       end subroutine swdatinit
5497
5498 !***************************************************************************
5499       subroutine swcmbdat
5500 !***************************************************************************
5501
5502       save
5503
5504 ! ------- Definitions -------
5505 !     Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
5506 !     This mapping from 224 to 112 points has been carefully selected to
5507 !     minimize the effect on the resulting fluxes and cooling rates, and
5508 !     caution should be used if the mapping is modified.  The full 224
5509 !     g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
5510 !     ngpt    The total number of new g-points
5511 !     ngc     The number of new g-points in each band
5512 !     ngs     The cumulative sum of new g-points for each band
5513 !     ngm     The index of each new g-point relative to the original
5514 !             16 g-points for each band.
5515 !     ngn     The number of original g-points that are combined to make
5516 !             each new g-point in each band.
5517 !     ngb     The band index for each new g-point.
5518 !     wt      RRTM weights for 16 g-points.
5519
5520 ! Use this set for 112 quadrature point (g-point) model
5521 ! ------- Data statements -------
5522       ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
5523       ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
5524       ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, &           ! band 16
5525                   1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, &      ! band 17
5526                   1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &           ! band 18
5527                   1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &           ! band 19
5528                   1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &     ! band 20
5529                   1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &     ! band 21
5530                   1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, &           ! band 22
5531                   1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, &       ! band 23
5532                   1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, &           ! band 24
5533                   1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 25
5534                   1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 26
5535                   1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, &           ! band 27
5536                   1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 28
5537                   1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /)        ! band 29
5538       ngn(:) = (/ 2,2,2,2,4,4, &                               ! band 16
5539                   1,1,1,1,1,2,1,2,1,2,1,2, &                   ! band 17
5540                   1,1,1,1,2,2,4,4, &                           ! band 18
5541                   1,1,1,1,2,2,4,4, &                           ! band 19
5542                   1,1,1,1,1,1,1,1,2,6, &                       ! band 20
5543                   1,1,1,1,1,1,1,1,2,6, &                       ! band 21
5544                   8,8, &                                       ! band 22
5545                   2,2,1,1,1,1,1,1,2,4, &                       ! band 23
5546                   2,2,2,2,2,2,2,2, &                           ! band 24
5547                   1,1,2,2,4,6, &                               ! band 25
5548                   1,1,2,2,4,6, &                               ! band 26
5549                   1,1,1,1,1,1,4,6, &                           ! band 27
5550                   1,1,2,2,4,6, &                               ! band 28
5551                   1,1,1,1,2,2,2,2,1,1,1,1 /)                   ! band 29
5552       ngb(:) = (/ 16,16,16,16,16,16, &                         ! band 16
5553                   17,17,17,17,17,17,17,17,17,17,17,17, &       ! band 17
5554                   18,18,18,18,18,18,18,18, &                   ! band 18
5555                   19,19,19,19,19,19,19,19, &                   ! band 19
5556                   20,20,20,20,20,20,20,20,20,20, &             ! band 20
5557                   21,21,21,21,21,21,21,21,21,21, &             ! band 21
5558                   22,22, &                                     ! band 22
5559                   23,23,23,23,23,23,23,23,23,23, &             ! band 23
5560                   24,24,24,24,24,24,24,24, &                   ! band 24
5561                   25,25,25,25,25,25, &                         ! band 25
5562                   26,26,26,26,26,26, &                         ! band 26
5563                   27,27,27,27,27,27,27,27, &                   ! band 27
5564                   28,28,28,28,28,28, &                         ! band 28
5565                   29,29,29,29,29,29,29,29,29,29,29,29 /)       ! band 29
5566
5567 ! Use this set for full 224 quadrature point (g-point) model
5568 ! ------- Data statements -------
5569 !      ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
5570 !      ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
5571 !      ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 16
5572 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 17
5573 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 18
5574 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 19
5575 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 20
5576 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 21
5577 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 22
5578 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 23
5579 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 24
5580 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 25
5581 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 26
5582 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 27
5583 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 28
5584 !                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /)    ! band 29
5585 !      ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 16
5586 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 17
5587 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 18
5588 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 19
5589 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 20
5590 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 21
5591 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 22
5592 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 23
5593 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 24
5594 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 25
5595 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 26
5596 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 27
5597 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 28
5598 !                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /)           ! band 29
5599 !      ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, &   ! band 16
5600 !                  17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, &   ! band 17
5601 !                  18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, &   ! band 18
5602 !                  19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, &   ! band 19
5603 !                  20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, &   ! band 20
5604 !                  21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, &   ! band 21
5605 !                  22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, &   ! band 22
5606 !                  23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, &   ! band 23
5607 !                  24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, &   ! band 24
5608 !                  25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, &   ! band 25
5609 !                  26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, &   ! band 26
5610 !                  27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, &   ! band 27
5611 !                  28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, &   ! band 28
5612 !                  29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /)   ! band 29
5613
5614
5615       wt(:) =  (/ 0.1527534276 , 0.1491729617 , 0.1420961469 , &
5616                   0.1316886544 , 0.1181945205 , 0.1019300893 , &
5617                   0.0832767040 , 0.0626720116 , 0.0424925000 , &
5618                   0.0046269894 , 0.0038279891 , 0.0030260086 , &
5619                   0.0022199750 , 0.0014140010 , 0.0005330000 , &
5620                   0.0000750000  /)
5621
5622       end subroutine swcmbdat
5623
5624 !***************************************************************************
5625       subroutine swaerpr
5626 !***************************************************************************
5627
5628 ! Purpose: Define spectral aerosol properties for six ECMWF aerosol types
5629 ! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
5630 !
5631 ! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003
5632 ! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
5633
5634       use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
5635
5636       save
5637
5638       rsrtaua( 1, :) = (/ &
5639         0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
5640       rsrtaua( 2, :) = (/ &
5641         0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
5642       rsrtaua( 3, :) = (/ &
5643         0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
5644       rsrtaua( 4, :) = (/ &
5645         0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
5646       rsrtaua( 5, :) = (/ &
5647         0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
5648       rsrtaua( 6, :) = (/ &
5649         0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
5650       rsrtaua( 7, :) = (/ &
5651         0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
5652       rsrtaua( 8, :) = (/ &
5653         0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /)
5654       rsrtaua( 9, :) = (/ &
5655         0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /)
5656       rsrtaua(10, :) = (/ &
5657         1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
5658       rsrtaua(11, :) = (/ &
5659         1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
5660       rsrtaua(12, :) = (/ &
5661         1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
5662       rsrtaua(13, :) = (/ &
5663         1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
5664       rsrtaua(14, :) = (/ &
5665         0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
5666
5667       rsrpiza( 1, :) = (/ &
5668         .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
5669       rsrpiza( 2, :) = (/ &
5670         .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
5671       rsrpiza( 3, :) = (/ &
5672         .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
5673       rsrpiza( 4, :) = (/ &
5674         .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
5675       rsrpiza( 5, :) = (/ &
5676         .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
5677       rsrpiza( 6, :) = (/ &
5678         .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
5679       rsrpiza( 7, :) = (/ &
5680         .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
5681       rsrpiza( 8, :) = (/ &
5682         .8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /)
5683       rsrpiza( 9, :) = (/ &
5684         .8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /)
5685       rsrpiza(10, :) = (/ &
5686         .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
5687       rsrpiza(11, :) = (/ &
5688         .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
5689       rsrpiza(12, :) = (/ &
5690         .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
5691       rsrpiza(13, :) = (/ &
5692         .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
5693       rsrpiza(14, :) = (/ &
5694         .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
5695
5696       rsrasya( 1, :) = (/ &
5697         0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
5698       rsrasya( 2, :) = (/ &
5699         0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
5700       rsrasya( 3, :) = (/ &
5701         0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
5702       rsrasya( 4, :) = (/ &
5703         0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
5704       rsrasya( 5, :) = (/ &
5705         0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
5706       rsrasya( 6, :) = (/ &
5707         0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
5708       rsrasya( 7, :) = (/ &
5709         0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
5710       rsrasya( 8, :) = (/ &
5711         0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /)
5712       rsrasya( 9, :) = (/ &
5713         0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /)
5714       rsrasya(10, :) = (/ &
5715         0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
5716       rsrasya(11, :) = (/ &
5717         0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
5718       rsrasya(12, :) = (/ &
5719         0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
5720       rsrasya(13, :) = (/ &
5721         0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
5722       rsrasya(14, :) = (/ &
5723         0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
5724
5725       end subroutine swaerpr
5726
5727 !***************************************************************************
5728       subroutine cmbgb16s
5729 !***************************************************************************
5730 !
5731 !  Original version:       MJIacono; July 1998
5732 !  Revision for RRTM_SW:   MJIacono; November 2002
5733 !  Revision for RRTMG_SW:  MJIacono; December 2003
5734 !  Revision for F90 reformatting:  MJIacono; July 2006
5735 !
5736 !  The subroutines CMBGB16->CMBGB29 input the absorption coefficient
5737 !  data for each band, which are defined for 16 g-points and 14 spectral
5738 !  bands. The data are combined with appropriate weighting following the
5739 !  g-point mapping arrays specified in RRTMG_SW_INIT.  Solar source
5740 !  function data in array SFLUXREF are combined without weighting.  All
5741 !  g-point reduced data are put into new arrays for use in RRTMG_SW.
5742 !
5743 !  band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
5744 !
5745 !-----------------------------------------------------------------------
5746
5747       use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5748                             absa, ka, absb, kb, selfref, forref, sfluxref
5749
5750 ! ------- Local -------
5751       integer  :: jn, jt, jp, igc, ipr, iprsm
5752       real  :: sumk, sumf
5753
5754
5755       do jn = 1,9
5756          do jt = 1,5
5757             do jp = 1,13
5758                iprsm = 0
5759                do igc = 1,ngc(1)
5760                   sumk = 0.
5761                   do ipr = 1, ngn(igc)
5762                      iprsm = iprsm + 1
5763                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
5764                   enddo
5765                   ka(jn,jt,jp,igc) = sumk
5766                enddo
5767             enddo
5768          enddo
5769       enddo
5770
5771       do jt = 1,5
5772          do jp = 13,59
5773             iprsm = 0
5774             do igc = 1,ngc(1)
5775                sumk = 0.
5776                do ipr = 1, ngn(igc)
5777                   iprsm = iprsm + 1
5778                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
5779                enddo
5780                kb(jt,jp,igc) = sumk
5781             enddo
5782          enddo
5783       enddo
5784
5785       do jt = 1,10
5786          iprsm = 0
5787          do igc = 1,ngc(1)
5788             sumk = 0.
5789             do ipr = 1, ngn(igc)
5790                iprsm = iprsm + 1
5791                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
5792             enddo
5793             selfref(jt,igc) = sumk
5794          enddo
5795       enddo
5796
5797       do jt = 1,3
5798          iprsm = 0
5799          do igc = 1,ngc(1)
5800             sumk = 0.
5801             do ipr = 1, ngn(igc)
5802                iprsm = iprsm + 1
5803                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
5804             enddo
5805             forref(jt,igc) = sumk
5806          enddo
5807       enddo
5808
5809       iprsm = 0
5810       do igc = 1,ngc(1)
5811          sumf = 0.
5812          do ipr = 1, ngn(igc)
5813             iprsm = iprsm + 1
5814             sumf = sumf + sfluxrefo(iprsm)
5815          enddo
5816          sfluxref(igc) = sumf
5817       enddo
5818
5819       end subroutine cmbgb16s
5820
5821 !***************************************************************************
5822       subroutine cmbgb17
5823 !***************************************************************************
5824 !
5825 !     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
5826 !-----------------------------------------------------------------------
5827
5828       use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5829                             absa, ka, absb, kb, selfref, forref, sfluxref
5830
5831 ! ------- Local -------
5832       integer  :: jn, jt, jp, igc, ipr, iprsm
5833       real  :: sumk, sumf
5834
5835
5836       do jn = 1,9
5837          do jt = 1,5
5838             do jp = 1,13
5839                iprsm = 0
5840                do igc = 1,ngc(2)
5841                   sumk = 0.
5842                   do ipr = 1, ngn(ngs(1)+igc)
5843                      iprsm = iprsm + 1
5844                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
5845                   enddo
5846                   ka(jn,jt,jp,igc) = sumk
5847                enddo
5848             enddo
5849          enddo
5850       enddo
5851
5852       do jn = 1,5
5853          do jt = 1,5
5854             do jp = 13,59
5855                iprsm = 0
5856                do igc = 1,ngc(2)
5857                   sumk = 0.
5858                   do ipr = 1, ngn(ngs(1)+igc)
5859                      iprsm = iprsm + 1
5860                      sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
5861                   enddo
5862                   kb(jn,jt,jp,igc) = sumk
5863                enddo
5864             enddo
5865          enddo
5866       enddo
5867
5868       do jt = 1,10
5869          iprsm = 0
5870          do igc = 1,ngc(2)
5871             sumk = 0.
5872             do ipr = 1, ngn(ngs(1)+igc)
5873                iprsm = iprsm + 1
5874                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
5875             enddo
5876             selfref(jt,igc) = sumk
5877          enddo
5878       enddo
5879
5880       do jt = 1,4
5881          iprsm = 0
5882          do igc = 1,ngc(2)
5883             sumk = 0.
5884             do ipr = 1, ngn(ngs(1)+igc)
5885                iprsm = iprsm + 1
5886                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
5887             enddo
5888             forref(jt,igc) = sumk
5889          enddo
5890       enddo
5891
5892       do jp = 1,5
5893          iprsm = 0
5894          do igc = 1,ngc(2)
5895             sumf = 0.
5896             do ipr = 1, ngn(ngs(1)+igc)
5897                iprsm = iprsm + 1
5898                sumf = sumf + sfluxrefo(iprsm,jp)
5899             enddo
5900             sfluxref(igc,jp) = sumf
5901          enddo
5902       enddo
5903
5904       end subroutine cmbgb17
5905
5906 !***************************************************************************
5907       subroutine cmbgb18
5908 !***************************************************************************
5909 !
5910 !     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
5911 !-----------------------------------------------------------------------
5912
5913       use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5914                             absa, ka, absb, kb, selfref, forref, sfluxref
5915
5916 ! ------- Local -------
5917       integer  :: jn, jt, jp, igc, ipr, iprsm
5918       real  :: sumk, sumf
5919
5920
5921       do jn = 1,9
5922          do jt = 1,5
5923             do jp = 1,13
5924                iprsm = 0
5925                do igc = 1,ngc(3)
5926                   sumk = 0.
5927                   do ipr = 1, ngn(ngs(2)+igc)
5928                      iprsm = iprsm + 1
5929                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
5930                   enddo
5931                   ka(jn,jt,jp,igc) = sumk
5932                enddo
5933             enddo
5934          enddo
5935       enddo
5936
5937       do jt = 1,5
5938          do jp = 13,59
5939             iprsm = 0
5940             do igc = 1,ngc(3)
5941                sumk = 0.
5942                do ipr = 1, ngn(ngs(2)+igc)
5943                   iprsm = iprsm + 1
5944                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
5945                enddo
5946                kb(jt,jp,igc) = sumk
5947             enddo
5948          enddo
5949       enddo
5950
5951       do jt = 1,10
5952          iprsm = 0
5953          do igc = 1,ngc(3)
5954             sumk = 0.
5955             do ipr = 1, ngn(ngs(2)+igc)
5956                iprsm = iprsm + 1
5957                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
5958             enddo
5959             selfref(jt,igc) = sumk
5960          enddo
5961       enddo
5962
5963       do jt = 1,3
5964          iprsm = 0
5965          do igc = 1,ngc(3)
5966             sumk = 0.
5967             do ipr = 1, ngn(ngs(2)+igc)
5968                iprsm = iprsm + 1
5969                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
5970             enddo
5971             forref(jt,igc) = sumk
5972          enddo
5973       enddo
5974
5975       do jp = 1,9
5976          iprsm = 0
5977          do igc = 1,ngc(3)
5978             sumf = 0.
5979             do ipr = 1, ngn(ngs(2)+igc)
5980                iprsm = iprsm + 1
5981                sumf = sumf + sfluxrefo(iprsm,jp)
5982             enddo
5983             sfluxref(igc,jp) = sumf
5984          enddo
5985       enddo
5986
5987       end subroutine cmbgb18
5988
5989 !***************************************************************************
5990       subroutine cmbgb19
5991 !***************************************************************************
5992 !
5993 !     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
5994 !-----------------------------------------------------------------------
5995
5996       use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
5997                             absa, ka, absb, kb, selfref, forref, sfluxref
5998
5999 ! ------- Local -------
6000       integer  :: jn, jt, jp, igc, ipr, iprsm
6001       real  :: sumk, sumf
6002
6003
6004       do jn = 1,9
6005          do jt = 1,5
6006             do jp = 1,13
6007                iprsm = 0
6008                do igc = 1,ngc(4)
6009                   sumk = 0.
6010                   do ipr = 1, ngn(ngs(3)+igc)
6011                      iprsm = iprsm + 1
6012                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
6013                   enddo
6014                   ka(jn,jt,jp,igc) = sumk
6015                enddo
6016             enddo
6017          enddo
6018       enddo
6019
6020       do jt = 1,5
6021          do jp = 13,59
6022             iprsm = 0
6023             do igc = 1,ngc(4)
6024                sumk = 0.
6025                do ipr = 1, ngn(ngs(3)+igc)
6026                   iprsm = iprsm + 1
6027                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
6028                enddo
6029                kb(jt,jp,igc) = sumk
6030             enddo
6031          enddo
6032       enddo
6033
6034       do jt = 1,10
6035          iprsm = 0
6036          do igc = 1,ngc(4)
6037             sumk = 0.
6038             do ipr = 1, ngn(ngs(3)+igc)
6039                iprsm = iprsm + 1
6040                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
6041             enddo
6042             selfref(jt,igc) = sumk
6043          enddo
6044       enddo
6045
6046       do jt = 1,3
6047          iprsm = 0
6048          do igc = 1,ngc(4)
6049             sumk = 0.
6050             do ipr = 1, ngn(ngs(3)+igc)
6051                iprsm = iprsm + 1
6052                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
6053             enddo
6054             forref(jt,igc) = sumk
6055          enddo
6056       enddo
6057
6058       do jp = 1,9
6059          iprsm = 0
6060          do igc = 1,ngc(4)
6061             sumf = 0.
6062             do ipr = 1, ngn(ngs(3)+igc)
6063                iprsm = iprsm + 1
6064                sumf = sumf + sfluxrefo(iprsm,jp)
6065             enddo
6066             sfluxref(igc,jp) = sumf
6067          enddo
6068       enddo
6069
6070       end subroutine cmbgb19
6071
6072 !***************************************************************************
6073       subroutine cmbgb20
6074 !***************************************************************************
6075 !
6076 !     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
6077 !-----------------------------------------------------------------------
6078
6079       use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
6080                             absa, ka, absb, kb, selfref, forref, sfluxref, absch4
6081
6082 ! ------- Local -------
6083       integer  :: jt, jp, igc, ipr, iprsm
6084       real  :: sumk, sumf1, sumf2
6085
6086
6087       do jt = 1,5
6088          do jp = 1,13
6089             iprsm = 0
6090             do igc = 1,ngc(5)
6091                sumk = 0.
6092                do ipr = 1, ngn(ngs(4)+igc)
6093                   iprsm = iprsm + 1
6094                   sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
6095                enddo
6096                ka(jt,jp,igc) = sumk
6097             enddo
6098          enddo
6099          do jp = 13,59
6100             iprsm = 0
6101             do igc = 1,ngc(5)
6102                sumk = 0.
6103                do ipr = 1, ngn(ngs(4)+igc)
6104                   iprsm = iprsm + 1
6105                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
6106                enddo
6107                kb(jt,jp,igc) = sumk
6108             enddo
6109          enddo
6110       enddo
6111
6112       do jt = 1,10
6113          iprsm = 0
6114          do igc = 1,ngc(5)
6115             sumk = 0.
6116             do ipr = 1, ngn(ngs(4)+igc)
6117                iprsm = iprsm + 1
6118                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
6119             enddo
6120             selfref(jt,igc) = sumk
6121          enddo
6122       enddo
6123
6124       do jt = 1,4
6125          iprsm = 0
6126          do igc = 1,ngc(5)
6127             sumk = 0.
6128             do ipr = 1, ngn(ngs(4)+igc)
6129                iprsm = iprsm + 1
6130                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
6131             enddo
6132             forref(jt,igc) = sumk
6133          enddo
6134       enddo
6135
6136       iprsm = 0
6137       do igc = 1,ngc(5)
6138          sumf1 = 0.
6139          sumf2 = 0.
6140          do ipr = 1, ngn(ngs(4)+igc)
6141             iprsm = iprsm + 1
6142             sumf1 = sumf1 + sfluxrefo(iprsm)
6143             sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
6144          enddo
6145          sfluxref(igc) = sumf1
6146          absch4(igc) = sumf2
6147       enddo
6148
6149       end subroutine cmbgb20
6150
6151 !***************************************************************************
6152       subroutine cmbgb21
6153 !***************************************************************************
6154 !
6155 !     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
6156 !-----------------------------------------------------------------------
6157
6158       use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
6159                             absa, ka, absb, kb, selfref, forref, sfluxref
6160
6161 ! ------- Local -------
6162       integer  :: jn, jt, jp, igc, ipr, iprsm
6163       real  :: sumk, sumf
6164
6165
6166       do jn = 1,9
6167          do jt = 1,5
6168             do jp = 1,13
6169                iprsm = 0
6170                do igc = 1,ngc(6)
6171                   sumk = 0.
6172                   do ipr = 1, ngn(ngs(5)+igc)
6173                      iprsm = iprsm + 1
6174                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
6175                   enddo
6176                   ka(jn,jt,jp,igc) = sumk
6177                enddo
6178             enddo
6179          enddo
6180       enddo
6181
6182       do jn = 1,5
6183          do jt = 1,5
6184             do jp = 13,59
6185                iprsm = 0
6186                do igc = 1,ngc(6)
6187                   sumk = 0.
6188                   do ipr = 1, ngn(ngs(5)+igc)
6189                      iprsm = iprsm + 1
6190                      sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
6191                   enddo
6192                   kb(jn,jt,jp,igc) = sumk
6193                enddo
6194             enddo
6195          enddo
6196       enddo
6197
6198       do jt = 1,10
6199          iprsm = 0
6200          do igc = 1,ngc(6)
6201             sumk = 0.
6202             do ipr = 1, ngn(ngs(5)+igc)
6203                iprsm = iprsm + 1
6204                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
6205             enddo
6206             selfref(jt,igc) = sumk
6207          enddo
6208       enddo
6209
6210       do jt = 1,4
6211          iprsm = 0
6212          do igc = 1,ngc(6)
6213             sumk = 0.
6214             do ipr = 1, ngn(ngs(5)+igc)
6215                iprsm = iprsm + 1
6216                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
6217             enddo
6218             forref(jt,igc) = sumk
6219          enddo
6220       enddo
6221
6222       do jp = 1,9
6223          iprsm = 0
6224          do igc = 1,ngc(6)
6225             sumf = 0.
6226             do ipr = 1, ngn(ngs(5)+igc)
6227                iprsm = iprsm + 1
6228                sumf = sumf + sfluxrefo(iprsm,jp)
6229             enddo
6230             sfluxref(igc,jp) = sumf
6231          enddo
6232       enddo
6233
6234       end subroutine cmbgb21
6235
6236 !***************************************************************************
6237       subroutine cmbgb22
6238 !***************************************************************************
6239 !
6240 !     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
6241 !-----------------------------------------------------------------------
6242
6243       use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
6244                             absa, ka, absb, kb, selfref, forref, sfluxref
6245
6246 ! ------- Local -------
6247       integer  :: jn, jt, jp, igc, ipr, iprsm
6248       real  :: sumk, sumf
6249
6250
6251       do jn = 1,9
6252          do jt = 1,5
6253             do jp = 1,13
6254                iprsm = 0
6255                do igc = 1,ngc(7)
6256                   sumk = 0.
6257                   do ipr = 1, ngn(ngs(6)+igc)
6258                      iprsm = iprsm + 1
6259                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
6260                   enddo
6261                   ka(jn,jt,jp,igc) = sumk
6262                enddo
6263             enddo
6264          enddo
6265       enddo
6266
6267       do jt = 1,5
6268          do jp = 13,59
6269             iprsm = 0
6270             do igc = 1,ngc(7)
6271                sumk = 0.
6272                do ipr = 1, ngn(ngs(6)+igc)
6273                   iprsm = iprsm + 1
6274                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
6275                enddo
6276                kb(jt,jp,igc) = sumk
6277             enddo
6278          enddo
6279       enddo
6280
6281       do jt = 1,10
6282          iprsm = 0
6283          do igc = 1,ngc(7)
6284             sumk = 0.
6285             do ipr = 1, ngn(ngs(6)+igc)
6286                iprsm = iprsm + 1
6287                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
6288             enddo
6289             selfref(jt,igc) = sumk
6290          enddo
6291       enddo
6292
6293       do jt = 1,3
6294          iprsm = 0
6295          do igc = 1,ngc(7)
6296             sumk = 0.
6297             do ipr = 1, ngn(ngs(6)+igc)
6298                iprsm = iprsm + 1
6299                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
6300             enddo
6301             forref(jt,igc) = sumk
6302          enddo
6303       enddo
6304
6305       do jp = 1,9
6306          iprsm = 0
6307          do igc = 1,ngc(7)
6308             sumf = 0.
6309             do ipr = 1, ngn(ngs(6)+igc)
6310                iprsm = iprsm + 1
6311                sumf = sumf + sfluxrefo(iprsm,jp)
6312             enddo
6313             sfluxref(igc,jp) = sumf
6314          enddo
6315       enddo
6316
6317       end subroutine cmbgb22
6318
6319 !***************************************************************************
6320       subroutine cmbgb23
6321 !***************************************************************************
6322 !
6323 !     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
6324 !-----------------------------------------------------------------------
6325
6326       use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
6327                             absa, ka, selfref, forref, sfluxref, rayl
6328
6329 ! ------- Local -------
6330       integer  :: jt, jp, igc, ipr, iprsm
6331       real  :: sumk, sumf1, sumf2
6332
6333
6334       do jt = 1,5
6335          do jp = 1,13
6336             iprsm = 0
6337             do igc = 1,ngc(8)
6338                sumk = 0.
6339                do ipr = 1, ngn(ngs(7)+igc)
6340                   iprsm = iprsm + 1
6341                   sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
6342                enddo
6343                ka(jt,jp,igc) = sumk
6344             enddo
6345          enddo
6346       enddo
6347
6348       do jt = 1,10
6349          iprsm = 0
6350          do igc = 1,ngc(8)
6351             sumk = 0.
6352             do ipr = 1, ngn(ngs(7)+igc)
6353                iprsm = iprsm + 1
6354                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
6355             enddo
6356             selfref(jt,igc) = sumk
6357          enddo
6358       enddo
6359
6360       do jt = 1,3
6361          iprsm = 0
6362          do igc = 1,ngc(8)
6363             sumk = 0.
6364             do ipr = 1, ngn(ngs(7)+igc)
6365                iprsm = iprsm + 1
6366                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
6367             enddo
6368             forref(jt,igc) = sumk
6369          enddo
6370       enddo
6371
6372       iprsm = 0
6373       do igc = 1,ngc(8)
6374          sumf1 = 0.
6375          sumf2 = 0.
6376          do ipr = 1, ngn(ngs(7)+igc)
6377             iprsm = iprsm + 1
6378             sumf1 = sumf1 + sfluxrefo(iprsm)
6379             sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
6380          enddo
6381          sfluxref(igc) = sumf1
6382          rayl(igc) = sumf2
6383       enddo
6384
6385       end subroutine cmbgb23
6386
6387 !***************************************************************************
6388       subroutine cmbgb24
6389 !***************************************************************************
6390 !
6391 !     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
6392 !-----------------------------------------------------------------------
6393
6394       use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
6395                             abso3ao, abso3bo, raylao, raylbo, &
6396                             absa, ka, absb, kb, selfref, forref, sfluxref, &
6397                             abso3a, abso3b, rayla, raylb
6398
6399 ! ------- Local -------
6400       integer  :: jn, jt, jp, igc, ipr, iprsm
6401       real  :: sumk, sumf1, sumf2, sumf3
6402
6403
6404       do jn = 1,9
6405          do jt = 1,5
6406             do jp = 1,13
6407                iprsm = 0
6408                do igc = 1,ngc(9)
6409                   sumk = 0.
6410                   do ipr = 1, ngn(ngs(8)+igc)
6411                      iprsm = iprsm + 1
6412                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
6413                   enddo
6414                   ka(jn,jt,jp,igc) = sumk
6415                enddo
6416             enddo
6417          enddo
6418       enddo
6419
6420       do jt = 1,5
6421          do jp = 13,59
6422             iprsm = 0
6423             do igc = 1,ngc(9)
6424                sumk = 0.
6425                do ipr = 1, ngn(ngs(8)+igc)
6426                   iprsm = iprsm + 1
6427                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
6428                enddo
6429                kb(jt,jp,igc) = sumk
6430             enddo
6431          enddo
6432       enddo
6433
6434       do jt = 1,10
6435          iprsm = 0
6436          do igc = 1,ngc(9)
6437             sumk = 0.
6438             do ipr = 1, ngn(ngs(8)+igc)
6439                iprsm = iprsm + 1
6440                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
6441             enddo
6442             selfref(jt,igc) = sumk
6443          enddo
6444       enddo
6445
6446       do jt = 1,3
6447          iprsm = 0
6448          do igc = 1,ngc(9)
6449             sumk = 0.
6450             do ipr = 1, ngn(ngs(8)+igc)
6451                iprsm = iprsm + 1
6452                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
6453             enddo
6454             forref(jt,igc) = sumk
6455          enddo
6456       enddo
6457
6458       iprsm = 0
6459       do igc = 1,ngc(9)
6460          sumf1 = 0.
6461          sumf2 = 0.
6462          sumf3 = 0.
6463          do ipr = 1, ngn(ngs(8)+igc)
6464             iprsm = iprsm + 1
6465             sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
6466             sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
6467             sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
6468          enddo
6469          raylb(igc) = sumf1
6470          abso3a(igc) = sumf2
6471          abso3b(igc) = sumf3
6472       enddo
6473
6474       do jp = 1,9
6475          iprsm = 0
6476          do igc = 1,ngc(9)
6477             sumf1 = 0.
6478             sumf2 = 0.
6479             do ipr = 1, ngn(ngs(8)+igc)
6480                iprsm = iprsm + 1
6481                sumf1 = sumf1 + sfluxrefo(iprsm,jp)
6482                sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
6483             enddo
6484             sfluxref(igc,jp) = sumf1
6485             rayla(igc,jp) = sumf2
6486          enddo
6487       enddo
6488
6489       end subroutine cmbgb24
6490
6491 !***************************************************************************
6492       subroutine cmbgb25
6493 !***************************************************************************
6494 !
6495 !     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
6496 !-----------------------------------------------------------------------
6497
6498       use rrsw_kg25_f, only : kao, sfluxrefo, &
6499                             abso3ao, abso3bo, raylo, &
6500                             absa, ka, sfluxref, &
6501                             abso3a, abso3b, rayl
6502
6503 ! ------- Local -------
6504       integer  :: jt, jp, igc, ipr, iprsm
6505       real  :: sumk, sumf1, sumf2, sumf3, sumf4
6506
6507
6508       do jt = 1,5
6509          do jp = 1,13
6510             iprsm = 0
6511             do igc = 1,ngc(10)
6512                sumk = 0.
6513                do ipr = 1, ngn(ngs(9)+igc)
6514                   iprsm = iprsm + 1
6515                   sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
6516                enddo
6517                ka(jt,jp,igc) = sumk
6518             enddo
6519          enddo
6520       enddo
6521
6522       iprsm = 0
6523       do igc = 1,ngc(10)
6524          sumf1 = 0.
6525          sumf2 = 0.
6526          sumf3 = 0.
6527          sumf4 = 0.
6528          do ipr = 1, ngn(ngs(9)+igc)
6529             iprsm = iprsm + 1
6530             sumf1 = sumf1 + sfluxrefo(iprsm)
6531             sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
6532             sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
6533             sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
6534          enddo
6535          sfluxref(igc) = sumf1
6536          abso3a(igc) = sumf2
6537          abso3b(igc) = sumf3
6538          rayl(igc) = sumf4
6539       enddo
6540
6541       end subroutine cmbgb25
6542
6543 !***************************************************************************
6544       subroutine cmbgb26
6545 !***************************************************************************
6546 !
6547 !     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
6548 !-----------------------------------------------------------------------
6549
6550       use rrsw_kg26_f, only : sfluxrefo, raylo, &
6551                             sfluxref, rayl
6552
6553 ! ------- Local -------
6554       integer  :: igc, ipr, iprsm
6555       real  :: sumf1, sumf2
6556
6557
6558       iprsm = 0
6559       do igc = 1,ngc(11)
6560          sumf1 = 0.
6561          sumf2 = 0.
6562          do ipr = 1, ngn(ngs(10)+igc)
6563             iprsm = iprsm + 1
6564             sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
6565             sumf2 = sumf2 + sfluxrefo(iprsm)
6566          enddo
6567          rayl(igc) = sumf1
6568          sfluxref(igc) = sumf2
6569       enddo
6570
6571       end subroutine cmbgb26
6572
6573 !***************************************************************************
6574       subroutine cmbgb27
6575 !***************************************************************************
6576 !
6577 !     band 27:  29000-38000 cm-1 (low - o3; high - o3)
6578 !-----------------------------------------------------------------------
6579
6580       use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, &
6581                             absa, ka, absb, kb, sfluxref, rayl
6582
6583 ! ------- Local -------
6584       integer  :: jt, jp, igc, ipr, iprsm
6585       real  :: sumk, sumf1, sumf2
6586
6587
6588       do jt = 1,5
6589          do jp = 1,13
6590             iprsm = 0
6591             do igc = 1,ngc(12)
6592                sumk = 0.
6593                do ipr = 1, ngn(ngs(11)+igc)
6594                   iprsm = iprsm + 1
6595                   sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
6596                enddo
6597                ka(jt,jp,igc) = sumk
6598             enddo
6599          enddo
6600          do jp = 13,59
6601             iprsm = 0
6602             do igc = 1,ngc(12)
6603                sumk = 0.
6604                do ipr = 1, ngn(ngs(11)+igc)
6605                   iprsm = iprsm + 1
6606                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
6607                enddo
6608                kb(jt,jp,igc) = sumk
6609             enddo
6610          enddo
6611       enddo
6612
6613       iprsm = 0
6614       do igc = 1,ngc(12)
6615          sumf1 = 0.
6616          sumf2 = 0.
6617          do ipr = 1, ngn(ngs(11)+igc)
6618             iprsm = iprsm + 1
6619             sumf1 = sumf1 + sfluxrefo(iprsm)
6620             sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
6621          enddo
6622          sfluxref(igc) = sumf1
6623          rayl(igc) = sumf2
6624       enddo
6625
6626       end subroutine cmbgb27
6627
6628 !***************************************************************************
6629       subroutine cmbgb28
6630 !***************************************************************************
6631 !
6632 !     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
6633 !-----------------------------------------------------------------------
6634
6635       use rrsw_kg28_f, only : kao, kbo, sfluxrefo, &
6636                             absa, ka, absb, kb, sfluxref
6637
6638 ! ------- Local -------
6639       integer  :: jn, jt, jp, igc, ipr, iprsm
6640       real  :: sumk, sumf
6641
6642
6643       do jn = 1,9
6644          do jt = 1,5
6645             do jp = 1,13
6646                iprsm = 0
6647                do igc = 1,ngc(13)
6648                   sumk = 0.
6649                   do ipr = 1, ngn(ngs(12)+igc)
6650                      iprsm = iprsm + 1
6651                      sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
6652                   enddo
6653                   ka(jn,jt,jp,igc) = sumk
6654                enddo
6655             enddo
6656          enddo
6657       enddo
6658
6659       do jn = 1,5
6660          do jt = 1,5
6661             do jp = 13,59
6662                iprsm = 0
6663                do igc = 1,ngc(13)
6664                   sumk = 0.
6665                   do ipr = 1, ngn(ngs(12)+igc)
6666                      iprsm = iprsm + 1
6667                      sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
6668                   enddo
6669                   kb(jn,jt,jp,igc) = sumk
6670                enddo
6671             enddo
6672          enddo
6673       enddo
6674
6675       do jp = 1,5
6676          iprsm = 0
6677          do igc = 1,ngc(13)
6678             sumf = 0.
6679             do ipr = 1, ngn(ngs(12)+igc)
6680                iprsm = iprsm + 1
6681                sumf = sumf + sfluxrefo(iprsm,jp)
6682             enddo
6683             sfluxref(igc,jp) = sumf
6684          enddo
6685       enddo
6686
6687       end subroutine cmbgb28
6688
6689 !***************************************************************************
6690       subroutine cmbgb29
6691 !***************************************************************************
6692 !
6693 !     band 29:  820-2600 cm-1 (low - h2o; high - co2)
6694 !-----------------------------------------------------------------------
6695
6696       use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
6697                             absh2oo, absco2o, &
6698                             absa, ka, absb, kb, selfref, forref, sfluxref, &
6699                             absh2o, absco2
6700
6701 ! ------- Local -------
6702       integer  :: jt, jp, igc, ipr, iprsm
6703       real  :: sumk, sumf1, sumf2, sumf3
6704
6705
6706       do jt = 1,5
6707          do jp = 1,13
6708             iprsm = 0
6709             do igc = 1,ngc(14)
6710                sumk = 0.
6711                do ipr = 1, ngn(ngs(13)+igc)
6712                   iprsm = iprsm + 1
6713                   sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
6714                enddo
6715                ka(jt,jp,igc) = sumk
6716             enddo
6717          enddo
6718          do jp = 13,59
6719             iprsm = 0
6720             do igc = 1,ngc(14)
6721                sumk = 0.
6722                do ipr = 1, ngn(ngs(13)+igc)
6723                   iprsm = iprsm + 1
6724                   sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
6725                enddo
6726                kb(jt,jp,igc) = sumk
6727             enddo
6728          enddo
6729       enddo
6730
6731       do jt = 1,10
6732          iprsm = 0
6733          do igc = 1,ngc(14)
6734             sumk = 0.
6735             do ipr = 1, ngn(ngs(13)+igc)
6736                iprsm = iprsm + 1
6737                sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
6738             enddo
6739             selfref(jt,igc) = sumk
6740          enddo
6741       enddo
6742
6743       do jt = 1,4
6744          iprsm = 0
6745          do igc = 1,ngc(14)
6746             sumk = 0.
6747             do ipr = 1, ngn(ngs(13)+igc)
6748                iprsm = iprsm + 1
6749                sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
6750             enddo
6751             forref(jt,igc) = sumk
6752          enddo
6753       enddo
6754
6755       iprsm = 0
6756       do igc = 1,ngc(14)
6757          sumf1 = 0.
6758          sumf2 = 0.
6759          sumf3 = 0.
6760          do ipr = 1, ngn(ngs(13)+igc)
6761             iprsm = iprsm + 1
6762             sumf1 = sumf1 + sfluxrefo(iprsm)
6763             sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
6764             sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
6765          enddo
6766          sfluxref(igc) = sumf1
6767          absco2(igc) = sumf2
6768          absh2o(igc) = sumf3
6769       enddo
6770
6771       end subroutine cmbgb29
6772
6773 !***********************************************************************
6774       subroutine swcldpr
6775 !***********************************************************************
6776
6777 ! Purpose: Define cloud extinction coefficient, single scattering albedo
6778 !          and asymmetry parameter data.
6779 !
6780
6781 ! ------- Modules -------
6782
6783       use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
6784                            extice2, ssaice2, asyice2, &
6785                            extice3, ssaice3, asyice3, fdlice3, &
6786                            abari, bbari, cbari, dbari, ebari, fbari
6787
6788       save
6789
6790 !-----------------------------------------------------------------------
6791 !
6792 ! Explanation of the method for each value of INFLAG.  A value of
6793 !  0 for INFLAG do not distingish being liquid and ice clouds.
6794 !  INFLAG = 2 does distinguish between liquid and ice clouds, and
6795 !    requires further user input to specify the method to be used to
6796 !    compute the aborption due to each.
6797 !  INFLAG = 0:  For each cloudy layer, the cloud fraction, the cloud optical
6798 !    depth, the cloud single-scattering albedo, and the
6799 !    moments of the phase function (0:NSTREAM).  Note
6800 !    that these values are delta-m scaled within this
6801 !    subroutine.
6802
6803 !  INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud
6804 !    water path (g/m2), and cloud ice fraction are input.
6805 !  ICEFLAG = 2:  The ice effective radius (microns) is input and the
6806 !    optical properties due to ice clouds are computed from
6807 !    the optical properties stored in the RT code, STREAMER v3.0
6808 !    (Reference: Key. J., Streamer User's Guide, Cooperative
6809 !    Institute for Meteorological Satellite Studies, 2001, 96 pp.).
6810 !    Valid range of values for re are between 5.0 and
6811 !    131.0 micron.
6812 !    This version uses Ebert and Curry, JGR, (1992) method for
6813 !    ice particles larger than 131.0 microns.
6814 !  ICEFLAG = 3:  The ice generalized effective size (dge) is input
6815 !    and the optical depths, single-scattering albedo,
6816 !    and phase function moments are calculated as in
6817 !    Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
6818 !    tables which were appropriately averaged for the
6819 !    bands in RRTM_SW.  Linear interpolation is used to
6820 !    get the coefficients from the stored tables.
6821 !    Valid range of values for dge are between 5.0 and
6822 !    140.0 micron.
6823 !    This version uses Ebert and Curry, JGR, (1992) method for
6824 !    ice particles larger than 140.0 microns.
6825 !  LIQFLAG = 1:  The water droplet effective radius (microns) is input
6826 !    and the optical depths due to water clouds are computed
6827 !    as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with
6828 !    modified coefficients derived from Mie scattering calculations.
6829 !    The values for absorption coefficients appropriate for
6830 !    the spectral bands in RRTM/RRTMG have been obtained for a
6831 !    range of effective radii by an averaging procedure
6832 !    based on the work of J. Pinto (private communication).
6833 !    Linear interpolation is used to get the absorption
6834 !    coefficients for the input effective radius.
6835 !    ..Updated tables suggested by Peter Blossey (Univ. Washington)
6836 !    and came from RRTMG_SW_v3.9 from AER, Inc.
6837 !
6838 !     ------------------------------------------------------------------
6839
6840 ! Everything below is for INFLAG = 2.
6841
6842 ! Coefficients for Ebert and Curry method
6843       abari(:) = (/ &
6844         & 3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03  /)
6845       bbari(:) = (/ &
6846         & 2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00  /)
6847       cbari(:) = (/ &
6848         & 1.000e-05 ,1.100e-04 ,1.240e-02 ,3.779e-02 ,4.666e-01  /)
6849       dbari(:) = (/ &
6850         & 0.000e+00 ,1.405e-05 ,6.867e-04 ,1.284e-03 ,2.050e-05  /)
6851       ebari(:) = (/ &
6852         & 7.661e-01 ,7.730e-01 ,7.865e-01 ,8.172e-01 ,9.595e-01  /)
6853       fbari(:) = (/ &
6854         & 5.851e-04 ,5.665e-04 ,7.204e-04 ,7.463e-04 ,1.076e-04  /)
6855
6856 ! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters
6857 !   Derived from on Mie scattering computations; based on Hu & Stamnes coefficients
6858
6859 ! Extinction coefficient
6860 !     BAND  16
6861       extliq1(:, 16) = (/ &
6862         & 9.004493E-01,6.366723E-01,4.542354E-01,3.468253E-01,2.816431E-01,&
6863         & 2.383415E-01,2.070854E-01,1.831854E-01,1.642115E-01,1.487539E-01,&
6864         & 1.359169E-01,1.250900E-01,1.158354E-01,1.078400E-01,1.008646E-01,&
6865         & 9.472307E-02,8.928000E-02,8.442308E-02,8.005924E-02,7.612231E-02,&
6866         & 7.255153E-02,6.929539E-02,6.631769E-02,6.358153E-02,6.106231E-02,&
6867         & 5.873077E-02,5.656924E-02,5.455769E-02,5.267846E-02,5.091923E-02,&
6868         & 4.926692E-02,4.771154E-02,4.623923E-02,4.484385E-02,4.351539E-02,&
6869         & 4.224615E-02,4.103385E-02,3.986538E-02,3.874077E-02,3.765462E-02,&
6870         & 3.660077E-02,3.557384E-02,3.457615E-02,3.360308E-02,3.265000E-02,&
6871         & 3.171770E-02,3.080538E-02,2.990846E-02,2.903000E-02,2.816461E-02,&
6872         & 2.731539E-02,2.648231E-02,2.566308E-02,2.485923E-02,2.407000E-02,&
6873         & 2.329615E-02,2.253769E-02,2.179615E-02 /)
6874 !     BAND  17
6875       extliq1(:, 17) = (/ &
6876        & 6.741200e-01,5.390739e-01,4.198767e-01,3.332553e-01,2.735633e-01,&
6877        & 2.317727e-01,2.012760e-01,1.780400e-01,1.596927e-01,1.447980e-01,&
6878        & 1.324480e-01,1.220347e-01,1.131327e-01,1.054313e-01,9.870534e-02,&
6879        & 9.278200e-02,8.752599e-02,8.282933e-02,7.860600e-02,7.479133e-02,&
6880        & 7.132800e-02,6.816733e-02,6.527401e-02,6.261266e-02,6.015934e-02,&
6881        & 5.788867e-02,5.578134e-02,5.381667e-02,5.198133e-02,5.026067e-02,&
6882        & 4.864466e-02,4.712267e-02,4.568066e-02,4.431200e-02,4.300867e-02,&
6883        & 4.176600e-02,4.057400e-02,3.942534e-02,3.832066e-02,3.725068e-02,&
6884        & 3.621400e-02,3.520533e-02,3.422333e-02,3.326400e-02,3.232467e-02,&
6885        & 3.140535e-02,3.050400e-02,2.962000e-02,2.875267e-02,2.789800e-02,&
6886        & 2.705934e-02,2.623667e-02,2.542667e-02,2.463200e-02,2.385267e-02,&
6887        & 2.308667e-02,2.233667e-02,2.160067e-02 /)
6888 !     BAND  18
6889       extliq1(:, 18) = (/ &
6890        & 9.250861e-01,6.245692e-01,4.347038e-01,3.320208e-01,2.714869e-01,&
6891        & 2.309516e-01,2.012592e-01,1.783315e-01,1.600369e-01,1.451000e-01,&
6892        & 1.326838e-01,1.222069e-01,1.132554e-01,1.055146e-01,9.876000e-02,&
6893        & 9.281386e-02,8.754000e-02,8.283078e-02,7.860077e-02,7.477769e-02,&
6894        & 7.130847e-02,6.814461e-02,6.524615e-02,6.258462e-02,6.012847e-02,&
6895        & 5.785462e-02,5.574231e-02,5.378000e-02,5.194461e-02,5.022462e-02,&
6896        & 4.860846e-02,4.708462e-02,4.564154e-02,4.427462e-02,4.297231e-02,&
6897        & 4.172769e-02,4.053693e-02,3.939000e-02,3.828462e-02,3.721692e-02,&
6898        & 3.618000e-02,3.517077e-02,3.418923e-02,3.323077e-02,3.229154e-02,&
6899        & 3.137154e-02,3.047154e-02,2.959077e-02,2.872308e-02,2.786846e-02,&
6900        & 2.703077e-02,2.620923e-02,2.540077e-02,2.460615e-02,2.382693e-02,&
6901        & 2.306231e-02,2.231231e-02,2.157923e-02 /)
6902 !     BAND  19
6903       extliq1(:, 19) = (/ &
6904        & 9.298960e-01,5.776460e-01,4.083450e-01,3.211160e-01,2.666390e-01,&
6905        & 2.281990e-01,1.993250e-01,1.768080e-01,1.587810e-01,1.440390e-01,&
6906        & 1.317720e-01,1.214150e-01,1.125540e-01,1.048890e-01,9.819600e-02,&
6907        & 9.230201e-02,8.706900e-02,8.239698e-02,7.819500e-02,7.439899e-02,&
6908        & 7.095300e-02,6.780700e-02,6.492900e-02,6.228600e-02,5.984600e-02,&
6909        & 5.758599e-02,5.549099e-02,5.353801e-02,5.171400e-02,5.000500e-02,&
6910        & 4.840000e-02,4.688500e-02,4.545100e-02,4.409300e-02,4.279700e-02,&
6911        & 4.156100e-02,4.037700e-02,3.923800e-02,3.813800e-02,3.707600e-02,&
6912        & 3.604500e-02,3.504300e-02,3.406500e-02,3.310800e-02,3.217700e-02,&
6913        & 3.126600e-02,3.036800e-02,2.948900e-02,2.862400e-02,2.777500e-02,&
6914        & 2.694200e-02,2.612300e-02,2.531700e-02,2.452800e-02,2.375100e-02,&
6915        & 2.299100e-02,2.224300e-02,2.151201e-02 /)
6916 !     BAND  20
6917       extliq1(:, 20) = (/ &
6918        & 8.780964e-01,5.407031e-01,3.961100e-01,3.166645e-01,2.640455e-01,&
6919        & 2.261070e-01,1.974820e-01,1.751775e-01,1.573415e-01,1.427725e-01,&
6920        & 1.306535e-01,1.204195e-01,1.116650e-01,1.040915e-01,9.747550e-02,&
6921        & 9.164800e-02,8.647649e-02,8.185501e-02,7.770200e-02,7.394749e-02,&
6922        & 7.053800e-02,6.742700e-02,6.457999e-02,6.196149e-02,5.954450e-02,&
6923        & 5.730650e-02,5.522949e-02,5.329450e-02,5.148500e-02,4.979000e-02,&
6924        & 4.819600e-02,4.669301e-02,4.527050e-02,4.391899e-02,4.263500e-02,&
6925        & 4.140500e-02,4.022850e-02,3.909500e-02,3.800199e-02,3.694600e-02,&
6926        & 3.592000e-02,3.492250e-02,3.395050e-02,3.300150e-02,3.207250e-02,&
6927        & 3.116250e-02,3.027100e-02,2.939500e-02,2.853500e-02,2.768900e-02,&
6928        & 2.686000e-02,2.604350e-02,2.524150e-02,2.445350e-02,2.368049e-02,&
6929        & 2.292150e-02,2.217800e-02,2.144800e-02 /)
6930 !     BAND  21
6931       extliq1(:, 21) = (/ &
6932        & 7.937480e-01,5.123036e-01,3.858181e-01,3.099622e-01,2.586829e-01,&
6933        & 2.217587e-01,1.939755e-01,1.723397e-01,1.550258e-01,1.408600e-01,&
6934        & 1.290545e-01,1.190661e-01,1.105039e-01,1.030848e-01,9.659387e-02,&
6935        & 9.086775e-02,8.577807e-02,8.122452e-02,7.712711e-02,7.342193e-02,&
6936        & 7.005387e-02,6.697840e-02,6.416000e-02,6.156903e-02,5.917484e-02,&
6937        & 5.695807e-02,5.489968e-02,5.298097e-02,5.118806e-02,4.950645e-02,&
6938        & 4.792710e-02,4.643581e-02,4.502484e-02,4.368547e-02,4.241001e-02,&
6939        & 4.118936e-02,4.002193e-02,3.889711e-02,3.781322e-02,3.676387e-02,&
6940        & 3.574549e-02,3.475548e-02,3.379033e-02,3.284678e-02,3.192420e-02,&
6941        & 3.102032e-02,3.013484e-02,2.926258e-02,2.840839e-02,2.756742e-02,&
6942        & 2.674258e-02,2.593064e-02,2.513258e-02,2.435000e-02,2.358064e-02,&
6943        & 2.282581e-02,2.208548e-02,2.135936e-02 /)
6944 !     BAND  22
6945       extliq1(:, 22) = (/ &
6946        & 7.533129e-01,5.033129e-01,3.811271e-01,3.062757e-01,2.558729e-01,&
6947        & 2.196828e-01,1.924372e-01,1.711714e-01,1.541086e-01,1.401114e-01,&
6948        & 1.284257e-01,1.185200e-01,1.100243e-01,1.026529e-01,9.620142e-02,&
6949        & 9.050714e-02,8.544428e-02,8.091714e-02,7.684000e-02,7.315429e-02,&
6950        & 6.980143e-02,6.673999e-02,6.394000e-02,6.136000e-02,5.897715e-02,&
6951        & 5.677000e-02,5.472285e-02,5.281286e-02,5.102858e-02,4.935429e-02,&
6952        & 4.778000e-02,4.629714e-02,4.489142e-02,4.355857e-02,4.228715e-02,&
6953        & 4.107285e-02,3.990857e-02,3.879000e-02,3.770999e-02,3.666429e-02,&
6954        & 3.565000e-02,3.466286e-02,3.370143e-02,3.276143e-02,3.184143e-02,&
6955        & 3.094000e-02,3.005714e-02,2.919000e-02,2.833714e-02,2.750000e-02,&
6956        & 2.667714e-02,2.586714e-02,2.507143e-02,2.429143e-02,2.352428e-02,&
6957        & 2.277143e-02,2.203429e-02,2.130857e-02 /)
6958 !     BAND  23
6959       extliq1(:, 23) = (/ &
6960        & 7.079894e-01,4.878198e-01,3.719852e-01,3.001873e-01,2.514795e-01,&
6961        & 2.163013e-01,1.897100e-01,1.689033e-01,1.521793e-01,1.384449e-01,&
6962        & 1.269666e-01,1.172326e-01,1.088745e-01,1.016224e-01,9.527085e-02,&
6963        & 8.966240e-02,8.467543e-02,8.021144e-02,7.619344e-02,7.255676e-02,&
6964        & 6.924996e-02,6.623030e-02,6.346261e-02,6.091499e-02,5.856325e-02,&
6965        & 5.638385e-02,5.435930e-02,5.247156e-02,5.070699e-02,4.905230e-02,&
6966        & 4.749499e-02,4.602611e-02,4.463581e-02,4.331543e-02,4.205647e-02,&
6967        & 4.085241e-02,3.969978e-02,3.859033e-02,3.751877e-02,3.648168e-02,&
6968        & 3.547468e-02,3.449553e-02,3.354072e-02,3.260732e-02,3.169438e-02,&
6969        & 3.079969e-02,2.992146e-02,2.905875e-02,2.821201e-02,2.737873e-02,&
6970        & 2.656052e-02,2.575586e-02,2.496511e-02,2.418783e-02,2.342500e-02,&
6971        & 2.267646e-02,2.194177e-02,2.122146e-02 /)
6972 !     BAND  24
6973       extliq1(:, 24) = (/ &
6974        & 6.850164e-01,4.762468e-01,3.642001e-01,2.946012e-01,2.472001e-01,&
6975        & 2.128588e-01,1.868537e-01,1.664893e-01,1.501142e-01,1.366620e-01,&
6976        & 1.254147e-01,1.158721e-01,1.076732e-01,1.005530e-01,9.431306e-02,&
6977        & 8.879891e-02,8.389232e-02,7.949714e-02,7.553857e-02,7.195474e-02,&
6978        & 6.869413e-02,6.571444e-02,6.298286e-02,6.046779e-02,5.814474e-02,&
6979        & 5.599141e-02,5.399114e-02,5.212443e-02,5.037870e-02,4.874321e-02,&
6980        & 4.720219e-02,4.574813e-02,4.437160e-02,4.306460e-02,4.181810e-02,&
6981        & 4.062603e-02,3.948252e-02,3.838256e-02,3.732049e-02,3.629192e-02,&
6982        & 3.529301e-02,3.432190e-02,3.337412e-02,3.244842e-02,3.154175e-02,&
6983        & 3.065253e-02,2.978063e-02,2.892367e-02,2.808221e-02,2.725478e-02,&
6984        & 2.644174e-02,2.564175e-02,2.485508e-02,2.408303e-02,2.332365e-02,&
6985        & 2.257890e-02,2.184824e-02,2.113224e-02 /)
6986 !     BAND  25
6987       extliq1(:, 25) = (/ &
6988        & 6.673017e-01,4.664520e-01,3.579398e-01,2.902234e-01,2.439904e-01,&
6989        & 2.104149e-01,1.849277e-01,1.649234e-01,1.488087e-01,1.355515e-01,&
6990        & 1.244562e-01,1.150329e-01,1.069321e-01,9.989310e-02,9.372070e-02,&
6991        & 8.826450e-02,8.340622e-02,7.905378e-02,7.513109e-02,7.157859e-02,&
6992        & 6.834588e-02,6.539114e-02,6.268150e-02,6.018621e-02,5.788098e-02,&
6993        & 5.574351e-02,5.375699e-02,5.190412e-02,5.017099e-02,4.854497e-02,&
6994        & 4.701490e-02,4.557030e-02,4.420249e-02,4.290304e-02,4.166427e-02,&
6995        & 4.047820e-02,3.934232e-02,3.824778e-02,3.719236e-02,3.616931e-02,&
6996        & 3.517597e-02,3.420856e-02,3.326566e-02,3.234346e-02,3.144122e-02,&
6997        & 3.055684e-02,2.968798e-02,2.883519e-02,2.799635e-02,2.717228e-02,&
6998        & 2.636182e-02,2.556424e-02,2.478114e-02,2.401086e-02,2.325657e-02,&
6999        & 2.251506e-02,2.178594e-02,2.107301e-02 /)
7000 !     BAND  26
7001       extliq1(:, 26) = (/ &
7002        & 6.552414e-01,4.599454e-01,3.538626e-01,2.873547e-01,2.418033e-01,&
7003        & 2.086660e-01,1.834885e-01,1.637142e-01,1.477767e-01,1.346583e-01,&
7004        & 1.236734e-01,1.143412e-01,1.063148e-01,9.933905e-02,9.322026e-02,&
7005        & 8.780979e-02,8.299230e-02,7.867554e-02,7.478450e-02,7.126053e-02,&
7006        & 6.805276e-02,6.512143e-02,6.243211e-02,5.995541e-02,5.766712e-02,&
7007        & 5.554484e-02,5.357246e-02,5.173222e-02,5.001069e-02,4.839505e-02,&
7008        & 4.687471e-02,4.543861e-02,4.407857e-02,4.278577e-02,4.155331e-02,&
7009        & 4.037322e-02,3.924302e-02,3.815376e-02,3.710172e-02,3.608296e-02,&
7010        & 3.509330e-02,3.412980e-02,3.319009e-02,3.227106e-02,3.137157e-02,&
7011        & 3.048950e-02,2.962365e-02,2.877297e-02,2.793726e-02,2.711500e-02,&
7012        & 2.630666e-02,2.551206e-02,2.473052e-02,2.396287e-02,2.320861e-02,&
7013        & 2.246810e-02,2.174162e-02,2.102927e-02 /)
7014 !     BAND  27
7015       extliq1(:, 27) = (/ &
7016        & 6.430901e-01,4.532134e-01,3.496132e-01,2.844655e-01,2.397347e-01,&
7017        & 2.071236e-01,1.822976e-01,1.627640e-01,1.469961e-01,1.340006e-01,&
7018        & 1.231069e-01,1.138441e-01,1.058706e-01,9.893678e-02,9.285166e-02,&
7019        & 8.746871e-02,8.267411e-02,7.837656e-02,7.450257e-02,7.099318e-02,&
7020        & 6.779929e-02,6.487987e-02,6.220168e-02,5.973530e-02,5.745636e-02,&
7021        & 5.534344e-02,5.337986e-02,5.154797e-02,4.983404e-02,4.822582e-02,&
7022        & 4.671228e-02,4.528321e-02,4.392997e-02,4.264325e-02,4.141647e-02,&
7023        & 4.024259e-02,3.911767e-02,3.803309e-02,3.698782e-02,3.597140e-02,&
7024        & 3.498774e-02,3.402852e-02,3.309340e-02,3.217818e-02,3.128292e-02,&
7025        & 3.040486e-02,2.954230e-02,2.869545e-02,2.786261e-02,2.704372e-02,&
7026        & 2.623813e-02,2.544668e-02,2.466788e-02,2.390313e-02,2.315136e-02,&
7027        & 2.241391e-02,2.168921e-02,2.097903e-02 /)
7028 !     BAND  28
7029       extliq1(:, 28) = (/ &
7030        & 6.367074e-01,4.495768e-01,3.471263e-01,2.826149e-01,2.382868e-01,&
7031        & 2.059640e-01,1.813562e-01,1.619881e-01,1.463436e-01,1.334402e-01,&
7032        & 1.226166e-01,1.134096e-01,1.054829e-01,9.858838e-02,9.253790e-02,&
7033        & 8.718582e-02,8.241830e-02,7.814482e-02,7.429212e-02,7.080165e-02,&
7034        & 6.762385e-02,6.471838e-02,6.205388e-02,5.959726e-02,5.732871e-02,&
7035        & 5.522402e-02,5.326793e-02,5.144230e-02,4.973440e-02,4.813188e-02,&
7036        & 4.662283e-02,4.519798e-02,4.384833e-02,4.256541e-02,4.134253e-02,&
7037        & 4.017136e-02,3.904911e-02,3.796779e-02,3.692364e-02,3.591182e-02,&
7038        & 3.492930e-02,3.397230e-02,3.303920e-02,3.212572e-02,3.123278e-02,&
7039        & 3.035519e-02,2.949493e-02,2.864985e-02,2.781840e-02,2.700197e-02,&
7040        & 2.619682e-02,2.540674e-02,2.462966e-02,2.386613e-02,2.311602e-02,&
7041        & 2.237846e-02,2.165660e-02,2.094756e-02 /)
7042 !     BAND  29
7043       extliq1(:, 29) = (/ &
7044        & 4.298416e-01,4.391639e-01,3.975030e-01,3.443028e-01,2.957345e-01,&
7045        & 2.556461e-01,2.234755e-01,1.976636e-01,1.767428e-01,1.595611e-01,&
7046        & 1.452636e-01,1.332156e-01,1.229481e-01,1.141059e-01,1.064208e-01,&
7047        & 9.968527e-02,9.373833e-02,8.845221e-02,8.372112e-02,7.946667e-02,&
7048        & 7.561807e-02,7.212029e-02,6.893166e-02,6.600944e-02,6.332277e-02,&
7049        & 6.084277e-02,5.854721e-02,5.641361e-02,5.442639e-02,5.256750e-02,&
7050        & 5.082499e-02,4.918556e-02,4.763694e-02,4.617222e-02,4.477861e-02,&
7051        & 4.344861e-02,4.217999e-02,4.096111e-02,3.978638e-02,3.865361e-02,&
7052        & 3.755473e-02,3.649028e-02,3.545361e-02,3.444361e-02,3.345666e-02,&
7053        & 3.249167e-02,3.154722e-02,3.062083e-02,2.971250e-02,2.882083e-02,&
7054        & 2.794611e-02,2.708778e-02,2.624500e-02,2.541750e-02,2.460528e-02,&
7055        & 2.381194e-02,2.303250e-02,2.226833e-02 /)
7056
7057 ! Single scattering albedo
7058 !     BAND  16
7059       ssaliq1(:, 16) = (/ &
7060        & 8.362119e-01,8.098460e-01,7.762291e-01,7.486042e-01,7.294172e-01,&
7061        & 7.161000e-01,7.060656e-01,6.978387e-01,6.907193e-01,6.843551e-01,&
7062        & 6.785668e-01,6.732450e-01,6.683191e-01,6.637264e-01,6.594307e-01,&
7063        & 6.554033e-01,6.516115e-01,6.480295e-01,6.446429e-01,6.414306e-01,&
7064        & 6.383783e-01,6.354750e-01,6.327068e-01,6.300665e-01,6.275376e-01,&
7065        & 6.251245e-01,6.228136e-01,6.205944e-01,6.184720e-01,6.164330e-01,&
7066        & 6.144742e-01,6.125962e-01,6.108004e-01,6.090740e-01,6.074200e-01,&
7067        & 6.058381e-01,6.043209e-01,6.028681e-01,6.014836e-01,6.001626e-01,&
7068        & 5.988957e-01,5.976864e-01,5.965390e-01,5.954379e-01,5.943972e-01,&
7069        & 5.934019e-01,5.924624e-01,5.915579e-01,5.907025e-01,5.898913e-01,&
7070        & 5.891213e-01,5.883815e-01,5.876851e-01,5.870158e-01,5.863868e-01,&
7071        & 5.857821e-01,5.852111e-01,5.846579e-01 /)
7072 !     BAND  17
7073       ssaliq1(:, 17) = (/ &
7074        & 6.995459e-01,7.158012e-01,7.076001e-01,6.927244e-01,6.786434e-01,&
7075        & 6.673545e-01,6.585859e-01,6.516314e-01,6.459010e-01,6.410225e-01,&
7076        & 6.367574e-01,6.329554e-01,6.295119e-01,6.263595e-01,6.234462e-01,&
7077        & 6.207274e-01,6.181755e-01,6.157678e-01,6.134880e-01,6.113173e-01,&
7078        & 6.092495e-01,6.072689e-01,6.053717e-01,6.035507e-01,6.018001e-01,&
7079        & 6.001134e-01,5.984951e-01,5.969294e-01,5.954256e-01,5.939698e-01,&
7080        & 5.925716e-01,5.912265e-01,5.899270e-01,5.886771e-01,5.874746e-01,&
7081        & 5.863185e-01,5.852077e-01,5.841460e-01,5.831249e-01,5.821474e-01,&
7082        & 5.812078e-01,5.803173e-01,5.794616e-01,5.786443e-01,5.778617e-01,&
7083        & 5.771236e-01,5.764191e-01,5.757400e-01,5.750971e-01,5.744842e-01,&
7084        & 5.739012e-01,5.733482e-01,5.728175e-01,5.723214e-01,5.718383e-01,&
7085        & 5.713827e-01,5.709471e-01,5.705330e-01 /)
7086 !     BAND  18
7087       ssaliq1(:, 18) = (/ &
7088        & 9.929711e-01,9.896942e-01,9.852408e-01,9.806820e-01,9.764512e-01,&
7089        & 9.725375e-01,9.688677e-01,9.653832e-01,9.620552e-01,9.588522e-01,&
7090        & 9.557475e-01,9.527265e-01,9.497731e-01,9.468756e-01,9.440270e-01,&
7091        & 9.412230e-01,9.384592e-01,9.357287e-01,9.330369e-01,9.303778e-01,&
7092        & 9.277502e-01,9.251546e-01,9.225907e-01,9.200553e-01,9.175521e-01,&
7093        & 9.150773e-01,9.126352e-01,9.102260e-01,9.078485e-01,9.055057e-01,&
7094        & 9.031978e-01,9.009306e-01,8.987010e-01,8.965177e-01,8.943774e-01,&
7095        & 8.922869e-01,8.902430e-01,8.882551e-01,8.863182e-01,8.844373e-01,&
7096        & 8.826143e-01,8.808499e-01,8.791413e-01,8.774940e-01,8.759019e-01,&
7097        & 8.743650e-01,8.728941e-01,8.714712e-01,8.701065e-01,8.688008e-01,&
7098        & 8.675409e-01,8.663295e-01,8.651714e-01,8.640637e-01,8.629943e-01,&
7099        & 8.619762e-01,8.609995e-01,8.600581e-01 /)
7100 !     BAND  19
7101       ssaliq1(:, 19) = (/ &
7102        & 9.910612e-01,9.854226e-01,9.795008e-01,9.742920e-01,9.695996e-01,&
7103        & 9.652274e-01,9.610648e-01,9.570521e-01,9.531397e-01,9.493086e-01,&
7104        & 9.455413e-01,9.418362e-01,9.381902e-01,9.346016e-01,9.310718e-01,&
7105        & 9.275957e-01,9.241757e-01,9.208038e-01,9.174802e-01,9.142058e-01,&
7106        & 9.109753e-01,9.077895e-01,9.046433e-01,9.015409e-01,8.984784e-01,&
7107        & 8.954572e-01,8.924748e-01,8.895367e-01,8.866395e-01,8.837864e-01,&
7108        & 8.809819e-01,8.782267e-01,8.755231e-01,8.728712e-01,8.702802e-01,&
7109        & 8.677443e-01,8.652733e-01,8.628678e-01,8.605300e-01,8.582593e-01,&
7110        & 8.560596e-01,8.539352e-01,8.518782e-01,8.498915e-01,8.479790e-01,&
7111        & 8.461384e-01,8.443645e-01,8.426613e-01,8.410229e-01,8.394495e-01,&
7112        & 8.379428e-01,8.364967e-01,8.351117e-01,8.337820e-01,8.325091e-01,&
7113        & 8.312874e-01,8.301169e-01,8.289985e-01 /)
7114 !     BAND  20
7115       ssaliq1(:, 20) = (/ &
7116        & 9.969802e-01,9.950445e-01,9.931448e-01,9.914272e-01,9.898652e-01,&
7117        & 9.884250e-01,9.870637e-01,9.857482e-01,9.844558e-01,9.831755e-01,&
7118        & 9.819068e-01,9.806477e-01,9.794000e-01,9.781666e-01,9.769461e-01,&
7119        & 9.757386e-01,9.745459e-01,9.733650e-01,9.721953e-01,9.710398e-01,&
7120        & 9.698936e-01,9.687583e-01,9.676334e-01,9.665192e-01,9.654132e-01,&
7121        & 9.643208e-01,9.632374e-01,9.621625e-01,9.611003e-01,9.600518e-01,&
7122        & 9.590144e-01,9.579922e-01,9.569864e-01,9.559948e-01,9.550239e-01,&
7123        & 9.540698e-01,9.531382e-01,9.522280e-01,9.513409e-01,9.504772e-01,&
7124        & 9.496360e-01,9.488220e-01,9.480327e-01,9.472693e-01,9.465333e-01,&
7125        & 9.458211e-01,9.451344e-01,9.444732e-01,9.438372e-01,9.432268e-01,&
7126        & 9.426391e-01,9.420757e-01,9.415308e-01,9.410102e-01,9.405115e-01,&
7127        & 9.400326e-01,9.395716e-01,9.391313e-01 /)
7128 !     BAND  21
7129       ssaliq1(:, 21) = (/ &
7130        & 9.980034e-01,9.968572e-01,9.958696e-01,9.949747e-01,9.941241e-01,&
7131        & 9.933043e-01,9.924971e-01,9.916978e-01,9.909023e-01,9.901046e-01,&
7132        & 9.893087e-01,9.885146e-01,9.877195e-01,9.869283e-01,9.861379e-01,&
7133        & 9.853523e-01,9.845715e-01,9.837945e-01,9.830217e-01,9.822567e-01,&
7134        & 9.814935e-01,9.807356e-01,9.799815e-01,9.792332e-01,9.784845e-01,&
7135        & 9.777424e-01,9.770042e-01,9.762695e-01,9.755416e-01,9.748152e-01,&
7136        & 9.740974e-01,9.733873e-01,9.726813e-01,9.719861e-01,9.713010e-01,&
7137        & 9.706262e-01,9.699647e-01,9.693144e-01,9.686794e-01,9.680596e-01,&
7138        & 9.674540e-01,9.668657e-01,9.662926e-01,9.657390e-01,9.652019e-01,&
7139        & 9.646820e-01,9.641784e-01,9.636945e-01,9.632260e-01,9.627743e-01,&
7140        & 9.623418e-01,9.619227e-01,9.615194e-01,9.611341e-01,9.607629e-01,&
7141        & 9.604057e-01,9.600622e-01,9.597322e-01 /)
7142 !     BAND  22
7143       ssaliq1(:, 22) = (/ &
7144        & 9.988219e-01,9.981767e-01,9.976168e-01,9.971066e-01,9.966195e-01,&
7145        & 9.961566e-01,9.956995e-01,9.952481e-01,9.947982e-01,9.943495e-01,&
7146        & 9.938955e-01,9.934368e-01,9.929825e-01,9.925239e-01,9.920653e-01,&
7147        & 9.916096e-01,9.911552e-01,9.907067e-01,9.902594e-01,9.898178e-01,&
7148        & 9.893791e-01,9.889453e-01,9.885122e-01,9.880837e-01,9.876567e-01,&
7149        & 9.872331e-01,9.868121e-01,9.863938e-01,9.859790e-01,9.855650e-01,&
7150        & 9.851548e-01,9.847491e-01,9.843496e-01,9.839521e-01,9.835606e-01,&
7151        & 9.831771e-01,9.827975e-01,9.824292e-01,9.820653e-01,9.817124e-01,&
7152        & 9.813644e-01,9.810291e-01,9.807020e-01,9.803864e-01,9.800782e-01,&
7153        & 9.797821e-01,9.794958e-01,9.792179e-01,9.789509e-01,9.786940e-01,&
7154        & 9.784460e-01,9.782090e-01,9.779789e-01,9.777553e-01,9.775425e-01,&
7155        & 9.773387e-01,9.771420e-01,9.769529e-01 /)
7156 !     BAND  23
7157       ssaliq1(:, 23) = (/ &
7158        & 9.998902e-01,9.998395e-01,9.997915e-01,9.997442e-01,9.997016e-01,&
7159        & 9.996600e-01,9.996200e-01,9.995806e-01,9.995411e-01,9.995005e-01,&
7160        & 9.994589e-01,9.994178e-01,9.993766e-01,9.993359e-01,9.992948e-01,&
7161        & 9.992533e-01,9.992120e-01,9.991723e-01,9.991313e-01,9.990906e-01,&
7162        & 9.990510e-01,9.990113e-01,9.989716e-01,9.989323e-01,9.988923e-01,&
7163        & 9.988532e-01,9.988140e-01,9.987761e-01,9.987373e-01,9.986989e-01,&
7164        & 9.986597e-01,9.986239e-01,9.985861e-01,9.985485e-01,9.985123e-01,&
7165        & 9.984762e-01,9.984415e-01,9.984065e-01,9.983722e-01,9.983398e-01,&
7166        & 9.983078e-01,9.982758e-01,9.982461e-01,9.982157e-01,9.981872e-01,&
7167        & 9.981595e-01,9.981324e-01,9.981068e-01,9.980811e-01,9.980580e-01,&
7168        & 9.980344e-01,9.980111e-01,9.979908e-01,9.979690e-01,9.979492e-01,&
7169        & 9.979316e-01,9.979116e-01,9.978948e-01 /)
7170 !     BAND  24
7171       ssaliq1(:, 24) = (/ &
7172        & 9.999978e-01,9.999948e-01,9.999915e-01,9.999905e-01,9.999896e-01,&
7173        & 9.999887e-01,9.999888e-01,9.999888e-01,9.999870e-01,9.999854e-01,&
7174        & 9.999855e-01,9.999856e-01,9.999839e-01,9.999834e-01,9.999829e-01,&
7175        & 9.999809e-01,9.999816e-01,9.999793e-01,9.999782e-01,9.999779e-01,&
7176        & 9.999772e-01,9.999764e-01,9.999756e-01,9.999744e-01,9.999744e-01,&
7177        & 9.999736e-01,9.999729e-01,9.999716e-01,9.999706e-01,9.999692e-01,&
7178        & 9.999690e-01,9.999675e-01,9.999673e-01,9.999660e-01,9.999654e-01,&
7179        & 9.999647e-01,9.999647e-01,9.999625e-01,9.999620e-01,9.999614e-01,&
7180        & 9.999613e-01,9.999607e-01,9.999604e-01,9.999594e-01,9.999589e-01,&
7181        & 9.999586e-01,9.999567e-01,9.999550e-01,9.999557e-01,9.999542e-01,&
7182        & 9.999546e-01,9.999539e-01,9.999536e-01,9.999526e-01,9.999523e-01,&
7183        & 9.999508e-01,9.999534e-01,9.999507e-01 /)
7184 !     BAND  25
7185       ssaliq1(:, 25) = (/ &
7186        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7187        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7188        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7189        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999995e-01,&
7190        & 9.999995e-01,9.999990e-01,9.999991e-01,9.999991e-01,9.999990e-01,&
7191        & 9.999989e-01,9.999988e-01,9.999988e-01,9.999986e-01,9.999988e-01,&
7192        & 9.999986e-01,9.999987e-01,9.999986e-01,9.999985e-01,9.999985e-01,&
7193        & 9.999985e-01,9.999985e-01,9.999983e-01,9.999983e-01,9.999981e-01,&
7194        & 9.999981e-01,9.999986e-01,9.999985e-01,9.999983e-01,9.999984e-01,&
7195        & 9.999982e-01,9.999983e-01,9.999982e-01,9.999980e-01,9.999981e-01,&
7196        & 9.999978e-01,9.999979e-01,9.999985e-01,9.999985e-01,9.999983e-01,&
7197        & 9.999983e-01,9.999983e-01,9.999983e-01 /)
7198 !     BAND  26
7199       ssaliq1(:, 26) = (/ &
7200        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7201        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7202        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
7203        & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999991e-01,&
7204        & 9.999990e-01,9.999992e-01,9.999995e-01,9.999986e-01,9.999994e-01,&
7205        & 9.999985e-01,9.999980e-01,9.999984e-01,9.999983e-01,9.999979e-01,&
7206        & 9.999969e-01,9.999977e-01,9.999971e-01,9.999969e-01,9.999969e-01,&
7207        & 9.999965e-01,9.999970e-01,9.999985e-01,9.999973e-01,9.999961e-01,&
7208        & 9.999968e-01,9.999952e-01,9.999970e-01,9.999974e-01,9.999965e-01,&
7209        & 9.999969e-01,9.999970e-01,9.999970e-01,9.999960e-01,9.999923e-01,&
7210        & 9.999958e-01,9.999937e-01,9.999960e-01,9.999953e-01,9.999946e-01,&
7211        & 9.999946e-01,9.999957e-01,9.999951e-01 /)
7212 !     BAND  27
7213       ssaliq1(:, 27) = (/ &
7214        & 1.000000e+00,1.000000e+00,9.999983e-01,9.999979e-01,9.999965e-01,&
7215        & 9.999949e-01,9.999948e-01,9.999918e-01,9.999917e-01,9.999923e-01,&
7216        & 9.999908e-01,9.999889e-01,9.999902e-01,9.999895e-01,9.999881e-01,&
7217        & 9.999882e-01,9.999876e-01,9.999866e-01,9.999866e-01,9.999858e-01,&
7218        & 9.999860e-01,9.999852e-01,9.999836e-01,9.999831e-01,9.999818e-01,&
7219        & 9.999808e-01,9.999816e-01,9.999800e-01,9.999783e-01,9.999780e-01,&
7220        & 9.999763e-01,9.999746e-01,9.999731e-01,9.999713e-01,9.999762e-01,&
7221        & 9.999740e-01,9.999670e-01,9.999703e-01,9.999687e-01,9.999666e-01,&
7222        & 9.999683e-01,9.999667e-01,9.999611e-01,9.999635e-01,9.999600e-01,&
7223        & 9.999635e-01,9.999594e-01,9.999601e-01,9.999586e-01,9.999559e-01,&
7224        & 9.999569e-01,9.999558e-01,9.999523e-01,9.999535e-01,9.999529e-01,&
7225        & 9.999553e-01,9.999495e-01,9.999490e-01 /)
7226 !     BAND  28
7227       ssaliq1(:, 28) = (/ &
7228        & 9.999920e-01,9.999873e-01,9.999855e-01,9.999832e-01,9.999807e-01,&
7229        & 9.999778e-01,9.999754e-01,9.999721e-01,9.999692e-01,9.999651e-01,&
7230        & 9.999621e-01,9.999607e-01,9.999567e-01,9.999546e-01,9.999521e-01,&
7231        & 9.999491e-01,9.999457e-01,9.999439e-01,9.999403e-01,9.999374e-01,&
7232        & 9.999353e-01,9.999315e-01,9.999282e-01,9.999244e-01,9.999234e-01,&
7233        & 9.999189e-01,9.999130e-01,9.999117e-01,9.999073e-01,9.999020e-01,&
7234        & 9.998993e-01,9.998987e-01,9.998922e-01,9.998893e-01,9.998869e-01,&
7235        & 9.998805e-01,9.998778e-01,9.998751e-01,9.998708e-01,9.998676e-01,&
7236        & 9.998624e-01,9.998642e-01,9.998582e-01,9.998547e-01,9.998546e-01,&
7237        & 9.998477e-01,9.998487e-01,9.998466e-01,9.998403e-01,9.998412e-01,&
7238        & 9.998406e-01,9.998342e-01,9.998326e-01,9.998333e-01,9.998328e-01,&
7239        & 9.998290e-01,9.998276e-01,9.998249e-01 /)
7240 !     BAND  29
7241       ssaliq1(:, 29) = (/ &
7242        & 8.383753e-01,8.461471e-01,8.373325e-01,8.212889e-01,8.023834e-01,&
7243        & 7.829501e-01,7.641777e-01,7.466000e-01,7.304023e-01,7.155998e-01,&
7244        & 7.021259e-01,6.898840e-01,6.787615e-01,6.686479e-01,6.594414e-01,&
7245        & 6.510417e-01,6.433668e-01,6.363335e-01,6.298788e-01,6.239398e-01,&
7246        & 6.184633e-01,6.134055e-01,6.087228e-01,6.043786e-01,6.003439e-01,&
7247        & 5.965910e-01,5.930917e-01,5.898280e-01,5.867798e-01,5.839264e-01,&
7248        & 5.812576e-01,5.787592e-01,5.764163e-01,5.742189e-01,5.721598e-01,&
7249        & 5.702286e-01,5.684182e-01,5.667176e-01,5.651237e-01,5.636253e-01,&
7250        & 5.622228e-01,5.609074e-01,5.596713e-01,5.585089e-01,5.574223e-01,&
7251        & 5.564002e-01,5.554411e-01,5.545397e-01,5.536914e-01,5.528967e-01,&
7252        & 5.521495e-01,5.514457e-01,5.507818e-01,5.501623e-01,5.495750e-01,&
7253        & 5.490192e-01,5.484980e-01,5.480046e-01 /)
7254
7255 ! Asymmetry parameter
7256 !     BAND  16
7257       asyliq1(:, 16) = (/ &
7258        & 8.038165e-01,8.014154e-01,7.942381e-01,7.970521e-01,8.086621e-01,&
7259        & 8.233392e-01,8.374127e-01,8.495742e-01,8.596945e-01,8.680497e-01,&
7260        & 8.750005e-01,8.808589e-01,8.858749e-01,8.902403e-01,8.940939e-01,&
7261        & 8.975379e-01,9.006450e-01,9.034741e-01,9.060659e-01,9.084561e-01,&
7262        & 9.106675e-01,9.127198e-01,9.146332e-01,9.164194e-01,9.180970e-01,&
7263        & 9.196658e-01,9.211421e-01,9.225352e-01,9.238443e-01,9.250841e-01,&
7264        & 9.262541e-01,9.273620e-01,9.284081e-01,9.294002e-01,9.303395e-01,&
7265        & 9.312285e-01,9.320715e-01,9.328716e-01,9.336271e-01,9.343427e-01,&
7266        & 9.350219e-01,9.356647e-01,9.362728e-01,9.368495e-01,9.373956e-01,&
7267        & 9.379113e-01,9.383987e-01,9.388608e-01,9.392986e-01,9.397132e-01,&
7268        & 9.401063e-01,9.404776e-01,9.408299e-01,9.411641e-01,9.414800e-01,&
7269        & 9.417787e-01,9.420633e-01,9.423364e-01 /)
7270 !     BAND  17
7271       asyliq1(:, 17) = (/ &
7272        & 8.941000e-01,9.054049e-01,9.049510e-01,9.027216e-01,9.021636e-01,&
7273        & 9.037878e-01,9.069852e-01,9.109817e-01,9.152013e-01,9.193040e-01,&
7274        & 9.231177e-01,9.265712e-01,9.296606e-01,9.324048e-01,9.348419e-01,&
7275        & 9.370131e-01,9.389529e-01,9.406954e-01,9.422727e-01,9.437088e-01,&
7276        & 9.450221e-01,9.462308e-01,9.473488e-01,9.483830e-01,9.493492e-01,&
7277        & 9.502541e-01,9.510999e-01,9.518971e-01,9.526455e-01,9.533554e-01,&
7278        & 9.540249e-01,9.546571e-01,9.552551e-01,9.558258e-01,9.563603e-01,&
7279        & 9.568713e-01,9.573569e-01,9.578141e-01,9.582485e-01,9.586604e-01,&
7280        & 9.590525e-01,9.594218e-01,9.597710e-01,9.601052e-01,9.604181e-01,&
7281        & 9.607159e-01,9.609979e-01,9.612655e-01,9.615184e-01,9.617564e-01,&
7282        & 9.619860e-01,9.622009e-01,9.624031e-01,9.625957e-01,9.627792e-01,&
7283        & 9.629530e-01,9.631171e-01,9.632746e-01 /)
7284 !     BAND  18
7285       asyliq1(:, 18) = (/ &
7286        & 8.574638e-01,8.351383e-01,8.142977e-01,8.083068e-01,8.129284e-01,&
7287        & 8.215827e-01,8.307238e-01,8.389963e-01,8.460481e-01,8.519273e-01,&
7288        & 8.568153e-01,8.609116e-01,8.643892e-01,8.673941e-01,8.700248e-01,&
7289        & 8.723707e-01,8.744902e-01,8.764240e-01,8.782057e-01,8.798593e-01,&
7290        & 8.814063e-01,8.828573e-01,8.842261e-01,8.855196e-01,8.867497e-01,&
7291        & 8.879164e-01,8.890316e-01,8.900941e-01,8.911118e-01,8.920832e-01,&
7292        & 8.930156e-01,8.939091e-01,8.947663e-01,8.955888e-01,8.963786e-01,&
7293        & 8.971350e-01,8.978617e-01,8.985590e-01,8.992243e-01,8.998631e-01,&
7294        & 9.004753e-01,9.010602e-01,9.016192e-01,9.021542e-01,9.026644e-01,&
7295        & 9.031535e-01,9.036194e-01,9.040656e-01,9.044894e-01,9.048933e-01,&
7296        & 9.052789e-01,9.056481e-01,9.060004e-01,9.063343e-01,9.066544e-01,&
7297        & 9.069604e-01,9.072512e-01,9.075290e-01 /)
7298 !     BAND  19
7299       asyliq1(:, 19) = (/ &
7300        & 8.349569e-01,8.034579e-01,7.932136e-01,8.010156e-01,8.137083e-01,&
7301        & 8.255339e-01,8.351938e-01,8.428286e-01,8.488944e-01,8.538187e-01,&
7302        & 8.579255e-01,8.614473e-01,8.645338e-01,8.672908e-01,8.697947e-01,&
7303        & 8.720843e-01,8.742015e-01,8.761718e-01,8.780160e-01,8.797479e-01,&
7304        & 8.813810e-01,8.829250e-01,8.843907e-01,8.857822e-01,8.871059e-01,&
7305        & 8.883724e-01,8.895810e-01,8.907384e-01,8.918456e-01,8.929083e-01,&
7306        & 8.939284e-01,8.949060e-01,8.958463e-01,8.967486e-01,8.976129e-01,&
7307        & 8.984463e-01,8.992439e-01,9.000094e-01,9.007438e-01,9.014496e-01,&
7308        & 9.021235e-01,9.027699e-01,9.033859e-01,9.039772e-01,9.045419e-01,&
7309        & 9.050819e-01,9.055975e-01,9.060907e-01,9.065607e-01,9.070093e-01,&
7310        & 9.074389e-01,9.078475e-01,9.082388e-01,9.086117e-01,9.089678e-01,&
7311        & 9.093081e-01,9.096307e-01,9.099410e-01 /)
7312 !     BAND  20
7313       asyliq1(:, 20) = (/ &
7314        & 8.109692e-01,7.846657e-01,7.881928e-01,8.009509e-01,8.131208e-01,&
7315        & 8.230400e-01,8.309448e-01,8.372920e-01,8.424837e-01,8.468166e-01,&
7316        & 8.504947e-01,8.536642e-01,8.564256e-01,8.588513e-01,8.610011e-01,&
7317        & 8.629122e-01,8.646262e-01,8.661720e-01,8.675752e-01,8.688582e-01,&
7318        & 8.700379e-01,8.711300e-01,8.721485e-01,8.731027e-01,8.740010e-01,&
7319        & 8.748499e-01,8.756564e-01,8.764239e-01,8.771542e-01,8.778523e-01,&
7320        & 8.785211e-01,8.791601e-01,8.797725e-01,8.803589e-01,8.809173e-01,&
7321        & 8.814552e-01,8.819705e-01,8.824611e-01,8.829311e-01,8.833791e-01,&
7322        & 8.838078e-01,8.842148e-01,8.846044e-01,8.849756e-01,8.853291e-01,&
7323        & 8.856645e-01,8.859841e-01,8.862904e-01,8.865801e-01,8.868551e-01,&
7324        & 8.871182e-01,8.873673e-01,8.876059e-01,8.878307e-01,8.880462e-01,&
7325        & 8.882501e-01,8.884453e-01,8.886339e-01 /)
7326 !     BAND  21
7327       asyliq1(:, 21) = (/ &
7328        & 7.838510e-01,7.803151e-01,7.980477e-01,8.144160e-01,8.261784e-01,&
7329        & 8.344240e-01,8.404278e-01,8.450391e-01,8.487593e-01,8.518741e-01,&
7330        & 8.545484e-01,8.568890e-01,8.589560e-01,8.607983e-01,8.624504e-01,&
7331        & 8.639408e-01,8.652945e-01,8.665301e-01,8.676634e-01,8.687121e-01,&
7332        & 8.696855e-01,8.705933e-01,8.714448e-01,8.722454e-01,8.730014e-01,&
7333        & 8.737180e-01,8.743982e-01,8.750436e-01,8.756598e-01,8.762481e-01,&
7334        & 8.768089e-01,8.773427e-01,8.778532e-01,8.783434e-01,8.788089e-01,&
7335        & 8.792530e-01,8.796784e-01,8.800845e-01,8.804716e-01,8.808411e-01,&
7336        & 8.811923e-01,8.815276e-01,8.818472e-01,8.821504e-01,8.824408e-01,&
7337        & 8.827155e-01,8.829777e-01,8.832269e-01,8.834631e-01,8.836892e-01,&
7338        & 8.839034e-01,8.841075e-01,8.843021e-01,8.844866e-01,8.846631e-01,&
7339        & 8.848304e-01,8.849910e-01,8.851425e-01 /)
7340 !     BAND  22
7341       asyliq1(:, 22) = (/ &
7342        & 7.760783e-01,7.890215e-01,8.090192e-01,8.230252e-01,8.321369e-01,&
7343        & 8.384258e-01,8.431529e-01,8.469558e-01,8.501499e-01,8.528899e-01,&
7344        & 8.552899e-01,8.573956e-01,8.592570e-01,8.609098e-01,8.623897e-01,&
7345        & 8.637169e-01,8.649184e-01,8.660097e-01,8.670096e-01,8.679338e-01,&
7346        & 8.687896e-01,8.695880e-01,8.703365e-01,8.710422e-01,8.717092e-01,&
7347        & 8.723378e-01,8.729363e-01,8.735063e-01,8.740475e-01,8.745661e-01,&
7348        & 8.750560e-01,8.755275e-01,8.759731e-01,8.764000e-01,8.768071e-01,&
7349        & 8.771942e-01,8.775628e-01,8.779126e-01,8.782483e-01,8.785626e-01,&
7350        & 8.788610e-01,8.791482e-01,8.794180e-01,8.796765e-01,8.799207e-01,&
7351        & 8.801522e-01,8.803707e-01,8.805777e-01,8.807749e-01,8.809605e-01,&
7352        & 8.811362e-01,8.813047e-01,8.814647e-01,8.816131e-01,8.817588e-01,&
7353        & 8.818930e-01,8.820230e-01,8.821445e-01 /)
7354 !     BAND  23
7355       asyliq1(:, 23) = (/ &
7356        & 7.847907e-01,8.099917e-01,8.257428e-01,8.350423e-01,8.411971e-01,&
7357        & 8.457241e-01,8.493010e-01,8.522565e-01,8.547660e-01,8.569311e-01,&
7358        & 8.588181e-01,8.604729e-01,8.619296e-01,8.632208e-01,8.643725e-01,&
7359        & 8.654050e-01,8.663363e-01,8.671835e-01,8.679590e-01,8.686707e-01,&
7360        & 8.693308e-01,8.699433e-01,8.705147e-01,8.710490e-01,8.715497e-01,&
7361        & 8.720219e-01,8.724669e-01,8.728849e-01,8.732806e-01,8.736550e-01,&
7362        & 8.740099e-01,8.743435e-01,8.746601e-01,8.749610e-01,8.752449e-01,&
7363        & 8.755143e-01,8.757688e-01,8.760095e-01,8.762375e-01,8.764532e-01,&
7364        & 8.766579e-01,8.768506e-01,8.770323e-01,8.772049e-01,8.773690e-01,&
7365        & 8.775226e-01,8.776679e-01,8.778062e-01,8.779360e-01,8.780587e-01,&
7366        & 8.781747e-01,8.782852e-01,8.783892e-01,8.784891e-01,8.785824e-01,&
7367        & 8.786705e-01,8.787546e-01,8.788336e-01 /)
7368 !     BAND  24
7369       asyliq1(:, 24) = (/ &
7370        & 8.054324e-01,8.266282e-01,8.378075e-01,8.449848e-01,8.502166e-01,&
7371        & 8.542268e-01,8.573477e-01,8.598022e-01,8.617689e-01,8.633859e-01,&
7372        & 8.647536e-01,8.659354e-01,8.669807e-01,8.679143e-01,8.687577e-01,&
7373        & 8.695222e-01,8.702207e-01,8.708591e-01,8.714446e-01,8.719836e-01,&
7374        & 8.724812e-01,8.729426e-01,8.733689e-01,8.737665e-01,8.741373e-01,&
7375        & 8.744834e-01,8.748070e-01,8.751131e-01,8.754011e-01,8.756676e-01,&
7376        & 8.759219e-01,8.761599e-01,8.763857e-01,8.765984e-01,8.767999e-01,&
7377        & 8.769889e-01,8.771669e-01,8.773373e-01,8.774969e-01,8.776469e-01,&
7378        & 8.777894e-01,8.779237e-01,8.780505e-01,8.781703e-01,8.782820e-01,&
7379        & 8.783886e-01,8.784894e-01,8.785844e-01,8.786736e-01,8.787584e-01,&
7380        & 8.788379e-01,8.789130e-01,8.789849e-01,8.790506e-01,8.791141e-01,&
7381        & 8.791750e-01,8.792324e-01,8.792867e-01 /)
7382 !     BAND  25
7383       asyliq1(:, 25) = (/ &
7384        & 8.249534e-01,8.391988e-01,8.474107e-01,8.526860e-01,8.563983e-01,&
7385        & 8.592389e-01,8.615144e-01,8.633790e-01,8.649325e-01,8.662504e-01,&
7386        & 8.673841e-01,8.683741e-01,8.692495e-01,8.700309e-01,8.707328e-01,&
7387        & 8.713650e-01,8.719432e-01,8.724676e-01,8.729498e-01,8.733922e-01,&
7388        & 8.737981e-01,8.741745e-01,8.745225e-01,8.748467e-01,8.751512e-01,&
7389        & 8.754315e-01,8.756962e-01,8.759450e-01,8.761774e-01,8.763945e-01,&
7390        & 8.766021e-01,8.767970e-01,8.769803e-01,8.771511e-01,8.773151e-01,&
7391        & 8.774689e-01,8.776147e-01,8.777533e-01,8.778831e-01,8.780050e-01,&
7392        & 8.781197e-01,8.782301e-01,8.783323e-01,8.784312e-01,8.785222e-01,&
7393        & 8.786096e-01,8.786916e-01,8.787688e-01,8.788411e-01,8.789122e-01,&
7394        & 8.789762e-01,8.790373e-01,8.790954e-01,8.791514e-01,8.792018e-01,&
7395        & 8.792517e-01,8.792990e-01,8.793429e-01 /)
7396 !     BAND  26
7397       asyliq1(:, 26) = (/ &
7398        & 8.323091e-01,8.429776e-01,8.498123e-01,8.546929e-01,8.584295e-01,&
7399        & 8.613489e-01,8.636324e-01,8.654303e-01,8.668675e-01,8.680404e-01,&
7400        & 8.690174e-01,8.698495e-01,8.705666e-01,8.711961e-01,8.717556e-01,&
7401        & 8.722546e-01,8.727063e-01,8.731170e-01,8.734933e-01,8.738382e-01,&
7402        & 8.741590e-01,8.744525e-01,8.747295e-01,8.749843e-01,8.752210e-01,&
7403        & 8.754437e-01,8.756524e-01,8.758472e-01,8.760288e-01,8.762030e-01,&
7404        & 8.763603e-01,8.765122e-01,8.766539e-01,8.767894e-01,8.769130e-01,&
7405        & 8.770310e-01,8.771422e-01,8.772437e-01,8.773419e-01,8.774355e-01,&
7406        & 8.775221e-01,8.776047e-01,8.776802e-01,8.777539e-01,8.778216e-01,&
7407        & 8.778859e-01,8.779473e-01,8.780031e-01,8.780562e-01,8.781097e-01,&
7408        & 8.781570e-01,8.782021e-01,8.782463e-01,8.782845e-01,8.783235e-01,&
7409        & 8.783610e-01,8.783953e-01,8.784273e-01 /)
7410 !     BAND  27
7411       asyliq1(:, 27) = (/ &
7412        & 8.396448e-01,8.480172e-01,8.535934e-01,8.574145e-01,8.600835e-01,&
7413        & 8.620347e-01,8.635500e-01,8.648003e-01,8.658758e-01,8.668248e-01,&
7414        & 8.676697e-01,8.684220e-01,8.690893e-01,8.696807e-01,8.702046e-01,&
7415        & 8.706676e-01,8.710798e-01,8.714478e-01,8.717778e-01,8.720747e-01,&
7416        & 8.723431e-01,8.725889e-01,8.728144e-01,8.730201e-01,8.732129e-01,&
7417        & 8.733907e-01,8.735541e-01,8.737100e-01,8.738533e-01,8.739882e-01,&
7418        & 8.741164e-01,8.742362e-01,8.743485e-01,8.744530e-01,8.745512e-01,&
7419        & 8.746471e-01,8.747373e-01,8.748186e-01,8.748973e-01,8.749732e-01,&
7420        & 8.750443e-01,8.751105e-01,8.751747e-01,8.752344e-01,8.752902e-01,&
7421        & 8.753412e-01,8.753917e-01,8.754393e-01,8.754843e-01,8.755282e-01,&
7422        & 8.755662e-01,8.756039e-01,8.756408e-01,8.756722e-01,8.757072e-01,&
7423        & 8.757352e-01,8.757653e-01,8.757932e-01 /)
7424 !     BAND  28
7425       asyliq1(:, 28) = (/ &
7426        & 8.374590e-01,8.465669e-01,8.518701e-01,8.547627e-01,8.565745e-01,&
7427        & 8.579065e-01,8.589717e-01,8.598632e-01,8.606363e-01,8.613268e-01,&
7428        & 8.619560e-01,8.625340e-01,8.630689e-01,8.635601e-01,8.640084e-01,&
7429        & 8.644180e-01,8.647885e-01,8.651220e-01,8.654218e-01,8.656908e-01,&
7430        & 8.659294e-01,8.661422e-01,8.663334e-01,8.665037e-01,8.666543e-01,&
7431        & 8.667913e-01,8.669156e-01,8.670242e-01,8.671249e-01,8.672161e-01,&
7432        & 8.672993e-01,8.673733e-01,8.674457e-01,8.675103e-01,8.675713e-01,&
7433        & 8.676267e-01,8.676798e-01,8.677286e-01,8.677745e-01,8.678178e-01,&
7434        & 8.678601e-01,8.678986e-01,8.679351e-01,8.679693e-01,8.680013e-01,&
7435        & 8.680334e-01,8.680624e-01,8.680915e-01,8.681178e-01,8.681428e-01,&
7436        & 8.681654e-01,8.681899e-01,8.682103e-01,8.682317e-01,8.682498e-01,&
7437        & 8.682677e-01,8.682861e-01,8.683041e-01 /)
7438 !     BAND  29
7439       asyliq1(:, 29) = (/ &
7440        & 7.877069e-01,8.244281e-01,8.367971e-01,8.409074e-01,8.429859e-01,&
7441        & 8.454386e-01,8.489350e-01,8.534141e-01,8.585814e-01,8.641267e-01,&
7442        & 8.697999e-01,8.754223e-01,8.808785e-01,8.860944e-01,8.910354e-01,&
7443        & 8.956837e-01,9.000392e-01,9.041091e-01,9.079071e-01,9.114479e-01,&
7444        & 9.147462e-01,9.178234e-01,9.206903e-01,9.233663e-01,9.258668e-01,&
7445        & 9.282006e-01,9.303847e-01,9.324288e-01,9.343418e-01,9.361356e-01,&
7446        & 9.378176e-01,9.393939e-01,9.408736e-01,9.422622e-01,9.435670e-01,&
7447        & 9.447900e-01,9.459395e-01,9.470199e-01,9.480335e-01,9.489852e-01,&
7448        & 9.498782e-01,9.507168e-01,9.515044e-01,9.522470e-01,9.529409e-01,&
7449        & 9.535946e-01,9.542071e-01,9.547838e-01,9.553256e-01,9.558351e-01,&
7450        & 9.563139e-01,9.567660e-01,9.571915e-01,9.575901e-01,9.579685e-01,&
7451        & 9.583239e-01,9.586602e-01,9.589766e-01 /)
7452
7453
7454 ! Spherical Ice Particle Parameterization
7455 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
7456       extice2(:, 16) = (/ &
7457 ! band 16
7458         & 4.101824e-01 ,2.435514e-01 ,1.713697e-01 ,1.314865e-01 ,1.063406e-01 ,&
7459         & 8.910701e-02 ,7.659480e-02 ,6.711784e-02 ,5.970353e-02 ,5.375249e-02 ,&
7460         & 4.887577e-02 ,4.481025e-02 ,4.137171e-02 ,3.842744e-02 ,3.587948e-02 ,&
7461         & 3.365396e-02 ,3.169419e-02 ,2.995593e-02 ,2.840419e-02 ,2.701091e-02 ,&
7462         & 2.575336e-02 ,2.461293e-02 ,2.357423e-02 ,2.262443e-02 ,2.175276e-02 ,&
7463         & 2.095012e-02 ,2.020875e-02 ,1.952199e-02 ,1.888412e-02 ,1.829018e-02 ,&
7464         & 1.773586e-02 ,1.721738e-02 ,1.673144e-02 ,1.627510e-02 ,1.584579e-02 ,&
7465         & 1.544122e-02 ,1.505934e-02 ,1.469833e-02 ,1.435654e-02 ,1.403251e-02 ,&
7466         & 1.372492e-02 ,1.343255e-02 ,1.315433e-02  /)
7467       extice2(:, 17) = (/ &
7468 ! band 17
7469         & 3.836650e-01 ,2.304055e-01 ,1.637265e-01 ,1.266681e-01 ,1.031602e-01 ,&
7470         & 8.695191e-02 ,7.511544e-02 ,6.610009e-02 ,5.900909e-02 ,5.328833e-02 ,&
7471         & 4.857728e-02 ,4.463133e-02 ,4.127880e-02 ,3.839567e-02 ,3.589013e-02 ,&
7472         & 3.369280e-02 ,3.175027e-02 ,3.002079e-02 ,2.847121e-02 ,2.707493e-02 ,&
7473         & 2.581031e-02 ,2.465962e-02 ,2.360815e-02 ,2.264363e-02 ,2.175571e-02 ,&
7474         & 2.093563e-02 ,2.017592e-02 ,1.947015e-02 ,1.881278e-02 ,1.819901e-02 ,&
7475         & 1.762463e-02 ,1.708598e-02 ,1.657982e-02 ,1.610330e-02 ,1.565390e-02 ,&
7476         & 1.522937e-02 ,1.482768e-02 ,1.444706e-02 ,1.408588e-02 ,1.374270e-02 ,&
7477         & 1.341619e-02 ,1.310517e-02 ,1.280857e-02  /)
7478       extice2(:, 18) = (/ &
7479 ! band 18
7480         & 4.152673e-01 ,2.436816e-01 ,1.702243e-01 ,1.299704e-01 ,1.047528e-01 ,&
7481         & 8.756039e-02 ,7.513327e-02 ,6.575690e-02 ,5.844616e-02 ,5.259609e-02 ,&
7482         & 4.781531e-02 ,4.383980e-02 ,4.048517e-02 ,3.761891e-02 ,3.514342e-02 ,&
7483         & 3.298525e-02 ,3.108814e-02 ,2.940825e-02 ,2.791096e-02 ,2.656858e-02 ,&
7484         & 2.535869e-02 ,2.426297e-02 ,2.326627e-02 ,2.235602e-02 ,2.152164e-02 ,&
7485         & 2.075420e-02 ,2.004613e-02 ,1.939091e-02 ,1.878296e-02 ,1.821744e-02 ,&
7486         & 1.769015e-02 ,1.719741e-02 ,1.673600e-02 ,1.630308e-02 ,1.589615e-02 ,&
7487         & 1.551298e-02 ,1.515159e-02 ,1.481021e-02 ,1.448726e-02 ,1.418131e-02 ,&
7488         & 1.389109e-02 ,1.361544e-02 ,1.335330e-02  /)
7489       extice2(:, 19) = (/ &
7490 ! band 19
7491         & 3.873250e-01 ,2.331609e-01 ,1.655002e-01 ,1.277753e-01 ,1.038247e-01 ,&
7492         & 8.731780e-02 ,7.527638e-02 ,6.611873e-02 ,5.892850e-02 ,5.313885e-02 ,&
7493         & 4.838068e-02 ,4.440356e-02 ,4.103167e-02 ,3.813804e-02 ,3.562870e-02 ,&
7494         & 3.343269e-02 ,3.149539e-02 ,2.977414e-02 ,2.823510e-02 ,2.685112e-02 ,&
7495         & 2.560015e-02 ,2.446411e-02 ,2.342805e-02 ,2.247948e-02 ,2.160789e-02 ,&
7496         & 2.080438e-02 ,2.006139e-02 ,1.937238e-02 ,1.873177e-02 ,1.813469e-02 ,&
7497         & 1.757689e-02 ,1.705468e-02 ,1.656479e-02 ,1.610435e-02 ,1.567081e-02 ,&
7498         & 1.526192e-02 ,1.487565e-02 ,1.451020e-02 ,1.416396e-02 ,1.383546e-02 ,&
7499         & 1.352339e-02 ,1.322657e-02 ,1.294392e-02  /)
7500       extice2(:, 20) = (/ &
7501 ! band 20
7502         & 3.784280e-01 ,2.291396e-01 ,1.632551e-01 ,1.263775e-01 ,1.028944e-01 ,&
7503         & 8.666975e-02 ,7.480952e-02 ,6.577335e-02 ,5.866714e-02 ,5.293694e-02 ,&
7504         & 4.822153e-02 ,4.427547e-02 ,4.092626e-02 ,3.804918e-02 ,3.555184e-02 ,&
7505         & 3.336440e-02 ,3.143307e-02 ,2.971577e-02 ,2.817912e-02 ,2.679632e-02 ,&
7506         & 2.554558e-02 ,2.440903e-02 ,2.337187e-02 ,2.242173e-02 ,2.154821e-02 ,&
7507         & 2.074249e-02 ,1.999706e-02 ,1.930546e-02 ,1.866212e-02 ,1.806221e-02 ,&
7508         & 1.750152e-02 ,1.697637e-02 ,1.648352e-02 ,1.602010e-02 ,1.558358e-02 ,&
7509         & 1.517172e-02 ,1.478250e-02 ,1.441413e-02 ,1.406498e-02 ,1.373362e-02 ,&
7510         & 1.341872e-02 ,1.311911e-02 ,1.283371e-02  /)
7511       extice2(:, 21) = (/ &
7512 ! band 21
7513         & 3.719909e-01 ,2.259490e-01 ,1.613144e-01 ,1.250648e-01 ,1.019462e-01 ,&
7514         & 8.595358e-02 ,7.425064e-02 ,6.532618e-02 ,5.830218e-02 ,5.263421e-02 ,&
7515         & 4.796697e-02 ,4.405891e-02 ,4.074013e-02 ,3.788776e-02 ,3.541071e-02 ,&
7516         & 3.324008e-02 ,3.132280e-02 ,2.961733e-02 ,2.809071e-02 ,2.671645e-02 ,&
7517         & 2.547302e-02 ,2.434276e-02 ,2.331102e-02 ,2.236558e-02 ,2.149614e-02 ,&
7518         & 2.069397e-02 ,1.995163e-02 ,1.926272e-02 ,1.862174e-02 ,1.802389e-02 ,&
7519         & 1.746500e-02 ,1.694142e-02 ,1.644994e-02 ,1.598772e-02 ,1.555225e-02 ,&
7520         & 1.514129e-02 ,1.475286e-02 ,1.438515e-02 ,1.403659e-02 ,1.370572e-02 ,&
7521         & 1.339124e-02 ,1.309197e-02 ,1.280685e-02  /)
7522       extice2(:, 22) = (/ &
7523 ! band 22
7524         & 3.713158e-01 ,2.253816e-01 ,1.608461e-01 ,1.246718e-01 ,1.016109e-01 ,&
7525         & 8.566332e-02 ,7.399666e-02 ,6.510199e-02 ,5.810290e-02 ,5.245608e-02 ,&
7526         & 4.780702e-02 ,4.391478e-02 ,4.060989e-02 ,3.776982e-02 ,3.530374e-02 ,&
7527         & 3.314296e-02 ,3.123458e-02 ,2.953719e-02 ,2.801794e-02 ,2.665043e-02 ,&
7528         & 2.541321e-02 ,2.428868e-02 ,2.326224e-02 ,2.232173e-02 ,2.145688e-02 ,&
7529         & 2.065899e-02 ,1.992067e-02 ,1.923552e-02 ,1.859808e-02 ,1.800356e-02 ,&
7530         & 1.744782e-02 ,1.692721e-02 ,1.643855e-02 ,1.597900e-02 ,1.554606e-02 ,&
7531         & 1.513751e-02 ,1.475137e-02 ,1.438586e-02 ,1.403938e-02 ,1.371050e-02 ,&
7532         & 1.339793e-02 ,1.310050e-02 ,1.281713e-02  /)
7533       extice2(:, 23) = (/ &
7534 ! band 23
7535         & 3.605883e-01 ,2.204388e-01 ,1.580431e-01 ,1.229033e-01 ,1.004203e-01 ,&
7536         & 8.482616e-02 ,7.338941e-02 ,6.465105e-02 ,5.776176e-02 ,5.219398e-02 ,&
7537         & 4.760288e-02 ,4.375369e-02 ,4.048111e-02 ,3.766539e-02 ,3.521771e-02 ,&
7538         & 3.307079e-02 ,3.117277e-02 ,2.948303e-02 ,2.796929e-02 ,2.660560e-02 ,&
7539         & 2.537086e-02 ,2.424772e-02 ,2.322182e-02 ,2.228114e-02 ,2.141556e-02 ,&
7540         & 2.061649e-02 ,1.987661e-02 ,1.918962e-02 ,1.855009e-02 ,1.795330e-02 ,&
7541         & 1.739514e-02 ,1.687199e-02 ,1.638069e-02 ,1.591845e-02 ,1.548276e-02 ,&
7542         & 1.507143e-02 ,1.468249e-02 ,1.431416e-02 ,1.396486e-02 ,1.363318e-02 ,&
7543         & 1.331781e-02 ,1.301759e-02 ,1.273147e-02  /)
7544       extice2(:, 24) = (/ &
7545 ! band 24
7546         & 3.527890e-01 ,2.168469e-01 ,1.560090e-01 ,1.216216e-01 ,9.955787e-02 ,&
7547         & 8.421942e-02 ,7.294827e-02 ,6.432192e-02 ,5.751081e-02 ,5.199888e-02 ,&
7548         & 4.744835e-02 ,4.362899e-02 ,4.037847e-02 ,3.757910e-02 ,3.514351e-02 ,&
7549         & 3.300546e-02 ,3.111382e-02 ,2.942853e-02 ,2.791775e-02 ,2.655584e-02 ,&
7550         & 2.532195e-02 ,2.419892e-02 ,2.317255e-02 ,2.223092e-02 ,2.136402e-02 ,&
7551         & 2.056334e-02 ,1.982160e-02 ,1.913258e-02 ,1.849087e-02 ,1.789178e-02 ,&
7552         & 1.733124e-02 ,1.680565e-02 ,1.631187e-02 ,1.584711e-02 ,1.540889e-02 ,&
7553         & 1.499502e-02 ,1.460354e-02 ,1.423269e-02 ,1.388088e-02 ,1.354670e-02 ,&
7554         & 1.322887e-02 ,1.292620e-02 ,1.263767e-02  /)
7555       extice2(:, 25) = (/ &
7556 ! band 25
7557         & 3.477874e-01 ,2.143515e-01 ,1.544887e-01 ,1.205942e-01 ,9.881779e-02 ,&
7558         & 8.366261e-02 ,7.251586e-02 ,6.397790e-02 ,5.723183e-02 ,5.176908e-02 ,&
7559         & 4.725658e-02 ,4.346715e-02 ,4.024055e-02 ,3.746055e-02 ,3.504080e-02 ,&
7560         & 3.291583e-02 ,3.103507e-02 ,2.935891e-02 ,2.785582e-02 ,2.650042e-02 ,&
7561         & 2.527206e-02 ,2.415376e-02 ,2.313142e-02 ,2.219326e-02 ,2.132934e-02 ,&
7562         & 2.053122e-02 ,1.979169e-02 ,1.910456e-02 ,1.846448e-02 ,1.786680e-02 ,&
7563         & 1.730745e-02 ,1.678289e-02 ,1.628998e-02 ,1.582595e-02 ,1.538835e-02 ,&
7564         & 1.497499e-02 ,1.458393e-02 ,1.421341e-02 ,1.386187e-02 ,1.352788e-02 ,&
7565         & 1.321019e-02 ,1.290762e-02 ,1.261913e-02  /)
7566       extice2(:, 26) = (/ &
7567 ! band 26
7568         & 3.453721e-01 ,2.130744e-01 ,1.536698e-01 ,1.200140e-01 ,9.838078e-02 ,&
7569         & 8.331940e-02 ,7.223803e-02 ,6.374775e-02 ,5.703770e-02 ,5.160290e-02 ,&
7570         & 4.711259e-02 ,4.334110e-02 ,4.012923e-02 ,3.736150e-02 ,3.495208e-02 ,&
7571         & 3.283589e-02 ,3.096267e-02 ,2.929302e-02 ,2.779560e-02 ,2.644517e-02 ,&
7572         & 2.522119e-02 ,2.410677e-02 ,2.308788e-02 ,2.215281e-02 ,2.129165e-02 ,&
7573         & 2.049602e-02 ,1.975874e-02 ,1.907365e-02 ,1.843542e-02 ,1.783943e-02 ,&
7574         & 1.728162e-02 ,1.675847e-02 ,1.626685e-02 ,1.580401e-02 ,1.536750e-02 ,&
7575         & 1.495515e-02 ,1.456502e-02 ,1.419537e-02 ,1.384463e-02 ,1.351139e-02 ,&
7576         & 1.319438e-02 ,1.289246e-02 ,1.260456e-02  /)
7577       extice2(:, 27) = (/ &
7578 ! band 27
7579         & 3.417883e-01 ,2.113379e-01 ,1.526395e-01 ,1.193347e-01 ,9.790253e-02 ,&
7580         & 8.296715e-02 ,7.196979e-02 ,6.353806e-02 ,5.687024e-02 ,5.146670e-02 ,&
7581         & 4.700001e-02 ,4.324667e-02 ,4.004894e-02 ,3.729233e-02 ,3.489172e-02 ,&
7582         & 3.278257e-02 ,3.091499e-02 ,2.924987e-02 ,2.775609e-02 ,2.640859e-02 ,&
7583         & 2.518695e-02 ,2.407439e-02 ,2.305697e-02 ,2.212303e-02 ,2.126273e-02 ,&
7584         & 2.046774e-02 ,1.973090e-02 ,1.904610e-02 ,1.840801e-02 ,1.781204e-02 ,&
7585         & 1.725417e-02 ,1.673086e-02 ,1.623902e-02 ,1.577590e-02 ,1.533906e-02 ,&
7586         & 1.492634e-02 ,1.453580e-02 ,1.416571e-02 ,1.381450e-02 ,1.348078e-02 ,&
7587         & 1.316327e-02 ,1.286082e-02 ,1.257240e-02  /)
7588       extice2(:, 28) = (/ &
7589 ! band 28
7590         & 3.416111e-01 ,2.114124e-01 ,1.527734e-01 ,1.194809e-01 ,9.804612e-02 ,&
7591         & 8.310287e-02 ,7.209595e-02 ,6.365442e-02 ,5.697710e-02 ,5.156460e-02 ,&
7592         & 4.708957e-02 ,4.332850e-02 ,4.012361e-02 ,3.736037e-02 ,3.495364e-02 ,&
7593         & 3.283879e-02 ,3.096593e-02 ,2.929589e-02 ,2.779751e-02 ,2.644571e-02 ,&
7594         & 2.522004e-02 ,2.410369e-02 ,2.308271e-02 ,2.214542e-02 ,2.128195e-02 ,&
7595         & 2.048396e-02 ,1.974429e-02 ,1.905679e-02 ,1.841614e-02 ,1.781774e-02 ,&
7596         & 1.725754e-02 ,1.673203e-02 ,1.623807e-02 ,1.577293e-02 ,1.533416e-02 ,&
7597         & 1.491958e-02 ,1.452727e-02 ,1.415547e-02 ,1.380262e-02 ,1.346732e-02 ,&
7598         & 1.314830e-02 ,1.284439e-02 ,1.255456e-02  /)
7599       extice2(:, 29) = (/ &
7600 ! band 29
7601         & 4.196611e-01 ,2.493642e-01 ,1.761261e-01 ,1.357197e-01 ,1.102161e-01 ,&
7602         & 9.269376e-02 ,7.992985e-02 ,7.022538e-02 ,6.260168e-02 ,5.645603e-02 ,&
7603         & 5.139732e-02 ,4.716088e-02 ,4.356133e-02 ,4.046498e-02 ,3.777303e-02 ,&
7604         & 3.541094e-02 ,3.332137e-02 ,3.145954e-02 ,2.978998e-02 ,2.828419e-02 ,&
7605         & 2.691905e-02 ,2.567559e-02 ,2.453811e-02 ,2.349350e-02 ,2.253072e-02 ,&
7606         & 2.164042e-02 ,2.081464e-02 ,2.004652e-02 ,1.933015e-02 ,1.866041e-02 ,&
7607         & 1.803283e-02 ,1.744348e-02 ,1.688894e-02 ,1.636616e-02 ,1.587244e-02 ,&
7608         & 1.540539e-02 ,1.496287e-02 ,1.454295e-02 ,1.414392e-02 ,1.376423e-02 ,&
7609         & 1.340247e-02 ,1.305739e-02 ,1.272784e-02  /)
7610
7611 ! single-scattering albedo: unitless
7612       ssaice2(:, 16) = (/ &
7613 ! band 16
7614         & 6.630615e-01 ,6.451169e-01 ,6.333696e-01 ,6.246927e-01 ,6.178420e-01 ,&
7615         & 6.121976e-01 ,6.074069e-01 ,6.032505e-01 ,5.995830e-01 ,5.963030e-01 ,&
7616         & 5.933372e-01 ,5.906311e-01 ,5.881427e-01 ,5.858395e-01 ,5.836955e-01 ,&
7617         & 5.816896e-01 ,5.798046e-01 ,5.780264e-01 ,5.763429e-01 ,5.747441e-01 ,&
7618         & 5.732213e-01 ,5.717672e-01 ,5.703754e-01 ,5.690403e-01 ,5.677571e-01 ,&
7619         & 5.665215e-01 ,5.653297e-01 ,5.641782e-01 ,5.630643e-01 ,5.619850e-01 ,&
7620         & 5.609381e-01 ,5.599214e-01 ,5.589328e-01 ,5.579707e-01 ,5.570333e-01 ,&
7621         & 5.561193e-01 ,5.552272e-01 ,5.543558e-01 ,5.535041e-01 ,5.526708e-01 ,&
7622         & 5.518551e-01 ,5.510561e-01 ,5.502729e-01  /)
7623       ssaice2(:, 17) = (/ &
7624 ! band 17
7625         & 7.689749e-01 ,7.398171e-01 ,7.205819e-01 ,7.065690e-01 ,6.956928e-01 ,&
7626         & 6.868989e-01 ,6.795813e-01 ,6.733606e-01 ,6.679838e-01 ,6.632742e-01 ,&
7627         & 6.591036e-01 ,6.553766e-01 ,6.520197e-01 ,6.489757e-01 ,6.461991e-01 ,&
7628         & 6.436531e-01 ,6.413075e-01 ,6.391375e-01 ,6.371221e-01 ,6.352438e-01 ,&
7629         & 6.334876e-01 ,6.318406e-01 ,6.302918e-01 ,6.288315e-01 ,6.274512e-01 ,&
7630         & 6.261436e-01 ,6.249022e-01 ,6.237211e-01 ,6.225953e-01 ,6.215201e-01 ,&
7631         & 6.204914e-01 ,6.195055e-01 ,6.185592e-01 ,6.176492e-01 ,6.167730e-01 ,&
7632         & 6.159280e-01 ,6.151120e-01 ,6.143228e-01 ,6.135587e-01 ,6.128177e-01 ,&
7633         & 6.120984e-01 ,6.113993e-01 ,6.107189e-01  /)
7634       ssaice2(:, 18) = (/ &
7635 ! band 18
7636         & 9.956167e-01 ,9.814770e-01 ,9.716104e-01 ,9.639746e-01 ,9.577179e-01 ,&
7637         & 9.524010e-01 ,9.477672e-01 ,9.436527e-01 ,9.399467e-01 ,9.365708e-01 ,&
7638         & 9.334672e-01 ,9.305921e-01 ,9.279118e-01 ,9.253993e-01 ,9.230330e-01 ,&
7639         & 9.207954e-01 ,9.186719e-01 ,9.166501e-01 ,9.147199e-01 ,9.128722e-01 ,&
7640         & 9.110997e-01 ,9.093956e-01 ,9.077544e-01 ,9.061708e-01 ,9.046406e-01 ,&
7641         & 9.031598e-01 ,9.017248e-01 ,9.003326e-01 ,8.989804e-01 ,8.976655e-01 ,&
7642         & 8.963857e-01 ,8.951389e-01 ,8.939233e-01 ,8.927370e-01 ,8.915785e-01 ,&
7643         & 8.904464e-01 ,8.893392e-01 ,8.882559e-01 ,8.871951e-01 ,8.861559e-01 ,&
7644         & 8.851373e-01 ,8.841383e-01 ,8.831581e-01  /)
7645       ssaice2(:, 19) = (/ &
7646 ! band 19
7647         & 9.723177e-01 ,9.452119e-01 ,9.267592e-01 ,9.127393e-01 ,9.014238e-01 ,&
7648         & 8.919334e-01 ,8.837584e-01 ,8.765773e-01 ,8.701736e-01 ,8.643950e-01 ,&
7649         & 8.591299e-01 ,8.542942e-01 ,8.498230e-01 ,8.456651e-01 ,8.417794e-01 ,&
7650         & 8.381324e-01 ,8.346964e-01 ,8.314484e-01 ,8.283687e-01 ,8.254408e-01 ,&
7651         & 8.226505e-01 ,8.199854e-01 ,8.174348e-01 ,8.149891e-01 ,8.126403e-01 ,&
7652         & 8.103808e-01 ,8.082041e-01 ,8.061044e-01 ,8.040765e-01 ,8.021156e-01 ,&
7653         & 8.002174e-01 ,7.983781e-01 ,7.965941e-01 ,7.948622e-01 ,7.931795e-01 ,&
7654         & 7.915432e-01 ,7.899508e-01 ,7.884002e-01 ,7.868891e-01 ,7.854156e-01 ,&
7655         & 7.839779e-01 ,7.825742e-01 ,7.812031e-01  /)
7656       ssaice2(:, 20) = (/ &
7657 ! band 20
7658         & 9.933294e-01 ,9.860917e-01 ,9.811564e-01 ,9.774008e-01 ,9.743652e-01 ,&
7659         & 9.718155e-01 ,9.696159e-01 ,9.676810e-01 ,9.659531e-01 ,9.643915e-01 ,&
7660         & 9.629667e-01 ,9.616561e-01 ,9.604426e-01 ,9.593125e-01 ,9.582548e-01 ,&
7661         & 9.572607e-01 ,9.563227e-01 ,9.554347e-01 ,9.545915e-01 ,9.537888e-01 ,&
7662         & 9.530226e-01 ,9.522898e-01 ,9.515874e-01 ,9.509130e-01 ,9.502643e-01 ,&
7663         & 9.496394e-01 ,9.490366e-01 ,9.484542e-01 ,9.478910e-01 ,9.473456e-01 ,&
7664         & 9.468169e-01 ,9.463039e-01 ,9.458056e-01 ,9.453212e-01 ,9.448499e-01 ,&
7665         & 9.443910e-01 ,9.439438e-01 ,9.435077e-01 ,9.430821e-01 ,9.426666e-01 ,&
7666         & 9.422607e-01 ,9.418638e-01 ,9.414756e-01  /)
7667       ssaice2(:, 21) = (/ &
7668 ! band 21
7669         & 9.900787e-01 ,9.828880e-01 ,9.779258e-01 ,9.741173e-01 ,9.710184e-01 ,&
7670         & 9.684012e-01 ,9.661332e-01 ,9.641301e-01 ,9.623352e-01 ,9.607083e-01 ,&
7671         & 9.592198e-01 ,9.578474e-01 ,9.565739e-01 ,9.553856e-01 ,9.542715e-01 ,&
7672         & 9.532226e-01 ,9.522314e-01 ,9.512919e-01 ,9.503986e-01 ,9.495472e-01 ,&
7673         & 9.487337e-01 ,9.479549e-01 ,9.472077e-01 ,9.464897e-01 ,9.457985e-01 ,&
7674         & 9.451322e-01 ,9.444890e-01 ,9.438673e-01 ,9.432656e-01 ,9.426826e-01 ,&
7675         & 9.421173e-01 ,9.415684e-01 ,9.410351e-01 ,9.405164e-01 ,9.400115e-01 ,&
7676         & 9.395198e-01 ,9.390404e-01 ,9.385728e-01 ,9.381164e-01 ,9.376707e-01 ,&
7677         & 9.372350e-01 ,9.368091e-01 ,9.363923e-01  /)
7678       ssaice2(:, 22) = (/ &
7679 ! band 22
7680         & 9.986793e-01 ,9.985239e-01 ,9.983911e-01 ,9.982715e-01 ,9.981606e-01 ,&
7681         & 9.980562e-01 ,9.979567e-01 ,9.978613e-01 ,9.977691e-01 ,9.976798e-01 ,&
7682         & 9.975929e-01 ,9.975081e-01 ,9.974251e-01 ,9.973438e-01 ,9.972640e-01 ,&
7683         & 9.971855e-01 ,9.971083e-01 ,9.970322e-01 ,9.969571e-01 ,9.968830e-01 ,&
7684         & 9.968099e-01 ,9.967375e-01 ,9.966660e-01 ,9.965951e-01 ,9.965250e-01 ,&
7685         & 9.964555e-01 ,9.963867e-01 ,9.963185e-01 ,9.962508e-01 ,9.961836e-01 ,&
7686         & 9.961170e-01 ,9.960508e-01 ,9.959851e-01 ,9.959198e-01 ,9.958550e-01 ,&
7687         & 9.957906e-01 ,9.957266e-01 ,9.956629e-01 ,9.955997e-01 ,9.955367e-01 ,&
7688         & 9.954742e-01 ,9.954119e-01 ,9.953500e-01  /)
7689       ssaice2(:, 23) = (/ &
7690 ! band 23
7691         & 9.997944e-01 ,9.997791e-01 ,9.997664e-01 ,9.997547e-01 ,9.997436e-01 ,&
7692         & 9.997327e-01 ,9.997219e-01 ,9.997110e-01 ,9.996999e-01 ,9.996886e-01 ,&
7693         & 9.996771e-01 ,9.996653e-01 ,9.996533e-01 ,9.996409e-01 ,9.996282e-01 ,&
7694         & 9.996152e-01 ,9.996019e-01 ,9.995883e-01 ,9.995743e-01 ,9.995599e-01 ,&
7695         & 9.995453e-01 ,9.995302e-01 ,9.995149e-01 ,9.994992e-01 ,9.994831e-01 ,&
7696         & 9.994667e-01 ,9.994500e-01 ,9.994329e-01 ,9.994154e-01 ,9.993976e-01 ,&
7697         & 9.993795e-01 ,9.993610e-01 ,9.993422e-01 ,9.993230e-01 ,9.993035e-01 ,&
7698         & 9.992837e-01 ,9.992635e-01 ,9.992429e-01 ,9.992221e-01 ,9.992008e-01 ,&
7699         & 9.991793e-01 ,9.991574e-01 ,9.991352e-01  /)
7700       ssaice2(:, 24) = (/ &
7701 ! band 24
7702         & 9.999949e-01 ,9.999947e-01 ,9.999943e-01 ,9.999939e-01 ,9.999934e-01 ,&
7703         & 9.999927e-01 ,9.999920e-01 ,9.999913e-01 ,9.999904e-01 ,9.999895e-01 ,&
7704         & 9.999885e-01 ,9.999874e-01 ,9.999863e-01 ,9.999851e-01 ,9.999838e-01 ,&
7705         & 9.999824e-01 ,9.999810e-01 ,9.999795e-01 ,9.999780e-01 ,9.999764e-01 ,&
7706         & 9.999747e-01 ,9.999729e-01 ,9.999711e-01 ,9.999692e-01 ,9.999673e-01 ,&
7707         & 9.999653e-01 ,9.999632e-01 ,9.999611e-01 ,9.999589e-01 ,9.999566e-01 ,&
7708         & 9.999543e-01 ,9.999519e-01 ,9.999495e-01 ,9.999470e-01 ,9.999444e-01 ,&
7709         & 9.999418e-01 ,9.999392e-01 ,9.999364e-01 ,9.999336e-01 ,9.999308e-01 ,&
7710         & 9.999279e-01 ,9.999249e-01 ,9.999219e-01  /)
7711       ssaice2(:, 25) = (/ &
7712 ! band 25
7713         & 9.999997e-01 ,9.999997e-01 ,9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,&
7714         & 9.999995e-01 ,9.999994e-01 ,9.999993e-01 ,9.999993e-01 ,9.999992e-01 ,&
7715         & 9.999991e-01 ,9.999989e-01 ,9.999988e-01 ,9.999987e-01 ,9.999986e-01 ,&
7716         & 9.999984e-01 ,9.999983e-01 ,9.999981e-01 ,9.999980e-01 ,9.999978e-01 ,&
7717         & 9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999971e-01 ,9.999969e-01 ,&
7718         & 9.999966e-01 ,9.999964e-01 ,9.999962e-01 ,9.999960e-01 ,9.999957e-01 ,&
7719         & 9.999955e-01 ,9.999953e-01 ,9.999950e-01 ,9.999947e-01 ,9.999945e-01 ,&
7720         & 9.999942e-01 ,9.999939e-01 ,9.999936e-01 ,9.999934e-01 ,9.999931e-01 ,&
7721         & 9.999928e-01 ,9.999925e-01 ,9.999921e-01  /)
7722       ssaice2(:, 26) = (/ &
7723 ! band 26
7724         & 9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,9.999995e-01 ,9.999994e-01 ,&
7725         & 9.999993e-01 ,9.999992e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,&
7726         & 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999982e-01 ,9.999980e-01 ,&
7727         & 9.999978e-01 ,9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999970e-01 ,&
7728         & 9.999967e-01 ,9.999965e-01 ,9.999962e-01 ,9.999959e-01 ,9.999956e-01 ,&
7729         & 9.999954e-01 ,9.999951e-01 ,9.999947e-01 ,9.999944e-01 ,9.999941e-01 ,&
7730         & 9.999938e-01 ,9.999934e-01 ,9.999931e-01 ,9.999927e-01 ,9.999923e-01 ,&
7731         & 9.999920e-01 ,9.999916e-01 ,9.999912e-01 ,9.999908e-01 ,9.999904e-01 ,&
7732         & 9.999899e-01 ,9.999895e-01 ,9.999891e-01  /)
7733       ssaice2(:, 27) = (/ &
7734 ! band 27
7735         & 9.999987e-01 ,9.999987e-01 ,9.999985e-01 ,9.999984e-01 ,9.999982e-01 ,&
7736         & 9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,9.999973e-01 ,9.999970e-01 ,&
7737         & 9.999967e-01 ,9.999964e-01 ,9.999960e-01 ,9.999956e-01 ,9.999952e-01 ,&
7738         & 9.999948e-01 ,9.999944e-01 ,9.999939e-01 ,9.999934e-01 ,9.999929e-01 ,&
7739         & 9.999924e-01 ,9.999918e-01 ,9.999913e-01 ,9.999907e-01 ,9.999901e-01 ,&
7740         & 9.999894e-01 ,9.999888e-01 ,9.999881e-01 ,9.999874e-01 ,9.999867e-01 ,&
7741         & 9.999860e-01 ,9.999853e-01 ,9.999845e-01 ,9.999837e-01 ,9.999829e-01 ,&
7742         & 9.999821e-01 ,9.999813e-01 ,9.999804e-01 ,9.999796e-01 ,9.999787e-01 ,&
7743         & 9.999778e-01 ,9.999768e-01 ,9.999759e-01  /)
7744       ssaice2(:, 28) = (/ &
7745 ! band 28
7746         & 9.999989e-01 ,9.999989e-01 ,9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,&
7747         & 9.999982e-01 ,9.999980e-01 ,9.999978e-01 ,9.999975e-01 ,9.999972e-01 ,&
7748         & 9.999969e-01 ,9.999966e-01 ,9.999962e-01 ,9.999958e-01 ,9.999954e-01 ,&
7749         & 9.999950e-01 ,9.999945e-01 ,9.999941e-01 ,9.999936e-01 ,9.999931e-01 ,&
7750         & 9.999925e-01 ,9.999920e-01 ,9.999914e-01 ,9.999908e-01 ,9.999902e-01 ,&
7751         & 9.999896e-01 ,9.999889e-01 ,9.999883e-01 ,9.999876e-01 ,9.999869e-01 ,&
7752         & 9.999861e-01 ,9.999854e-01 ,9.999846e-01 ,9.999838e-01 ,9.999830e-01 ,&
7753         & 9.999822e-01 ,9.999814e-01 ,9.999805e-01 ,9.999796e-01 ,9.999787e-01 ,&
7754         & 9.999778e-01 ,9.999769e-01 ,9.999759e-01  /)
7755       ssaice2(:, 29) = (/ &
7756 ! band 29
7757         & 7.042143e-01 ,6.691161e-01 ,6.463240e-01 ,6.296590e-01 ,6.166381e-01 ,&
7758         & 6.060183e-01 ,5.970908e-01 ,5.894144e-01 ,5.826968e-01 ,5.767343e-01 ,&
7759         & 5.713804e-01 ,5.665256e-01 ,5.620867e-01 ,5.579987e-01 ,5.542101e-01 ,&
7760         & 5.506794e-01 ,5.473727e-01 ,5.442620e-01 ,5.413239e-01 ,5.385389e-01 ,&
7761         & 5.358901e-01 ,5.333633e-01 ,5.309460e-01 ,5.286277e-01 ,5.263988e-01 ,&
7762         & 5.242512e-01 ,5.221777e-01 ,5.201719e-01 ,5.182280e-01 ,5.163410e-01 ,&
7763         & 5.145062e-01 ,5.127197e-01 ,5.109776e-01 ,5.092766e-01 ,5.076137e-01 ,&
7764         & 5.059860e-01 ,5.043911e-01 ,5.028266e-01 ,5.012904e-01 ,4.997805e-01 ,&
7765         & 4.982951e-01 ,4.968326e-01 ,4.953913e-01  /)
7766
7767 ! asymmetry factor: unitless
7768       asyice2(:, 16) = (/ &
7769 ! band 16
7770         & 7.946655e-01 ,8.547685e-01 ,8.806016e-01 ,8.949880e-01 ,9.041676e-01 ,&
7771         & 9.105399e-01 ,9.152249e-01 ,9.188160e-01 ,9.216573e-01 ,9.239620e-01 ,&
7772         & 9.258695e-01 ,9.274745e-01 ,9.288441e-01 ,9.300267e-01 ,9.310584e-01 ,&
7773         & 9.319665e-01 ,9.327721e-01 ,9.334918e-01 ,9.341387e-01 ,9.347236e-01 ,&
7774         & 9.352551e-01 ,9.357402e-01 ,9.361850e-01 ,9.365942e-01 ,9.369722e-01 ,&
7775         & 9.373225e-01 ,9.376481e-01 ,9.379516e-01 ,9.382352e-01 ,9.385010e-01 ,&
7776         & 9.387505e-01 ,9.389854e-01 ,9.392070e-01 ,9.394163e-01 ,9.396145e-01 ,&
7777         & 9.398024e-01 ,9.399809e-01 ,9.401508e-01 ,9.403126e-01 ,9.404670e-01 ,&
7778         & 9.406144e-01 ,9.407555e-01 ,9.408906e-01  /)
7779       asyice2(:, 17) = (/ &
7780 ! band 17
7781         & 9.078091e-01 ,9.195850e-01 ,9.267250e-01 ,9.317083e-01 ,9.354632e-01 ,&
7782         & 9.384323e-01 ,9.408597e-01 ,9.428935e-01 ,9.446301e-01 ,9.461351e-01 ,&
7783         & 9.474555e-01 ,9.486259e-01 ,9.496722e-01 ,9.506146e-01 ,9.514688e-01 ,&
7784         & 9.522476e-01 ,9.529612e-01 ,9.536181e-01 ,9.542251e-01 ,9.547883e-01 ,&
7785         & 9.553124e-01 ,9.558019e-01 ,9.562601e-01 ,9.566904e-01 ,9.570953e-01 ,&
7786         & 9.574773e-01 ,9.578385e-01 ,9.581806e-01 ,9.585054e-01 ,9.588142e-01 ,&
7787         & 9.591083e-01 ,9.593888e-01 ,9.596569e-01 ,9.599135e-01 ,9.601593e-01 ,&
7788         & 9.603952e-01 ,9.606219e-01 ,9.608399e-01 ,9.610499e-01 ,9.612523e-01 ,&
7789         & 9.614477e-01 ,9.616365e-01 ,9.618192e-01  /)
7790       asyice2(:, 18) = (/ &
7791 ! band 18
7792         & 8.322045e-01 ,8.528693e-01 ,8.648167e-01 ,8.729163e-01 ,8.789054e-01 ,&
7793         & 8.835845e-01 ,8.873819e-01 ,8.905511e-01 ,8.932532e-01 ,8.955965e-01 ,&
7794         & 8.976567e-01 ,8.994887e-01 ,9.011334e-01 ,9.026221e-01 ,9.039791e-01 ,&
7795         & 9.052237e-01 ,9.063715e-01 ,9.074349e-01 ,9.084245e-01 ,9.093489e-01 ,&
7796         & 9.102154e-01 ,9.110303e-01 ,9.117987e-01 ,9.125253e-01 ,9.132140e-01 ,&
7797         & 9.138682e-01 ,9.144910e-01 ,9.150850e-01 ,9.156524e-01 ,9.161955e-01 ,&
7798         & 9.167160e-01 ,9.172157e-01 ,9.176959e-01 ,9.181581e-01 ,9.186034e-01 ,&
7799         & 9.190330e-01 ,9.194478e-01 ,9.198488e-01 ,9.202368e-01 ,9.206126e-01 ,&
7800         & 9.209768e-01 ,9.213301e-01 ,9.216731e-01  /)
7801       asyice2(:, 19) = (/ &
7802 ! band 19
7803         & 8.116560e-01 ,8.488278e-01 ,8.674331e-01 ,8.788148e-01 ,8.865810e-01 ,&
7804         & 8.922595e-01 ,8.966149e-01 ,9.000747e-01 ,9.028980e-01 ,9.052513e-01 ,&
7805         & 9.072468e-01 ,9.089632e-01 ,9.104574e-01 ,9.117713e-01 ,9.129371e-01 ,&
7806         & 9.139793e-01 ,9.149174e-01 ,9.157668e-01 ,9.165400e-01 ,9.172473e-01 ,&
7807         & 9.178970e-01 ,9.184962e-01 ,9.190508e-01 ,9.195658e-01 ,9.200455e-01 ,&
7808         & 9.204935e-01 ,9.209130e-01 ,9.213067e-01 ,9.216771e-01 ,9.220262e-01 ,&
7809         & 9.223560e-01 ,9.226680e-01 ,9.229636e-01 ,9.232443e-01 ,9.235112e-01 ,&
7810         & 9.237652e-01 ,9.240074e-01 ,9.242385e-01 ,9.244594e-01 ,9.246708e-01 ,&
7811         & 9.248733e-01 ,9.250674e-01 ,9.252536e-01  /)
7812       asyice2(:, 20) = (/ &
7813 ! band 20
7814         & 8.047113e-01 ,8.402864e-01 ,8.570332e-01 ,8.668455e-01 ,8.733206e-01 ,&
7815         & 8.779272e-01 ,8.813796e-01 ,8.840676e-01 ,8.862225e-01 ,8.879904e-01 ,&
7816         & 8.894682e-01 ,8.907228e-01 ,8.918019e-01 ,8.927404e-01 ,8.935645e-01 ,&
7817         & 8.942943e-01 ,8.949452e-01 ,8.955296e-01 ,8.960574e-01 ,8.965366e-01 ,&
7818         & 8.969736e-01 ,8.973740e-01 ,8.977422e-01 ,8.980820e-01 ,8.983966e-01 ,&
7819         & 8.986889e-01 ,8.989611e-01 ,8.992153e-01 ,8.994533e-01 ,8.996766e-01 ,&
7820         & 8.998865e-01 ,9.000843e-01 ,9.002709e-01 ,9.004474e-01 ,9.006146e-01 ,&
7821         & 9.007731e-01 ,9.009237e-01 ,9.010670e-01 ,9.012034e-01 ,9.013336e-01 ,&
7822         & 9.014579e-01 ,9.015767e-01 ,9.016904e-01  /)
7823       asyice2(:, 21) = (/ &
7824 ! band 21
7825         & 8.179122e-01 ,8.480726e-01 ,8.621945e-01 ,8.704354e-01 ,8.758555e-01 ,&
7826         & 8.797007e-01 ,8.825750e-01 ,8.848078e-01 ,8.865939e-01 ,8.880564e-01 ,&
7827         & 8.892765e-01 ,8.903105e-01 ,8.911982e-01 ,8.919689e-01 ,8.926446e-01 ,&
7828         & 8.932419e-01 ,8.937738e-01 ,8.942506e-01 ,8.946806e-01 ,8.950702e-01 ,&
7829         & 8.954251e-01 ,8.957497e-01 ,8.960477e-01 ,8.963223e-01 ,8.965762e-01 ,&
7830         & 8.968116e-01 ,8.970306e-01 ,8.972347e-01 ,8.974255e-01 ,8.976042e-01 ,&
7831         & 8.977720e-01 ,8.979298e-01 ,8.980784e-01 ,8.982188e-01 ,8.983515e-01 ,&
7832         & 8.984771e-01 ,8.985963e-01 ,8.987095e-01 ,8.988171e-01 ,8.989195e-01 ,&
7833         & 8.990172e-01 ,8.991104e-01 ,8.991994e-01  /)
7834       asyice2(:, 22) = (/ &
7835 ! band 22
7836         & 8.169789e-01 ,8.455024e-01 ,8.586925e-01 ,8.663283e-01 ,8.713217e-01 ,&
7837         & 8.748488e-01 ,8.774765e-01 ,8.795122e-01 ,8.811370e-01 ,8.824649e-01 ,&
7838         & 8.835711e-01 ,8.845073e-01 ,8.853103e-01 ,8.860068e-01 ,8.866170e-01 ,&
7839         & 8.871560e-01 ,8.876358e-01 ,8.880658e-01 ,8.884533e-01 ,8.888044e-01 ,&
7840         & 8.891242e-01 ,8.894166e-01 ,8.896851e-01 ,8.899324e-01 ,8.901612e-01 ,&
7841         & 8.903733e-01 ,8.905706e-01 ,8.907545e-01 ,8.909265e-01 ,8.910876e-01 ,&
7842         & 8.912388e-01 ,8.913812e-01 ,8.915153e-01 ,8.916419e-01 ,8.917617e-01 ,&
7843         & 8.918752e-01 ,8.919829e-01 ,8.920851e-01 ,8.921824e-01 ,8.922751e-01 ,&
7844         & 8.923635e-01 ,8.924478e-01 ,8.925284e-01  /)
7845       asyice2(:, 23) = (/ &
7846 ! band 23
7847         & 8.387642e-01 ,8.569979e-01 ,8.658630e-01 ,8.711825e-01 ,8.747605e-01 ,&
7848         & 8.773472e-01 ,8.793129e-01 ,8.808621e-01 ,8.821179e-01 ,8.831583e-01 ,&
7849         & 8.840361e-01 ,8.847875e-01 ,8.854388e-01 ,8.860094e-01 ,8.865138e-01 ,&
7850         & 8.869634e-01 ,8.873668e-01 ,8.877310e-01 ,8.880617e-01 ,8.883635e-01 ,&
7851         & 8.886401e-01 ,8.888947e-01 ,8.891298e-01 ,8.893477e-01 ,8.895504e-01 ,&
7852         & 8.897393e-01 ,8.899159e-01 ,8.900815e-01 ,8.902370e-01 ,8.903833e-01 ,&
7853         & 8.905214e-01 ,8.906518e-01 ,8.907753e-01 ,8.908924e-01 ,8.910036e-01 ,&
7854         & 8.911094e-01 ,8.912101e-01 ,8.913062e-01 ,8.913979e-01 ,8.914856e-01 ,&
7855         & 8.915695e-01 ,8.916498e-01 ,8.917269e-01  /)
7856       asyice2(:, 24) = (/ &
7857 ! band 24
7858         & 8.522208e-01 ,8.648132e-01 ,8.711224e-01 ,8.749901e-01 ,8.776354e-01 ,&
7859         & 8.795743e-01 ,8.810649e-01 ,8.822518e-01 ,8.832225e-01 ,8.840333e-01 ,&
7860         & 8.847224e-01 ,8.853162e-01 ,8.858342e-01 ,8.862906e-01 ,8.866962e-01 ,&
7861         & 8.870595e-01 ,8.873871e-01 ,8.876842e-01 ,8.879551e-01 ,8.882032e-01 ,&
7862         & 8.884316e-01 ,8.886425e-01 ,8.888380e-01 ,8.890199e-01 ,8.891895e-01 ,&
7863         & 8.893481e-01 ,8.894968e-01 ,8.896366e-01 ,8.897683e-01 ,8.898926e-01 ,&
7864         & 8.900102e-01 ,8.901215e-01 ,8.902272e-01 ,8.903276e-01 ,8.904232e-01 ,&
7865         & 8.905144e-01 ,8.906014e-01 ,8.906845e-01 ,8.907640e-01 ,8.908402e-01 ,&
7866         & 8.909132e-01 ,8.909834e-01 ,8.910507e-01  /)
7867       asyice2(:, 25) = (/ &
7868 ! band 25
7869         & 8.578202e-01 ,8.683033e-01 ,8.735431e-01 ,8.767488e-01 ,8.789378e-01 ,&
7870         & 8.805399e-01 ,8.817701e-01 ,8.827485e-01 ,8.835480e-01 ,8.842152e-01 ,&
7871         & 8.847817e-01 ,8.852696e-01 ,8.856949e-01 ,8.860694e-01 ,8.864020e-01 ,&
7872         & 8.866997e-01 ,8.869681e-01 ,8.872113e-01 ,8.874330e-01 ,8.876360e-01 ,&
7873         & 8.878227e-01 ,8.879951e-01 ,8.881548e-01 ,8.883033e-01 ,8.884418e-01 ,&
7874         & 8.885712e-01 ,8.886926e-01 ,8.888066e-01 ,8.889139e-01 ,8.890152e-01 ,&
7875         & 8.891110e-01 ,8.892017e-01 ,8.892877e-01 ,8.893695e-01 ,8.894473e-01 ,&
7876         & 8.895214e-01 ,8.895921e-01 ,8.896597e-01 ,8.897243e-01 ,8.897862e-01 ,&
7877         & 8.898456e-01 ,8.899025e-01 ,8.899572e-01  /)
7878       asyice2(:, 26) = (/ &
7879 ! band 26
7880         & 8.625615e-01 ,8.713831e-01 ,8.755799e-01 ,8.780560e-01 ,8.796983e-01 ,&
7881         & 8.808714e-01 ,8.817534e-01 ,8.824420e-01 ,8.829953e-01 ,8.834501e-01 ,&
7882         & 8.838310e-01 ,8.841549e-01 ,8.844338e-01 ,8.846767e-01 ,8.848902e-01 ,&
7883         & 8.850795e-01 ,8.852484e-01 ,8.854002e-01 ,8.855374e-01 ,8.856620e-01 ,&
7884         & 8.857758e-01 ,8.858800e-01 ,8.859759e-01 ,8.860644e-01 ,8.861464e-01 ,&
7885         & 8.862225e-01 ,8.862935e-01 ,8.863598e-01 ,8.864218e-01 ,8.864800e-01 ,&
7886         & 8.865347e-01 ,8.865863e-01 ,8.866349e-01 ,8.866809e-01 ,8.867245e-01 ,&
7887         & 8.867658e-01 ,8.868050e-01 ,8.868423e-01 ,8.868778e-01 ,8.869117e-01 ,&
7888         & 8.869440e-01 ,8.869749e-01 ,8.870044e-01  /)
7889       asyice2(:, 27) = (/ &
7890 ! band 27
7891         & 8.587495e-01 ,8.684764e-01 ,8.728189e-01 ,8.752872e-01 ,8.768846e-01 ,&
7892         & 8.780060e-01 ,8.788386e-01 ,8.794824e-01 ,8.799960e-01 ,8.804159e-01 ,&
7893         & 8.807660e-01 ,8.810626e-01 ,8.813175e-01 ,8.815390e-01 ,8.817335e-01 ,&
7894         & 8.819057e-01 ,8.820593e-01 ,8.821973e-01 ,8.823220e-01 ,8.824353e-01 ,&
7895         & 8.825387e-01 ,8.826336e-01 ,8.827209e-01 ,8.828016e-01 ,8.828764e-01 ,&
7896         & 8.829459e-01 ,8.830108e-01 ,8.830715e-01 ,8.831283e-01 ,8.831817e-01 ,&
7897         & 8.832320e-01 ,8.832795e-01 ,8.833244e-01 ,8.833668e-01 ,8.834071e-01 ,&
7898         & 8.834454e-01 ,8.834817e-01 ,8.835164e-01 ,8.835495e-01 ,8.835811e-01 ,&
7899         & 8.836113e-01 ,8.836402e-01 ,8.836679e-01  /)
7900       asyice2(:, 28) = (/ &
7901 ! band 28
7902         & 8.561110e-01 ,8.678583e-01 ,8.727554e-01 ,8.753892e-01 ,8.770154e-01 ,&
7903         & 8.781109e-01 ,8.788949e-01 ,8.794812e-01 ,8.799348e-01 ,8.802952e-01 ,&
7904         & 8.805880e-01 ,8.808300e-01 ,8.810331e-01 ,8.812058e-01 ,8.813543e-01 ,&
7905         & 8.814832e-01 ,8.815960e-01 ,8.816956e-01 ,8.817839e-01 ,8.818629e-01 ,&
7906         & 8.819339e-01 ,8.819979e-01 ,8.820560e-01 ,8.821089e-01 ,8.821573e-01 ,&
7907         & 8.822016e-01 ,8.822425e-01 ,8.822801e-01 ,8.823150e-01 ,8.823474e-01 ,&
7908         & 8.823775e-01 ,8.824056e-01 ,8.824318e-01 ,8.824564e-01 ,8.824795e-01 ,&
7909         & 8.825011e-01 ,8.825215e-01 ,8.825408e-01 ,8.825589e-01 ,8.825761e-01 ,&
7910         & 8.825924e-01 ,8.826078e-01 ,8.826224e-01  /)
7911       asyice2(:, 29) = (/ &
7912 ! band 29
7913         & 8.311124e-01 ,8.688197e-01 ,8.900274e-01 ,9.040696e-01 ,9.142334e-01 ,&
7914         & 9.220181e-01 ,9.282195e-01 ,9.333048e-01 ,9.375689e-01 ,9.412085e-01 ,&
7915         & 9.443604e-01 ,9.471230e-01 ,9.495694e-01 ,9.517549e-01 ,9.537224e-01 ,&
7916         & 9.555057e-01 ,9.571316e-01 ,9.586222e-01 ,9.599952e-01 ,9.612656e-01 ,&
7917         & 9.624458e-01 ,9.635461e-01 ,9.645756e-01 ,9.655418e-01 ,9.664513e-01 ,&
7918         & 9.673098e-01 ,9.681222e-01 ,9.688928e-01 ,9.696256e-01 ,9.703237e-01 ,&
7919         & 9.709903e-01 ,9.716280e-01 ,9.722391e-01 ,9.728258e-01 ,9.733901e-01 ,&
7920         & 9.739336e-01 ,9.744579e-01 ,9.749645e-01 ,9.754546e-01 ,9.759294e-01 ,&
7921         & 9.763901e-01 ,9.768376e-01 ,9.772727e-01  /)
7922
7923 ! Hexagonal Ice Particle Parameterization
7924 ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
7925       extice3(:, 16) = (/ &
7926 ! band 16
7927         & 5.194013e-01 ,3.215089e-01 ,2.327917e-01 ,1.824424e-01 ,1.499977e-01 ,&
7928         & 1.273492e-01 ,1.106421e-01 ,9.780982e-02 ,8.764435e-02 ,7.939266e-02 ,&
7929         & 7.256081e-02 ,6.681137e-02 ,6.190600e-02 ,5.767154e-02 ,5.397915e-02 ,&
7930         & 5.073102e-02 ,4.785151e-02 ,4.528125e-02 ,4.297296e-02 ,4.088853e-02 ,&
7931         & 3.899690e-02 ,3.727251e-02 ,3.569411e-02 ,3.424393e-02 ,3.290694e-02 ,&
7932         & 3.167040e-02 ,3.052340e-02 ,2.945654e-02 ,2.846172e-02 ,2.753188e-02 ,&
7933         & 2.666085e-02 ,2.584322e-02 ,2.507423e-02 ,2.434967e-02 ,2.366579e-02 ,&
7934         & 2.301926e-02 ,2.240711e-02 ,2.182666e-02 ,2.127551e-02 ,2.075150e-02 ,&
7935         & 2.025267e-02 ,1.977725e-02 ,1.932364e-02 ,1.889035e-02 ,1.847607e-02 ,&
7936         & 1.807956e-02  /)
7937       extice3(:, 17) = (/ &
7938 ! band 17
7939         & 4.901155e-01 ,3.065286e-01 ,2.230800e-01 ,1.753951e-01 ,1.445402e-01 ,&
7940         & 1.229417e-01 ,1.069777e-01 ,9.469760e-02 ,8.495824e-02 ,7.704501e-02 ,&
7941         & 7.048834e-02 ,6.496693e-02 ,6.025353e-02 ,5.618286e-02 ,5.263186e-02 ,&
7942         & 4.950698e-02 ,4.673585e-02 ,4.426164e-02 ,4.203904e-02 ,4.003153e-02 ,&
7943         & 3.820932e-02 ,3.654790e-02 ,3.502688e-02 ,3.362919e-02 ,3.234041e-02 ,&
7944         & 3.114829e-02 ,3.004234e-02 ,2.901356e-02 ,2.805413e-02 ,2.715727e-02 ,&
7945         & 2.631705e-02 ,2.552828e-02 ,2.478637e-02 ,2.408725e-02 ,2.342734e-02 ,&
7946         & 2.280343e-02 ,2.221264e-02 ,2.165242e-02 ,2.112043e-02 ,2.061461e-02 ,&
7947         & 2.013308e-02 ,1.967411e-02 ,1.923616e-02 ,1.881783e-02 ,1.841781e-02 ,&
7948         & 1.803494e-02  /)
7949       extice3(:, 18) = (/ &
7950 ! band 18
7951         & 5.056264e-01 ,3.160261e-01 ,2.298442e-01 ,1.805973e-01 ,1.487318e-01 ,&
7952         & 1.264258e-01 ,1.099389e-01 ,9.725656e-02 ,8.719819e-02 ,7.902576e-02 ,&
7953         & 7.225433e-02 ,6.655206e-02 ,6.168427e-02 ,5.748028e-02 ,5.381296e-02 ,&
7954         & 5.058572e-02 ,4.772383e-02 ,4.516857e-02 ,4.287317e-02 ,4.079990e-02 ,&
7955         & 3.891801e-02 ,3.720217e-02 ,3.563133e-02 ,3.418786e-02 ,3.285686e-02 ,&
7956         & 3.162569e-02 ,3.048352e-02 ,2.942104e-02 ,2.843018e-02 ,2.750395e-02 ,&
7957         & 2.663621e-02 ,2.582160e-02 ,2.505539e-02 ,2.433337e-02 ,2.365185e-02 ,&
7958         & 2.300750e-02 ,2.239736e-02 ,2.181878e-02 ,2.126937e-02 ,2.074699e-02 ,&
7959         & 2.024968e-02 ,1.977567e-02 ,1.932338e-02 ,1.889134e-02 ,1.847823e-02 ,&
7960         & 1.808281e-02  /)
7961       extice3(:, 19) = (/ &
7962 ! band 19
7963         & 4.881605e-01 ,3.055237e-01 ,2.225070e-01 ,1.750688e-01 ,1.443736e-01 ,&
7964         & 1.228869e-01 ,1.070054e-01 ,9.478893e-02 ,8.509997e-02 ,7.722769e-02 ,&
7965         & 7.070495e-02 ,6.521211e-02 ,6.052311e-02 ,5.647351e-02 ,5.294088e-02 ,&
7966         & 4.983217e-02 ,4.707539e-02 ,4.461398e-02 ,4.240288e-02 ,4.040575e-02 ,&
7967         & 3.859298e-02 ,3.694016e-02 ,3.542701e-02 ,3.403655e-02 ,3.275444e-02 ,&
7968         & 3.156849e-02 ,3.046827e-02 ,2.944481e-02 ,2.849034e-02 ,2.759812e-02 ,&
7969         & 2.676226e-02 ,2.597757e-02 ,2.523949e-02 ,2.454400e-02 ,2.388750e-02 ,&
7970         & 2.326682e-02 ,2.267909e-02 ,2.212176e-02 ,2.159253e-02 ,2.108933e-02 ,&
7971         & 2.061028e-02 ,2.015369e-02 ,1.971801e-02 ,1.930184e-02 ,1.890389e-02 ,&
7972         & 1.852300e-02  /)
7973       extice3(:, 20) = (/ &
7974 ! band 20
7975         & 5.103703e-01 ,3.188144e-01 ,2.317435e-01 ,1.819887e-01 ,1.497944e-01 ,&
7976         & 1.272584e-01 ,1.106013e-01 ,9.778822e-02 ,8.762610e-02 ,7.936938e-02 ,&
7977         & 7.252809e-02 ,6.676701e-02 ,6.184901e-02 ,5.760165e-02 ,5.389651e-02 ,&
7978         & 5.063598e-02 ,4.774457e-02 ,4.516295e-02 ,4.284387e-02 ,4.074922e-02 ,&
7979         & 3.884792e-02 ,3.711438e-02 ,3.552734e-02 ,3.406898e-02 ,3.272425e-02 ,&
7980         & 3.148038e-02 ,3.032643e-02 ,2.925299e-02 ,2.825191e-02 ,2.731612e-02 ,&
7981         & 2.643943e-02 ,2.561642e-02 ,2.484230e-02 ,2.411284e-02 ,2.342429e-02 ,&
7982         & 2.277329e-02 ,2.215686e-02 ,2.157231e-02 ,2.101724e-02 ,2.048946e-02 ,&
7983         & 1.998702e-02 ,1.950813e-02 ,1.905118e-02 ,1.861468e-02 ,1.819730e-02 ,&
7984         & 1.779781e-02  /)
7985       extice3(:, 21) = (/ &
7986 ! band 21
7987         & 5.031161e-01 ,3.144511e-01 ,2.286942e-01 ,1.796903e-01 ,1.479819e-01 ,&
7988         & 1.257860e-01 ,1.093803e-01 ,9.676059e-02 ,8.675183e-02 ,7.861971e-02 ,&
7989         & 7.188168e-02 ,6.620754e-02 ,6.136376e-02 ,5.718050e-02 ,5.353127e-02 ,&
7990         & 5.031995e-02 ,4.747218e-02 ,4.492952e-02 ,4.264544e-02 ,4.058240e-02 ,&
7991         & 3.870979e-02 ,3.700242e-02 ,3.543933e-02 ,3.400297e-02 ,3.267854e-02 ,&
7992         & 3.145345e-02 ,3.031691e-02 ,2.925967e-02 ,2.827370e-02 ,2.735203e-02 ,&
7993         & 2.648858e-02 ,2.567798e-02 ,2.491555e-02 ,2.419710e-02 ,2.351893e-02 ,&
7994         & 2.287776e-02 ,2.227063e-02 ,2.169491e-02 ,2.114821e-02 ,2.062840e-02 ,&
7995         & 2.013354e-02 ,1.966188e-02 ,1.921182e-02 ,1.878191e-02 ,1.837083e-02 ,&
7996         & 1.797737e-02  /)
7997       extice3(:, 22) = (/ &
7998 ! band 22
7999         & 4.949453e-01 ,3.095918e-01 ,2.253402e-01 ,1.771964e-01 ,1.460446e-01 ,&
8000         & 1.242383e-01 ,1.081206e-01 ,9.572235e-02 ,8.588928e-02 ,7.789990e-02 ,&
8001         & 7.128013e-02 ,6.570559e-02 ,6.094684e-02 ,5.683701e-02 ,5.325183e-02 ,&
8002         & 5.009688e-02 ,4.729909e-02 ,4.480106e-02 ,4.255708e-02 ,4.053025e-02 ,&
8003         & 3.869051e-02 ,3.701310e-02 ,3.547745e-02 ,3.406631e-02 ,3.276512e-02 ,&
8004         & 3.156153e-02 ,3.044494e-02 ,2.940626e-02 ,2.843759e-02 ,2.753211e-02 ,&
8005         & 2.668381e-02 ,2.588744e-02 ,2.513839e-02 ,2.443255e-02 ,2.376629e-02 ,&
8006         & 2.313637e-02 ,2.253990e-02 ,2.197428e-02 ,2.143718e-02 ,2.092649e-02 ,&
8007         & 2.044032e-02 ,1.997694e-02 ,1.953478e-02 ,1.911241e-02 ,1.870855e-02 ,&
8008         & 1.832199e-02  /)
8009       extice3(:, 23) = (/ &
8010 ! band 23
8011         & 5.052816e-01 ,3.157665e-01 ,2.296233e-01 ,1.803986e-01 ,1.485473e-01 ,&
8012         & 1.262514e-01 ,1.097718e-01 ,9.709524e-02 ,8.704139e-02 ,7.887264e-02 ,&
8013         & 7.210424e-02 ,6.640454e-02 ,6.153894e-02 ,5.733683e-02 ,5.367116e-02 ,&
8014         & 5.044537e-02 ,4.758477e-02 ,4.503066e-02 ,4.273629e-02 ,4.066395e-02 ,&
8015         & 3.878291e-02 ,3.706784e-02 ,3.549771e-02 ,3.405488e-02 ,3.272448e-02 ,&
8016         & 3.149387e-02 ,3.035221e-02 ,2.929020e-02 ,2.829979e-02 ,2.737397e-02 ,&
8017         & 2.650663e-02 ,2.569238e-02 ,2.492651e-02 ,2.420482e-02 ,2.352361e-02 ,&
8018         & 2.287954e-02 ,2.226968e-02 ,2.169136e-02 ,2.114220e-02 ,2.062005e-02 ,&
8019         & 2.012296e-02 ,1.964917e-02 ,1.919709e-02 ,1.876524e-02 ,1.835231e-02 ,&
8020         & 1.795707e-02  /)
8021       extice3(:, 24) = (/ &
8022 ! band 24
8023         & 5.042067e-01 ,3.151195e-01 ,2.291708e-01 ,1.800573e-01 ,1.482779e-01 ,&
8024         & 1.260324e-01 ,1.095900e-01 ,9.694202e-02 ,8.691087e-02 ,7.876056e-02 ,&
8025         & 7.200745e-02 ,6.632062e-02 ,6.146600e-02 ,5.727338e-02 ,5.361599e-02 ,&
8026         & 5.039749e-02 ,4.754334e-02 ,4.499500e-02 ,4.270580e-02 ,4.063815e-02 ,&
8027         & 3.876135e-02 ,3.705016e-02 ,3.548357e-02 ,3.404400e-02 ,3.271661e-02 ,&
8028         & 3.148877e-02 ,3.034969e-02 ,2.929008e-02 ,2.830191e-02 ,2.737818e-02 ,&
8029         & 2.651279e-02 ,2.570039e-02 ,2.493624e-02 ,2.421618e-02 ,2.353650e-02 ,&
8030         & 2.289390e-02 ,2.228541e-02 ,2.170840e-02 ,2.116048e-02 ,2.063950e-02 ,&
8031         & 2.014354e-02 ,1.967082e-02 ,1.921975e-02 ,1.878888e-02 ,1.837688e-02 ,&
8032         & 1.798254e-02  /)
8033       extice3(:, 25) = (/ &
8034 ! band 25
8035         & 5.022507e-01 ,3.139246e-01 ,2.283218e-01 ,1.794059e-01 ,1.477544e-01 ,&
8036         & 1.255984e-01 ,1.092222e-01 ,9.662516e-02 ,8.663439e-02 ,7.851688e-02 ,&
8037         & 7.179095e-02 ,6.612700e-02 ,6.129193e-02 ,5.711618e-02 ,5.347351e-02 ,&
8038         & 5.026796e-02 ,4.742530e-02 ,4.488721e-02 ,4.260724e-02 ,4.054790e-02 ,&
8039         & 3.867866e-02 ,3.697435e-02 ,3.541407e-02 ,3.398029e-02 ,3.265824e-02 ,&
8040         & 3.143535e-02 ,3.030085e-02 ,2.924551e-02 ,2.826131e-02 ,2.734130e-02 ,&
8041         & 2.647939e-02 ,2.567026e-02 ,2.490919e-02 ,2.419203e-02 ,2.351509e-02 ,&
8042         & 2.287507e-02 ,2.226903e-02 ,2.169434e-02 ,2.114862e-02 ,2.062975e-02 ,&
8043         & 2.013578e-02 ,1.966496e-02 ,1.921571e-02 ,1.878658e-02 ,1.837623e-02 ,&
8044         & 1.798348e-02  /)
8045       extice3(:, 26) = (/ &
8046 ! band 26
8047         & 5.068316e-01 ,3.166869e-01 ,2.302576e-01 ,1.808693e-01 ,1.489122e-01 ,&
8048         & 1.265423e-01 ,1.100080e-01 ,9.728926e-02 ,8.720201e-02 ,7.900612e-02 ,&
8049         & 7.221524e-02 ,6.649660e-02 ,6.161484e-02 ,5.739877e-02 ,5.372093e-02 ,&
8050         & 5.048442e-02 ,4.761431e-02 ,4.505172e-02 ,4.274972e-02 ,4.067050e-02 ,&
8051         & 3.878321e-02 ,3.706244e-02 ,3.548710e-02 ,3.403948e-02 ,3.270466e-02 ,&
8052         & 3.146995e-02 ,3.032450e-02 ,2.925897e-02 ,2.826527e-02 ,2.733638e-02 ,&
8053         & 2.646615e-02 ,2.564920e-02 ,2.488078e-02 ,2.415670e-02 ,2.347322e-02 ,&
8054         & 2.282702e-02 ,2.221513e-02 ,2.163489e-02 ,2.108390e-02 ,2.056002e-02 ,&
8055         & 2.006128e-02 ,1.958591e-02 ,1.913232e-02 ,1.869904e-02 ,1.828474e-02 ,&
8056         & 1.788819e-02  /)
8057       extice3(:, 27) = (/ &
8058 ! band 27
8059         & 5.077707e-01 ,3.172636e-01 ,2.306695e-01 ,1.811871e-01 ,1.491691e-01 ,&
8060         & 1.267565e-01 ,1.101907e-01 ,9.744773e-02 ,8.734125e-02 ,7.912973e-02 ,&
8061         & 7.232591e-02 ,6.659637e-02 ,6.170530e-02 ,5.748120e-02 ,5.379634e-02 ,&
8062         & 5.055367e-02 ,4.767809e-02 ,4.511061e-02 ,4.280423e-02 ,4.072104e-02 ,&
8063         & 3.883015e-02 ,3.710611e-02 ,3.552776e-02 ,3.407738e-02 ,3.274002e-02 ,&
8064         & 3.150296e-02 ,3.035532e-02 ,2.928776e-02 ,2.829216e-02 ,2.736150e-02 ,&
8065         & 2.648961e-02 ,2.567111e-02 ,2.490123e-02 ,2.417576e-02 ,2.349098e-02 ,&
8066         & 2.284354e-02 ,2.223049e-02 ,2.164914e-02 ,2.109711e-02 ,2.057222e-02 ,&
8067         & 2.007253e-02 ,1.959626e-02 ,1.914181e-02 ,1.870770e-02 ,1.829261e-02 ,&
8068         & 1.789531e-02  /)
8069       extice3(:, 28) = (/ &
8070 ! band 28
8071         & 5.062281e-01 ,3.163402e-01 ,2.300275e-01 ,1.807060e-01 ,1.487921e-01 ,&
8072         & 1.264523e-01 ,1.099403e-01 ,9.723879e-02 ,8.716516e-02 ,7.898034e-02 ,&
8073         & 7.219863e-02 ,6.648771e-02 ,6.161254e-02 ,5.740217e-02 ,5.372929e-02 ,&
8074         & 5.049716e-02 ,4.763092e-02 ,4.507179e-02 ,4.277290e-02 ,4.069649e-02 ,&
8075         & 3.881175e-02 ,3.709331e-02 ,3.552008e-02 ,3.407442e-02 ,3.274141e-02 ,&
8076         & 3.150837e-02 ,3.036447e-02 ,2.930037e-02 ,2.830801e-02 ,2.738037e-02 ,&
8077         & 2.651132e-02 ,2.569547e-02 ,2.492810e-02 ,2.420499e-02 ,2.352243e-02 ,&
8078         & 2.287710e-02 ,2.226604e-02 ,2.168658e-02 ,2.113634e-02 ,2.061316e-02 ,&
8079         & 2.011510e-02 ,1.964038e-02 ,1.918740e-02 ,1.875471e-02 ,1.834096e-02 ,&
8080         & 1.794495e-02  /)
8081       extice3(:, 29) = (/ &
8082 ! band 29
8083         & 1.338834e-01 ,1.924912e-01 ,1.755523e-01 ,1.534793e-01 ,1.343937e-01 ,&
8084         & 1.187883e-01 ,1.060654e-01 ,9.559106e-02 ,8.685880e-02 ,7.948698e-02 ,&
8085         & 7.319086e-02 ,6.775669e-02 ,6.302215e-02 ,5.886236e-02 ,5.517996e-02 ,&
8086         & 5.189810e-02 ,4.895539e-02 ,4.630225e-02 ,4.389823e-02 ,4.171002e-02 ,&
8087         & 3.970998e-02 ,3.787493e-02 ,3.618537e-02 ,3.462471e-02 ,3.317880e-02 ,&
8088         & 3.183547e-02 ,3.058421e-02 ,2.941590e-02 ,2.832256e-02 ,2.729724e-02 ,&
8089         & 2.633377e-02 ,2.542675e-02 ,2.457136e-02 ,2.376332e-02 ,2.299882e-02 ,&
8090         & 2.227443e-02 ,2.158707e-02 ,2.093400e-02 ,2.031270e-02 ,1.972091e-02 ,&
8091         & 1.915659e-02 ,1.861787e-02 ,1.810304e-02 ,1.761055e-02 ,1.713899e-02 ,&
8092         & 1.668704e-02  /)
8093
8094 ! single-scattering albedo: unitless
8095       ssaice3(:, 16) = (/ &
8096 ! band 16
8097         & 6.749442e-01 ,6.649947e-01 ,6.565828e-01 ,6.489928e-01 ,6.420046e-01 ,&
8098         & 6.355231e-01 ,6.294964e-01 ,6.238901e-01 ,6.186783e-01 ,6.138395e-01 ,&
8099         & 6.093543e-01 ,6.052049e-01 ,6.013742e-01 ,5.978457e-01 ,5.946030e-01 ,&
8100         & 5.916302e-01 ,5.889115e-01 ,5.864310e-01 ,5.841731e-01 ,5.821221e-01 ,&
8101         & 5.802624e-01 ,5.785785e-01 ,5.770549e-01 ,5.756759e-01 ,5.744262e-01 ,&
8102         & 5.732901e-01 ,5.722524e-01 ,5.712974e-01 ,5.704097e-01 ,5.695739e-01 ,&
8103         & 5.687747e-01 ,5.679964e-01 ,5.672238e-01 ,5.664415e-01 ,5.656340e-01 ,&
8104         & 5.647860e-01 ,5.638821e-01 ,5.629070e-01 ,5.618452e-01 ,5.606815e-01 ,&
8105         & 5.594006e-01 ,5.579870e-01 ,5.564255e-01 ,5.547008e-01 ,5.527976e-01 ,&
8106         & 5.507005e-01  /)
8107       ssaice3(:, 17) = (/ &
8108 ! band 17
8109         & 7.628550e-01 ,7.567297e-01 ,7.508463e-01 ,7.451972e-01 ,7.397745e-01 ,&
8110         & 7.345705e-01 ,7.295775e-01 ,7.247881e-01 ,7.201945e-01 ,7.157894e-01 ,&
8111         & 7.115652e-01 ,7.075145e-01 ,7.036300e-01 ,6.999044e-01 ,6.963304e-01 ,&
8112         & 6.929007e-01 ,6.896083e-01 ,6.864460e-01 ,6.834067e-01 ,6.804833e-01 ,&
8113         & 6.776690e-01 ,6.749567e-01 ,6.723397e-01 ,6.698109e-01 ,6.673637e-01 ,&
8114         & 6.649913e-01 ,6.626870e-01 ,6.604441e-01 ,6.582561e-01 ,6.561163e-01 ,&
8115         & 6.540182e-01 ,6.519554e-01 ,6.499215e-01 ,6.479099e-01 ,6.459145e-01 ,&
8116         & 6.439289e-01 ,6.419468e-01 ,6.399621e-01 ,6.379686e-01 ,6.359601e-01 ,&
8117         & 6.339306e-01 ,6.318740e-01 ,6.297845e-01 ,6.276559e-01 ,6.254825e-01 ,&
8118         & 6.232583e-01  /)
8119       ssaice3(:, 18) = (/ &
8120 ! band 18
8121         & 9.924147e-01 ,9.882792e-01 ,9.842257e-01 ,9.802522e-01 ,9.763566e-01 ,&
8122         & 9.725367e-01 ,9.687905e-01 ,9.651157e-01 ,9.615104e-01 ,9.579725e-01 ,&
8123         & 9.544997e-01 ,9.510901e-01 ,9.477416e-01 ,9.444520e-01 ,9.412194e-01 ,&
8124         & 9.380415e-01 ,9.349165e-01 ,9.318421e-01 ,9.288164e-01 ,9.258373e-01 ,&
8125         & 9.229027e-01 ,9.200106e-01 ,9.171589e-01 ,9.143457e-01 ,9.115688e-01 ,&
8126         & 9.088263e-01 ,9.061161e-01 ,9.034362e-01 ,9.007846e-01 ,8.981592e-01 ,&
8127         & 8.955581e-01 ,8.929792e-01 ,8.904206e-01 ,8.878803e-01 ,8.853562e-01 ,&
8128         & 8.828464e-01 ,8.803488e-01 ,8.778616e-01 ,8.753827e-01 ,8.729102e-01 ,&
8129         & 8.704421e-01 ,8.679764e-01 ,8.655112e-01 ,8.630445e-01 ,8.605744e-01 ,&
8130         & 8.580989e-01  /)
8131       ssaice3(:, 19) = (/ &
8132 ! band 19
8133         & 9.629413e-01 ,9.517182e-01 ,9.409209e-01 ,9.305366e-01 ,9.205529e-01 ,&
8134         & 9.109569e-01 ,9.017362e-01 ,8.928780e-01 ,8.843699e-01 ,8.761992e-01 ,&
8135         & 8.683536e-01 ,8.608204e-01 ,8.535873e-01 ,8.466417e-01 ,8.399712e-01 ,&
8136         & 8.335635e-01 ,8.274062e-01 ,8.214868e-01 ,8.157932e-01 ,8.103129e-01 ,&
8137         & 8.050336e-01 ,7.999432e-01 ,7.950294e-01 ,7.902798e-01 ,7.856825e-01 ,&
8138         & 7.812250e-01 ,7.768954e-01 ,7.726815e-01 ,7.685711e-01 ,7.645522e-01 ,&
8139         & 7.606126e-01 ,7.567404e-01 ,7.529234e-01 ,7.491498e-01 ,7.454074e-01 ,&
8140         & 7.416844e-01 ,7.379688e-01 ,7.342485e-01 ,7.305118e-01 ,7.267468e-01 ,&
8141         & 7.229415e-01 ,7.190841e-01 ,7.151628e-01 ,7.111657e-01 ,7.070811e-01 ,&
8142         & 7.028972e-01  /)
8143       ssaice3(:, 20) = (/ &
8144 ! band 20
8145         & 9.942270e-01 ,9.909206e-01 ,9.876775e-01 ,9.844960e-01 ,9.813746e-01 ,&
8146         & 9.783114e-01 ,9.753049e-01 ,9.723535e-01 ,9.694553e-01 ,9.666088e-01 ,&
8147         & 9.638123e-01 ,9.610641e-01 ,9.583626e-01 ,9.557060e-01 ,9.530928e-01 ,&
8148         & 9.505211e-01 ,9.479895e-01 ,9.454961e-01 ,9.430393e-01 ,9.406174e-01 ,&
8149         & 9.382288e-01 ,9.358717e-01 ,9.335446e-01 ,9.312456e-01 ,9.289731e-01 ,&
8150         & 9.267255e-01 ,9.245010e-01 ,9.222980e-01 ,9.201147e-01 ,9.179496e-01 ,&
8151         & 9.158008e-01 ,9.136667e-01 ,9.115457e-01 ,9.094359e-01 ,9.073358e-01 ,&
8152         & 9.052436e-01 ,9.031577e-01 ,9.010763e-01 ,8.989977e-01 ,8.969203e-01 ,&
8153         & 8.948423e-01 ,8.927620e-01 ,8.906778e-01 ,8.885879e-01 ,8.864907e-01 ,&
8154         & 8.843843e-01  /)
8155       ssaice3(:, 21) = (/ &
8156 ! band 21
8157         & 9.934014e-01 ,9.899331e-01 ,9.865537e-01 ,9.832610e-01 ,9.800523e-01 ,&
8158         & 9.769254e-01 ,9.738777e-01 ,9.709069e-01 ,9.680106e-01 ,9.651862e-01 ,&
8159         & 9.624315e-01 ,9.597439e-01 ,9.571212e-01 ,9.545608e-01 ,9.520605e-01 ,&
8160         & 9.496177e-01 ,9.472301e-01 ,9.448954e-01 ,9.426111e-01 ,9.403749e-01 ,&
8161         & 9.381843e-01 ,9.360370e-01 ,9.339307e-01 ,9.318629e-01 ,9.298313e-01 ,&
8162         & 9.278336e-01 ,9.258673e-01 ,9.239302e-01 ,9.220198e-01 ,9.201338e-01 ,&
8163         & 9.182700e-01 ,9.164258e-01 ,9.145991e-01 ,9.127874e-01 ,9.109884e-01 ,&
8164         & 9.091999e-01 ,9.074194e-01 ,9.056447e-01 ,9.038735e-01 ,9.021033e-01 ,&
8165         & 9.003320e-01 ,8.985572e-01 ,8.967766e-01 ,8.949879e-01 ,8.931888e-01 ,&
8166         & 8.913770e-01  /)
8167       ssaice3(:, 22) = (/ &
8168 ! band 22
8169         & 9.994833e-01 ,9.992055e-01 ,9.989278e-01 ,9.986500e-01 ,9.983724e-01 ,&
8170         & 9.980947e-01 ,9.978172e-01 ,9.975397e-01 ,9.972623e-01 ,9.969849e-01 ,&
8171         & 9.967077e-01 ,9.964305e-01 ,9.961535e-01 ,9.958765e-01 ,9.955997e-01 ,&
8172         & 9.953230e-01 ,9.950464e-01 ,9.947699e-01 ,9.944936e-01 ,9.942174e-01 ,&
8173         & 9.939414e-01 ,9.936656e-01 ,9.933899e-01 ,9.931144e-01 ,9.928390e-01 ,&
8174         & 9.925639e-01 ,9.922889e-01 ,9.920141e-01 ,9.917396e-01 ,9.914652e-01 ,&
8175         & 9.911911e-01 ,9.909171e-01 ,9.906434e-01 ,9.903700e-01 ,9.900967e-01 ,&
8176         & 9.898237e-01 ,9.895510e-01 ,9.892784e-01 ,9.890062e-01 ,9.887342e-01 ,&
8177         & 9.884625e-01 ,9.881911e-01 ,9.879199e-01 ,9.876490e-01 ,9.873784e-01 ,&
8178         & 9.871081e-01  /)
8179       ssaice3(:, 23) = (/ &
8180 ! band 23
8181         & 9.999343e-01 ,9.998917e-01 ,9.998492e-01 ,9.998067e-01 ,9.997642e-01 ,&
8182         & 9.997218e-01 ,9.996795e-01 ,9.996372e-01 ,9.995949e-01 ,9.995528e-01 ,&
8183         & 9.995106e-01 ,9.994686e-01 ,9.994265e-01 ,9.993845e-01 ,9.993426e-01 ,&
8184         & 9.993007e-01 ,9.992589e-01 ,9.992171e-01 ,9.991754e-01 ,9.991337e-01 ,&
8185         & 9.990921e-01 ,9.990505e-01 ,9.990089e-01 ,9.989674e-01 ,9.989260e-01 ,&
8186         & 9.988846e-01 ,9.988432e-01 ,9.988019e-01 ,9.987606e-01 ,9.987194e-01 ,&
8187         & 9.986782e-01 ,9.986370e-01 ,9.985959e-01 ,9.985549e-01 ,9.985139e-01 ,&
8188         & 9.984729e-01 ,9.984319e-01 ,9.983910e-01 ,9.983502e-01 ,9.983094e-01 ,&
8189         & 9.982686e-01 ,9.982279e-01 ,9.981872e-01 ,9.981465e-01 ,9.981059e-01 ,&
8190         & 9.980653e-01  /)
8191       ssaice3(:, 24) = (/ &
8192 ! band 24
8193         & 9.999978e-01 ,9.999965e-01 ,9.999952e-01 ,9.999939e-01 ,9.999926e-01 ,&
8194         & 9.999913e-01 ,9.999900e-01 ,9.999887e-01 ,9.999873e-01 ,9.999860e-01 ,&
8195         & 9.999847e-01 ,9.999834e-01 ,9.999821e-01 ,9.999808e-01 ,9.999795e-01 ,&
8196         & 9.999782e-01 ,9.999769e-01 ,9.999756e-01 ,9.999743e-01 ,9.999730e-01 ,&
8197         & 9.999717e-01 ,9.999704e-01 ,9.999691e-01 ,9.999678e-01 ,9.999665e-01 ,&
8198         & 9.999652e-01 ,9.999639e-01 ,9.999626e-01 ,9.999613e-01 ,9.999600e-01 ,&
8199         & 9.999587e-01 ,9.999574e-01 ,9.999561e-01 ,9.999548e-01 ,9.999535e-01 ,&
8200         & 9.999522e-01 ,9.999509e-01 ,9.999496e-01 ,9.999483e-01 ,9.999470e-01 ,&
8201         & 9.999457e-01 ,9.999444e-01 ,9.999431e-01 ,9.999418e-01 ,9.999405e-01 ,&
8202         & 9.999392e-01  /)
8203       ssaice3(:, 25) = (/ &
8204 ! band 25
8205         & 9.999994e-01 ,9.999993e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,&
8206         & 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999983e-01 ,9.999982e-01 ,&
8207         & 9.999980e-01 ,9.999979e-01 ,9.999977e-01 ,9.999976e-01 ,9.999975e-01 ,&
8208         & 9.999973e-01 ,9.999972e-01 ,9.999970e-01 ,9.999969e-01 ,9.999967e-01 ,&
8209         & 9.999966e-01 ,9.999965e-01 ,9.999963e-01 ,9.999962e-01 ,9.999960e-01 ,&
8210         & 9.999959e-01 ,9.999957e-01 ,9.999956e-01 ,9.999954e-01 ,9.999953e-01 ,&
8211         & 9.999952e-01 ,9.999950e-01 ,9.999949e-01 ,9.999947e-01 ,9.999946e-01 ,&
8212         & 9.999944e-01 ,9.999943e-01 ,9.999941e-01 ,9.999940e-01 ,9.999939e-01 ,&
8213         & 9.999937e-01 ,9.999936e-01 ,9.999934e-01 ,9.999933e-01 ,9.999931e-01 ,&
8214         & 9.999930e-01  /)
8215       ssaice3(:, 26) = (/ &
8216 ! band 26
8217         & 9.999997e-01 ,9.999995e-01 ,9.999992e-01 ,9.999990e-01 ,9.999987e-01 ,&
8218         & 9.999985e-01 ,9.999983e-01 ,9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,&
8219         & 9.999973e-01 ,9.999971e-01 ,9.999969e-01 ,9.999967e-01 ,9.999965e-01 ,&
8220         & 9.999963e-01 ,9.999960e-01 ,9.999958e-01 ,9.999956e-01 ,9.999954e-01 ,&
8221         & 9.999952e-01 ,9.999950e-01 ,9.999948e-01 ,9.999946e-01 ,9.999944e-01 ,&
8222         & 9.999942e-01 ,9.999939e-01 ,9.999937e-01 ,9.999935e-01 ,9.999933e-01 ,&
8223         & 9.999931e-01 ,9.999929e-01 ,9.999927e-01 ,9.999925e-01 ,9.999923e-01 ,&
8224         & 9.999920e-01 ,9.999918e-01 ,9.999916e-01 ,9.999914e-01 ,9.999911e-01 ,&
8225         & 9.999909e-01 ,9.999907e-01 ,9.999905e-01 ,9.999902e-01 ,9.999900e-01 ,&
8226         & 9.999897e-01  /)
8227       ssaice3(:, 27) = (/ &
8228 ! band 27
8229         & 9.999991e-01 ,9.999985e-01 ,9.999980e-01 ,9.999974e-01 ,9.999968e-01 ,&
8230         & 9.999963e-01 ,9.999957e-01 ,9.999951e-01 ,9.999946e-01 ,9.999940e-01 ,&
8231         & 9.999934e-01 ,9.999929e-01 ,9.999923e-01 ,9.999918e-01 ,9.999912e-01 ,&
8232         & 9.999907e-01 ,9.999901e-01 ,9.999896e-01 ,9.999891e-01 ,9.999885e-01 ,&
8233         & 9.999880e-01 ,9.999874e-01 ,9.999869e-01 ,9.999863e-01 ,9.999858e-01 ,&
8234         & 9.999853e-01 ,9.999847e-01 ,9.999842e-01 ,9.999836e-01 ,9.999831e-01 ,&
8235         & 9.999826e-01 ,9.999820e-01 ,9.999815e-01 ,9.999809e-01 ,9.999804e-01 ,&
8236         & 9.999798e-01 ,9.999793e-01 ,9.999787e-01 ,9.999782e-01 ,9.999776e-01 ,&
8237         & 9.999770e-01 ,9.999765e-01 ,9.999759e-01 ,9.999754e-01 ,9.999748e-01 ,&
8238         & 9.999742e-01  /)
8239       ssaice3(:, 28) = (/ &
8240 ! band 28
8241         & 9.999975e-01 ,9.999961e-01 ,9.999946e-01 ,9.999931e-01 ,9.999917e-01 ,&
8242         & 9.999903e-01 ,9.999888e-01 ,9.999874e-01 ,9.999859e-01 ,9.999845e-01 ,&
8243         & 9.999831e-01 ,9.999816e-01 ,9.999802e-01 ,9.999788e-01 ,9.999774e-01 ,&
8244         & 9.999759e-01 ,9.999745e-01 ,9.999731e-01 ,9.999717e-01 ,9.999702e-01 ,&
8245         & 9.999688e-01 ,9.999674e-01 ,9.999660e-01 ,9.999646e-01 ,9.999631e-01 ,&
8246         & 9.999617e-01 ,9.999603e-01 ,9.999589e-01 ,9.999574e-01 ,9.999560e-01 ,&
8247         & 9.999546e-01 ,9.999532e-01 ,9.999517e-01 ,9.999503e-01 ,9.999489e-01 ,&
8248         & 9.999474e-01 ,9.999460e-01 ,9.999446e-01 ,9.999431e-01 ,9.999417e-01 ,&
8249         & 9.999403e-01 ,9.999388e-01 ,9.999374e-01 ,9.999359e-01 ,9.999345e-01 ,&
8250         & 9.999330e-01  /)
8251       ssaice3(:, 29) = (/ &
8252 ! band 29
8253         & 4.526500e-01 ,5.287890e-01 ,5.410487e-01 ,5.459865e-01 ,5.485149e-01 ,&
8254         & 5.498914e-01 ,5.505895e-01 ,5.508310e-01 ,5.507364e-01 ,5.503793e-01 ,&
8255         & 5.498090e-01 ,5.490612e-01 ,5.481637e-01 ,5.471395e-01 ,5.460083e-01 ,&
8256         & 5.447878e-01 ,5.434946e-01 ,5.421442e-01 ,5.407514e-01 ,5.393309e-01 ,&
8257         & 5.378970e-01 ,5.364641e-01 ,5.350464e-01 ,5.336582e-01 ,5.323140e-01 ,&
8258         & 5.310283e-01 ,5.298158e-01 ,5.286914e-01 ,5.276704e-01 ,5.267680e-01 ,&
8259         & 5.260000e-01 ,5.253823e-01 ,5.249311e-01 ,5.246629e-01 ,5.245946e-01 ,&
8260         & 5.247434e-01 ,5.251268e-01 ,5.257626e-01 ,5.266693e-01 ,5.278653e-01 ,&
8261         & 5.293698e-01 ,5.312022e-01 ,5.333823e-01 ,5.359305e-01 ,5.388676e-01 ,&
8262         & 5.422146e-01  /)
8263
8264 ! asymmetry factor: unitless
8265       asyice3(:, 16) = (/ &
8266 ! band 16
8267         & 8.340752e-01 ,8.435170e-01 ,8.517487e-01 ,8.592064e-01 ,8.660387e-01 ,&
8268         & 8.723204e-01 ,8.780997e-01 ,8.834137e-01 ,8.882934e-01 ,8.927662e-01 ,&
8269         & 8.968577e-01 ,9.005914e-01 ,9.039899e-01 ,9.070745e-01 ,9.098659e-01 ,&
8270         & 9.123836e-01 ,9.146466e-01 ,9.166734e-01 ,9.184817e-01 ,9.200886e-01 ,&
8271         & 9.215109e-01 ,9.227648e-01 ,9.238661e-01 ,9.248304e-01 ,9.256727e-01 ,&
8272         & 9.264078e-01 ,9.270505e-01 ,9.276150e-01 ,9.281156e-01 ,9.285662e-01 ,&
8273         & 9.289806e-01 ,9.293726e-01 ,9.297557e-01 ,9.301435e-01 ,9.305491e-01 ,&
8274         & 9.309859e-01 ,9.314671e-01 ,9.320055e-01 ,9.326140e-01 ,9.333053e-01 ,&
8275         & 9.340919e-01 ,9.349861e-01 ,9.360000e-01 ,9.371451e-01 ,9.384329e-01 ,&
8276         & 9.398744e-01  /)
8277       asyice3(:, 17) = (/ &
8278 ! band 17
8279         & 8.728160e-01 ,8.777333e-01 ,8.823754e-01 ,8.867535e-01 ,8.908785e-01 ,&
8280         & 8.947611e-01 ,8.984118e-01 ,9.018408e-01 ,9.050582e-01 ,9.080739e-01 ,&
8281         & 9.108976e-01 ,9.135388e-01 ,9.160068e-01 ,9.183106e-01 ,9.204595e-01 ,&
8282         & 9.224620e-01 ,9.243271e-01 ,9.260632e-01 ,9.276788e-01 ,9.291822e-01 ,&
8283         & 9.305817e-01 ,9.318853e-01 ,9.331012e-01 ,9.342372e-01 ,9.353013e-01 ,&
8284         & 9.363013e-01 ,9.372450e-01 ,9.381400e-01 ,9.389939e-01 ,9.398145e-01 ,&
8285         & 9.406092e-01 ,9.413856e-01 ,9.421511e-01 ,9.429131e-01 ,9.436790e-01 ,&
8286         & 9.444561e-01 ,9.452517e-01 ,9.460729e-01 ,9.469270e-01 ,9.478209e-01 ,&
8287         & 9.487617e-01 ,9.497562e-01 ,9.508112e-01 ,9.519335e-01 ,9.531294e-01 ,&
8288         & 9.544055e-01  /)
8289       asyice3(:, 18) = (/ &
8290 ! band 18
8291         & 7.897566e-01 ,7.948704e-01 ,7.998041e-01 ,8.045623e-01 ,8.091495e-01 ,&
8292         & 8.135702e-01 ,8.178290e-01 ,8.219305e-01 ,8.258790e-01 ,8.296792e-01 ,&
8293         & 8.333355e-01 ,8.368524e-01 ,8.402343e-01 ,8.434856e-01 ,8.466108e-01 ,&
8294         & 8.496143e-01 ,8.525004e-01 ,8.552737e-01 ,8.579384e-01 ,8.604990e-01 ,&
8295         & 8.629597e-01 ,8.653250e-01 ,8.675992e-01 ,8.697867e-01 ,8.718916e-01 ,&
8296         & 8.739185e-01 ,8.758715e-01 ,8.777551e-01 ,8.795734e-01 ,8.813308e-01 ,&
8297         & 8.830315e-01 ,8.846799e-01 ,8.862802e-01 ,8.878366e-01 ,8.893534e-01 ,&
8298         & 8.908350e-01 ,8.922854e-01 ,8.937090e-01 ,8.951099e-01 ,8.964925e-01 ,&
8299         & 8.978609e-01 ,8.992192e-01 ,9.005718e-01 ,9.019229e-01 ,9.032765e-01 ,&
8300         & 9.046369e-01  /)
8301       asyice3(:, 19) = (/ &
8302 ! band 19
8303         & 7.812615e-01 ,7.887764e-01 ,7.959664e-01 ,8.028413e-01 ,8.094109e-01 ,&
8304         & 8.156849e-01 ,8.216730e-01 ,8.273846e-01 ,8.328294e-01 ,8.380166e-01 ,&
8305         & 8.429556e-01 ,8.476556e-01 ,8.521258e-01 ,8.563753e-01 ,8.604131e-01 ,&
8306         & 8.642481e-01 ,8.678893e-01 ,8.713455e-01 ,8.746254e-01 ,8.777378e-01 ,&
8307         & 8.806914e-01 ,8.834948e-01 ,8.861566e-01 ,8.886854e-01 ,8.910897e-01 ,&
8308         & 8.933779e-01 ,8.955586e-01 ,8.976402e-01 ,8.996311e-01 ,9.015398e-01 ,&
8309         & 9.033745e-01 ,9.051436e-01 ,9.068555e-01 ,9.085185e-01 ,9.101410e-01 ,&
8310         & 9.117311e-01 ,9.132972e-01 ,9.148476e-01 ,9.163905e-01 ,9.179340e-01 ,&
8311         & 9.194864e-01 ,9.210559e-01 ,9.226505e-01 ,9.242784e-01 ,9.259476e-01 ,&
8312         & 9.276661e-01  /)
8313       asyice3(:, 20) = (/ &
8314 ! band 20
8315         & 7.640720e-01 ,7.691119e-01 ,7.739941e-01 ,7.787222e-01 ,7.832998e-01 ,&
8316         & 7.877304e-01 ,7.920177e-01 ,7.961652e-01 ,8.001765e-01 ,8.040551e-01 ,&
8317         & 8.078044e-01 ,8.114280e-01 ,8.149294e-01 ,8.183119e-01 ,8.215791e-01 ,&
8318         & 8.247344e-01 ,8.277812e-01 ,8.307229e-01 ,8.335629e-01 ,8.363046e-01 ,&
8319         & 8.389514e-01 ,8.415067e-01 ,8.439738e-01 ,8.463560e-01 ,8.486568e-01 ,&
8320         & 8.508795e-01 ,8.530274e-01 ,8.551039e-01 ,8.571122e-01 ,8.590558e-01 ,&
8321         & 8.609378e-01 ,8.627618e-01 ,8.645309e-01 ,8.662485e-01 ,8.679178e-01 ,&
8322         & 8.695423e-01 ,8.711251e-01 ,8.726697e-01 ,8.741792e-01 ,8.756571e-01 ,&
8323         & 8.771065e-01 ,8.785307e-01 ,8.799331e-01 ,8.813169e-01 ,8.826854e-01 ,&
8324         & 8.840419e-01  /)
8325       asyice3(:, 21) = (/ &
8326 ! band 21
8327         & 7.602598e-01 ,7.651572e-01 ,7.699014e-01 ,7.744962e-01 ,7.789452e-01 ,&
8328         & 7.832522e-01 ,7.874205e-01 ,7.914538e-01 ,7.953555e-01 ,7.991290e-01 ,&
8329         & 8.027777e-01 ,8.063049e-01 ,8.097140e-01 ,8.130081e-01 ,8.161906e-01 ,&
8330         & 8.192645e-01 ,8.222331e-01 ,8.250993e-01 ,8.278664e-01 ,8.305374e-01 ,&
8331         & 8.331153e-01 ,8.356030e-01 ,8.380037e-01 ,8.403201e-01 ,8.425553e-01 ,&
8332         & 8.447121e-01 ,8.467935e-01 ,8.488022e-01 ,8.507412e-01 ,8.526132e-01 ,&
8333         & 8.544210e-01 ,8.561675e-01 ,8.578554e-01 ,8.594875e-01 ,8.610665e-01 ,&
8334         & 8.625951e-01 ,8.640760e-01 ,8.655119e-01 ,8.669055e-01 ,8.682594e-01 ,&
8335         & 8.695763e-01 ,8.708587e-01 ,8.721094e-01 ,8.733308e-01 ,8.745255e-01 ,&
8336         & 8.756961e-01  /)
8337       asyice3(:, 22) = (/ &
8338 ! band 22
8339         & 7.568957e-01 ,7.606995e-01 ,7.644072e-01 ,7.680204e-01 ,7.715402e-01 ,&
8340         & 7.749682e-01 ,7.783057e-01 ,7.815541e-01 ,7.847148e-01 ,7.877892e-01 ,&
8341         & 7.907786e-01 ,7.936846e-01 ,7.965084e-01 ,7.992515e-01 ,8.019153e-01 ,&
8342         & 8.045011e-01 ,8.070103e-01 ,8.094444e-01 ,8.118048e-01 ,8.140927e-01 ,&
8343         & 8.163097e-01 ,8.184571e-01 ,8.205364e-01 ,8.225488e-01 ,8.244958e-01 ,&
8344         & 8.263789e-01 ,8.281993e-01 ,8.299586e-01 ,8.316580e-01 ,8.332991e-01 ,&
8345         & 8.348831e-01 ,8.364115e-01 ,8.378857e-01 ,8.393071e-01 ,8.406770e-01 ,&
8346         & 8.419969e-01 ,8.432682e-01 ,8.444923e-01 ,8.456706e-01 ,8.468044e-01 ,&
8347         & 8.478952e-01 ,8.489444e-01 ,8.499533e-01 ,8.509234e-01 ,8.518561e-01 ,&
8348         & 8.527528e-01  /)
8349       asyice3(:, 23) = (/ &
8350 ! band 23
8351         & 7.575066e-01 ,7.606912e-01 ,7.638236e-01 ,7.669035e-01 ,7.699306e-01 ,&
8352         & 7.729046e-01 ,7.758254e-01 ,7.786926e-01 ,7.815060e-01 ,7.842654e-01 ,&
8353         & 7.869705e-01 ,7.896211e-01 ,7.922168e-01 ,7.947574e-01 ,7.972428e-01 ,&
8354         & 7.996726e-01 ,8.020466e-01 ,8.043646e-01 ,8.066262e-01 ,8.088313e-01 ,&
8355         & 8.109796e-01 ,8.130709e-01 ,8.151049e-01 ,8.170814e-01 ,8.190001e-01 ,&
8356         & 8.208608e-01 ,8.226632e-01 ,8.244071e-01 ,8.260924e-01 ,8.277186e-01 ,&
8357         & 8.292856e-01 ,8.307932e-01 ,8.322411e-01 ,8.336291e-01 ,8.349570e-01 ,&
8358         & 8.362244e-01 ,8.374312e-01 ,8.385772e-01 ,8.396621e-01 ,8.406856e-01 ,&
8359         & 8.416476e-01 ,8.425479e-01 ,8.433861e-01 ,8.441620e-01 ,8.448755e-01 ,&
8360         & 8.455263e-01  /)
8361       asyice3(:, 24) = (/ &
8362 ! band 24
8363         & 7.568829e-01 ,7.597947e-01 ,7.626745e-01 ,7.655212e-01 ,7.683337e-01 ,&
8364         & 7.711111e-01 ,7.738523e-01 ,7.765565e-01 ,7.792225e-01 ,7.818494e-01 ,&
8365         & 7.844362e-01 ,7.869819e-01 ,7.894854e-01 ,7.919459e-01 ,7.943623e-01 ,&
8366         & 7.967337e-01 ,7.990590e-01 ,8.013373e-01 ,8.035676e-01 ,8.057488e-01 ,&
8367         & 8.078802e-01 ,8.099605e-01 ,8.119890e-01 ,8.139645e-01 ,8.158862e-01 ,&
8368         & 8.177530e-01 ,8.195641e-01 ,8.213183e-01 ,8.230149e-01 ,8.246527e-01 ,&
8369         & 8.262308e-01 ,8.277483e-01 ,8.292042e-01 ,8.305976e-01 ,8.319275e-01 ,&
8370         & 8.331929e-01 ,8.343929e-01 ,8.355265e-01 ,8.365928e-01 ,8.375909e-01 ,&
8371         & 8.385197e-01 ,8.393784e-01 ,8.401659e-01 ,8.408815e-01 ,8.415240e-01 ,&
8372         & 8.420926e-01  /)
8373       asyice3(:, 25) = (/ &
8374 ! band 25
8375         & 7.548616e-01 ,7.575454e-01 ,7.602153e-01 ,7.628696e-01 ,7.655067e-01 ,&
8376         & 7.681249e-01 ,7.707225e-01 ,7.732978e-01 ,7.758492e-01 ,7.783750e-01 ,&
8377         & 7.808735e-01 ,7.833430e-01 ,7.857819e-01 ,7.881886e-01 ,7.905612e-01 ,&
8378         & 7.928983e-01 ,7.951980e-01 ,7.974588e-01 ,7.996789e-01 ,8.018567e-01 ,&
8379         & 8.039905e-01 ,8.060787e-01 ,8.081196e-01 ,8.101115e-01 ,8.120527e-01 ,&
8380         & 8.139416e-01 ,8.157764e-01 ,8.175557e-01 ,8.192776e-01 ,8.209405e-01 ,&
8381         & 8.225427e-01 ,8.240826e-01 ,8.255585e-01 ,8.269688e-01 ,8.283117e-01 ,&
8382         & 8.295856e-01 ,8.307889e-01 ,8.319198e-01 ,8.329767e-01 ,8.339579e-01 ,&
8383         & 8.348619e-01 ,8.356868e-01 ,8.364311e-01 ,8.370930e-01 ,8.376710e-01 ,&
8384         & 8.381633e-01  /)
8385       asyice3(:, 26) = (/ &
8386 ! band 26
8387         & 7.491854e-01 ,7.518523e-01 ,7.545089e-01 ,7.571534e-01 ,7.597839e-01 ,&
8388         & 7.623987e-01 ,7.649959e-01 ,7.675737e-01 ,7.701303e-01 ,7.726639e-01 ,&
8389         & 7.751727e-01 ,7.776548e-01 ,7.801084e-01 ,7.825318e-01 ,7.849230e-01 ,&
8390         & 7.872804e-01 ,7.896020e-01 ,7.918862e-01 ,7.941309e-01 ,7.963345e-01 ,&
8391         & 7.984951e-01 ,8.006109e-01 ,8.026802e-01 ,8.047009e-01 ,8.066715e-01 ,&
8392         & 8.085900e-01 ,8.104546e-01 ,8.122636e-01 ,8.140150e-01 ,8.157072e-01 ,&
8393         & 8.173382e-01 ,8.189063e-01 ,8.204096e-01 ,8.218464e-01 ,8.232148e-01 ,&
8394         & 8.245130e-01 ,8.257391e-01 ,8.268915e-01 ,8.279682e-01 ,8.289675e-01 ,&
8395         & 8.298875e-01 ,8.307264e-01 ,8.314824e-01 ,8.321537e-01 ,8.327385e-01 ,&
8396         & 8.332350e-01  /)
8397       asyice3(:, 27) = (/ &
8398 ! band 27
8399         & 7.397086e-01 ,7.424069e-01 ,7.450955e-01 ,7.477725e-01 ,7.504362e-01 ,&
8400         & 7.530846e-01 ,7.557159e-01 ,7.583283e-01 ,7.609199e-01 ,7.634888e-01 ,&
8401         & 7.660332e-01 ,7.685512e-01 ,7.710411e-01 ,7.735009e-01 ,7.759288e-01 ,&
8402         & 7.783229e-01 ,7.806814e-01 ,7.830024e-01 ,7.852841e-01 ,7.875246e-01 ,&
8403         & 7.897221e-01 ,7.918748e-01 ,7.939807e-01 ,7.960380e-01 ,7.980449e-01 ,&
8404         & 7.999995e-01 ,8.019000e-01 ,8.037445e-01 ,8.055311e-01 ,8.072581e-01 ,&
8405         & 8.089235e-01 ,8.105255e-01 ,8.120623e-01 ,8.135319e-01 ,8.149326e-01 ,&
8406         & 8.162626e-01 ,8.175198e-01 ,8.187025e-01 ,8.198089e-01 ,8.208371e-01 ,&
8407         & 8.217852e-01 ,8.226514e-01 ,8.234338e-01 ,8.241306e-01 ,8.247399e-01 ,&
8408         & 8.252599e-01  /)
8409       asyice3(:, 28) = (/ &
8410 ! band 28
8411         & 7.224533e-01 ,7.251681e-01 ,7.278728e-01 ,7.305654e-01 ,7.332444e-01 ,&
8412         & 7.359078e-01 ,7.385539e-01 ,7.411808e-01 ,7.437869e-01 ,7.463702e-01 ,&
8413         & 7.489291e-01 ,7.514616e-01 ,7.539661e-01 ,7.564408e-01 ,7.588837e-01 ,&
8414         & 7.612933e-01 ,7.636676e-01 ,7.660049e-01 ,7.683034e-01 ,7.705612e-01 ,&
8415         & 7.727767e-01 ,7.749480e-01 ,7.770733e-01 ,7.791509e-01 ,7.811789e-01 ,&
8416         & 7.831556e-01 ,7.850791e-01 ,7.869478e-01 ,7.887597e-01 ,7.905131e-01 ,&
8417         & 7.922062e-01 ,7.938372e-01 ,7.954044e-01 ,7.969059e-01 ,7.983399e-01 ,&
8418         & 7.997047e-01 ,8.009985e-01 ,8.022195e-01 ,8.033658e-01 ,8.044357e-01 ,&
8419         & 8.054275e-01 ,8.063392e-01 ,8.071692e-01 ,8.079157e-01 ,8.085768e-01 ,&
8420         & 8.091507e-01  /)
8421       asyice3(:, 29) = (/ &
8422 ! band 29
8423         & 8.850026e-01 ,9.005489e-01 ,9.069242e-01 ,9.121799e-01 ,9.168987e-01 ,&
8424         & 9.212259e-01 ,9.252176e-01 ,9.289028e-01 ,9.323000e-01 ,9.354235e-01 ,&
8425         & 9.382858e-01 ,9.408985e-01 ,9.432734e-01 ,9.454218e-01 ,9.473557e-01 ,&
8426         & 9.490871e-01 ,9.506282e-01 ,9.519917e-01 ,9.531904e-01 ,9.542374e-01 ,&
8427         & 9.551461e-01 ,9.559298e-01 ,9.566023e-01 ,9.571775e-01 ,9.576692e-01 ,&
8428         & 9.580916e-01 ,9.584589e-01 ,9.587853e-01 ,9.590851e-01 ,9.593729e-01 ,&
8429         & 9.596632e-01 ,9.599705e-01 ,9.603096e-01 ,9.606954e-01 ,9.611427e-01 ,&
8430         & 9.616667e-01 ,9.622826e-01 ,9.630060e-01 ,9.638524e-01 ,9.648379e-01 ,&
8431         & 9.659788e-01 ,9.672916e-01 ,9.687933e-01 ,9.705014e-01 ,9.724337e-01 ,&
8432         & 9.746084e-01  /)
8433
8434 ! fdelta: unitless
8435       fdlice3(:, 16) = (/ &
8436 ! band 16
8437         & 4.959277e-02 ,4.685292e-02 ,4.426104e-02 ,4.181231e-02 ,3.950191e-02 ,&
8438         & 3.732500e-02 ,3.527675e-02 ,3.335235e-02 ,3.154697e-02 ,2.985578e-02 ,&
8439         & 2.827395e-02 ,2.679666e-02 ,2.541909e-02 ,2.413640e-02 ,2.294378e-02 ,&
8440         & 2.183639e-02 ,2.080940e-02 ,1.985801e-02 ,1.897736e-02 ,1.816265e-02 ,&
8441         & 1.740905e-02 ,1.671172e-02 ,1.606585e-02 ,1.546661e-02 ,1.490917e-02 ,&
8442         & 1.438870e-02 ,1.390038e-02 ,1.343939e-02 ,1.300089e-02 ,1.258006e-02 ,&
8443         & 1.217208e-02 ,1.177212e-02 ,1.137536e-02 ,1.097696e-02 ,1.057210e-02 ,&
8444         & 1.015596e-02 ,9.723704e-03 ,9.270516e-03 ,8.791565e-03 ,8.282026e-03 ,&
8445         & 7.737072e-03 ,7.151879e-03 ,6.521619e-03 ,5.841467e-03 ,5.106597e-03 ,&
8446         & 4.312183e-03  /)
8447       fdlice3(:, 17) = (/ &
8448 ! band 17
8449         & 5.071224e-02 ,5.000217e-02 ,4.933872e-02 ,4.871992e-02 ,4.814380e-02 ,&
8450         & 4.760839e-02 ,4.711170e-02 ,4.665177e-02 ,4.622662e-02 ,4.583426e-02 ,&
8451         & 4.547274e-02 ,4.514007e-02 ,4.483428e-02 ,4.455340e-02 ,4.429544e-02 ,&
8452         & 4.405844e-02 ,4.384041e-02 ,4.363939e-02 ,4.345340e-02 ,4.328047e-02 ,&
8453         & 4.311861e-02 ,4.296586e-02 ,4.282024e-02 ,4.267977e-02 ,4.254248e-02 ,&
8454         & 4.240640e-02 ,4.226955e-02 ,4.212995e-02 ,4.198564e-02 ,4.183462e-02 ,&
8455         & 4.167494e-02 ,4.150462e-02 ,4.132167e-02 ,4.112413e-02 ,4.091003e-02 ,&
8456         & 4.067737e-02 ,4.042420e-02 ,4.014854e-02 ,3.984840e-02 ,3.952183e-02 ,&
8457         & 3.916683e-02 ,3.878144e-02 ,3.836368e-02 ,3.791158e-02 ,3.742316e-02 ,&
8458         & 3.689645e-02  /)
8459       fdlice3(:, 18) = (/ &
8460 ! band 18
8461         & 1.062938e-01 ,1.065234e-01 ,1.067822e-01 ,1.070682e-01 ,1.073793e-01 ,&
8462         & 1.077137e-01 ,1.080693e-01 ,1.084442e-01 ,1.088364e-01 ,1.092439e-01 ,&
8463         & 1.096647e-01 ,1.100970e-01 ,1.105387e-01 ,1.109878e-01 ,1.114423e-01 ,&
8464         & 1.119004e-01 ,1.123599e-01 ,1.128190e-01 ,1.132757e-01 ,1.137279e-01 ,&
8465         & 1.141738e-01 ,1.146113e-01 ,1.150385e-01 ,1.154534e-01 ,1.158540e-01 ,&
8466         & 1.162383e-01 ,1.166045e-01 ,1.169504e-01 ,1.172741e-01 ,1.175738e-01 ,&
8467         & 1.178472e-01 ,1.180926e-01 ,1.183080e-01 ,1.184913e-01 ,1.186405e-01 ,&
8468         & 1.187538e-01 ,1.188291e-01 ,1.188645e-01 ,1.188580e-01 ,1.188076e-01 ,&
8469         & 1.187113e-01 ,1.185672e-01 ,1.183733e-01 ,1.181277e-01 ,1.178282e-01 ,&
8470         & 1.174731e-01  /)
8471       fdlice3(:, 19) = (/ &
8472 ! band 19
8473         & 1.076195e-01 ,1.065195e-01 ,1.054696e-01 ,1.044673e-01 ,1.035099e-01 ,&
8474         & 1.025951e-01 ,1.017203e-01 ,1.008831e-01 ,1.000808e-01 ,9.931116e-02 ,&
8475         & 9.857151e-02 ,9.785939e-02 ,9.717230e-02 ,9.650774e-02 ,9.586322e-02 ,&
8476         & 9.523623e-02 ,9.462427e-02 ,9.402484e-02 ,9.343544e-02 ,9.285358e-02 ,&
8477         & 9.227675e-02 ,9.170245e-02 ,9.112818e-02 ,9.055144e-02 ,8.996974e-02 ,&
8478         & 8.938056e-02 ,8.878142e-02 ,8.816981e-02 ,8.754323e-02 ,8.689919e-02 ,&
8479         & 8.623517e-02 ,8.554869e-02 ,8.483724e-02 ,8.409832e-02 ,8.332943e-02 ,&
8480         & 8.252807e-02 ,8.169175e-02 ,8.081795e-02 ,7.990419e-02 ,7.894796e-02 ,&
8481         & 7.794676e-02 ,7.689809e-02 ,7.579945e-02 ,7.464834e-02 ,7.344227e-02 ,&
8482         & 7.217872e-02  /)
8483       fdlice3(:, 20) = (/ &
8484 ! band 20
8485         & 1.119014e-01 ,1.122706e-01 ,1.126690e-01 ,1.130947e-01 ,1.135456e-01 ,&
8486         & 1.140199e-01 ,1.145154e-01 ,1.150302e-01 ,1.155623e-01 ,1.161096e-01 ,&
8487         & 1.166703e-01 ,1.172422e-01 ,1.178233e-01 ,1.184118e-01 ,1.190055e-01 ,&
8488         & 1.196025e-01 ,1.202008e-01 ,1.207983e-01 ,1.213931e-01 ,1.219832e-01 ,&
8489         & 1.225665e-01 ,1.231411e-01 ,1.237050e-01 ,1.242561e-01 ,1.247926e-01 ,&
8490         & 1.253122e-01 ,1.258132e-01 ,1.262934e-01 ,1.267509e-01 ,1.271836e-01 ,&
8491         & 1.275896e-01 ,1.279669e-01 ,1.283134e-01 ,1.286272e-01 ,1.289063e-01 ,&
8492         & 1.291486e-01 ,1.293522e-01 ,1.295150e-01 ,1.296351e-01 ,1.297104e-01 ,&
8493         & 1.297390e-01 ,1.297189e-01 ,1.296480e-01 ,1.295244e-01 ,1.293460e-01 ,&
8494         & 1.291109e-01  /)
8495       fdlice3(:, 21) = (/ &
8496 ! band 21
8497         & 1.133298e-01 ,1.136777e-01 ,1.140556e-01 ,1.144615e-01 ,1.148934e-01 ,&
8498         & 1.153492e-01 ,1.158269e-01 ,1.163243e-01 ,1.168396e-01 ,1.173706e-01 ,&
8499         & 1.179152e-01 ,1.184715e-01 ,1.190374e-01 ,1.196108e-01 ,1.201897e-01 ,&
8500         & 1.207720e-01 ,1.213558e-01 ,1.219389e-01 ,1.225194e-01 ,1.230951e-01 ,&
8501         & 1.236640e-01 ,1.242241e-01 ,1.247733e-01 ,1.253096e-01 ,1.258309e-01 ,&
8502         & 1.263352e-01 ,1.268205e-01 ,1.272847e-01 ,1.277257e-01 ,1.281415e-01 ,&
8503         & 1.285300e-01 ,1.288893e-01 ,1.292173e-01 ,1.295118e-01 ,1.297710e-01 ,&
8504         & 1.299927e-01 ,1.301748e-01 ,1.303154e-01 ,1.304124e-01 ,1.304637e-01 ,&
8505         & 1.304673e-01 ,1.304212e-01 ,1.303233e-01 ,1.301715e-01 ,1.299638e-01 ,&
8506         & 1.296983e-01  /)
8507       fdlice3(:, 22) = (/ &
8508 ! band 22
8509         & 1.145360e-01 ,1.153256e-01 ,1.161453e-01 ,1.169929e-01 ,1.178666e-01 ,&
8510         & 1.187641e-01 ,1.196835e-01 ,1.206227e-01 ,1.215796e-01 ,1.225522e-01 ,&
8511         & 1.235383e-01 ,1.245361e-01 ,1.255433e-01 ,1.265579e-01 ,1.275779e-01 ,&
8512         & 1.286011e-01 ,1.296257e-01 ,1.306494e-01 ,1.316703e-01 ,1.326862e-01 ,&
8513         & 1.336951e-01 ,1.346950e-01 ,1.356838e-01 ,1.366594e-01 ,1.376198e-01 ,&
8514         & 1.385629e-01 ,1.394866e-01 ,1.403889e-01 ,1.412678e-01 ,1.421212e-01 ,&
8515         & 1.429469e-01 ,1.437430e-01 ,1.445074e-01 ,1.452381e-01 ,1.459329e-01 ,&
8516         & 1.465899e-01 ,1.472069e-01 ,1.477819e-01 ,1.483128e-01 ,1.487976e-01 ,&
8517         & 1.492343e-01 ,1.496207e-01 ,1.499548e-01 ,1.502346e-01 ,1.504579e-01 ,&
8518         & 1.506227e-01  /)
8519       fdlice3(:, 23) = (/ &
8520 ! band 23
8521         & 1.153263e-01 ,1.161445e-01 ,1.169932e-01 ,1.178703e-01 ,1.187738e-01 ,&
8522         & 1.197016e-01 ,1.206516e-01 ,1.216217e-01 ,1.226099e-01 ,1.236141e-01 ,&
8523         & 1.246322e-01 ,1.256621e-01 ,1.267017e-01 ,1.277491e-01 ,1.288020e-01 ,&
8524         & 1.298584e-01 ,1.309163e-01 ,1.319736e-01 ,1.330281e-01 ,1.340778e-01 ,&
8525         & 1.351207e-01 ,1.361546e-01 ,1.371775e-01 ,1.381873e-01 ,1.391820e-01 ,&
8526         & 1.401593e-01 ,1.411174e-01 ,1.420540e-01 ,1.429671e-01 ,1.438547e-01 ,&
8527         & 1.447146e-01 ,1.455449e-01 ,1.463433e-01 ,1.471078e-01 ,1.478364e-01 ,&
8528         & 1.485270e-01 ,1.491774e-01 ,1.497857e-01 ,1.503497e-01 ,1.508674e-01 ,&
8529         & 1.513367e-01 ,1.517554e-01 ,1.521216e-01 ,1.524332e-01 ,1.526880e-01 ,&
8530         & 1.528840e-01  /)
8531       fdlice3(:, 24) = (/ &
8532 ! band 24
8533         & 1.160842e-01 ,1.169118e-01 ,1.177697e-01 ,1.186556e-01 ,1.195676e-01 ,&
8534         & 1.205036e-01 ,1.214616e-01 ,1.224394e-01 ,1.234349e-01 ,1.244463e-01 ,&
8535         & 1.254712e-01 ,1.265078e-01 ,1.275539e-01 ,1.286075e-01 ,1.296664e-01 ,&
8536         & 1.307287e-01 ,1.317923e-01 ,1.328550e-01 ,1.339149e-01 ,1.349699e-01 ,&
8537         & 1.360179e-01 ,1.370567e-01 ,1.380845e-01 ,1.390991e-01 ,1.400984e-01 ,&
8538         & 1.410803e-01 ,1.420429e-01 ,1.429840e-01 ,1.439016e-01 ,1.447936e-01 ,&
8539         & 1.456579e-01 ,1.464925e-01 ,1.472953e-01 ,1.480642e-01 ,1.487972e-01 ,&
8540         & 1.494923e-01 ,1.501472e-01 ,1.507601e-01 ,1.513287e-01 ,1.518511e-01 ,&
8541         & 1.523252e-01 ,1.527489e-01 ,1.531201e-01 ,1.534368e-01 ,1.536969e-01 ,&
8542         & 1.538984e-01  /)
8543       fdlice3(:, 25) = (/ &
8544 ! band 25
8545         & 1.168725e-01 ,1.177088e-01 ,1.185747e-01 ,1.194680e-01 ,1.203867e-01 ,&
8546         & 1.213288e-01 ,1.222923e-01 ,1.232750e-01 ,1.242750e-01 ,1.252903e-01 ,&
8547         & 1.263187e-01 ,1.273583e-01 ,1.284069e-01 ,1.294626e-01 ,1.305233e-01 ,&
8548         & 1.315870e-01 ,1.326517e-01 ,1.337152e-01 ,1.347756e-01 ,1.358308e-01 ,&
8549         & 1.368788e-01 ,1.379175e-01 ,1.389449e-01 ,1.399590e-01 ,1.409577e-01 ,&
8550         & 1.419389e-01 ,1.429007e-01 ,1.438410e-01 ,1.447577e-01 ,1.456488e-01 ,&
8551         & 1.465123e-01 ,1.473461e-01 ,1.481483e-01 ,1.489166e-01 ,1.496492e-01 ,&
8552         & 1.503439e-01 ,1.509988e-01 ,1.516118e-01 ,1.521808e-01 ,1.527038e-01 ,&
8553         & 1.531788e-01 ,1.536037e-01 ,1.539764e-01 ,1.542951e-01 ,1.545575e-01 ,&
8554         & 1.547617e-01  /)
8555       fdlice3(:, 26) = (/ &
8556 !band 26
8557         & 1.180509e-01 ,1.189025e-01 ,1.197820e-01 ,1.206875e-01 ,1.216171e-01 ,&
8558         & 1.225687e-01 ,1.235404e-01 ,1.245303e-01 ,1.255363e-01 ,1.265564e-01 ,&
8559         & 1.275888e-01 ,1.286313e-01 ,1.296821e-01 ,1.307392e-01 ,1.318006e-01 ,&
8560         & 1.328643e-01 ,1.339284e-01 ,1.349908e-01 ,1.360497e-01 ,1.371029e-01 ,&
8561         & 1.381486e-01 ,1.391848e-01 ,1.402095e-01 ,1.412208e-01 ,1.422165e-01 ,&
8562         & 1.431949e-01 ,1.441539e-01 ,1.450915e-01 ,1.460058e-01 ,1.468947e-01 ,&
8563         & 1.477564e-01 ,1.485888e-01 ,1.493900e-01 ,1.501580e-01 ,1.508907e-01 ,&
8564         & 1.515864e-01 ,1.522428e-01 ,1.528582e-01 ,1.534305e-01 ,1.539578e-01 ,&
8565         & 1.544380e-01 ,1.548692e-01 ,1.552494e-01 ,1.555767e-01 ,1.558490e-01 ,&
8566         & 1.560645e-01  /)
8567       fdlice3(:, 27) = (/ &
8568 ! band 27
8569         & 1.200480e-01 ,1.209267e-01 ,1.218304e-01 ,1.227575e-01 ,1.237059e-01 ,&
8570         & 1.246739e-01 ,1.256595e-01 ,1.266610e-01 ,1.276765e-01 ,1.287041e-01 ,&
8571         & 1.297420e-01 ,1.307883e-01 ,1.318412e-01 ,1.328988e-01 ,1.339593e-01 ,&
8572         & 1.350207e-01 ,1.360813e-01 ,1.371393e-01 ,1.381926e-01 ,1.392396e-01 ,&
8573         & 1.402783e-01 ,1.413069e-01 ,1.423235e-01 ,1.433263e-01 ,1.443134e-01 ,&
8574         & 1.452830e-01 ,1.462332e-01 ,1.471622e-01 ,1.480681e-01 ,1.489490e-01 ,&
8575         & 1.498032e-01 ,1.506286e-01 ,1.514236e-01 ,1.521863e-01 ,1.529147e-01 ,&
8576         & 1.536070e-01 ,1.542614e-01 ,1.548761e-01 ,1.554491e-01 ,1.559787e-01 ,&
8577         & 1.564629e-01 ,1.568999e-01 ,1.572879e-01 ,1.576249e-01 ,1.579093e-01 ,&
8578         & 1.581390e-01  /)
8579       fdlice3(:, 28) = (/ &
8580 ! band 28
8581         & 1.247813e-01 ,1.256496e-01 ,1.265417e-01 ,1.274560e-01 ,1.283905e-01 ,&
8582         & 1.293436e-01 ,1.303135e-01 ,1.312983e-01 ,1.322964e-01 ,1.333060e-01 ,&
8583         & 1.343252e-01 ,1.353523e-01 ,1.363855e-01 ,1.374231e-01 ,1.384632e-01 ,&
8584         & 1.395042e-01 ,1.405441e-01 ,1.415813e-01 ,1.426140e-01 ,1.436404e-01 ,&
8585         & 1.446587e-01 ,1.456672e-01 ,1.466640e-01 ,1.476475e-01 ,1.486157e-01 ,&
8586         & 1.495671e-01 ,1.504997e-01 ,1.514117e-01 ,1.523016e-01 ,1.531673e-01 ,&
8587         & 1.540073e-01 ,1.548197e-01 ,1.556026e-01 ,1.563545e-01 ,1.570734e-01 ,&
8588         & 1.577576e-01 ,1.584054e-01 ,1.590149e-01 ,1.595843e-01 ,1.601120e-01 ,&
8589         & 1.605962e-01 ,1.610349e-01 ,1.614266e-01 ,1.617693e-01 ,1.620614e-01 ,&
8590         & 1.623011e-01  /)
8591       fdlice3(:, 29) = (/ &
8592 ! band 29
8593         & 1.006055e-01 ,9.549582e-02 ,9.063960e-02 ,8.602900e-02 ,8.165612e-02 ,&
8594         & 7.751308e-02 ,7.359199e-02 ,6.988496e-02 ,6.638412e-02 ,6.308156e-02 ,&
8595         & 5.996942e-02 ,5.703979e-02 ,5.428481e-02 ,5.169657e-02 ,4.926719e-02 ,&
8596         & 4.698880e-02 ,4.485349e-02 ,4.285339e-02 ,4.098061e-02 ,3.922727e-02 ,&
8597         & 3.758547e-02 ,3.604733e-02 ,3.460497e-02 ,3.325051e-02 ,3.197604e-02 ,&
8598         & 3.077369e-02 ,2.963558e-02 ,2.855381e-02 ,2.752050e-02 ,2.652776e-02 ,&
8599         & 2.556772e-02 ,2.463247e-02 ,2.371415e-02 ,2.280485e-02 ,2.189670e-02 ,&
8600         & 2.098180e-02 ,2.005228e-02 ,1.910024e-02 ,1.811781e-02 ,1.709709e-02 ,&
8601         & 1.603020e-02 ,1.490925e-02 ,1.372635e-02 ,1.247363e-02 ,1.114319e-02 ,&
8602         & 9.727157e-03  /)
8603
8604       end subroutine swcldpr
8605
8606       end module rrtmg_sw_init_f
8607
8608       module rrtmg_sw_spcvmc_f
8609
8610 ! ------- Modules -------
8611
8612       use parrrsw_f, only : nbndsw, ngptsw, mxmol, jpband, mxlay
8613       use rrsw_tbl_f, only : tblint, bpade, od_lo, exp_tbl
8614       use rrsw_vsn_f, only : hvrspc, hnamspc
8615       use rrsw_wvn_f, only : ngc, ngs, ngb
8616
8617       use rrtmg_sw_taumol_f, only: taumol_sw
8618
8619       implicit none
8620
8621       contains
8622
8623 ! ---------------------------------------------------------------------------
8624       subroutine spcvmc_sw &
8625             (cc,tncol, ncol, nlayers, istart, iend, icpr, idelm, iout, &
8626              pavel, tavel, pz, tz, tbound, palbd, palbp, &
8627              pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
8628              ptaua, pasya, pomga, prmu0, coldry,  adjflux, &
8629              laytrop, layswtch, laylow, jp, jt, jt1, &
8630              co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
8631              fac00, fac01, fac10, fac11, &
8632              selffac, selffrac, indself, forfac, forfrac, indfor, &
8633              pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
8634              pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir, &
8635              zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt, &
8636              ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen)
8637 ! ---------------------------------------------------------------------------
8638 !
8639 ! Purpose: Contains spectral loop to compute the shortwave radiative fluxes,
8640 !          using the two-stream method of H. Barker and McICA, the Monte-Carlo
8641 !          Independent Column Approximation, for the representation of
8642 !          sub-grid cloud variability (i.e. cloud overlap).
8643 !
8644 ! Interface:  *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
8645 !
8646 ! Method:
8647 !    Adapted from two-stream model of H. Barker;
8648 !    Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
8649 !        1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
8650 !
8651 ! Modifications:
8652 !
8653 ! Original: H. Barker
8654 ! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003
8655 ! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003
8656 ! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003
8657 ! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004
8658 ! Revision: Code modified so that delta scaling is not done in cloudy profiles
8659 !           if routine cldprop is used; delta scaling can be applied by swithcing
8660 !           code below if cldprop is not used to get cloud properties.
8661 !           AER, Jan 2005
8662 ! Revision: Modified to use McICA: MJIacono, AER, Nov 2005
8663 ! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006
8664 ! Revision: Use exponential lookup table for transmittance: MJIacono, AER,
8665 !           Aug 2007
8666 !
8667 ! ------------------------------------------------------------------
8668
8669 ! ------- Declarations ------
8670
8671 ! ------- Input -------
8672
8673       integer , intent(in) :: tncol, ncol,cc
8674       integer , intent(in) :: nlayers
8675       integer , intent(in) :: istart
8676       integer , intent(in) :: iend
8677       integer , intent(in) :: icpr
8678       integer , intent(in) :: idelm   ! delta-m scaling flag
8679                                               ! [0 = direct and diffuse fluxes are unscaled]
8680                                               ! [1 = direct and diffuse fluxes are scaled]
8681       integer , intent(in) :: iout
8682       integer , intent(in) :: laytrop(:)
8683       integer , intent(in) :: layswtch(:)
8684       integer , intent(in) :: laylow(:)
8685
8686       integer , intent(in) :: indfor(:,:)
8687       integer , intent(in) :: indself(:,:)
8688       integer , intent(in) :: jp(:,:)
8689       integer , intent(in) :: jt(:,:)
8690       integer , intent(in) :: jt1(:,:)
8691                                                           !   Dimensions: (ncol,nlayers)
8692
8693       real , intent(in) :: pavel(:,:)                     ! layer pressure (hPa, mb)
8694                                                           !   Dimensions: (ncol,nlayers)
8695       real , intent(in) :: tavel(:,:)                     ! layer temperature (K)
8696                                                           !   Dimensions: (ncol,nlayers)
8697       real , intent(in) :: pz(:,0:)                       ! level (interface) pressure (hPa, mb)
8698                                                           !   Dimensions: (ncol,0:nlayers)
8699       real , intent(in) :: tz(:,0:)                       ! level temperatures (hPa, mb)
8700                                                           !   Dimensions: (ncol,0:nlayers)
8701       real , intent(in) :: tbound(:)                      ! surface temperature (K)
8702                                                           !   Dimensions: (ncol)
8703       real , intent(in) :: coldry(:,:)                    ! dry air column density (mol/cm2)
8704                                                           !   Dimensions: (ncol,nlayers)
8705       real , intent(in) :: colmol(:,:)
8706                                                           !   Dimensions: (ncol,nlayers)
8707       real , intent(in) :: adjflux(:)                     ! Earth/Sun distance adjustment
8708                                                           !   Dimensions: (jpband)
8709
8710       real , intent(in) :: palbd(:,:)                     ! surface albedo (diffuse)
8711                                                           !   Dimensions: (ncol,nbndsw)
8712       real , intent(in) :: palbp(:,:)                     ! surface albedo (direct)
8713                                                           !   Dimensions: (ncol,nbndsw)
8714       real , intent(in) :: prmu0(:)                       ! cosine of solar zenith angle
8715                                                           !   Dimensions: (ncol)
8716
8717       real , intent(in) :: pcldfmc(:,:,:)                 ! cloud fraction [mcica]
8718       real , intent(in) :: ptaucmc(:,:,:)                 ! cloud optical depth [mcica]
8719       real , intent(in) :: pasycmc(:,:,:)                 ! cloud asymmetry parameter [mcica]
8720       real , intent(in) :: pomgcmc(:,:,:)                 ! cloud single scattering albedo [mcica]
8721       real , intent(in) :: ptaormc(:,:,:)                 ! cloud optical depth, non-delta scaled [mcica]
8722                                                           !   Dimensions: (ncol,nlayers,ngptsw)
8723
8724       real , intent(in) :: ptaua(:,:,:)                   ! aerosol optical depth
8725       real , intent(in) :: pasya(:,:,:)                   ! aerosol asymmetry parameter
8726       real , intent(in) :: pomga(:,:,:)                   ! aerosol single scattering albedo
8727                                                           !   Dimensions: (ncol,nlayers,nbndsw)
8728
8729       real , intent(in) :: colh2o(:,:)
8730       real , intent(in) :: colco2(:,:)
8731       real , intent(in) :: colch4(:,:)
8732       real , intent(in) :: co2mult(:,:)
8733       real , intent(in) :: colo3(:,:)
8734       real , intent(in) :: colo2(:,:)
8735       real , intent(in) :: coln2o(:,:)
8736                                                           !   Dimensions: (ncol,nlayers)
8737
8738       real , intent(in) :: forfac(:,:)
8739       real , intent(in) :: forfrac(:,:)
8740       real , intent(in) :: selffac(:,:)
8741       real , intent(in) :: selffrac(:,:)
8742       real , intent(in) :: fac00(:,:)
8743       real , intent(in) :: fac01(:,:)
8744       real , intent(in) :: fac10(:,:)
8745       real , intent(in) :: fac11(:,:)
8746                                                           !   Dimensions: (ncol,nlayers)
8747
8748       real, intent(inout) gpu_device  :: zgco(tncol,ngptsw,nlayers+1), zomco(tncol,ngptsw,nlayers+1)
8749       real, intent(inout) gpu_device  :: zrdnd(tncol,ngptsw,nlayers+1)
8750       real, intent(inout) gpu_device  :: zref(tncol,ngptsw,nlayers+1)  , zrefo(tncol,ngptsw,nlayers+1)
8751       real, intent(inout) gpu_device  :: zrefd(tncol,ngptsw,nlayers+1)  , zrefdo(tncol,ngptsw,nlayers+1)
8752       real, intent(inout) gpu_device  :: ztauo(tncol,ngptsw,nlayers)
8753       real, intent(inout) gpu_device  :: zdbt(tncol,ngptsw,nlayers+1)  ,ztdbt(tncol,ngptsw,nlayers+1)
8754       real, intent(inout) gpu_device  :: ztra(tncol,ngptsw,nlayers+1)  , ztrao(tncol,ngptsw,nlayers+1)
8755       real, intent(inout) gpu_device  :: ztrad(tncol,ngptsw,nlayers+1)  , ztrado(tncol,ngptsw,nlayers+1)
8756       real, intent(inout) gpu_device  :: zfd(tncol,ngptsw,nlayers+1)  , zfu(tncol,ngptsw,nlayers+1)
8757 real gpu_device  :: zcd(tncol,ngptsw,nlayers+1)  , zcu(tncol,ngptsw,nlayers+1)
8758       real, intent(inout) gpu_device :: ztaur(tncol,nlayers,ngptsw), ztaug(tncol,nlayers,ngptsw)
8759       real, intent(inout) gpu_device :: zsflxzen(tncol,ngptsw)
8760
8761
8762 ! ------- Output -------
8763                                                                !   All Dimensions: (ncol,nlayers+1)
8764       real , intent(out) :: pbbcd(:,:)
8765       real , intent(out) :: pbbcu(:,:)
8766       real , intent(out) :: pbbfd(:,:)
8767       real , intent(out) :: pbbfu(:,:)
8768       real , intent(out) :: pbbfddir(:,:)
8769       real , intent(out) :: pbbcddir(:,:)
8770
8771       real , intent(out) :: puvcd(:,:)
8772       real , intent(out) :: puvfd(:,:)
8773       real , intent(out) :: puvcddir(:,:)
8774       real , intent(out) :: puvfddir(:,:)
8775
8776       real , intent(out) :: pnicd(:,:)
8777       real , intent(out) :: pnifd(:,:)
8778       real , intent(out) :: pnicddir(:,:)
8779       real , intent(out) :: pnifddir(:,:)
8780
8781 ! ------- Local -------
8782
8783       integer   :: klev
8784       integer  :: ibm, ikl, ikp, ikx
8785       integer  :: iw, jb, jg, jl, jk
8786
8787       integer  :: itind
8788
8789       real  :: tblind, ze1
8790       real  :: zclear, zcloud
8791
8792       real  :: zincflx, ze2
8793
8794       real  :: zdbtmc, zdbtmo, zf, zgw, zreflect
8795       real  :: zwf, tauorig, repclc
8796
8797       real :: zdbt_nodel(tncol,ngptsw,nlayers+1)
8798       real :: zdbtc_nodel(tncol,ngptsw,nlayers+1)
8799       real :: ztdbt_nodel(tncol,ngptsw,nlayers+1)
8800       real :: ztdbtc_nodel(tncol,ngptsw,nlayers+1)
8801
8802
8803 ! Arrays from rrtmg_sw_vrtqdr routine
8804
8805       integer :: iplon
8806
8807 ! ------------------------------------------------------------------
8808
8809 !$acc update host(pomga, ptaua)
8810
8811 !print *, "aerosol values"
8812 !print *, pomga(1, :, :)
8813 !print *, ptaua(1, :, :)
8814
8815 !$acc kernels
8816          pbbcd =0.
8817          pbbcu =0.
8818          pbbfd =0.
8819          pbbfu =0.
8820          pbbcddir =0.
8821          pbbfddir =0.
8822          puvcd =0.
8823          puvfd =0.
8824          puvcddir =0.
8825          puvfddir =0.
8826          pnicd =0.
8827          pnifd =0.
8828          pnicddir =0.
8829          pnifddir =0.
8830          zsflxzen = 0.
8831 !         znirr=0.
8832 !         znirf=0.
8833 !         zparr=0.
8834 !         zparf=0.
8835 !         zuvrr=0.
8836 !         zuvrf=0.
8837          klev = nlayers
8838 !$acc end kernels
8839
8840 #ifndef _ACCEL
8841 #  define ncol CHNK
8842 #endif
8843
8844
8845 ! Calculate the optical depths for gaseous absorption and Rayleigh scattering
8846       call taumol_sw(ncol,nlayers, &
8847                      colh2o , colco2 , colch4 , colo2 , &
8848                      colo3 , colmol , &
8849                      laytrop , jp , jt , jt1 , &
8850                      fac00 , fac01 , fac10 , fac11 , &
8851                      selffac , selffrac , indself , forfac , forfrac ,&
8852                      indfor , &
8853                      zsflxzen , ztaug, ztaur)
8854
8855
8856       repclc = 1.e-12
8857
8858 #ifdef _ACCEL
8859 # define ILOOP_S_CPU
8860 # define ILOOP_E_CPU
8861 # define ILOOP_S_GPU do iplon = 1, ncol
8862 # define ILOOP_E_GPU enddo
8863 # define WLOOP_S_CPU
8864 # define WLOOP_E_CPU
8865 # define WLOOP_S_GPU do iw = 1, 112
8866 # define WLOOP_E_GPU enddo
8867 #else
8868 # define ILOOP_S_GPU
8869 # define ILOOP_E_GPU
8870 # define ILOOP_S_CPU do iplon = 1, ncol
8871 # define ILOOP_E_CPU enddo
8872 # define WLOOP_S_GPU
8873 # define WLOOP_E_GPU
8874 # define WLOOP_S_CPU do iw = 1, 112
8875 # define WLOOP_E_CPU enddo
8876 #endif
8877
8878
8879 !$acc kernels
8880
8881       ILOOP_S_GPU
8882       WLOOP_S_CPU
8883
8884         WLOOP_S_GPU
8885         ILOOP_S_CPU
8886
8887 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
8888
8889           jb = ngb(iw)
8890           ibm = jb-15
8891
8892 ! Clear-sky
8893 !   TOA direct beam
8894
8895           ztdbtc_nodel(iplon,iw,1)=1.0  !jm
8896
8897 ! Cloudy-sky
8898 !   Surface values
8899           ztrao(iplon,iw,klev+1)   =0.0
8900           ztrado(iplon,iw,klev+1)  =0.0
8901           zrefo(iplon,iw,klev+1)   =palbp(iplon,ibm)
8902           zrefdo(iplon,iw,klev+1)  =palbd(iplon,ibm)
8903
8904 ! Total sky
8905 !   TOA direct beam
8906           ztdbt(iplon,iw,1)  =1.0
8907           ztdbt_nodel(iplon,iw,1)=1.0
8908
8909
8910 !   Surface values
8911           zdbt(iplon,iw,klev+1)   =0.0
8912           ztra(iplon,iw,klev+1)   =0.0
8913           ztrad(iplon,iw,klev+1)  =0.0
8914           zref(iplon,iw,klev+1)   =palbp(iplon,ibm)
8915           zrefd(iplon,iw,klev+1)  =palbd(iplon,ibm)
8916
8917         enddo
8918       enddo
8919
8920 !$acc end kernels
8921
8922
8923 !$acc kernels loop
8924
8925        ILOOP_S_GPU
8926 !$acc loop private(zf, zwf, ibm, ikl, jb)
8927          WLOOP_S_GPU
8928             !$acc loop seq
8929             do jk=1,klev
8930
8931                ikl=klev+1-jk
8932        WLOOP_S_CPU
8933                jb = ngb(iw)
8934                ibm = jb-15
8935          ILOOP_S_CPU
8936                ! Clear-sky optical parameters including aerosols
8937                ztauo(iplon,iw,jk)   = ztaur(iplon,ikl,iw)  + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm)
8938
8939 #ifndef _ACCEL
8940 ! Use exponential lookup table for transmittance, or expansion of
8941 ! exponential for low tau
8942                zclear = 1.0  - pcldfmc(iplon,ikl,iw)
8943                zcloud =  pcldfmc(iplon,ikl,iw)
8944
8945                ze1 = ztauo(iplon,iw,jk) / prmu0(iplon)  ! ztauo corresponds to ztauc at this point in _sw.F version
8946                if (ze1 .le. od_lo) then
8947                   zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
8948                else
8949                   tblind = ze1 / (bpade + ze1)
8950                   itind = tblint * tblind + 0.5
8951                   zdbtmc = exp_tbl(itind)
8952                endif
8953
8954                zdbtc_nodel(iplon,iw,jk) = zdbtmc
8955                ztdbtc_nodel(iplon,iw,jk+1) = zdbtc_nodel(iplon,iw,jk) * ztdbtc_nodel(iplon,iw,jk)
8956
8957                tauorig = ztauo(iplon,iw,jk) + ptaormc(iplon,ikl,iw)    ! ztauo corresponds to ztauc at this point in _sw.F version
8958                ze1 = tauorig / prmu0(iplon)
8959                if (ze1 .le. od_lo) then
8960                   zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1
8961                else
8962                   tblind = ze1 / (bpade + ze1)
8963                   itind = tblint * tblind + 0.5
8964                   zdbtmo = exp_tbl(itind)
8965                endif
8966
8967                zdbt_nodel(iplon,iw,jk) = zclear*zdbtmc + zcloud*zdbtmo
8968                ztdbt_nodel(iplon,iw,jk+1) = zdbt_nodel(iplon,iw,jk) * ztdbt_nodel(iplon,iw,jk)
8969
8970 #endif
8971
8972                zomco(iplon,iw,jk)   = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm)
8973                zgco(iplon,iw,jk) = pasya(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) * ptaua(iplon,ikl,ibm) / zomco(iplon,iw,jk)
8974                zomco(iplon,iw,jk)   = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk)
8975
8976                zf = zgco(iplon, iw, jk)
8977                zf = zf * zf
8978                zwf = zomco(iplon, iw, jk) * zf
8979
8980                ztauo(iplon, iw, jk) = (1.0 - zwf) * ztauo(iplon, iw, jk)
8981                zomco(iplon, iw, jk) = (zomco(iplon, iw, jk) - zwf) / (1.0 - zwf)
8982                zgco(iplon, iw, jk) = (zgco(iplon, iw, jk) - zf) / (1.0 - zf)
8983
8984            end do
8985         end do
8986       end do
8987 !$acc end kernels
8988
8989
8990 ! Clear sky reflectivities
8991       call reftra_sw (ncol, nlayers, &
8992                       pcldfmc, zgco, prmu0, ztauo, zomco, &
8993                       zrefo, zrefdo, ztrao, ztrado, 1)
8994
8995
8996 !$acc kernels loop
8997        ILOOP_S_GPU
8998
8999 ! Combine clear and cloudy reflectivies and optical depths
9000
9001 !$acc loop
9002        WLOOP_S_GPU
9003
9004 !$acc loop seq
9005             do jk=1,klev
9006
9007        WLOOP_S_CPU
9008        ILOOP_S_CPU
9009 ! Combine clear and cloudy contributions for total sky
9010                !ikl = klev+1-jk
9011
9012 ! Direct beam transmittance
9013
9014                ze1 = (ztauo(iplon,iw,jk))  / prmu0(iplon)
9015 #ifdef _ACCEL
9016                zdbtmc = exp(-ze1)
9017 #else
9018                ze1 = ztauo(iplon,iw,jk) / prmu0(iplon)
9019                if (ze1 .le. od_lo) then
9020                   zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
9021                else
9022                   tblind = ze1 / (bpade + ze1)
9023                   itind = tblint * tblind + 0.5
9024                   zdbtmc = exp_tbl(itind)
9025                endif
9026 #endif
9027                zdbt(iplon,iw,jk)   = zdbtmc
9028                ztdbt(iplon,iw,jk+1)   = zdbt(iplon,iw,jk)  *ztdbt(iplon,iw,jk)
9029
9030            end do
9031         end do
9032       end do
9033 !$acc end kernels
9034
9035 ! compute the fluxes from the optical depths and reflectivities
9036
9037
9038 ! Vertical quadrature for clear-sky fluxes
9039
9040 !$acc kernels
9041        ILOOP_S_GPU
9042         WLOOP_S_GPU
9043        WLOOP_S_CPU
9044           jb = ngb(iw)
9045           ibm = jb-15
9046         ILOOP_S_CPU
9047
9048 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
9049
9050
9051           zgco(iplon,iw,klev+1)   =palbp(iplon,ibm)
9052           zomco(iplon,iw,klev+1)  =palbd(iplon,ibm)
9053
9054         end do
9055       end do
9056 !$acc end kernels
9057
9058
9059             call vrtqdr_sw(ncol, klev, &
9060                            zrefo  , zrefdo  , ztrao  , ztrado  , &
9061                            zdbt , zrdnd  , zgco, zomco, ztdbt  , &
9062                            zcd , zcu  , ztra)
9063
9064 ! perform band integration for clear cases
9065 !$acc kernels loop
9066        ILOOP_S_GPU
9067
9068 !$acc loop
9069         do ikl=1,klev+1
9070
9071       !$acc loop seq
9072           do iw = 1, 112
9073              jb = ngb(iw)
9074
9075              jk=klev+2-ikl
9076              ibm = jb-15
9077 !DIR$ SIMD
9078           ILOOP_S_CPU
9079              zincflx = adjflux(jb)  * zsflxzen(iplon,iw)   * prmu0(iplon)
9080
9081 ! Accumulate spectral fluxes over whole spectrum
9082
9083              pbbcu(iplon,ikl)  = pbbcu(iplon,ikl)  + zincflx*zcu(iplon,iw,jk)
9084              pbbcd(iplon,ikl)  = pbbcd(iplon,ikl)  + zincflx*zcd(iplon,iw,jk)
9085              pbbcddir(iplon,ikl)  = pbbcddir(iplon,ikl)  + zincflx*ztdbtc_nodel(iplon,iw,jk)
9086
9087
9088 ! Accumulate direct fluxes for UV/visible bands
9089              if (ibm >= 10 .and. ibm <= 13) then
9090                 puvcd(iplon,ikl)  = puvcd(iplon,ikl)  + zincflx*zcd(iplon,iw,jk)
9091                 puvcddir(iplon,ikl)  = puvcddir(iplon,ikl)  + zincflx*ztdbtc_nodel(iplon,iw,jk)
9092
9093 ! Accumulate direct fluxes for near-IR bands
9094              else if (ibm == 14 .or. ibm <= 9) then
9095                 pnicd(iplon,ikl)  = pnicd(iplon,ikl)  + zincflx*zcd(iplon,iw,jk)
9096                 pnicddir(iplon,ikl)  = pnicddir(iplon,ikl)  + zincflx*ztdbtc_nodel(iplon,iw,jk)
9097
9098              endif
9099
9100           enddo
9101
9102 ! End loop on jb, spectral band
9103         enddo
9104
9105 ! End of longitude loop
9106       enddo
9107 !$acc end kernels
9108
9109
9110
9111       if (cc==2) then
9112
9113 !$acc kernels
9114         ILOOP_S_GPU
9115           WLOOP_S_GPU
9116             do jk=1,klev
9117
9118                ikl=klev+1-jk
9119           WLOOP_S_CPU
9120                jb = ngb(iw)
9121                ibm = jb-15
9122 !DIR$ SIMD
9123            ILOOP_S_CPU
9124                ! since the cloudy cases are now computed in a separate partition from the clear cases, we must
9125                ! recompute the needed clear sky prerequisites.
9126                ze1 = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon, ikl, ibm)
9127                ze2 = pasya(iplon, ikl, ibm) * pomga(iplon, ikl, ibm) * ptaua(iplon, ikl, ibm) / ze1
9128                ze1 = ze1/ (ztaur(iplon,ikl,iw)  + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm)  )
9129
9130                ! compute delta scaled coefficients
9131                zf = ze2*ze2
9132                zwf = ze1*zf
9133                ze1 = (ze1 - zwf) / (1.0 - zwf)
9134                ze2 = (ze2 - zf) / (1.0 - zf)
9135
9136                ! direct calculation of delta scaled values
9137                zomco(iplon,iw,jk)   = (ztauo(iplon,iw,jk) * ze1  + ptaucmc(iplon,ikl,iw)  * pomgcmc(iplon,ikl,iw))
9138
9139                zgco(iplon, iw, jk) =  (ptaucmc(iplon,ikl,iw)  * pomgcmc(iplon,ikl,iw)  * pasycmc(iplon,ikl,iw) ) + &
9140                                       (ztauo(iplon, iw, jk) * ze1 * ze2)
9141
9142                ztauo(iplon,iw,jk)   = ztauo(iplon,iw,jk) + ptaucmc(iplon,ikl,iw)
9143
9144                zgco(iplon,iw,jk)   = zgco(iplon, iw, jk) / zomco(iplon, iw, jk)
9145                zomco(iplon,iw,jk)  = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk)
9146
9147             end do
9148           end do
9149         end do
9150 !$acc end kernels
9151
9152
9153 ! Total sky reflectivities
9154         call reftra_sw (ncol, nlayers, &
9155                         pcldfmc, zgco, prmu0, ztauo, zomco, &
9156                         zref, zrefd, ztra, ztrad, 0)
9157
9158
9159         klev = nlayers
9160
9161
9162 !$acc kernels loop
9163         ILOOP_S_GPU
9164
9165 !$acc loop
9166           WLOOP_S_GPU
9167
9168 !$acc loop seq
9169             do jk=1,klev
9170
9171 ! Combine clear and cloudy contributions for total sky
9172                ikl = klev+1-jk
9173           WLOOP_S_CPU
9174             ILOOP_S_CPU
9175                zclear = 1.0  - pcldfmc(iplon,ikl,iw)
9176                zcloud = pcldfmc(iplon,ikl,iw)
9177
9178                zref(iplon,iw,jk)   = zclear*zrefo(iplon,iw,jk)   + zcloud*zref(iplon,iw,jk)
9179                zrefd(iplon,iw,jk)  = zclear*zrefdo(iplon,iw,jk)   + zcloud*zrefd(iplon,iw,jk)
9180                ztra(iplon,iw,jk)   = zclear*ztrao(iplon,iw,jk)   + zcloud*ztra(iplon,iw,jk)
9181                ztrad(iplon,iw,jk)  = zclear*ztrado(iplon,iw,jk)   + zcloud*ztrad(iplon,iw,jk)
9182
9183 ! Clear + Cloud
9184
9185                ze1 = ztauo(iplon,iw,jk )   / prmu0(iplon)
9186 #ifdef _ACCEL
9187                zdbtmo = exp(-ze1)
9188 #else
9189               if (ze1 .le. od_lo) then
9190                   zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1
9191                else
9192                   tblind = ze1 / (bpade + ze1)
9193                   itind = tblint * tblind + 0.5
9194                   zdbtmo = exp_tbl(itind)
9195                endif
9196 #endif
9197                ze1 = (ztauo(iplon,iw,jk) - ptaucmc(iplon,ikl,iw))  / prmu0(iplon)
9198 #ifdef _ACCEL
9199                zdbtmc = exp(-ze1)
9200 #else
9201                if (ze1 .le. od_lo) then
9202                   zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
9203                else
9204                   tblind = ze1 / (bpade + ze1)
9205                   itind = tblint * tblind + 0.5
9206                   zdbtmc = exp_tbl(itind)
9207                endif
9208 #endif
9209
9210                zdbt(iplon,iw,jk)   = zclear*zdbtmc + zcloud*zdbtmo
9211                ztdbt(iplon,iw,jk+1)   = zdbt(iplon,iw,jk)  *ztdbt(iplon,iw,jk)
9212
9213             enddo
9214           end do
9215         end do
9216 !$acc end kernels
9217
9218 !$acc kernels
9219         zrdnd = 0.0
9220         zgco = 0.0
9221         zomco = 0.0
9222         zfd = 0.0
9223         zfu = 0.0
9224 !$acc end kernels
9225
9226
9227 !$acc kernels
9228         ILOOP_S_GPU
9229           WLOOP_S_GPU
9230
9231 ! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
9232
9233         WLOOP_S_CPU
9234             jb = ngb(iw)
9235             ibm = jb-15
9236           ILOOP_S_CPU
9237
9238             zgco(iplon,iw,klev+1)   =palbp(iplon,ibm)
9239             zomco(iplon,iw,klev+1)  =palbd(iplon,ibm)
9240
9241           end do
9242         end do
9243 !$acc end kernels
9244
9245
9246 ! Vertical quadrature for cloudy fluxes
9247
9248
9249         call vrtqdr_sw(ncol, klev, &
9250                        zref  , zrefd  , ztra  , ztrad , &
9251                        zdbt , zrdnd  , zgco, zomco , ztdbt  , &
9252                        zfd , zfu  ,  ztrao)
9253
9254 ! Upwelling and downwelling fluxes at levels
9255 !   Two-stream calculations go from top to bottom;
9256 !   layer indexing is reversed to go bottom to top for output arrays
9257
9258         klev = nlayers
9259         repclc = 1.e-12
9260
9261 !$acc kernels loop
9262         ILOOP_S_GPU
9263
9264 !$acc loop
9265           do ikl=1,klev+1
9266 !$acc loop seq
9267           WLOOP_S_GPU
9268           WLOOP_S_CPU
9269                jb = ngb(iw)
9270                jk=klev+2-ikl
9271                ibm = jb-15
9272             ILOOP_S_CPU
9273                zincflx = adjflux(jb)  * zsflxzen(iplon,iw)   * prmu0(iplon)
9274
9275 ! Accumulate spectral fluxes over whole spectrum
9276                pbbfu(iplon,ikl)  = pbbfu(iplon,ikl)  + zincflx*zfu(iplon,iw,jk)
9277                pbbfd(iplon,ikl)  = pbbfd(iplon,ikl)  + zincflx*zfd(iplon,iw,jk)
9278                pbbfddir(iplon,ikl)  = pbbfddir(iplon,ikl)  + zincflx*ztdbt_nodel(iplon,iw,jk)
9279
9280 ! Accumulate direct fluxes for UV/visible bands
9281                if (ibm >= 10 .and. ibm <= 13) then
9282
9283                   puvfd(iplon,ikl)  = puvfd(iplon,ikl)  + zincflx*zfd(iplon,iw,jk)
9284                   puvfddir(iplon,ikl)  = puvfddir(iplon,ikl)  + zincflx*ztdbt_nodel(iplon,iw,jk)
9285
9286
9287 ! Accumulate direct fluxes for near-IR bands
9288                else if (ibm == 14 .or. ibm <= 9) then
9289
9290                   pnifd(iplon,ikl)  = pnifd(iplon,ikl)  + zincflx*zfd(iplon,iw,jk)
9291                   pnifddir(iplon,ikl)  = pnifddir(iplon,ikl)  + zincflx*ztdbt_nodel(iplon,iw,jk)
9292
9293
9294                endif
9295
9296             enddo
9297
9298 ! End loop on jb, spectral band
9299           enddo
9300
9301 ! End of longitude loop
9302         enddo
9303 !$acc end kernels
9304
9305
9306       else      ! cc = 1
9307 !$acc kernels
9308          pbbfd = pbbcd
9309          pbbfu = pbbcu
9310          puvfd = puvcd
9311          puvfddir = puvcddir
9312          pnifd = pnicd
9313          pnifddir = pnicddir
9314 !$acc end kernels
9315       end if    ! if cc=2, else, endif
9316
9317
9318 !$acc kernels
9319       ILOOP_S_GPU
9320          WLOOP_S_GPU
9321       WLOOP_S_CPU
9322             jb = ngb(iw)
9323             ibm = jb - 15
9324          ILOOP_S_CPU
9325             zincflx = adjflux(jb)  * zsflxzen(iplon,iw)   * prmu0(iplon)
9326
9327          end do
9328       end do
9329 !$acc end kernels
9330
9331 !!$acc end data
9332 # undef ILOOP_S_GPU
9333 # undef ILOOP_E_GPU
9334 # undef ILOOP_S_CPU
9335 # undef ILOOP_E_CPU
9336 # undef WLOOP_S_GPU
9337 # undef WLOOP_E_GPU
9338 # undef WLOOP_S_CPU
9339 # undef WLOOP_E_CPU
9340 #ifndef _ACCEL
9341 #  undef ncol
9342 #endif
9343
9344 ! !!!!!!!!!!!!!!!!!!!!!
9345 !  END CLEAR  !!!!!!!!!
9346 ! !!!!!!!!!!!!!!!!!!!!!
9347
9348       end subroutine spcvmc_sw
9349
9350 ! --------------------------------------------------------------------
9351       subroutine reftra_sw(ncol, nlayers, pcldfmc, pgg, prmuzl, ptau, pw, &
9352                            pref, prefd, ptra, ptrad, ac)
9353 ! --------------------------------------------------------------------
9354
9355 ! Purpose: computes the reflectivity and transmissivity of a clear or
9356 !   cloudy layer using a choice of various approximations.
9357 !
9358 ! Interface:  *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
9359 !
9360 ! Description:
9361 ! explicit arguments :
9362 ! --------------------
9363 ! inputs
9364 ! ------
9365 !      lrtchk  = .t. for all layers in clear profile
9366 !      lrtchk  = .t. for cloudy layers in cloud profile
9367 !              = .f. for clear layers in cloud profile
9368 !      pgg     = assymetry factor
9369 !      prmuz   = cosine solar zenith angle
9370 !      ptau    = optical thickness
9371 !      pw      = single scattering albedo
9372 !
9373 ! outputs
9374 ! -------
9375 !      pref    : collimated beam reflectivity
9376 !      prefd   : diffuse beam reflectivity
9377 !      ptra    : collimated beam transmissivity
9378 !      ptrad   : diffuse beam transmissivity
9379 !
9380 !
9381 ! Method:
9382 ! -------
9383 !      standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
9384 !      kmodts  = 1 eddington (joseph et al., 1976)
9385 !              = 2 pifm (zdunkowski et al., 1980)
9386 !              = 3 discrete ordinates (liou, 1973)
9387 !
9388 ! ac = 1 -- clear
9389 ! ac = 0 -- total (clear and cloudy)
9390 !
9391 ! Modifications:
9392 ! --------------
9393 ! Original: J-JMorcrette, ECMWF, Feb 2003
9394 ! Revised for F90 reformatting: MJIacono, AER, Jul 2006
9395 ! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
9396 !
9397 ! ------------------------------------------------------------------
9398
9399 ! ------- Declarations ------
9400
9401 ! ------- Input -------
9402
9403       integer , intent(in) :: nlayers
9404       integer , intent(in) :: ncol
9405
9406       real,  intent(in) :: pcldfmc(:,:,:)                      ! Logical flag for reflectivity and
9407                                                                ! and transmissivity calculation;
9408                                                                !   Dimensions: (ncol,nlayers,ngptsw)
9409
9410       real , intent(in) gpu_device :: pgg(:,:,:)               ! asymmetry parameter
9411       real , intent(in) gpu_device :: ptau(:,:,:)              ! optical depth
9412       real , intent(in) gpu_device :: pw(:,:,:)                ! single scattering albedo
9413                                                                !   Dimensions: (ncol,nlayers,ngptsw)
9414
9415       real ,  intent(in) :: prmuzl(:)                          ! cosine of solar zenith angle
9416                                                                !   Dimensions: (ncol)
9417       integer, intent(in) :: ac
9418
9419 ! ------- Output -------
9420
9421       real , intent(out) gpu_device :: pref(:,:,:)             ! direct beam reflectivity
9422       real , intent(out) gpu_device :: prefd(:,:,:)            ! diffuse beam reflectivity
9423       real , intent(out) gpu_device :: ptra(:,:,:)             ! direct beam transmissivity
9424       real , intent(out) gpu_device :: ptrad(:,:,:)            ! diffuse beam transmissivity
9425                                                                !   Dimensions: (ncol,nlayers,ngptsw)
9426
9427 ! ------- Local -------
9428
9429       integer  :: jk, jl, kmodts
9430       integer  :: itind, iplon, iw
9431
9432       real  :: tblind
9433       real  :: za, za1, za2
9434       real  :: zbeta, zdend, zdenr, zdent
9435       real  :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
9436       real  :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
9437       real  :: zr1, zr2, zr3, zr4, zr5
9438       real  :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
9439       real  :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
9440       real  :: zw, zwcrit, zwo, prmuz
9441       real  :: denom
9442
9443       real , parameter :: eps = 1.e-08
9444
9445 !     ------------------------------------------------------------------
9446
9447 ! Initialize
9448
9449       zsr3=sqrt(3. )
9450       zwcrit=0.9999995
9451       kmodts=2
9452
9453 !$acc kernels loop
9454       do iplon=1,ncol
9455 !$acc loop
9456         do iw=1,112
9457 !$acc loop private(zgamma1, zgamma2, zgamma3, zgamma4)
9458           do jk=1, nlayers
9459              prmuz = prmuzl(iplon)
9460              if ((.not.(pcldfmc(iplon,nlayers+1-jk,iw))  > 1.e-12) .and. ac==0  ) then
9461                pref(iplon,iw,jk)   =0.
9462                ptra(iplon,iw,jk)   =1.
9463                prefd(iplon,iw,jk)  =0.
9464                ptrad(iplon,iw,jk)  =1.
9465              else
9466                zto1=ptau(iplon,iw,jk)
9467                zw  =pw(iplon,iw,jk)
9468                zg  =pgg(iplon,iw,jk)
9469
9470 ! General two-stream expressions
9471
9472                zg3= 3.  * zg
9473
9474                zgamma1= (8.  - zw * (5.  + zg3)) * 0.25
9475                zgamma2=  3.  *(zw * (1.  - zg )) * 0.25
9476                zgamma3= (2.  - zg3 * prmuz ) * 0.25
9477
9478                zgamma4= 1.  - zgamma3
9479
9480 ! Recompute original s.s.a. to test for conservative solution
9481
9482                zwo = 0.
9483                denom = 1.
9484                if (zg .ne. 1.) denom = (1. - (1. - zw) * (zg / (1. - zg))**2)
9485                if (zw .gt. 0. .and. denom .ne. 0.) zwo = zw / denom
9486
9487                if (zwo >= zwcrit) then
9488 ! Conservative scattering
9489
9490                   za  = zgamma1 * prmuz
9491                   za1 = za - zgamma3
9492                   zgt = zgamma1 * zto1
9493
9494 ! Homogeneous reflectance and transmittance,
9495 ! collimated beam
9496
9497                   ze1 = min ( zto1 / prmuz , 500. )
9498
9499
9500                   ze2 = exp(-ze1)
9501                   pref(iplon,iw,jk)   = (zgt - za1 * (1.  - ze2)) / (1.  + zgt)
9502                   ptra(iplon,iw,jk)   = 1.  - pref(iplon,iw,jk)
9503
9504 ! isotropic incidence
9505
9506                   prefd(iplon,iw,jk)   = zgt / (1.  + zgt)
9507                   ptrad(iplon,iw,jk)   = 1.  - prefd(iplon,iw,jk)
9508
9509 ! This is applied for consistency between total (delta-scaled) and direct (unscaled)
9510 ! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup
9511 ! table returns a transmittance of 1.0.
9512                   if (ze2 .eq. 1.0 ) then
9513                      pref(iplon,iw,jk)   = 0.0
9514                      ptra(iplon,iw,jk)   = 1.0
9515                      prefd(iplon,iw,jk)   = 0.0
9516                      ptrad(iplon,iw,jk)   = 1.0
9517                   endif
9518
9519                else
9520 ! Non-conservative scattering
9521
9522                   za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
9523                   za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
9524                   zrk = sqrt ( zgamma1**2 - zgamma2**2)
9525                   zrp = zrk * prmuz
9526                   zrp1 = 1.  + zrp
9527                   zrm1 = 1.  - zrp
9528                   zrk2 = 2.  * zrk
9529                   zrpp = 1.  - zrp*zrp
9530                   zrkg = zrk + zgamma1
9531                   zr1  = zrm1 * (za2 + zrk * zgamma3)
9532                   zr2  = zrp1 * (za2 - zrk * zgamma3)
9533                   zr3  = zrk2 * (zgamma3 - za2 * prmuz )
9534                   zr4  = zrpp * zrkg
9535                   zr5  = zrpp * (zrk - zgamma1)
9536                   zt1  = zrp1 * (za1 + zrk * zgamma4)
9537                   zt2  = zrm1 * (za1 - zrk * zgamma4)
9538                   zt3  = zrk2 * (zgamma4 + za1 * prmuz )
9539                   zt4  = zr4
9540                   zt5  = zr5
9541
9542 ! mji - reformulated code to avoid potential floating point exceptions
9543 !               zbeta = - zr5 / zr4
9544                   zbeta = (zgamma1 - zrk) / zrkg
9545 !!
9546
9547 ! Homogeneous reflectance and transmittance
9548
9549                   ze1 = min ( zrk * zto1, 5. )
9550                   ze2 = min ( zto1 / prmuz , 5. )
9551
9552 ! Use exponential lookup table for transmittance, or expansion of
9553 ! exponential for low tau
9554                   if (ze1 .le. od_lo) then
9555                      zem1 = 1.  - ze1 + 0.5  * ze1 * ze1
9556                      zep1 = 1.  / zem1
9557                   else
9558                      zem1 = exp(-ze1)
9559                      zep1 = 1.  / zem1
9560                   endif
9561                   if (ze2 .le. od_lo) then
9562                      zem2 = 1.  - ze2 + 0.5  * ze2 * ze2
9563                      zep2 = 1.  / zem2
9564                   else
9565                      zem2 = exp(-ze2)
9566                      zep2 = 1.  / zem2
9567                   endif
9568
9569                   zdenr = zr4*zep1 + zr5*zem1
9570                   zdent = zt4*zep1 + zt5*zem1
9571                   if (zdenr .ge. -eps .and. zdenr .le. eps) then
9572                      pref(iplon,iw,jk)   = eps
9573                      ptra(iplon,iw,jk)   = zem2
9574                   else
9575                      pref(iplon,iw,jk)   = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
9576                      ptra(iplon,iw,jk)   = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
9577                   endif
9578
9579 ! diffuse beam
9580
9581                   zemm = zem1*zem1
9582                   zdend = 1.  / ( (1.  - zbeta*zemm ) * zrkg)
9583                   prefd(iplon,iw,jk)   =  zgamma2 * (1.  - zemm) * zdend
9584                   ptrad(iplon,iw,jk)   =  zrk2*zem1*zdend
9585
9586                endif
9587
9588             endif
9589
9590           end do
9591         end do
9592       end do
9593 !$acc end kernels
9594
9595       end subroutine reftra_sw
9596
9597 ! --------------------------------------------------------------------------
9598       subroutine vrtqdr_sw(ncol, klev, &
9599                            pref, prefd, ptra, ptrad, &
9600                            pdbt, prdnd, prup, prupd, ptdbt, &
9601                            pfd, pfu, ztdn)
9602 ! --------------------------------------------------------------------------
9603
9604 ! Purpose: This routine performs the vertical quadrature integration
9605 !
9606 ! Interface:  *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
9607 !
9608 ! Modifications.
9609 !
9610 ! Original: H. Barker
9611 ! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
9612 ! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
9613 !
9614 !-----------------------------------------------------------------------
9615
9616 ! ------- Declarations -------
9617
9618 ! Input
9619
9620       integer , intent (in) :: klev                           ! number of model layers
9621       integer , intent (in) :: ncol
9622
9623
9624 #ifdef _ACCEL
9625       real , intent(in) gpu_device :: pref(:,:,:)             ! direct beam reflectivity
9626       real , intent(in) gpu_device :: prefd(:,:,:)            ! diffuse beam reflectivity
9627       real , intent(in) gpu_device :: ptra(:,:,:)             ! direct beam transmissivity
9628       real , intent(in) gpu_device :: ptrad(:,:,:)            ! diffuse beam transmissivity
9629       real , intent(in) gpu_device :: pdbt(:,:,:)
9630       real , intent(in) gpu_device :: ptdbt(:,:,:)
9631       real , intent(out) gpu_device :: prdnd(:,:,:)
9632       real , intent(inout) gpu_device :: prup(:,:,:)
9633       real , intent(inout) gpu_device  :: prupd(:,:,:)
9634       real, intent(inout) gpu_device :: ztdn(:,:,:)
9635                                                               !   Dimensions: (ncol,nlayers,ngptsw)
9636
9637 ! Output
9638       real , intent(out) gpu_device  :: pfd(:,:,:)            ! downwelling flux (W/m2)
9639                                                               ! unadjusted for earth/sun distance or zenith angle
9640       real , intent(inout) gpu_device  :: pfu(:,:,:)          ! upwelling flux (W/m2)
9641                                                               ! unadjusted for earth/sun distance or zenith angle
9642                                                               !   Dimensions: (ncol,nlayers,ngptsw)
9643 #else
9644       real , intent(in) :: pref(CHNK,112,klev+1)             ! direct beam reflectivity
9645       real , intent(in) :: prefd(CHNK,112,klev+1)            ! diffuse beam reflectivity
9646       real , intent(in) :: ptra(CHNK,112,klev+1)             ! direct beam transmissivity
9647       real , intent(in) :: ptrad(CHNK,112,klev+1)            ! diffuse beam transmissivity
9648       real , intent(in) :: pdbt(CHNK,112,klev+1)
9649       real , intent(in) :: ptdbt(CHNK,112,klev+1)
9650       real , intent(out) :: prdnd(CHNK,112,klev+1)
9651       real , intent(inout) :: prup(CHNK,112,klev+1)
9652       real , intent(inout)  :: prupd(CHNK,112,klev+1)
9653       real, intent(inout) :: ztdn(CHNK,112,klev+1)
9654                                                               !   Dimensions: (ncol,nlayers,ngptsw)
9655
9656 ! Output
9657       real , intent(out) gpu_device  :: pfd(CHNK,112,klev+1)            ! downwelling flux (W/m2)
9658                                                               ! unadjusted for earth/sun distance or zenith angle
9659       real , intent(inout) gpu_device  :: pfu(CHNK,112,klev+1)          ! upwelling flux (W/m2)
9660                                                               ! unadjusted for earth/sun distance or zenith angle
9661                                                               !   Dimensions: (ncol,nlayers,ngptsw)
9662 #endif
9663
9664 ! Local
9665
9666       integer  :: ikp, ikx, jk, iplon, iw
9667
9668 #ifdef _ACCEL
9669
9670       real  :: zreflect, zreflectj
9671
9672 # define ILOOP_S_CPU
9673 # define ILOOP_E_CPU
9674 # define ILOOP_S_GPU do iplon = 1, ncol
9675 # define ILOOP_E_GPU enddo
9676 # define WLOOP_S_CPU
9677 # define WLOOP_E_CPU
9678 # define WLOOP_S_GPU do iw = 1, 112
9679 # define WLOOP_E_GPU enddo
9680
9681 #else
9682
9683 !      real, dimension(CHNK)  :: zreflect, zreflectj
9684       real  :: zreflect, zreflectj
9685
9686 # define ncol CHNK
9687
9688 # define ILOOP_S_GPU
9689 # define ILOOP_E_GPU
9690 # define ILOOP_S_CPU do iplon = 1, ncol
9691 # define ILOOP_E_CPU enddo
9692 # define WLOOP_S_GPU
9693 # define WLOOP_E_GPU
9694 # define WLOOP_S_CPU do iw = 1, 112
9695 # define WLOOP_E_CPU enddo
9696
9697 !# define zreflect ZREFLECT(iplon)
9698 !# define zreflectj ZREFLECTJ(iplon)
9699
9700 #endif
9701
9702 ! Definitions
9703 !
9704 ! pref(jk)   direct reflectance
9705 ! prefd(jk)  diffuse reflectance
9706 ! ptra(jk)   direct transmittance
9707 ! ptrad(jk)  diffuse transmittance
9708 !
9709 ! pdbt(jk)   layer mean direct beam transmittance
9710 ! ptdbt(jk)  total direct beam transmittance at levels
9711 !
9712 !-----------------------------------------------------------------------------
9713
9714 ! Link lowest layer with surface
9715 ! this kernel has a lot of dependencies
9716
9717 !               CHNK       hardcode      klev+1
9718 ! pref            8         112          52
9719 ! prefd            8         112          52
9720 ! ptra            8         112          52
9721 ! ptrad            8         112          52
9722 ! pdbt            8         112          52
9723 ! ptdbt            8         112          52
9724 ! prdnd            8         112          52
9725 ! prup            8         112          52
9726 ! prupd            8         112          52
9727 ! ztdn            8         112          52
9728 ! pfd            8         112          52
9729 ! pfu            8         112          52
9730 !DIR$ ASSUME_ALIGNED pref:64,prefd:64,ptra:64,ptrad:64
9731 !DIR$ ASSUME_ALIGNED pdbt:64,ptdbt:64,prdnd:64,prup:64,prupd:64,ztdn:64,pfd:64,pfu:64
9732
9733 #if 0
9734 write(0,*)'pref ',shape( pref)             ! direct beam reflectivity
9735 write(0,*)'prefd ',shape( prefd)            ! diffuse beam reflectivity
9736 write(0,*)'ptra ',shape( ptra)             ! direct beam transmissivity
9737 write(0,*)'ptrad ',shape( ptrad)            ! diffuse beam transmissivity
9738 write(0,*)'pdbt ',shape( pdbt)
9739 write(0,*)'ptdbt ',shape( ptdbt)
9740 write(0,*)'prdnd ',shape( prdnd)
9741 write(0,*)'prup ',shape( prup)
9742 write(0,*)'prupd ',shape( prupd)
9743 write(0,*)'ztdn ',shape( ztdn)
9744 write(0,*)'pfd ',shape( pfd)            ! downwelling flux (W/m2)
9745 write(0,*)'pfu ',shape( pfu)          ! upwelling flux (W/m2)
9746 #endif
9747
9748
9749
9750 !$acc kernels loop
9751       ILOOP_S_GPU
9752
9753 !$acc loop private(zreflect)
9754         WLOOP_S_GPU
9755          WLOOP_S_CPU
9756 !DIR$ VECTOR ALIGNED
9757            ILOOP_S_CPU
9758             zreflect = 1.  / (1.  - prefd(iplon,iw,klev+1)   * prefd(iplon,iw,klev)  )
9759             prup(iplon,iw,klev)   = pref(iplon,iw,klev)   + (ptrad(iplon,iw,klev)   * &
9760                  ((ptra(iplon,iw,klev)   - pdbt(iplon,iw,klev)  ) * prefd(iplon,iw,klev+1)   + &
9761                    pdbt(iplon,iw,klev)   * pref(iplon,iw,klev+1)  )) * zreflect
9762             prupd(iplon,iw,klev)   = prefd(iplon,iw,klev)   + ptrad(iplon,iw,klev)   * ptrad(iplon,iw,klev)   * &
9763                     prefd(iplon,iw,klev+1)   * zreflect
9764            ILOOP_E_CPU
9765          WLOOP_E_GPU
9766         WLOOP_E_CPU
9767       ILOOP_E_GPU
9768 !$acc end kernels
9769
9770 ! Pass from bottom to top
9771 !$acc kernels loop
9772       ILOOP_S_GPU
9773
9774 !$acc loop
9775        WLOOP_S_GPU
9776
9777 !$acc loop seq
9778             do jk = 1,klev-1
9779                ikp = klev+1-jk
9780                ikx = ikp-1
9781          WLOOP_S_CPU
9782 !DIR$ VECTOR ALIGNED
9783            ILOOP_S_CPU
9784                zreflectj = 1.  / (1.  -prupd(iplon,iw,ikp)   * prefd(iplon,iw,ikx)  )
9785                prup(iplon,iw,ikx)   = pref(iplon,iw,ikx)   + (ptrad(iplon,iw,ikx)   * &
9786                    ((ptra(iplon,iw,ikx)   - pdbt(iplon,iw,ikx)  ) * prupd(iplon,iw,ikp)   + &
9787                      pdbt(iplon,iw,ikx)   * prup(iplon,iw,ikp)  )) * zreflectj
9788                prupd(iplon,iw,ikx)   = prefd(iplon,iw,ikx)   + ptrad(iplon,iw,ikx)   * ptrad(iplon,iw,ikx)   * &
9789                       prupd(iplon,iw,ikp)   * zreflectj
9790            ILOOP_E_CPU
9791          WLOOP_E_CPU
9792             end do
9793        WLOOP_E_GPU
9794       ILOOP_E_GPU
9795 !$acc end kernels
9796
9797 !$acc kernels loop
9798       ILOOP_S_GPU
9799 !$acc loop
9800         WLOOP_S_GPU
9801          WLOOP_S_CPU
9802
9803 ! Upper boundary conditions
9804 !DIR$ VECTOR ALIGNED
9805            ILOOP_S_CPU
9806             ztdn(iplon, iw, 1) = 1.
9807             prdnd(iplon,iw,1)   = 0.
9808             ztdn(iplon, iw, 2) = ptra(iplon,iw,1)
9809             prdnd(iplon,iw,2)   = prefd(iplon,iw,1)
9810            ILOOP_E_CPU
9811          WLOOP_E_GPU
9812         WLOOP_E_CPU
9813       ILOOP_E_GPU
9814 !$acc end kernels
9815
9816 !$acc kernels loop
9817       ILOOP_S_GPU
9818 !$acc loop
9819        WLOOP_S_GPU
9820
9821 ! Pass from top to bottom
9822 !$acc loop seq
9823             do jk = 2,klev
9824                ikp = jk+1
9825          WLOOP_S_CPU
9826 !DIR$ VECTOR ALIGNED
9827            ILOOP_S_CPU
9828                zreflect = 1.  / (1.  - prefd(iplon,iw,jk)   * prdnd(iplon,iw,jk)  )
9829                ztdn(iplon, iw, ikp) = ptdbt(iplon,iw,jk)   * ptra(iplon,iw,jk)   + &
9830                     (ptrad(iplon,iw,jk)   * ((ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk)  ) + &
9831                      ptdbt(iplon,iw,jk)   * pref(iplon,iw,jk)   * prdnd(iplon,iw,jk)  )) * zreflect
9832                prdnd(iplon,iw,ikp)   = prefd(iplon,iw,jk)   + ptrad(iplon,iw,jk)   * ptrad(iplon,iw,jk)   * &
9833                       prdnd(iplon,iw,jk)   * zreflect
9834            ILOOP_E_CPU
9835          WLOOP_E_CPU
9836             end do
9837        WLOOP_E_GPU
9838       ILOOP_E_GPU
9839 !$acc end kernels
9840
9841 ! Up and down-welling fluxes at levels
9842
9843 !$acc kernels loop
9844       ILOOP_S_GPU
9845 !$acc loop
9846        WLOOP_S_GPU
9847 !$acc loop
9848             do jk = 1,klev+1
9849          WLOOP_S_CPU
9850 !DIR$ VECTOR ALIGNED
9851            ILOOP_S_CPU
9852                zreflect = 1.  / (1.  - prdnd(iplon,iw,jk)   * prupd(iplon,iw,jk)  )
9853                pfu(iplon,iw,jk)   = (ptdbt(iplon,iw,jk)   * prup(iplon,iw,jk)   + &
9854                       (ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk)  ) * prupd(iplon,iw,jk)  ) * zreflect
9855                pfd(iplon,iw,jk)   = ptdbt(iplon,iw,jk)   + (ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk)  + &
9856                       ptdbt(iplon,iw,jk)   * prup(iplon,iw,jk)   * prdnd(iplon,iw,jk)  ) * zreflect
9857            ILOOP_E_CPU
9858          WLOOP_E_CPU
9859             end do
9860        WLOOP_E_GPU
9861       ILOOP_E_GPU
9862 !$acc end kernels
9863
9864       end subroutine vrtqdr_sw
9865
9866       end module rrtmg_sw_spcvmc_f
9867 # undef ILOOP_S_GPU
9868 # undef ILOOP_E_GPU
9869 # undef ILOOP_S_CPU
9870 # undef ILOOP_E_CPU
9871 # undef WLOOP_S_GPU
9872 # undef WLOOP_E_GPU
9873 # undef WLOOP_S_CPU
9874 # undef WLOOP_E_CPU
9875 # undef zreflect
9876 # undef zreflectj
9877 # undef ncol
9878
9879       module rrtmg_sw_rad_f
9880 !
9881 ! ****************************************************************************
9882 ! *                                                                          *
9883 ! *                             RRTMG_SW                                     *
9884 ! *                                                                          *
9885 ! *                                                                          *
9886 ! *                                                                          *
9887 ! *                 a rapid radiative transfer model                         *
9888 ! *                  for the solar spectral region                           *
9889 ! *           for application to general circulation models                  *
9890 ! *                                                                          *
9891 ! *                                                                          *
9892 ! *           Atmospheric and Environmental Research, Inc.                   *
9893 ! *                       131 Hartwell Avenue                                *
9894 ! *                       Lexington, MA 02421                                *
9895 ! *                                                                          *
9896 ! *                                                                          *
9897 ! *                          Eli J. Mlawer                                   *
9898 ! *                       Jennifer S. Delamere                               *
9899 ! *                        Michael J. Iacono                                 *
9900 ! *                        Shepard A. Clough                                 *
9901 ! *                       David M. Berthiaume                                *
9902 ! *                                                                          *
9903 ! *                                                                          *
9904 ! *                                                                          *
9905 ! *                                                                          *
9906 ! *                                                                          *
9907 ! *                      email:  miacono@aer.com                             *
9908 ! *                      email:  emlawer@aer.com                             *
9909 ! *                      email:  jdelamer@aer.com                            *
9910 ! *                                                                          *
9911 ! *       The authors wish to acknowledge the contributions of the           *
9912 ! *       following people:  Steven J. Taubman, Patrick D. Brown,            *
9913 ! *       Ronald E. Farren, Luke Chen, Robert Bergstrom.                     *
9914 ! *                                                                          *
9915 ! ****************************************************************************
9916
9917 ! --------- Modules ---------
9918
9919       use rrsw_vsn_f
9920       use mcica_subcol_gen_sw_f, only: mcica_sw
9921       use rrtmg_sw_cldprmc_f, only: cldprmc_sw
9922       use rrtmg_sw_setcoef_f, only: setcoef_sw
9923       use rrtmg_sw_spcvmc_f, only: spcvmc_sw
9924
9925       implicit none
9926
9927       public :: rrtmg_sw,  earth_sun
9928
9929       INTEGER, PARAMETER :: debug_level_swf=100
9930
9931       contains
9932
9933       subroutine rrtmg_sw &
9934             (rpart   ,ncol    ,nlay    ,icld    ,iaer   , &
9935              play    ,plev    ,tlay    ,tlev    ,tsfc   , &
9936              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr , &
9937              asdir   ,asdif   ,aldir   ,aldif   , &
9938              coszen  ,adjes   ,dyofyr  ,scon    , &
9939              inflgsw ,iceflgsw,liqflgsw,cld     , &
9940              tauc    ,ssac    ,asmc    ,fsfc    , &
9941              ciwp    ,clwp    ,cswp    ,rei     ,rel    ,res   , &
9942              tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
9943              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc,swhrc , &
9944 ! --------- Add the following four compenants for ssib shortwave down radiation ---!
9945 ! -------------------      by Zhenxin 2011-06-20      --------------------------------!
9946              sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
9947 ! ----------------------  End,  Zhenxin 2011-06-20    --------------------------------!
9948              swdkdir,swdkdif,                               & ! jararias, 2013/08/10
9949              swdkdirc                                       & ! PAJ
9950                                 )
9951
9952
9953       use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
9954                           jpband, jpb1, jpb2, rrsw_scon
9955       use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
9956       use rrsw_con_f, only : heatfac, oneminus, pi,  grav, avogad
9957       use rrsw_wvn_f, only : wavenum1, wavenum2
9958       use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
9959                            extice2, ssaice2, asyice2, &
9960                            extice3, ssaice3, asyice3, fdlice3, &
9961                            abari, bbari, cbari, dbari, ebari, fbari
9962       use rrsw_wvn_f, only : wavenum2, ngb
9963       use rrsw_ref_f, only : preflog, tref
9964
9965 #ifdef _ACCEL
9966       use cudafor
9967 #endif
9968
9969
9970 ! ------- Declarations
9971
9972       integer , intent(in) :: rpart           ! The number of columns in each partition
9973       integer , intent(in) :: ncol            ! Number of horizontal columns
9974       integer , intent(in) :: nlay            ! Number of model layers
9975       integer , intent(inout) :: icld         ! Cloud overlap method
9976                                               !    0: Clear only
9977                                               !    1: Random
9978                                               !    2: Maximum/random
9979                                               !    3: Maximum
9980       integer , intent(in) :: iaer            ! Aerosol option flag
9981       real , intent(in) :: play(:,:)          ! Layer pressures (hPa, mb)
9982                                               !    Dimensions: (ncol,nlay)
9983       real , intent(in) :: plev(:,:)          ! Interface pressures (hPa, mb)
9984                                               !    Dimensions: (ncol,nlay+1)
9985       real , intent(in) :: tlay(:,:)          ! Layer temperatures (K)
9986                                               !    Dimensions: (ncol,nlay)
9987       real , intent(in) :: tlev(:,:)          ! Interface temperatures (K)
9988                                               !    Dimensions: (ncol,nlay+1)
9989       real , intent(in) :: tsfc(:)            ! Surface temperature (K)
9990                                               !    Dimensions: (ncol)
9991       real , intent(in) :: h2ovmr(:,:)        ! H2O volume mixing ratio
9992                                               !    Dimensions: (ncol,nlay)
9993       real , intent(in) :: o3vmr(:,:)         ! O3 volume mixing ratio
9994                                               !    Dimensions: (ncol,nlay)
9995       real , intent(in) :: co2vmr(:,:)        ! CO2 volume mixing ratio
9996                                               !    Dimensions: (ncol,nlay)
9997       real , intent(in) :: ch4vmr(:,:)        ! Methane volume mixing ratio
9998                                               !    Dimensions: (ncol,nlay)
9999       real , intent(in) :: n2ovmr(:,:)        ! Nitrous oxide volume mixing ratio
10000                                               !    Dimensions: (ncol,nlay)
10001       real , intent(in) :: o2vmr(:,:)         ! Oxygen volume mixing ratio
10002                                               !    Dimensions: (ncol,nlay)
10003       real , intent(in) :: asdir(:)           ! UV/vis surface albedo direct rad
10004                                               !    Dimensions: (ncol)
10005       real , intent(in) :: aldir(:)           ! Near-IR surface albedo direct rad
10006                                               !    Dimensions: (ncol)
10007       real , intent(in) :: asdif(:)           ! UV/vis surface albedo: diffuse rad
10008                                               !    Dimensions: (ncol)
10009       real , intent(in) :: aldif(:)           ! Near-IR surface albedo: diffuse rad
10010                                               !    Dimensions: (ncol)
10011
10012       integer , intent(in) :: dyofyr          ! Day of the year (used to get Earth/Sun
10013                                               !  distance if adjflx not provided)
10014       real , intent(in) :: adjes              ! Flux adjustment for Earth/Sun distance
10015       real , intent(in) :: coszen(:)          ! Cosine of solar zenith angle
10016                                               !    Dimensions: (ncol)
10017       real , intent(in) :: scon               ! Solar constant (W/m2)
10018
10019       integer , intent(in) :: inflgsw         ! Flag for cloud optical properties
10020       integer , intent(in) :: iceflgsw        ! Flag for ice particle specification
10021       integer , intent(in) :: liqflgsw        ! Flag for liquid droplet specification
10022
10023       real , intent(in) :: cld(:,:)           ! Cloud fraction
10024                                               !    Dimensions: (ncol,nlay)
10025       real , intent(in) :: tauc(:,:,:)        ! In-cloud optical depth
10026                                               !    Dimensions: (ncol,nlay,nbndlw)
10027       real , intent(in) :: ssac(:,:,:)        ! In-cloud single scattering albedo
10028                                               !    Dimensions: (ncol,nlay,nbndlw)
10029       real , intent(in) :: asmc(:,:,:)        ! In-cloud asymmetry parameter
10030                                               !    Dimensions: (ncol,nlay,nbndlw)
10031       real , intent(in) :: fsfc(:,:,:)        ! In-cloud forward scattering fraction
10032                                               !    Dimensions: (ncol,nlay,nbndlw)
10033       real , intent(in) :: ciwp(:,:)          ! In-cloud ice water path (g/m2)
10034                                               !    Dimensions: (ncol, nlay)
10035       real , intent(in) :: clwp(:,:)          ! In-cloud liquid water path (g/m2)
10036                                               !    Dimensions: (ncol, nlay)
10037       real , intent(in) :: cswp(:,:)          ! In-cloud snow water path (g/m2)
10038                                               !    Dimensions: (ncol, nlay)
10039       real , intent(in) :: rei(:,:)           ! Cloud ice effective radius (microns)
10040                                               !    Dimensions: (ncol, nlay)
10041                                               ! specific definition of rei depends on setting of iceflglw:
10042                                               ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
10043                                               !               r_ec must be >= 10.0 microns
10044                                               ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
10045                                               !               r_ec range is limited to 13.0 to 130.0 microns
10046                                               ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
10047                                               !               r_k range is limited to 5.0 to 131.0 microns
10048                                               ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
10049                                               !               dge range is limited to 5.0 to 140.0 microns
10050                                               !               [dge = 1.0315 * r_ec]
10051       real , intent(in) :: rel(:,:)           ! Cloud water drop effective radius (microns)
10052                                               !    Dimensions: (ncol,nlay)
10053       real , intent(in) :: res(:,:)           ! Cloud snow effective radius (microns)
10054                                               !    Dimensions: (ncol,nlay)
10055       real , intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth (iaer=10 only)
10056                                               !    Dimensions: (ncol,nlay,nbndsw)
10057                                               ! (non-delta scaled)
10058       real , intent(in) :: ssaaer(:,:,:)      ! Aerosol single scattering albedo (iaer=10 only)
10059                                               !    Dimensions: (ncol,nlay,nbndsw)
10060                                               ! (non-delta scaled)
10061       real , intent(in) :: asmaer(:,:,:)      ! Aerosol asymmetry parameter (iaer=10 only)
10062                                               !    Dimensions: (ncol,nlay,nbndsw)
10063                                               ! (non-delta scaled)
10064       real , intent(in) :: ecaer(:,:,:)       ! Aerosol optical depth at 0.55 micron (iaer=6 only)
10065                                               !    Dimensions: (ncol,nlay,naerec)
10066                                               ! (non-delta scaled)
10067
10068 ! ----- Output -----
10069
10070       real , intent(out) :: swuflx(:,:)       ! Total sky shortwave upward flux (W/m2)
10071                                               !    Dimensions: (ncol,nlay+1)
10072       real , intent(out) :: swdflx(:,:)       ! Total sky shortwave downward flux (W/m2)
10073                                               !    Dimensions: (ncol,nlay+1)
10074       real , intent(out) :: swhr(:,:)         ! Total sky shortwave radiative heating rate (K/d)
10075                                               !    Dimensions: (ncol,nlay)
10076       real , intent(out) :: swuflxc(:,:)      ! Clear sky shortwave upward flux (W/m2)
10077                                               !    Dimensions: (ncol,nlay+1)
10078       real , intent(out) :: swdflxc(:,:)      ! Clear sky shortwave downward flux (W/m2)
10079                                               !    Dimensions: (ncol,nlay+1)
10080       real , intent(out) :: swhrc(:,:)        ! Clear sky shortwave radiative heating rate (K/d)
10081                                               !    Dimensions: (ncol,nlay)
10082
10083       real, intent(out) :: sibvisdir(:,:)      ! visible direct downward flux  (W/m2)
10084                                                !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10085       real, intent(out) :: sibvisdif(:,:)      ! visible diffusion downward flux  (W/m2)
10086                                                !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10087       real, intent(out) :: sibnirdir(:,:)      ! Near IR direct downward flux  (W/m2)
10088                                                !    Dimensions: (ncol,nlay+1)  Zhenxin (2011/06/20)
10089       real, intent(out) :: sibnirdif(:,:)      ! Near IR diffusion downward flux  (W/m2)
10090                                                !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10091       real, intent(out) :: swdkdir(:,:)        ! Total shortwave downward direct flux (W/m2)
10092                                                !    Dimensions: (ncol,nlay+1) jararias, 2013/08/10
10093       real, intent(out) :: swdkdif(:,:)        ! Total shortwave downward diffuse flux (W/m2)
10094                                                !    Dimensions: (ncol,nlay+1) jararias, 2013/08/10
10095       real, intent(out) :: swdkdirc(:,:)       ! Total shortwave downward direct flux clear sky (W/m2)
10096                                                !    Dimensions: (ncol,nlay+1)
10097
10098       integer :: npart, pncol, ns
10099       CHARACTER(LEN=256) :: message
10100
10101 ! mji - time
10102       real :: t1, t2
10103
10104 #ifdef _ACCEL
10105       type(cudadeviceprop) :: prop
10106       real :: gmem
10107       integer :: err
10108       integer :: munits
10109 #endif
10110
10111       if (rpart > 0) then
10112          pncol = rpart
10113       else
10114
10115 #ifdef _ACCEL
10116
10117       err = cudaGetDeviceProperties( prop, 0)
10118       gmem = prop%totalGlobalMem / (1024.0 * 1024.0)
10119 !      print *, "Total GPU global memory is ", gmem , "MB"
10120
10121       ! dmb 2013
10122       ! Here
10123       ! The optimal partition size is determined by the following conditions
10124       ! 1. Powers of 2 are the most efficient.
10125       ! 2. The second to largest power of 2 that can fit on
10126       !    the GPU is most efficient.
10127       ! 3. Having a small remainder for the final partiion is inefficient.
10128
10129       if (gmem > 5000) then
10130          pncol = 4096
10131       else if (gmem > 3000) then
10132          pncol = 2048
10133       else if (gmem > 1000) then
10134           pncol = 1024
10135       else
10136           pncol = 512
10137       end if
10138
10139       ! the smallest allowed partition size is 32
10140       do err = 1, 6
10141           if (pncol > ncol .and. pncol>32) then
10142               pncol = pncol/2
10143           end if
10144       end do
10145
10146       ! if we have a very large number of columns, account for the
10147       ! static ncol memory requirement
10148       if (ncol>29000 .and. pncol>4000) then
10149           pncol = pncol/2
10150       end if
10151
10152 #else
10153       pncol = 2
10154       pncol = 4
10155 !jm      pncol = CHNK  redundant, since this is passed in
10156
10157 #endif
10158
10159       end if
10160
10161       WRITE(message,*)'RRTMG_SWF: Number of columns is               ',ncol
10162       call wrf_debug( debug_level_swf, message)
10163       WRITE(message,*)'RRTMG_SWF: Number of columns per partition is ',pncol
10164       call wrf_debug( debug_level_swf, message)
10165       ns = ceiling( real(ncol) / real(pncol) )
10166       WRITE(message,*)'RRTMG_SWF: Number of partitions is            ',ns
10167       call wrf_debug( debug_level_swf, message)
10168
10169       call cpu_time(t1)
10170
10171       call rrtmg_sw_sub &
10172             (pncol   ,ncol    ,nlay    ,icld    ,iaer   , &
10173              play    ,plev    ,tlay    ,tlev    ,tsfc   , &
10174              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr , &
10175              asdir   ,asdif   ,aldir   ,aldif   , &
10176              coszen  ,adjes   ,dyofyr  ,scon    , &
10177              inflgsw ,iceflgsw,liqflgsw,cld     , &
10178              tauc    ,ssac    ,asmc    ,fsfc    , &
10179              ciwp    ,clwp    ,cswp    ,rei     ,rel    ,res   , &
10180              tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
10181              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc, &
10182              sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
10183              swdkdir  , swdkdif , swdkdirc                       & ! jararias, 2013/08/10
10184                                 )
10185       call cpu_time(t2)
10186       WRITE(message,*)'------------------------------------------------'
10187       call wrf_debug( debug_level_swf, message)
10188       WRITE(message,*)'TOTAL RRTMG_SWF RUN TIME IS   ', t2-t1
10189       call wrf_debug( debug_level_swf, message)
10190       WRITE(message,*)'------------------------------------------------'
10191       call wrf_debug( debug_level_swf, message)
10192
10193       end subroutine rrtmg_sw
10194
10195
10196       subroutine rrtmg_sw_sub &
10197             (ncol    ,gncol   ,nlay    ,icld    ,iaer    , &
10198              gplay   ,gplev   ,gtlay   ,gtlev   ,gtsfc   , &
10199              gh2ovmr ,go3vmr  ,gco2vmr ,gch4vmr ,gn2ovmr ,go2vmr , &
10200              gasdir  ,gasdif  ,galdir  ,galdif  , &
10201              gcoszen ,adjes   ,dyofyr  ,scon    , &
10202              inflgsw ,iceflgsw,liqflgsw,gcld    , &
10203              gtauc   ,gssac   ,gasmc   ,gfsfc   , &
10204              gciwp   ,gclwp   ,gcswp   ,grei    ,grel    ,gres   , &
10205              gtauaer ,gssaaer ,gasmaer ,gecaer  , &
10206              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc, &
10207              sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
10208              swdkdir  , swdkdif , swdkdirc                       & ! jararias, 2013/08/10
10209                                 )
10210       use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
10211                           jpband, jpb1, jpb2, rrsw_scon
10212       use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
10213       use rrsw_con_f, only : heatfac, oneminus, pi,  grav, avogad
10214       use rrsw_wvn_f, only : wavenum1, wavenum2
10215       use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
10216                            extice2, ssaice2, asyice2, &
10217                            extice3, ssaice3, asyice3, fdlice3, &
10218                            abari, bbari, cbari, dbari, ebari, fbari
10219       use rrsw_wvn_f, only : wavenum2, ngb, icxa, nspa, nspb
10220       use rrsw_ref_f, only : preflog, tref
10221       use rrsw_kg16_f, kao16 => kao, kbo16 => kbo, selfrefo16 => selfrefo, forrefo16 => forrefo, sfluxrefo16 => sfluxrefo
10222       use rrsw_kg16_f, ka16 => ka, kb16 => kb, selfref16 => selfref, forref16 => forref, sfluxref16 => sfluxref
10223
10224       use rrsw_kg17_f, kao17 => kao, kbo17 => kbo, selfrefo17 => selfrefo, forrefo17 => forrefo, sfluxrefo17 => sfluxrefo
10225       use rrsw_kg17_f, ka17 => ka, kb17 => kb, selfref17 => selfref, forref17 => forref, sfluxref17 => sfluxref
10226
10227       use rrsw_kg18_f, kao18 => kao, kbo18 => kbo, selfrefo18 => selfrefo, forrefo18 => forrefo, sfluxrefo18 => sfluxrefo
10228       use rrsw_kg18_f, ka18 => ka, kb18 => kb, selfref18 => selfref, forref18 => forref, sfluxref18 => sfluxref
10229
10230       use rrsw_kg19_f, kao19 => kao, kbo19 => kbo, selfrefo19 => selfrefo, forrefo19 => forrefo, sfluxrefo19 => sfluxrefo
10231       use rrsw_kg19_f, ka19 => ka, kb19 => kb, selfref19 => selfref, forref19 => forref, sfluxref19 => sfluxref
10232
10233       use rrsw_kg20_f, kao20 => kao, kbo20 => kbo, selfrefo20 => selfrefo, forrefo20 => forrefo, &
10234           sfluxrefo20 => sfluxrefo, absch4o20 => absch4o
10235       use rrsw_kg20_f, ka20 => ka, kb20 => kb, selfref20 => selfref, forref20 => forref, &
10236           sfluxref20 => sfluxref, absch420 => absch4
10237
10238       use rrsw_kg21_f, kao21 => kao, kbo21 => kbo, selfrefo21 => selfrefo, forrefo21 => forrefo, sfluxrefo21 => sfluxrefo
10239       use rrsw_kg21_f, ka21 => ka, kb21 => kb, selfref21 => selfref, forref21 => forref, sfluxref21 => sfluxref
10240
10241       use rrsw_kg22_f, kao22 => kao, kbo22 => kbo, selfrefo22 => selfrefo, forrefo22 => forrefo, sfluxrefo22 => sfluxrefo
10242       use rrsw_kg22_f, ka22 => ka, kb22 => kb, selfref22 => selfref, forref22 => forref, sfluxref22 => sfluxref
10243
10244       use rrsw_kg23_f, kao23 => kao, selfrefo23 => selfrefo, forrefo23 => forrefo, sfluxrefo23 => sfluxrefo, raylo23 => raylo
10245       use rrsw_kg23_f, ka23 => ka, selfref23 => selfref, forref23 => forref, sfluxref23 => sfluxref, rayl23 => rayl
10246
10247       use rrsw_kg24_f, kao24 => kao, kbo24 => kbo, selfrefo24 => selfrefo, forrefo24 => forrefo, sfluxrefo24 => sfluxrefo
10248       use rrsw_kg24_f, abso3ao24 => abso3ao, abso3bo24 => abso3bo, raylao24 => raylao, raylbo24 => raylbo
10249       use rrsw_kg24_f, ka24 => ka, kb24 => kb, selfref24 => selfref, forref24 => forref, sfluxref24 => sfluxref
10250       use rrsw_kg24_f, abso3a24 => abso3a, abso3b24 => abso3b, rayla24 => rayla, raylb24 => raylb
10251
10252       use rrsw_kg25_f, kao25 => kao, sfluxrefo25=>sfluxrefo
10253       use rrsw_kg25_f, abso3ao25 => abso3ao, abso3bo25 => abso3bo, raylo25 => raylo
10254       use rrsw_kg25_f, ka25 => ka, sfluxref25=>sfluxref
10255       use rrsw_kg25_f, abso3a25 => abso3a, abso3b25 => abso3b, rayl25 => rayl
10256
10257       use rrsw_kg26_f, sfluxrefo26 => sfluxrefo
10258       use rrsw_kg26_f, sfluxref26 => sfluxref
10259
10260       use rrsw_kg27_f, kao27 => kao, kbo27 => kbo, sfluxrefo27 => sfluxrefo, rayl27=>rayl
10261       use rrsw_kg27_f, ka27 => ka, kb27 => kb, sfluxref27 => sfluxref, raylo27=>raylo
10262
10263       use rrsw_kg28_f, kao28 => kao, kbo28 => kbo, sfluxrefo28 => sfluxrefo
10264       use rrsw_kg28_f, ka28 => ka, kb28 => kb, sfluxref28 => sfluxref
10265
10266       use rrsw_kg29_f, kao29 => kao, kbo29 => kbo, selfrefo29 => selfrefo, forrefo29 => forrefo, sfluxrefo29 => sfluxrefo
10267       use rrsw_kg29_f, absh2oo29 => absh2oo, absco2o29 => absco2o
10268       use rrsw_kg29_f, ka29 => ka, kb29 => kb, selfref29 => selfref, forref29 => forref, sfluxref29 => sfluxref
10269       use rrsw_kg29_f, absh2o29 => absh2o, absco229 => absco2
10270
10271 ! ------- Declarations
10272
10273       integer , intent(in) :: ncol
10274       integer , intent(in) :: gncol                   ! Number of horizontal columns
10275       integer , intent(in) :: nlay                    ! Number of model layers
10276       integer , intent(inout) :: icld                 ! Cloud overlap method
10277                                                       !    0: Clear only
10278                                                       !    1: Random
10279                                                       !    2: Maximum/random
10280                                                       !    3: Maximum
10281       integer , intent(in) :: iaer
10282       integer , intent(in) :: dyofyr                  ! Day of the year (used to get Earth/Sun
10283                                                       !  distance if adjflx not provided)
10284       real , intent(in) :: adjes                      ! Flux adjustment for Earth/Sun distance
10285       real , intent(in) :: scon                       ! Solar constant (W/m2)
10286
10287       integer , intent(in) :: inflgsw                 ! Flag for cloud optical properties
10288       integer , intent(in) :: iceflgsw                ! Flag for ice particle specification
10289       integer , intent(in) :: liqflgsw                ! Flag for liquid droplet specification
10290
10291       real , intent(in) :: gcld(gncol, nlay)          ! Cloud fraction
10292                                                       !    Dimensions: (ncol,nlay)
10293       real , intent(in) :: gtauc(gncol,nlay,nbndsw)   ! In-cloud optical depth
10294                                                       !    Dimensions: (ncol,nlay,nbndsw)
10295       real , intent(in) :: gssac(gncol,nlay,nbndsw)   ! In-cloud single scattering albedo
10296                                                       !    Dimensions: (ncol,nlay,nbndsw)
10297       real , intent(in) :: gasmc(gncol,nlay,nbndsw)   ! In-cloud asymmetry parameter
10298                                                       !    Dimensions: (ncol,nlay,nbndsw)
10299       real , intent(in) :: gfsfc(gncol,nlay,nbndsw)   ! In-cloud forward scattering fraction
10300                                                       !    Dimensions: (ncol,nlay,nbndsw)
10301       real , intent(in) :: gciwp(gncol, nlay)         ! In-cloud ice water path (g/m2)
10302                                                       !    Dimensions: (ncol,nlay)
10303       real , intent(in) :: gclwp(gncol, nlay)         ! In-cloud liquid water path (g/m2)
10304                                                       !    Dimensions: (ncol,nlay)
10305       real , intent(in) :: gcswp(gncol, nlay)         ! In-cloud snow water path (g/m2)
10306                                                       !    Dimensions: (ncol,nlay)
10307
10308       real , intent(in) :: grei(gncol, nlay)          ! Cloud ice effective radius (microns)
10309                                                       !    Dimensions: (ncol,nlay)
10310       real , intent(in) :: grel(gncol, nlay)          ! Cloud water drop effective radius (microns)
10311                                                       !    Dimensions: (ncol,nlay)
10312       real , intent(in) :: gres(gncol, nlay)          ! Cloud snow drop effective radius (microns)
10313                                                       !    Dimensions: (ncol,nlay)
10314
10315
10316       real , intent(in) :: gplay(gncol,nlay)          ! Layer pressures (hPa, mb)
10317                                                       !    Dimensions: (ncol,nlay)
10318       real , intent(in) :: gplev(gncol,nlay+1)        ! Interface pressures (hPa, mb)
10319                                                       !    Dimensions: (ncol,nlay+1)
10320       real , intent(in) :: gtlay(gncol,nlay)          ! Layer temperatures (K)
10321                                                       !    Dimensions: (ncol,nlay)
10322       real , intent(in) :: gtlev(gncol,nlay+1)        ! Interface temperatures (K)
10323                                                       !    Dimensions: (ncol,nlay+1)
10324       real , intent(in) :: gtsfc(gncol)               ! Surface temperature (K)
10325                                                       !    Dimensions: (ncol)
10326       real , intent(in) :: gh2ovmr(gncol,nlay)        ! H2O volume mixing ratio
10327                                                       !    Dimensions: (ncol,nlay)
10328       real , intent(in) :: go3vmr(gncol,nlay)         ! O3 volume mixing ratio
10329                                                       !    Dimensions: (ncol,nlay)
10330       real , intent(in) :: gco2vmr(gncol,nlay)        ! CO2 volume mixing ratio
10331                                                       !    Dimensions: (ncol,nlay)
10332       real , intent(in) :: gch4vmr(gncol,nlay)        ! Methane volume mixing ratio
10333                                                       !    Dimensions: (ncol,nlay)
10334       real , intent(in) :: gn2ovmr(gncol,nlay)        ! Nitrous oxide volume mixing ratio
10335                                                       !    Dimensions: (ncol,nlay)
10336       real , intent(in) :: go2vmr(gncol,nlay)         ! Oxygen volume mixing ratio
10337                                                       !    Dimensions: (ncol,nlay)
10338       real , intent(in) :: gasdir(gncol)              ! UV/vis surface albedo direct rad
10339                                                       !    Dimensions: (ncol)
10340       real , intent(in) :: galdir(gncol)              ! Near-IR surface albedo direct rad
10341                                                       !    Dimensions: (ncol)
10342       real , intent(in) :: gasdif(gncol)              ! UV/vis surface albedo: diffuse rad
10343                                                       !    Dimensions: (ncol)
10344       real , intent(in) :: galdif(gncol)              ! Near-IR surface albedo: diffuse rad
10345                                                       !    Dimensions: (ncol)
10346
10347
10348       real , intent(in) :: gcoszen(gncol)             ! Cosine of solar zenith angle
10349                                                       !    Dimensions: (ncol)
10350
10351       real , intent(in) :: gtauaer(gncol,nlay,nbndsw) ! Aerosol optical depth (iaer=10 only)
10352                                                       !    Dimensions: (ncol,nlay,nbndsw)
10353                                                       ! (non-delta scaled)
10354       real , intent(in) :: gssaaer(gncol,nlay,nbndsw) ! Aerosol single scattering albedo (iaer=10 only)
10355                                                       !    Dimensions: (ncol,nlay,nbndsw)
10356                                                       ! (non-delta scaled)
10357       real , intent(in) :: gasmaer(gncol,nlay,nbndsw) ! Aerosol asymmetry parameter (iaer=10 only)
10358                                                       !    Dimensions: (ncol,nlay,nbndsw)
10359                                                       ! (non-delta scaled)
10360       real , intent(in) :: gecaer(:,:,:)              ! Aerosol optical depth at 0.55 micron (iaer=6 only)
10361                                                       !    Dimensions: (ncol,nlay,naerec)
10362                                                       ! (non-delta scaled)
10363 !      integer , intent(in) :: normFlx                 ! Normalize fluxes flag
10364                                                        ! 0 = no normalization
10365                                                        ! 1 = normalize fluxes ( / (scon * coszen) )
10366
10367 ! ----- Output -----
10368
10369       real , intent(out) :: swuflx(:,:)               ! Total sky shortwave upward flux (W/m2)
10370                                                       !    Dimensions: (ncol,nlay+1)
10371       real , intent(out) :: swdflx(:,:)               ! Total sky shortwave downward flux (W/m2)
10372                                                       !    Dimensions: (ncol,nlay+1)
10373       real , intent(out) :: swhr(:,:)                 ! Total sky shortwave radiative heating rate (K/d)
10374                                                       !    Dimensions: (ncol,nlay)
10375       real , intent(out) :: swuflxc(:,:)              ! Clear sky shortwave upward flux (W/m2)
10376                                                       !    Dimensions: (ncol,nlay+1)
10377       real , intent(out) :: swdflxc(:,:)              ! Clear sky shortwave downward flux (W/m2)
10378                                                       !    Dimensions: (ncol,nlay+1)
10379       real , intent(out) :: swhrc(:,:)                ! Clear sky shortwave radiative heating rate (K/d)
10380                                                       !    Dimensions: (ncol,nlay)
10381
10382       real, intent(out) :: sibvisdir(:,:)              ! visible direct downward flux  (W/m2)
10383                                                        !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10384       real, intent(out) :: sibvisdif(:,:)              ! visible diffusion downward flux  (W/m2)
10385                                                        !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10386       real, intent(out) :: sibnirdir(:,:)              ! Near IR direct downward flux  (W/m2)
10387                                                        !    Dimensions: (ncol,nlay+1)  Zhenxin (2011/06/20)
10388       real, intent(out) :: sibnirdif(:,:)              ! Near IR diffusion downward flux  (W/m2)
10389                                                        !    Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
10390       real, intent(out) :: swdkdir(:,:)                ! Total shortwave downward direct flux (W/m2)
10391                                                        !    Dimensions: (ncol,nlay+1) jararias, 2013/08/10
10392       real, intent(out) :: swdkdif(:,:)                ! Total shortwave downward diffuse flux (W/m2)
10393                                                        !    Dimensions: (ncol,nlay+1) jararias, 2013/08/10
10394       real, intent(out) :: swdkdirc(:,:)               ! Total shortwave downward direct flux clear sky (W/m2)
10395                                                        !    Dimensions: (ncol,nlay+1)
10396
10397 ! ----- Local -----
10398
10399 ! Control
10400
10401       integer  :: istart                      ! beginning band of calculation
10402       integer  :: iend                        ! ending band of calculation
10403       integer  :: icpr                        ! cldprop/cldprmc use flag
10404       integer  :: iout                        ! output option flag
10405
10406       integer  :: idelm                       ! delta-m scaling flag
10407                                               ! [0 = direct and diffuse fluxes are unscaled]
10408                                               ! [1 = direct and diffuse fluxes are scaled]
10409                                               ! (total downward fluxes are always delta scaled)
10410       integer  :: isccos                      ! instrumental cosine response flag (inactive)
10411       integer  :: iplon                       ! column loop index
10412       integer  :: i                           ! layer loop index                       ! jk
10413       integer  :: ib                          ! band loop index                        ! jsw
10414       integer  :: ia, ig                      ! indices
10415       integer  :: k                           ! layer loop index
10416       integer  :: ims                         ! value for changing mcica permute seed
10417       integer  :: imca                        ! flag for mcica [0=off, 1=on]
10418
10419       real  :: zepsec, zepzen                 ! epsilon
10420       real  :: zdpgcp                         ! flux to heating conversion ratio
10421
10422 #ifndef _ACCEL
10423 # define ncol CHNK
10424 #endif
10425
10426 ! Atmosphere
10427
10428       real  :: coldry(ncol,nlay+1)            ! dry air column amount
10429       real  :: wkl(ncol,mxmol,nlay)           ! molecular amounts (mol/cm-2)
10430
10431       real  :: cossza(ncol)                   ! Cosine of solar zenith angle
10432       real  :: adjflux(jpband)                ! adjustment for current Earth/Sun distance
10433
10434                                               !  default value of 1368.22 Wm-2 at 1 AU
10435       real  :: albdir(ncol,nbndsw)            ! surface albedo, direct          ! zalbp
10436       real  :: albdif(ncol,nbndsw)            ! surface albedo, diffuse         ! zalbd
10437
10438 !      real  :: rdl(ncol), adl(ncol)
10439
10440 ! Atmosphere - setcoef
10441       integer  :: laytrop(ncol)               ! tropopause layer index
10442       integer  :: layswtch(ncol)              ! tropopause layer index
10443       integer  :: laylow(ncol)                ! tropopause layer index
10444       integer  :: jp(ncol,nlay+1)             !
10445       integer  :: jt(ncol,nlay+1)             !
10446       integer  :: jt1(ncol,nlay+1)            !
10447
10448       real  :: colh2o(ncol,nlay+1)            ! column amount (h2o)
10449       real  :: colco2(ncol,nlay+1)            ! column amount (co2)
10450       real  :: colo3(ncol,nlay+1)             ! column amount (o3)
10451       real  :: coln2o(ncol,nlay+1)            ! column amount (n2o)
10452       real  :: colch4(ncol,nlay+1)            ! column amount (ch4)
10453       real  :: colo2(ncol,nlay+1)             ! column amount (o2)
10454       real  :: colmol(ncol,nlay+1)            ! column amount
10455       real  :: co2mult(ncol,nlay+1)           ! column amount
10456
10457       integer  :: indself(ncol,nlay+1)
10458       integer  :: indfor(ncol,nlay+1)
10459       real  :: selffac(ncol,nlay+1)
10460       real  :: selffrac(ncol,nlay+1)
10461       real  :: forfac(ncol,nlay+1)
10462       real  :: forfrac(ncol,nlay+1)
10463
10464       real  :: &                              !
10465                          fac00(ncol,nlay+1) , fac01(ncol,nlay+1) , &
10466                          fac10(ncol,nlay+1) , fac11(ncol,nlay+1)
10467
10468       real :: play(ncol,nlay)                 ! Layer pressures (hPa, mb)
10469                                               !    Dimensions: (ncol,nlay)
10470       real :: plev(ncol,nlay+1)               ! Interface pressures (hPa, mb)
10471                                               !    Dimensions: (ncol,nlay+1)
10472       real :: tlay(ncol,nlay)                 ! Layer temperatures (K)
10473                                               !    Dimensions: (ncol,nlay)
10474       real :: tlev(ncol,nlay+1)               ! Interface temperatures (K)
10475                                               !    Dimensions: (ncol,nlay+1)
10476       real :: tsfc(ncol)                      ! Surface temperature (K)
10477                                               !    Dimensions: (ncol)
10478       real :: coszen(ncol)
10479
10480 ! Atmosphere/clouds - cldprop
10481       integer  :: ncbands                     ! number of cloud spectral bands
10482
10483       real   :: cld(ncol,nlay)                ! Cloud fraction
10484       real   :: tauc(ncol,nlay,nbndsw)        ! In-cloud optical depth
10485       real   :: ssac(ncol,nlay,nbndsw)        ! In-cloud single scattering
10486       real   :: asmc(ncol,nlay,nbndsw)        ! In-cloud asymmetry parameter
10487       real   :: fsfc(ncol,nlay,nbndsw)        ! In-cloud forward scattering fraction
10488       real   :: ciwp(ncol,nlay)               ! In-cloud ice water path (g/m2)
10489       real   :: clwp(ncol,nlay)               ! In-cloud liquid water path (g/m2)
10490       real   :: cswp(ncol,nlay)               ! In-cloud snow water path (g/m2)
10491       real   :: rei(ncol,nlay)                ! Cloud ice effective radius (microns)
10492       real   :: rel(ncol,nlay)                ! Cloud water drop effective radius (microns)
10493       real   :: res(ncol,nlay)                ! Cloud snow effective radius (microns)
10494
10495       real  :: taucmc(ncol,nlay+1,ngptsw)     ! in-cloud optical depth [mcica]
10496       real  :: taormc(ncol,nlay+1,ngptsw)     ! unscaled in-cloud optical depth [mcica]
10497       real  :: ssacmc(ncol,nlay+1,ngptsw)     ! in-cloud single scattering albedo [mcica]
10498       real  :: asmcmc(ncol,nlay+1,ngptsw)     ! in-cloud asymmetry parameter [mcica]
10499       real  :: fsfcmc(ncol,nlay+1,ngptsw)     ! in-cloud forward scattering fraction [mcica]
10500
10501       real :: cldfmcl(ncol,nlay+1,ngptsw)     ! cloud fraction [mcica]
10502       real :: ciwpmcl(ncol,nlay+1,ngptsw)     ! in-cloud ice water path [mcica]
10503       real :: clwpmcl(ncol,nlay+1,ngptsw)     ! in-cloud liquid water path [mcica]
10504       real :: cswpmcl(ncol,nlay+1,ngptsw)     ! in-cloud liquid water path [mcica]
10505
10506 ! Atmosphere/clouds/aerosol - spcvrt,spcvmc
10507       real  :: ztauc(ncol,nlay+1,nbndsw)      ! cloud optical depth
10508       real  :: ztaucorig(ncol,nlay+1,nbndsw)  ! unscaled cloud optical depth
10509       real  :: zasyc(ncol,nlay+1,nbndsw)      ! cloud asymmetry parameter
10510                                               !  (first moment of phase function)
10511       real  :: zomgc(ncol,nlay+1,nbndsw)      ! cloud single scattering albedo
10512
10513       real  :: taua(ncol, nlay+1, nbndsw)
10514       real  :: asya(ncol, nlay+1, nbndsw)
10515       real  :: omga(ncol, nlay+1, nbndsw)
10516
10517       real  :: zbbfu(ncol,nlay+2)             ! temporary upward shortwave flux (w/m2)
10518       real  :: zbbfd(ncol,nlay+2)             ! temporary downward shortwave flux (w/m2)
10519       real  :: zbbcu(ncol,nlay+2)             ! temporary clear sky upward shortwave flux (w/m2)
10520       real  :: zbbcd(ncol,nlay+2)             ! temporary clear sky downward shortwave flux (w/m2)
10521       real  :: zbbfddir(ncol,nlay+2)          ! temporary downward direct shortwave flux (w/m2)
10522       real  :: zbbcddir(ncol,nlay+2)          ! temporary clear sky downward direct shortwave flux (w/m2)
10523       real  :: zuvfd(ncol,nlay+2)             ! temporary UV downward shortwave flux (w/m2)
10524       real  :: zuvcd(ncol,nlay+2)             ! temporary clear sky UV downward shortwave flux (w/m2)
10525       real  :: zuvfddir(ncol,nlay+2)          ! temporary UV downward direct shortwave flux (w/m2)
10526       real  :: zuvcddir(ncol,nlay+2)          ! temporary clear sky UV downward direct shortwave flux (w/m2)
10527       real  :: znifd(ncol,nlay+2)             ! temporary near-IR downward shortwave flux (w/m2)
10528       real  :: znicd(ncol,nlay+2)             ! temporary clear sky near-IR downward shortwave flux (w/m2)
10529       real  :: znifddir(ncol,nlay+2)          ! temporary near-IR downward direct shortwave flux (w/m2)
10530       real  :: znicddir(ncol,nlay+2)          ! temporary clear sky near-IR downward direct shortwave flux (w/m2)
10531
10532 ! Optional output fields
10533       real  :: swnflx(ncol,nlay+2)            ! Total sky shortwave net flux (W/m2)
10534       real  :: swnflxc(ncol,nlay+2)           ! Clear sky shortwave net flux (W/m2)
10535       real  :: dirdflux(ncol,nlay+2)          ! Direct downward shortwave surface flux
10536       real  :: difdflux(ncol,nlay+2)          ! Diffuse downward shortwave surface flux
10537       real  :: uvdflx(ncol,nlay+2)            ! Total sky downward shortwave flux, UV/vis
10538       real  :: nidflx(ncol,nlay+2)            ! Total sky downward shortwave flux, near-IR
10539       real  :: dirdnuv(ncol,nlay+2)           ! Direct downward shortwave flux, UV/vis
10540       real  :: difdnuv(ncol,nlay+2)           ! Diffuse downward shortwave flux, UV/vis
10541       real  :: dirdnir(ncol,nlay+2)           ! Direct downward shortwave flux, near-IR
10542       real  :: difdnir(ncol,nlay+2)           ! Diffuse downward shortwave flux, near-IR
10543
10544       real gpu_device :: zgco(ncol,ngptsw,nlay+1)  , zomco(ncol,ngptsw,nlay+1)
10545       real gpu_device :: zrdnd(ncol,ngptsw,nlay+1)
10546       real gpu_device :: zref(ncol,ngptsw,nlay+1)  , zrefo(ncol,ngptsw,nlay+1)
10547       real gpu_device :: zrefd(ncol,ngptsw,nlay+1) , zrefdo(ncol,ngptsw,nlay+1)
10548       real gpu_device :: ztauo(ncol,ngptsw,nlay)
10549       real gpu_device :: zdbt(ncol,ngptsw,nlay+1)  , ztdbt(ncol,ngptsw,nlay+1)
10550       real gpu_device :: ztra(ncol,ngptsw,nlay+1)  , ztrao(ncol,ngptsw,nlay+1)
10551       real gpu_device :: ztrad(ncol,ngptsw,nlay+1) , ztrado(ncol,ngptsw,nlay+1)
10552       real gpu_device :: zfd(ncol,ngptsw,nlay+1)   , zfu(ncol,ngptsw,nlay+1)
10553       real gpu_device :: zsflxzen(ncol,ngptsw)
10554       real gpu_device :: ztaur(ncol,nlay,ngptsw)   , ztaug(ncol,nlay,ngptsw)
10555 #ifndef _ACCEL
10556 # undef ncol
10557 #endif
10558
10559       integer :: npartc, npart, npartb, cldflag(gncol), profic(gncol), profi(gncol)
10560
10561       real , parameter :: amd = 28.9660       ! Effective molecular weight of dry air (g/mol)
10562       real , parameter :: amw = 18.0160       ! Molecular weight of water vapor (g/mol)
10563
10564 ! Set molecular weight ratios (for converting mmr to vmr)
10565 !  e.g. h2ovmr = h2ommr * amdw)
10566       real , parameter :: amdw = 1.607793   ! Molecular weight of dry air / water vapor
10567       real , parameter :: amdc = 0.658114   ! Molecular weight of dry air / carbon dioxide
10568       real , parameter :: amdo = 0.603428   ! Molecular weight of dry air / ozone
10569       real , parameter :: amdm = 1.805423   ! Molecular weight of dry air / methane
10570       real , parameter :: amdn = 0.658090   ! Molecular weight of dry air / nitrous oxide
10571       real , parameter :: amdo2 = 0.905140  ! Molecular weight of dry air / oxygen
10572
10573       real , parameter :: sbc = 5.67e-08    ! Stefan-Boltzmann constant (W/m2K4)
10574       integer ii,jj,kk,iw
10575       integer  :: isp, l, ix, n, imol  ! Loop indices
10576       real  :: amm, summol                      !
10577       real  :: adjflx                           ! flux adjustment for Earth/Sun distance
10578       integer :: prt
10579       integer :: piplon
10580
10581       integer :: ipart, cols, cole, colr, ncolc, ncolb
10582       integer :: irng, cc, ncolst
10583
10584 ! Initializations
10585
10586       zepsec = 1.e-06
10587       zepzen = 1.e-10
10588       oneminus = 1.0  - zepsec
10589       pi = 2.  * asin(1. )
10590       irng = 0
10591
10592       istart = jpb1
10593       iend = jpb2
10594       iout = 0
10595       icpr = 1
10596       ims = 2
10597
10598       adjflx = adjes
10599       if (dyofyr .gt. 0) then
10600          adjflx = earth_sun(dyofyr)
10601       endif
10602
10603       do ib = jpb1, jpb2
10604          adjflux(ib) = adjflx * scon / rrsw_scon
10605       end do
10606
10607       if (icld.lt.0.or.icld.gt.3) icld = 2
10608
10609
10610 ! determine cloud profile
10611       cldflag=0
10612       do iplon = 1, gncol
10613         if (any(gcld(iplon,:) > 0)) cldflag(iplon)=1
10614       end do
10615
10616
10617 ! build profile separation
10618       cols = 0
10619       cole = 0
10620
10621       do iplon = 1, gncol
10622         if (cldflag(iplon)==1) then
10623             cole=cole+1
10624             profi(cole) = iplon
10625         else
10626             cols=cols+1
10627             profic(cols) = iplon
10628         end if
10629       end do
10630
10631
10632 !$acc data copyout(swuflxc, swdflxc, swuflx, swdflx, swnflxc, swnflx, swhrc, swhr) &
10633 !$acc create(laytrop, layswtch, laylow, jp, jt, jt1, &
10634 !$acc co2mult, colch4, colco2, colh2o, colmol, coln2o, &
10635 !$acc colo2, colo3, fac00, fac01, fac10, fac11, &
10636 !$acc selffac, selffrac, indself, forfac, forfrac, indfor, &
10637 !$acc zbbfu, zbbfd, zbbcu, zbbcd,zbbfddir, zbbcddir, zuvfd, zuvcd, zuvfddir, &
10638 !$acc zuvcddir, znifd, znicd, znifddir,znicddir, &
10639 !$acc cldfmcl, ciwpmcl, clwpmcl, cswpmcl, &
10640 !$acc taormc, taucmc, ssacmc, asmcmc, fsfcmc) &
10641 !$acc deviceptr(zref,zrefo,zrefd,zrefdo,&
10642 !$acc ztauo,ztdbt,&
10643 !$acc ztra,ztrao,ztrad,ztrado,&
10644 !$acc zfd,zfu,zdbt,zgco,&
10645 !$acc zomco,zrdnd,ztaug, ztaur,zsflxzen)&
10646 !$acc create(ciwp, clwp, cswp, cld, tauc, ssac, asmc, fsfc, rei, rel, res) &
10647 !$acc create(play, tlay, plev, tlev, tsfc, cldflag, coszen) &
10648 !$acc create(coldry, wkl) &
10649 !$acc create(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) &
10650 !$acc create(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) &
10651 !$acc create(taua, asya, omga,gtauaer,gssaaer,gasmaer) &
10652 !$acc copyin(wavenum2, ngb) &
10653 !$acc copyin(tref, preflog, albdif, albdir, cossza)&
10654 !$acc copyin(icxa, adjflux, nspa, nspb)&
10655 !$acc copyin(kao16,kbo16,selfrefo16,forrefo16,sfluxrefo16)&
10656 !$acc copyin(ka16,kb16,selfref16,forref16,sfluxref16)&
10657 !$acc copyin(kao17,kbo17,selfrefo17,forrefo17,sfluxrefo17)&
10658 !$acc copyin(ka17,kb17,selfref17,forref17,sfluxref17)&
10659 !$acc copyin(kao18,kbo18,selfrefo18,forrefo18,sfluxrefo18)&
10660 !$acc copyin(ka18,kb18,selfref18,forref18,sfluxref18)&
10661 !$acc copyin(kao19,kbo19,selfrefo19,forrefo19,sfluxrefo19)&
10662 !$acc copyin(ka19,kb19,selfref19,forref19,sfluxref19)&
10663 !$acc copyin(kao20,kbo20,selfrefo20,forrefo20,sfluxrefo20,absch4o20)&
10664 !$acc copyin(ka20,kb20,selfref20,forref20,sfluxref20,absch420)&
10665 !$acc copyin(kao21,kbo21,selfrefo21,forrefo21,sfluxrefo21)&
10666 !$acc copyin(ka21,kb21,selfref21,forref21,sfluxref21)&
10667 !$acc copyin(kao22,kbo22,selfrefo22,forrefo22,sfluxrefo22)&
10668 !$acc copyin(ka22,kb22,selfref22,forref22,sfluxref22)&
10669 !$acc copyin(kao23,selfrefo23,forrefo23,sfluxrefo23,raylo23)&
10670 !$acc copyin(ka23,selfref23,forref23,sfluxref23,rayl23)&
10671 !$acc copyin(kao24,kbo24,selfrefo24,forrefo24,sfluxrefo24,abso3ao24,abso3bo24,raylao24,raylbo24)&
10672 !$acc copyin(ka24,kb24,selfref24,forref24,sfluxref24,abso3a24,abso3b24,rayla24,raylb24)&
10673 !$acc copyin(kao25,sfluxrefo25,abso3ao25,abso3bo25,raylo25)&
10674 !$acc copyin(ka25,sfluxref25,abso3a25,abso3b25,rayl25)&
10675 !$acc copyin(sfluxrefo26)&
10676 !$acc copyin(sfluxref26)&
10677 !$acc copyin(kao27,kbo27,sfluxrefo27, raylo27)&
10678 !$acc copyin(ka27,kb27,sfluxref27, rayl27)&
10679 !$acc copyin(kao28,kbo28,sfluxrefo28)&
10680 !$acc copyin(ka28,kb28,sfluxref28,gtauc, gssac, gasmc, gfsfc)&
10681 !$acc copyin(kao29,kbo29,selfrefo29,forrefo29,sfluxrefo29,absh2oo29,absco2o29)&
10682 !$acc copyin(ka29,kb29,selfref29,forref29,sfluxref29,absh2o29,absco229)&
10683 !$acc copyin(gh2ovmr, gco2vmr, go3vmr, gn2ovmr, gch4vmr, go2vmr)&
10684 !$acc copyin(gcld, gciwp, gclwp, gcswp, grei, grel, gres, gplay, gplev, gtlay, gtlev, gtsfc)&
10685 !$acc copyin(gasdir, galdir, gasdif, galdif,profi,profic,gcoszen)&
10686 !$acc copyout(sibvisdir,sibvisdif,sibnirdir,sibnirdif,swdkdir,swdkdif,swdkdirc)
10687
10688 !$acc update device(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) &
10689 !$acc device(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) &
10690 !$acc device(preflog)
10691
10692
10693       ncolc = cols
10694       ncolb = cole
10695
10696       npartc = ceiling( real(ncolc) / real(ncol) )
10697       npartb = ceiling( real(ncolb) / real(ncol) )
10698
10699
10700 !$acc kernels
10701       cldfmcl = 0.0
10702       ciwpmcl = 0.0
10703       clwpmcl = 0.0
10704       cswpmcl = 0.0
10705 !$acc end kernels
10706
10707       idelm = 1
10708
10709 !$acc kernels
10710       taua = 0.0
10711       asya = 0.0
10712       omga = 1.0
10713 !$acc end kernels
10714
10715       if (iaer==10) then
10716
10717 !$acc update device(gtauaer,gssaaer,gasmaer)
10718
10719       end if
10720
10721
10722
10723
10724 ! PARTITION LOOP ----------------------------------------------------------------------------
10725       do cc = 1, 2
10726
10727         if (cc==1) then
10728
10729           npart = npartc
10730           ncolst = ncolc
10731
10732         else
10733
10734           npart = npartb
10735           ncolst = ncolb
10736
10737         end if
10738
10739         do ipart = 0,npart-1
10740 !jm call unsetdebug
10741 !jm if (ipart.eq.IDEBUG-1) then
10742 !jm write(0,*)'setting setdebug ipart = ',ipart+1,' npart ',npart
10743 !jm call setdebug
10744 !jm endif
10745           cols = ipart * ncol + 1
10746           cole = (ipart + 1) * ncol
10747           if (cole>ncolst) cole=ncolst
10748           colr = cole - cols + 1
10749
10750 !$acc kernels
10751           taormc = 0.0
10752           taucmc = 0.0
10753           ssacmc = 1.0
10754           asmcmc = 0.0
10755           fsfcmc = 0.0
10756 !$acc end kernels
10757
10758 ! Clear cases
10759           if (cc==1) then
10760 !$acc kernels loop private(piplon)
10761              do iplon = 1, colr
10762                piplon = profic(iplon + cols - 1)
10763
10764                do ib=1,8
10765                  albdir(iplon,ib)  = galdir(piplon)
10766                  albdif(iplon,ib)  = galdif(piplon)
10767                enddo
10768                albdir(iplon,nbndsw)  = galdir(piplon)
10769                albdif(iplon,nbndsw)  = galdif(piplon)
10770 !  UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
10771
10772                do ib=10,13
10773                  albdir(iplon,ib)  = gasdir(piplon)
10774                  albdif(iplon,ib)  = gasdif(piplon)
10775                enddo
10776
10777 !  Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average
10778                albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2.
10779                albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2.
10780              end do
10781 !$acc end kernels
10782
10783 !$acc kernels
10784              do iplon = 1, colr
10785                piplon = profic(iplon + cols - 1)
10786                play(iplon,:) = gplay(piplon, 1:nlay)
10787                plev(iplon,:) = gplev(piplon, 1:nlay+1)
10788                tlay(iplon,:) = gtlay(piplon, 1:nlay)
10789                tlev(iplon,:) = gtlev(piplon, 1:nlay+1)
10790                tsfc(iplon)   = gtsfc(piplon)
10791              end do
10792 !$acc end kernels
10793
10794              if (iaer==10) then
10795 !$acc kernels
10796                do iw=1,nbndsw
10797                do kk=1,nlay
10798                do iplon = 1, colr
10799                  piplon = profic(iplon + cols - 1)
10800                  taua(iplon, kk, iw) = gtauaer(piplon, kk, iw)
10801                  asya(iplon, kk, iw) = gasmaer(piplon, kk, iw)
10802                  omga(iplon, kk, iw) = gssaaer(piplon, kk, iw)
10803                end do
10804                end do
10805                end do
10806 !$acc end kernels
10807              end if
10808
10809 !$acc kernels
10810              do iplon = 1, colr
10811                piplon = profic(iplon + cols - 1)
10812                wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay)
10813                wkl(iplon,2,:) = gco2vmr(piplon,1:nlay)
10814                wkl(iplon,3,:) = go3vmr(piplon,1:nlay)
10815                wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay)
10816                wkl(iplon,5,:) = 0.0
10817                wkl(iplon,6,:) = gch4vmr(piplon,1:nlay)
10818                wkl(iplon,7,:) = go2vmr(piplon,1:nlay)
10819                coszen(iplon)  = gcoszen(piplon)
10820              end do
10821 !$acc end kernels
10822
10823 !************** cloudy cases ***************
10824           else
10825
10826 !$acc kernels loop private(piplon)
10827             do iplon = 1, colr
10828               piplon = profi(iplon + cols - 1)
10829
10830               do ib=1,8
10831                 albdir(iplon,ib)  = galdir(piplon)
10832                 albdif(iplon,ib)  = galdif(piplon)
10833               enddo
10834               albdir(iplon,nbndsw)  = galdir(piplon)
10835               albdif(iplon,nbndsw)  = galdif(piplon)
10836
10837 !  UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
10838               do ib=10,13
10839                  albdir(iplon,ib)  = gasdir(piplon)
10840                  albdif(iplon,ib)  = gasdif(piplon)
10841               enddo
10842
10843 !  Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average
10844               albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2.
10845               albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2.
10846             end do
10847 !$acc end kernels
10848
10849 !$acc kernels
10850             do iplon = 1, colr
10851               piplon = profi(iplon + cols - 1)
10852               play(iplon,:) = gplay(piplon, 1:nlay)
10853               plev(iplon,:) = gplev(piplon, 1:nlay+1)
10854               tlay(iplon,:) = gtlay(piplon, 1:nlay)
10855               tlev(iplon,:) = gtlev(piplon, 1:nlay+1)
10856               tsfc(iplon) = gtsfc(piplon)
10857               cld(iplon,:) = gcld(piplon, 1:nlay)
10858               ciwp(iplon,:) = gciwp(piplon, 1:nlay)
10859               clwp(iplon,:) = gclwp(piplon, 1:nlay)
10860               cswp(iplon,:) = gcswp(piplon, 1:nlay)
10861               rei(iplon,:) = grei(piplon, 1:nlay)
10862               rel(iplon,:) = grel(piplon, 1:nlay)
10863               res(iplon,:) = gres(piplon, 1:nlay)
10864             end do
10865
10866 !$acc end kernels
10867             if (iaer==10) then
10868
10869 !$acc kernels
10870               do iw=1,nbndsw
10871               do kk=1,nlay
10872               do iplon = 1, colr
10873                 piplon = profi(iplon + cols - 1)
10874                 taua(iplon, kk, iw) = gtauaer(piplon, kk, iw)
10875                 asya(iplon, kk, iw) = gasmaer(piplon, kk, iw)
10876                 omga(iplon, kk, iw) = gssaaer(piplon, kk, iw)
10877               end do
10878               end do
10879               end do
10880 !$acc end kernels
10881             end if
10882
10883
10884 ! Copy the direct cloud optical properties over to the temp arrays
10885 ! and then onto the GPU
10886 ! We are on the CPU here
10887
10888 !$acc kernels
10889             do iw=1,nbndsw
10890             do kk=1,nlay
10891             do iplon = 1, colr
10892               piplon = profi(iplon + cols - 1)
10893               tauc(iplon, kk, iw) = gtauc(piplon, kk, iw)
10894               ssac(iplon, kk, iw) = gssac(piplon, kk, iw)
10895               asmc(iplon, kk, iw) = gasmc(piplon, kk, iw)
10896               fsfc(iplon, kk, iw) = gfsfc(piplon, kk, iw)
10897             end do
10898             end do
10899             end do
10900 !$acc end kernels
10901
10902 !$acc kernels
10903             do iplon = 1, colr
10904               piplon = profi(iplon + cols - 1)
10905               wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay)
10906               wkl(iplon,2,:) = gco2vmr(piplon,1:nlay)
10907               wkl(iplon,3,:) = go3vmr(piplon,1:nlay)
10908               wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay)
10909               wkl(iplon,5,:) = 0.0
10910               wkl(iplon,6,:) = gch4vmr(piplon,1:nlay)
10911               wkl(iplon,7,:) = go2vmr(piplon,1:nlay)
10912               coszen(iplon)  = gcoszen(piplon)
10913             end do
10914 !$acc end kernels
10915           end if    ! if-else-endif cc=1 (clear and cloudy cases)
10916
10917 !$acc kernels
10918           cossza = max(zepzen,coszen)
10919 !$acc end kernels
10920
10921 !$acc kernels
10922           do iplon = 1,colr
10923             do l = 1,nlay
10924               coldry(iplon, l) = (plev(iplon, l)-plev(iplon, l+1)) * 1.e3  * avogad / &
10925                  (1.e2  * grav * ((1.  - wkl(iplon, 1,l)) * amd + wkl(iplon, 1,l) * amw) * &
10926                  (1.  + wkl(iplon, 1,l)))
10927             end do
10928           end do
10929 !$acc end kernels
10930
10931 !$acc kernels
10932           do iplon = 1,colr
10933             do l = 1,nlay
10934               do imol = 1, nmol
10935                 wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l)
10936               end do
10937             end do
10938           end do
10939 !$acc end kernels
10940
10941 #ifndef _ACCEL
10942 ! Use Tom Henderson's technique to pad out and vector remainder
10943 ! with valid data so that we can have a static loop range over
10944 ! columns without having to test for short vectors.
10945       IF ( colr < CHNK ) THEN
10946
10947         DO jj = 1,ngptsw
10948         DO kk = 1,nlay+1
10949         DO ii = colr+1, CHNK
10950            taormc(ii,kk,jj) = taormc(colr,kk,jj)
10951            taucmc(ii,kk,jj) = taucmc(colr,kk,jj)
10952            ssacmc(ii,kk,jj) = ssacmc(colr,kk,jj)
10953            asmcmc(ii,kk,jj) = asmcmc(colr,kk,jj)
10954            fsfcmc(ii,kk,jj) = fsfcmc(colr,kk,jj)
10955         ENDDO
10956         ENDDO
10957         ENDDO
10958         DO ib = 1,13
10959         DO ii = colr+1, CHNK
10960            albdir(ii,ib) = albdir(colr,ib)
10961            albdif(ii,ib) = albdif(colr,ib)
10962         ENDDO
10963         ENDDO
10964         DO kk = 1,nlay+1
10965         DO ii = colr+1, CHNK
10966            plev(ii,kk) = plev(colr,kk)
10967            tlev(ii,kk) = tlev(colr,kk)
10968            coldry(ii,kk) = coldry(colr,kk)
10969         ENDDO
10970         ENDDO
10971         DO kk = 1,nlay
10972         DO ii = colr+1, CHNK
10973            play(ii,kk) = play(colr,kk)
10974            tlay(ii,kk) = tlay(colr,kk)
10975            cld(ii,kk)  = cld(colr,kk)
10976            ciwp(ii,kk) = ciwp(colr,kk)
10977            clwp(ii,kk) = clwp(colr,kk)
10978            cswp(ii,kk) = cswp(colr,kk)
10979            rei(ii,kk) = rei(colr,kk)
10980            rel(ii,kk) = rel(colr,kk)
10981            res(ii,kk) = res(colr,kk)
10982         ENDDO
10983         ENDDO
10984         DO ii = colr+1, CHNK
10985            tsfc(ii) = tsfc(colr)
10986         ENDDO
10987         IF ( iaer==10 ) THEN
10988          DO jj = 1,nbndsw
10989          DO kk = 1,nlay+1
10990          DO ii = colr+1, CHNK
10991            taua(ii,kk,jj) = taua(colr,kk,jj)
10992            asya(ii,kk,jj) = asya(colr,kk,jj)
10993            omga(ii,kk,jj) = omga(colr,kk,jj)
10994          ENDDO
10995          ENDDO
10996          ENDDO
10997         ENDIF
10998         DO jj = 1,nbndsw
10999         DO kk = 1,nlay
11000         DO ii = colr+1, CHNK
11001            tauc(ii,kk,jj) = tauc(colr,kk,jj)
11002            ssac(ii,kk,jj) = ssac(colr,kk,jj)
11003            asmc(ii,kk,jj) = asmc(colr,kk,jj)
11004            fsfc(ii,kk,jj) = fsfc(colr,kk,jj)
11005         ENDDO
11006         ENDDO
11007         ENDDO
11008         DO kk = 1,nlay
11009         DO jj = 1,mxmol
11010         DO ii = colr+1, CHNK
11011            wkl(ii,jj,kk) = wkl(colr,jj,kk)
11012         ENDDO
11013         ENDDO
11014         ENDDO
11015         DO ii = colr+1, CHNK
11016            coszen(ii) = coszen(colr)
11017         ENDDO
11018
11019       ENDIF
11020 #endif
11021
11022 #ifndef _ACCEL
11023 #  define colr CHNK
11024 #endif
11025
11026           if (cc==2) then   ! call mcica for cloudy cases
11027             call mcica_sw(colr, nlay, 112, icld, irng, play, &
11028                           cld, ciwp, clwp, cswp, tauc, ssac, asmc, fsfc, &
11029                           cldfmcl, ciwpmcl, clwpmcl, cswpmcl, &
11030                           taucmc, ssacmc, asmcmc, fsfcmc, 1 )
11031           end if
11032
11033           if (cc==2) then   ! call cldprmc for cloudy cases
11034             call cldprmc_sw(colr, nlay, inflgsw, iceflgsw, liqflgsw,  &
11035                             cldfmcl, ciwpmcl, clwpmcl, cswpmcl, rei, rel, res, &
11036                             taormc, taucmc, ssacmc, asmcmc, fsfcmc)
11037           end if
11038
11039           call setcoef_sw(colr, nlay, play , tlay , plev , tlev , tsfc , &
11040                           coldry , wkl , &
11041                           laytrop, layswtch, laylow, jp , jt , jt1 , &
11042                           co2mult , colch4 , colco2 , colh2o , colmol , coln2o , &
11043                           colo2 , colo3 , fac00 , fac01 , fac10 , fac11 , &
11044                           selffac , selffrac , indself , forfac , forfrac , indfor )
11045
11046           call spcvmc_sw(cc, ncol, colr, nlay, istart, iend, icpr, idelm, iout, &
11047                          play, tlay, plev, tlev, &
11048                          tsfc, albdif, albdir, &
11049                          cldfmcl, taucmc, asmcmc, ssacmc, taormc, &
11050                          taua, asya, omga, cossza, coldry, adjflux, &
11051                          laytrop, layswtch, laylow, jp, jt, jt1, &
11052                          co2mult, colch4, colco2, colh2o, colmol, &
11053                          coln2o, colo2, colo3, &
11054                          fac00, fac01, fac10, fac11, &
11055                          selffac, selffrac, indself, forfac, forfrac, indfor, &
11056                          zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, &
11057                          zuvcd, znifd, znicd, &
11058                          zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir,&
11059                          zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt,&
11060                          ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen)
11061
11062 #ifndef _ACCEL
11063 #  undef colr
11064 #endif
11065
11066 ! Transfer up and down, clear and total sky fluxes to output arrays.
11067 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
11068
11069           if (cc==1) then   ! clear
11070 !$acc kernels loop independent
11071             do iplon = 1, colr
11072               piplon = profic(iplon + cols - 1)
11073
11074               do i = 1, nlay+1
11075                 swuflxc(piplon,i) = zbbcu(iplon,i)
11076                 swdflxc(piplon,i) = zbbcd(iplon,i)
11077                 swuflx(piplon,i) = zbbfu(iplon,i)
11078                 swdflx(piplon,i) = zbbfd(iplon,i)
11079
11080 !  All-sky downwward direct and diffuse fluxes
11081                 swdkdir(piplon,i) = zbbfddir(iplon,i)
11082                 swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i)
11083                 swdkdirc(piplon,i) = zbbcddir(iplon,i) ! PAJ: clear-sky direct flux
11084 !  UV/visible downward direct/diffuse fluxes
11085                 sibvisdir(piplon,i) = zuvfddir(iplon,i)
11086                 sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i)
11087 !  Near-IR downward direct/diffuse fluxes
11088                 sibnirdir(piplon,i) = znifddir(iplon,i)
11089                 sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i)
11090               enddo
11091
11092 !  Total and clear sky net fluxes
11093
11094               do i = 1, nlay+1
11095                 swnflxc(iplon,i)  = swdflxc(piplon,i) - swuflxc(piplon,i)
11096                 swnflx(iplon,i)  = swdflx(piplon,i) - swuflx(piplon,i)
11097               enddo
11098
11099 !  Total and clear sky heating rates
11100
11101               do i = 1, nlay
11102                 zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1))
11103                 swhrc(piplon,i) = (swnflxc(iplon,i+1)  - swnflxc(iplon,i) ) * zdpgcp
11104                 swhr(piplon,i) = (swnflx(iplon,i+1)  - swnflx(iplon,i) ) * zdpgcp
11105               enddo
11106               swhrc(piplon,nlay) = 0.
11107               swhr(piplon,nlay) = 0.
11108
11109 ! End longitude loop
11110             enddo
11111 !$acc end kernels
11112
11113           else     ! cc = 2, cloudy
11114 !$acc kernels loop independent
11115             do iplon = 1, colr
11116               piplon = profi(iplon + cols - 1)
11117
11118               do i = 1, nlay+1
11119                 swuflxc(piplon,i) = zbbcu(iplon,i)
11120                 swdflxc(piplon,i) = zbbcd(iplon,i)
11121                 swuflx(piplon,i) = zbbfu(iplon,i)
11122                 swdflx(piplon,i) = zbbfd(iplon,i)
11123
11124 !  All-sky downwward direct and diffuse fluxes
11125                 swdkdir(piplon,i) = zbbfddir(iplon,i)
11126                 swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i)
11127                 swdkdirc(piplon,i) = zbbcddir(iplon,i) ! PAJ: clear-sky direct flux
11128 !  UV/visible downward direct/diffuse fluxes
11129                 sibvisdir(piplon,i) = zuvfddir(iplon,i)
11130                 sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i)
11131 !  Near-IR downward direct/diffuse fluxes
11132                 sibnirdir(piplon,i) = znifddir(iplon,i)
11133                 sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i)
11134               enddo
11135
11136 !  Total and clear sky net fluxes
11137
11138               do i = 1, nlay+1
11139                 swnflxc(iplon,i)  = swdflxc(piplon,i) - swuflxc(piplon,i)
11140                 swnflx(iplon,i)  = swdflx(piplon,i) - swuflx(piplon,i)
11141               enddo
11142
11143 !  Total and clear sky heating rates
11144
11145               do i = 1, nlay
11146                 zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1))
11147                 swhrc(piplon,i) = (swnflxc(iplon,i+1)  - swnflxc(iplon,i) ) * zdpgcp
11148                 swhr(piplon,i) = (swnflx(iplon,i+1)  - swnflx(iplon,i) ) * zdpgcp
11149               enddo
11150               swhrc(piplon,nlay) = 0.
11151               swhr(piplon,nlay) = 0.
11152
11153 ! End longitude loop
11154             enddo
11155 !$acc end kernels
11156
11157           end if   ! if-else-endif clear-cloudy
11158
11159 ! End partition loops
11160         end do
11161
11162       end do
11163
11164 !$acc end data
11165
11166       end subroutine rrtmg_sw_sub
11167
11168 !*************************************************************************
11169       real  function earth_sun(idn)
11170 !*************************************************************************
11171 !
11172 !  Purpose: Function to calculate the correction factor of Earth's orbit
11173 !  for current day of the year
11174
11175 !  idn        : Day of the year
11176 !  earth_sun  : square of the ratio of mean to actual Earth-Sun distance
11177
11178 ! ------- Modules -------
11179
11180       use rrsw_con_f, only : pi
11181
11182       integer , intent(in) :: idn
11183
11184       real  :: gamma
11185
11186       gamma = 2. *pi*(idn-1)/365.
11187
11188 ! Use Iqbal's equation 1.2.1
11189
11190       earth_sun = 1.000110  + .034221  * cos(gamma) + .001289  * sin(gamma) + &
11191                    .000719  * cos(2. *gamma) + .000077  * sin(2. *gamma)
11192
11193       end function earth_sun
11194
11195       end module rrtmg_sw_rad_f
11196
11197 !------------------------------------------------------------------
11198       MODULE module_ra_rrtmg_swf
11199
11200       use module_model_constants, only : cp
11201       USE module_wrf_error
11202 !     USE module_dm
11203
11204       use parrrsw_f, only : nbndsw, ngptsw, naerec
11205       use rrtmg_sw_init_f, only: rrtmg_sw_ini
11206       use rrtmg_sw_rad_f, only: rrtmg_sw
11207 !     use mcica_subcol_gen_sw, only: mcica_subcol_sw
11208
11209       use module_ra_rrtmg_lwf, only : inirad, o3data, relcalc, reicalc, retab
11210 !                               mcica_random_numbers, randomNumberSequence, &
11211 !                               new_RandomNumberSequence, getRandomReal
11212
11213       CONTAINS
11214
11215 !------------------------------------------------------------------
11216       SUBROUTINE RRTMG_SWRAD_FAST(                                &
11217                        rthratensw,                                &
11218                        rthratenswc,                               &
11219                        swupt, swuptc, swdnt, swdntc,              &
11220                        swupb, swupbc, swdnb, swdnbc,              &
11221 !                      swupflx, swupflxc, swdnflx, swdnflxc,      &
11222                        swcf, gsw,                                 &
11223                        xtime, gmt, xlat, xlong,                   &
11224                        radt, degrad, declin,                      &
11225                        coszr, julday, solcon,                     &
11226                        albedo, t3d, t8w, tsk,                     &
11227                        p3d, p8w, pi3d, rho3d,                     &
11228                        dz8w, cldfra3d, ghg_input,                 &
11229                        lradius, iradius,                          &
11230                        is_cammgmp_used, r, g,                     &
11231                        re_cloud,re_ice,re_snow,                   &
11232                        has_reqc,has_reqi,has_reqs,                &
11233                        icloud, warm_rain,                         &
11234                        f_ice_phy, f_rain_phy,                     &
11235                        xland, xice, snow,                         &
11236                        qv3d, qc3d, qr3d,                          &
11237                        qi3d, qs3d, qg3d,                          &
11238                        o3input, o33d,                             &
11239                        aer_opt, aerod, no_src,                    &
11240                        alswvisdir, alswvisdif,                    &  !Zhenxin ssib alb comp (06/20/2011)
11241                        alswnirdir, alswnirdif,                    &  !Zhenxin ssib alb comp (06/20/2011)
11242                        swvisdir, swvisdif,                        &  !Zhenxin ssib swr comp (06/20/2011)
11243                        swnirdir, swnirdif,                        &  !Zhenxin ssib swi comp (06/20/2011)
11244                        sf_surface_physics,                        &  !Zhenxin
11245                        f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,        &
11246                        tauaer300,tauaer400,tauaer600,tauaer999,   & ! czhao
11247                        gaer300,gaer400,gaer600,gaer999,           & ! czhao
11248                        waer300,waer400,waer600,waer999,           & ! czhao
11249                        aer_ra_feedback,                           &
11250 !jdfcz                 progn,prescribe,                           &
11251                        progn,                                     &
11252                        qndrop3d,f_qndrop,                         & !czhao
11253                        ids,ide, jds,jde, kds,kde,                 &
11254                        ims,ime, jms,jme, kms,kme,                 &
11255                        its,ite, jts,jte, kts,kte,                 &
11256                        swupflx, swupflxc, swdnflx, swdnflxc,      &
11257                        tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw,       & ! jararias 2013/11
11258                        swddir, swddni, swddif,                    & ! jararias 2013/08
11259                        swdownc, swddnic, swddirc,                 & ! PAJ
11260                        xcoszen,yr,julian                          & ! jararias 2013/08
11261                                                                   )
11262 !------------------------------------------------------------------
11263       USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
11264       IMPLICIT NONE
11265 !------------------------------------------------------------------
11266    LOGICAL, INTENT(IN )      ::        warm_rain
11267    LOGICAL, INTENT(IN )      ::   is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
11268 !
11269    INTEGER, INTENT(IN )      ::        ids,ide, jds,jde, kds,kde, &
11270                                        ims,ime, jms,jme, kms,kme, &
11271                                        its,ite, jts,jte, kts,kte
11272
11273    INTEGER, INTENT(IN )      ::        ICLOUD, GHG_INPUT
11274 !
11275    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
11276          INTENT(IN   ) ::                                   dz8w, &
11277                                                              t3d, &
11278                                                              t8w, &
11279                                                              p3d, &
11280                                                              p8w, &
11281                                                             pi3d, &
11282                                                            rho3d
11283
11284    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
11285          INTENT(INOUT)  ::                            RTHRATENSW,&
11286                                                       RTHRATENSWC
11287
11288    REAL, DIMENSION( ims:ime, jms:jme )                          , &
11289          INTENT(INOUT)  ::                                   GSW, &
11290                                                             SWCF, &
11291                                                            COSZR
11292
11293    INTEGER, INTENT(IN  )     ::                           JULDAY
11294    REAL, INTENT(IN    )      ::                      RADT,DEGRAD, &
11295                                          XTIME,DECLIN,SOLCON,GMT
11296
11297    REAL, DIMENSION( ims:ime, jms:jme )                          , &
11298          INTENT(IN   )  ::                                  XLAT, &
11299                                                            XLONG, &
11300                                                            XLAND, &
11301                                                             XICE, &
11302                                                             SNOW, &
11303                                                              TSK, &
11304                                                           ALBEDO
11305 !
11306 !!! -------------------  Zhenxin (2011-06/20) ------------------
11307    REAL, DIMENSION( ims:ime, jms:jme )                          , &
11308          OPTIONAL                                               , &
11309          INTENT(IN)     ::                            ALSWVISDIR, &     ! ssib albedo of sw and lw
11310                                                       ALSWVISDIF, &
11311                                                       ALSWNIRDIR, &
11312                                                       ALSWNIRDIF
11313
11314    REAL, DIMENSION( ims:ime, jms:jme )                          , &
11315          OPTIONAL                                               , &
11316          INTENT(OUT)    ::                              SWVISDIR, &
11317                                                         SWVISDIF, &
11318                                                         SWNIRDIR, &
11319                                                         SWNIRDIF        ! ssib sw dir and diff rad
11320    INTEGER, INTENT(IN) :: sf_surface_physics                            ! ssib para
11321
11322 !  ----------------------- end Zhenxin --------------------------
11323 !
11324
11325 ! ------------------------ jararias 2013/08/10 -----------------
11326    real, dimension(ims:ime,jms:jme), intent(out) :: &
11327          swddir,  &  ! All-sky broadband surface direct horiz irradiance
11328          swddni,  &  ! All-sky broadband surface direct normal irradiance
11329          swddif,  &  ! All-sky broadband surface diffuse irradiance
11330          swdownc, & ! Clear sky GHI
11331          swddnic, & ! Clear ski DNI
11332          swddirc    ! Clear ski direct horizontal irradiance
11333    integer, intent(in)        :: yr
11334    real, optional, intent(in) :: &
11335          julian      ! julian day (1-366)
11336    real, dimension(ims:ime,jms:jme), optional, intent(in) :: &
11337          xcoszen     ! cosine of the solar zenith angle
11338    real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw
11339 ! ------------------------ jararias end snippet -----------------
11340
11341
11342    REAL, INTENT(IN  )   ::                                   R,G
11343 !
11344 ! Optional
11345 !
11346    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
11347          OPTIONAL                                               , &
11348          INTENT(IN   ) ::                                         &
11349                                                         CLDFRA3D, &
11350                                                          LRADIUS, &
11351                                                          IRADIUS, &
11352                                                             QV3D, &
11353                                                             QC3D, &
11354                                                             QR3D, &
11355                                                             QI3D, &
11356                                                             QS3D, &
11357                                                             QG3D, &
11358                                                         QNDROP3D
11359
11360 !..Added by G. Thompson to couple cloud physics effective radii.
11361    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN)::       &
11362                                                         RE_CLOUD, &
11363                                                           RE_ICE, &
11364                                                          RE_SNOW
11365    INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
11366
11367    real pi,third,relconst,lwpmin,rhoh2o
11368
11369    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
11370          OPTIONAL                                               , &
11371          INTENT(IN   ) ::                                         &
11372                                                        F_ICE_PHY, &
11373                                                       F_RAIN_PHY
11374
11375    LOGICAL, OPTIONAL, INTENT(IN)   ::                             &
11376                           F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
11377
11378 ! Optional
11379    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
11380        INTENT(IN    ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
11381                                  gaer300,gaer400,gaer600,gaer999, & ! czhao
11382                                  waer300,waer400,waer600,waer999    ! czhao
11383
11384    INTEGER,    INTENT(IN  ), OPTIONAL   ::       aer_ra_feedback
11385 !jdfcz   INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn,prescribe
11386    INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn
11387 !  Ozone
11388    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
11389          INTENT(INOUT) :: O33D
11390    INTEGER, OPTIONAL, INTENT(IN ) :: o3input
11391 !  EC aerosol: no_src = naerec = 6
11392    INTEGER,           INTENT(IN ) :: no_src
11393    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src )       , &
11394          OPTIONAL                                               , &
11395          INTENT(IN   ) :: aerod
11396    INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
11397
11398 !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
11399    real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
11400    data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
11401    1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
11402    real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
11403    data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
11404    1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
11405    real wavemid(nbndsw) ! Mid wavelength (um) of interval
11406    real, parameter :: thresh=1.e-9
11407    real ang,slope
11408    character(len=200) :: msg
11409
11410 ! Top of atmosphere and surface shortwave fluxes (W m-2)
11411    REAL, DIMENSION( ims:ime, jms:jme ),                           &
11412          OPTIONAL, INTENT(INOUT) ::                               &
11413                                        SWUPT,SWUPTC,SWDNT,SWDNTC, &
11414                                        SWUPB,SWUPBC,SWDNB,SWDNBC
11415
11416 ! Layer shortwave fluxes (including extra layer above model top)
11417 ! Vertical ordering is from bottom to top (W m-2)
11418    REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ),                &
11419          OPTIONAL, INTENT(OUT) ::                                 &
11420                                SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC
11421
11422 !  LOCAL VARS
11423
11424    REAL, DIMENSION( kts:kte+1 ) ::                          Pw1D, &
11425                                                             Tw1D
11426
11427    REAL, DIMENSION( kts:kte ) ::                          TTEN1D, &
11428                                                         CLDFRA1D, &
11429                                                             DZ1D, &
11430                                                              P1D, &
11431                                                              T1D, &
11432                                                             QV1D, &
11433                                                             QC1D, &
11434                                                             QR1D, &
11435                                                             QI1D, &
11436                                                             QS1D, &
11437                                                             QG1D, &
11438                                                             O31D, &
11439                                                         qndrop1d
11440
11441 ! Added local arrays for RRTMG
11442     integer ::                                              ncol, &
11443                                                             nlay, &
11444                                                             icld, &
11445                                                             iaer, &
11446                                                          inflgsw, &
11447                                                         iceflgsw, &
11448                                                         liqflgsw
11449 ! Dimension with extra layer from model top to TOA
11450     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 )  ::                  plev, &
11451                                                             tlev
11452     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 )  ::                  play, &
11453                                                             tlay, &
11454                                                           h2ovmr, &
11455                                                            o3vmr, &
11456                                                           co2vmr, &
11457                                                            o2vmr, &
11458                                                           ch4vmr, &
11459                                                           n2ovmr
11460     real, dimension( kts:kte+1 )  ::                       o3mmr
11461 ! Surface albedo (for UV/visible and near-IR spectral regions,
11462 ! and for direct and diffuse radiation)
11463     real, dimension( (jte-jts+1)*(ite-its+1) )  ::                            asdir, &
11464                                                            asdif, &
11465                                                            aldir, &
11466                                                            aldif
11467 ! Dimension with extra layer from model top to TOA,
11468 ! though no clouds are allowed in extra layer
11469     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 )  ::                clwpth, &
11470                                                           ciwpth, &
11471                                                           cswpth, &
11472                                                              rel, &
11473                                                              rei, &
11474                                                              res, &
11475                                                          cldfrac
11476 !                                                         cldfrac, &
11477 !                                                         relqmcl, &
11478 !                                                         reicmcl, &
11479 !                                                         resnmcl
11480     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw )  ::        taucld, &
11481                                                           ssacld, &
11482                                                           asmcld, &
11483                                                           fsfcld
11484 !    real, dimension( ngptsw, (jte-jts+1)*(ite-its+1), kts:kte+1 )  ::       cldfmcl, &
11485 !                                                         clwpmcl, &
11486 !                                                         ciwpmcl, &
11487 !                                                         cswpmcl, &
11488 !                                                         taucmcl, &
11489 !                                                         ssacmcl, &
11490 !                                                         asmcmcl, &
11491 !                                                         fsfcmcl
11492     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw )  ::        tauaer, &
11493                                                           ssaaer, &
11494                                                           asmaer
11495     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, naerec )  ::         ecaer
11496
11497 ! Output arrays contain extra layer from model top to TOA
11498     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 )  ::                swuflx, &
11499                                                           swdflx, &
11500                                                          swuflxc, &
11501                                                          swdflxc, &
11502                                                        sibvisdir, &  ! Zhenxin 2011-06-20
11503                                                        sibvisdif, &
11504                                                        sibnirdir, &
11505                                                        sibnirdif     ! Zhenxin 2011-06-20
11506
11507     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) ::                swdkdir, &  ! jararias, 2013/08/10
11508                                                          swdkdif, &  ! jararias, 2013/08/10
11509                                                         swdkdirc     ! PAJ
11510
11511     real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 )  ::                  swhr, &
11512                                                            swhrc
11513
11514     real, dimension ( (jte-jts+1)*(ite-its+1) ) ::                             tsfc, &
11515                                                               ps, &
11516                                                           coszen
11517     real ::                                                   ro, &
11518                                                               dz, &
11519                                                            adjes, &
11520                                                             scon, &
11521                                                 snow_mass_factor
11522     integer ::                                            dyofyr
11523
11524     integer:: idx_rei
11525     real:: corr
11526
11527     real(kind=8)                                 :: co2, n2o, ch4, cfc11, cfc12
11528 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11529 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
11530     real :: o2
11531     data o2 / 0.209488 /
11532
11533     integer :: iplon, irng, permuteseed
11534     integer :: nb
11535
11536 ! For old lw cloud property specification
11537 ! Cloud and precipitation absorption coefficients
11538 !    real :: abcw,abice,abrn,absn
11539 !    data abcw /0.144/
11540 !    data abice /0.0735/
11541 !    data abrn /0.330e-3/
11542 !    data absn /2.34e-3/
11543
11544 ! Molecular weights and ratios for converting mmr to vmr units
11545 !    real :: amd       ! Effective molecular weight of dry air (g/mol)
11546 !    real :: amw       ! Molecular weight of water vapor (g/mol)
11547 !    real :: amo       ! Molecular weight of ozone (g/mol)
11548 !    real :: amo2      ! Molecular weight of oxygen (g/mol)
11549 ! Atomic weights for conversion from mass to volume mixing ratios
11550 !    data amd   /  28.9660   /
11551 !    data amw   /  18.0160   /
11552 !    data amo   /  47.9998   /
11553 !    data amo2  /  31.9999   /
11554
11555     real :: amdw     ! Molecular weight of dry air / water vapor
11556     real :: amdo     ! Molecular weight of dry air / ozone
11557     real :: amdo2    ! Molecular weight of dry air / oxygen
11558     data amdw /  1.607793 /
11559     data amdo /  0.603461 /
11560     data amdo2 / 0.905190 /
11561
11562 !!
11563     real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1 )  :: pdel          ! Layer pressure thickness (mb)
11564
11565     real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1) ::   cicewp, &     ! in-cloud cloud ice water path
11566                                             cliqwp, &     ! in-cloud cloud liquid water path
11567                                             csnowp, &     ! in-cloud snow water path
11568                                              reliq, &     ! effective drop radius (microns)
11569                                              reice        ! ice effective drop size (microns)
11570     real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1):: recloud1d, &
11571                                            reice1d, &
11572                                           resnow1d
11573     real :: gliqwp, gicewp, gsnowp, gravmks
11574
11575 !
11576 !    REAL   ::  TSFC,GLW0,OLR0,EMISS0,FP
11577     REAL   ::  FP
11578
11579 !    real, dimension(1:ite-its+1 )          ::   clat     ! latitude in radians for columns
11580     real :: coszrs                      ! Cosine of solar zenith angle for present latitude
11581     logical :: dorrsw                   ! Flag to allow shortwave calculation
11582
11583     real, dimension ((jte-jts+1)*(ite-its+1)) :: landfrac, landm, snowh, icefrac
11584
11585     integer :: pcols, pver
11586     integer :: icol
11587     integer :: rpart
11588
11589     REAL :: XT24, TLOCTM, HRANG, XXLAT
11590
11591     INTEGER :: i,j,K, na
11592     LOGICAL :: predicate
11593
11594     REAL :: da, eot ! jararias, 14/08/2013
11595
11596     integer :: icnt
11597
11598 ! mji - write
11599 !    REAL, DIMENSION( ims:ime, jms:jme ) ::         SWDB, SWUT
11600
11601     CHARACTER(LEN=256) :: message
11602     LOGICAL, EXTERNAL :: wrf_dm_on_monitor
11603
11604 !------------------------------------------------------------------
11605 #if ( WRF_CHEM == 1 )
11606       IF ( aer_ra_feedback == 1) then
11607       IF ( .NOT. &
11608       ( PRESENT(tauaer300) .AND. &
11609         PRESENT(tauaer400) .AND. &
11610         PRESENT(tauaer600) .AND. &
11611         PRESENT(tauaer999) .AND. &
11612         PRESENT(gaer300) .AND. &
11613         PRESENT(gaer400) .AND. &
11614         PRESENT(gaer600) .AND. &
11615         PRESENT(gaer999) .AND. &
11616         PRESENT(waer300) .AND. &
11617         PRESENT(waer400) .AND. &
11618         PRESENT(waer600) .AND. &
11619         PRESENT(waer999) ) ) THEN
11620       CALL wrf_error_fatal  &
11621       ('Warning: missing fields required for aerosol radiation' )
11622       ENDIF
11623       ENDIF
11624 #endif
11625
11626 ! Initial value of number of columns per partition;
11627 ! Use 2 for CPU; for GPU set to 0 here to allow selection
11628 ! of appropriate value in rrtmg_sw
11629 #ifdef _ACCEL
11630       rpart = 0
11631 #else
11632       rpart = CHNK
11633 #endif
11634
11635
11636 !-----CALCULATE SHORT WAVE RADIATION
11637 !
11638 ! All fields are ordered vertically from bottom to top
11639 ! Pressures are in mb
11640 !
11641 ! Read time-varying trace gases concentrations and interpolate them to run date.
11642    IF ( GHG_INPUT .EQ. 1 ) THEN
11643       CALL read_CAMgases(yr,julian,.false.,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
11644       IF ( wrf_dm_on_monitor() ) THEN
11645         WRITE(message,*)'RRTMG SWF CLWRF interpolated GHG values year:',yr,' julian day:',julian
11646         call wrf_debug( 1, message)
11647         WRITE(message,*)'  co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12
11648         call wrf_debug( 1, message)
11649       END IF
11650    ELSE
11651 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
11652 ! Annual function for co2 in WRF v4.2
11653       co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
11654 !     co2 = 379.e-6
11655       ch4 = 1774.e-9
11656       n2o = 319.e-9
11657    END IF
11658
11659 ! jararias, 14/08/2013
11660       if (present(xcoszen)) then
11661          call wrf_debug(100,'coszen from radiation driver')
11662       end if
11663
11664 ! Number of columns to process
11665    ncol = (jte-jts+1)*(ite-its+1)
11666
11667    icnt = 0
11668 ! latitude loop
11669    j_loop: do j = jts,jte
11670
11671 ! longitude loop
11672       i_loop: do i = its,ite
11673 !
11674          icol = i-its+1 + (j-jts)*(ite-its+1)
11675
11676 ! Do shortwave by default, deactivate below if sun below horizon
11677          dorrsw = .true.
11678
11679 ! Cosine solar zenith angle for current time step
11680 !
11681 ! xt24 is the fractional part of simulation days plus half of radt expressed in
11682 ! units of minutes
11683 ! julian is in days
11684 ! radt is in minutes
11685 ! jararias, 14/08/2013
11686          if (present(xcoszen)) then
11687             coszr(i,j)=xcoszen(i,j)
11688             coszrs=xcoszen(i,j)
11689          else
11690 !            da=6.2831853071795862*(julian-1)/365.
11691 !            eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
11692 !               -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
11693             xt24 = mod(xtime+radt*0.5,1440.)+eot
11694             tloctm = gmt + xt24/60. + xlong(i,j)/15.
11695             hrang = 15. * (tloctm-12.) * degrad
11696             xxlat = xlat(i,j) * degrad
11697             coszrs = sin(xxlat) * sin(declin) &
11698                    + cos(xxlat) * cos(declin) * cos(hrang)
11699             coszr(i,j) = coszrs
11700          end if
11701
11702 ! mji - count daytime points to not process fully nighttime scenes
11703          if (coszrs .gt. 0.0) icnt = icnt + 1
11704
11705 ! Set flag to prevent shortwave calculation when sun below horizon
11706 ! mji - must set up input everywhere to run model at all grid points on
11707 !       GPU when any daytime points present
11708 !         if (coszrs.le.0.0) dorrsw = .false.
11709
11710 ! Perform shortwave calculation if sun above horizon
11711          if (dorrsw) then
11712
11713          do k=kts,kte+1
11714             Pw1D(K) = p8w(I,K,J)/100.
11715             Tw1D(K) = t8w(I,K,J)
11716          enddo
11717
11718          DO K=kts,kte
11719             QV1D(K)=0.
11720             QC1D(K)=0.
11721             QR1D(K)=0.
11722             QI1D(K)=0.
11723             QS1D(K)=0.
11724             CLDFRA1D(k)=0.
11725             QNDROP1D(k)=0.
11726          ENDDO
11727
11728          DO K=kts,kte
11729             QV1D(K)=QV3D(I,K,J)
11730             QV1D(K)=max(0.,QV1D(K))
11731          ENDDO
11732
11733          IF (o3input.eq.2) THEN
11734             DO K=kts,kte
11735                O31D(K)=O33D(I,K,J)
11736             ENDDO
11737          ELSE
11738             DO K=kts,kte
11739                O31D(K)=0.0
11740             ENDDO
11741          ENDIF
11742
11743          DO K=kts,kte
11744             TTEN1D(K)=0.
11745             T1D(K)=t3d(I,K,J)
11746             P1D(K)=p3d(I,K,J)/100.
11747             DZ1D(K)=dz8w(I,K,J)
11748          ENDDO
11749
11750 ! moist variables
11751
11752          IF (ICLOUD .ne. 0) THEN
11753             IF ( PRESENT( CLDFRA3D ) ) THEN
11754               DO K=kts,kte
11755                  CLDFRA1D(k)=CLDFRA3D(I,K,J)
11756               ENDDO
11757             ENDIF
11758
11759             IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
11760               IF ( F_QC) THEN
11761                  DO K=kts,kte
11762                     QC1D(K)=QC3D(I,K,J)
11763                     QC1D(K)=max(0.,QC1D(K))
11764                  ENDDO
11765               ENDIF
11766             ENDIF
11767
11768             IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
11769               IF ( F_QR) THEN
11770                  DO K=kts,kte
11771                     QR1D(K)=QR3D(I,K,J)
11772                     QR1D(K)=max(0.,QR1D(K))
11773                  ENDDO
11774               ENDIF
11775             ENDIF
11776
11777             IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
11778              IF (F_QNDROP) THEN
11779               DO K=kts,kte
11780                qndrop1d(K)=qndrop3d(I,K,J)
11781               ENDDO
11782              ENDIF
11783             ENDIF
11784
11785 ! This logic is tortured because cannot test F_QI unless
11786 ! it is present, and order of evaluation of expressions
11787 ! is not specified in Fortran
11788
11789             IF ( PRESENT ( F_QI ) ) THEN
11790               predicate = F_QI
11791             ELSE
11792               predicate = .FALSE.
11793             ENDIF
11794
11795 ! For MP option 3
11796             IF (.NOT. predicate .and. .not. warm_rain) THEN
11797                DO K=kts,kte
11798                   IF (T1D(K) .lt. 273.15) THEN
11799                   QI1D(K)=QC1D(K)
11800                   QS1D(K)=QR1D(K)
11801                   QC1D(K)=0.
11802                   QR1D(K)=0.
11803                   ENDIF
11804                ENDDO
11805             ENDIF
11806
11807             IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
11808                IF (F_QI) THEN
11809                   DO K=kts,kte
11810                      QI1D(K)=QI3D(I,K,J)
11811                      QI1D(K)=max(0.,QI1D(K))
11812                   ENDDO
11813                ENDIF
11814             ENDIF
11815
11816             IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
11817                IF (F_QS) THEN
11818                   DO K=kts,kte
11819                      QS1D(K)=QS3D(I,K,J)
11820                      QS1D(K)=max(0.,QS1D(K))
11821                   ENDDO
11822                ENDIF
11823             ENDIF
11824
11825             IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
11826                IF (F_QG) THEN
11827                   DO K=kts,kte
11828                      QG1D(K)=QG3D(I,K,J)
11829                      QG1D(K)=max(0.,QG1D(K))
11830                   ENDDO
11831                ENDIF
11832             ENDIF
11833
11834 ! mji - For MP option 5
11835             IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
11836                IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
11837                   DO K=kts,kte
11838                      qi1d(k) = 0.1*qs3d(i,k,j)
11839                      qs1d(k) = 0.9*qs3d(i,k,j)
11840                      qc1d(k) = qc3d(i,k,j)
11841                      qi1d(k) = max(0.,qi1d(k))
11842                      qc1d(k) = max(0.,qc1d(k))
11843                   ENDDO
11844                ENDIF
11845             ENDIF
11846
11847          ENDIF
11848
11849 !         EMISS0=EMISS(I,J)
11850 !         GLW0=0.
11851 !         OLR0=0.
11852 !         TSFC=TSK(I,J)
11853          DO K=kts,kte
11854             QV1D(K)=AMAX1(QV1D(K),1.E-12)
11855          ENDDO
11856
11857 ! Set up input for shortwave
11858 !         ncol = 1
11859 ! Add extra layer from top of model to top of atmosphere
11860          nlay = (kte - kts + 1) + 1
11861
11862 ! Select cloud liquid and ice optics parameterization options
11863 ! For passing in cloud optical properties directly:
11864 !         icld = 2
11865 !         inflgsw = 0
11866 !         iceflgsw = 0
11867 !         liqflgsw = 0
11868 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
11869          icld = 2
11870          inflgsw = 2
11871          iceflgsw = 3
11872          liqflgsw = 1
11873
11874 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
11875          IF (ICLOUD .ne. 0) THEN
11876             IF ( has_reqc .ne. 0) THEN
11877                inflgsw = 3
11878                DO K=kts,kte
11879                   recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
11880                   if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
11881      &                            .AND. (XLAND(I,J)-1.5).GT.0.) then      !--- Ocean
11882                      recloud1D(icol,K) = 10.5
11883                   elseif (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
11884      &                            .AND. (XLAND(I,J)-1.5).LT.0.) then      !--- Land
11885                      recloud1D(icol,K) = 7.5
11886                   endif
11887                ENDDO
11888             ELSE
11889                DO K=kts,kte
11890                   recloud1D(icol,K) = 5.0
11891                ENDDO
11892             ENDIF
11893
11894             IF ( has_reqi .ne. 0) THEN
11895                inflgsw  = 4
11896                iceflgsw = 4
11897                DO K=kts,kte
11898                   reice1D(icol,K) = MAX(5., re_ice(I,K,J)*1.E6)
11899                   if (reice1D(icol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
11900                      idx_rei = int(t3d(i,k,j)-179.)
11901                      idx_rei = min(max(idx_rei,1),75)
11902                      corr = t3d(i,k,j) - int(t3d(i,k,j))
11903                      reice1D(icol,K) = retab(idx_rei)*(1.-corr) +      &
11904      &                                 retab(idx_rei+1)*corr
11905                      reice1D(icol,K) = MAX(reice1D(icol,K), 5.0)
11906                   endif
11907                ENDDO
11908             ELSE
11909                DO K=kts,kte
11910                   reice1D(icol,K) = 10.0
11911                ENDDO
11912             ENDIF
11913
11914             IF ( has_reqs .ne. 0) THEN
11915                inflgsw  = 5
11916                iceflgsw = 5
11917                DO K=kts,kte
11918                   resnow1D(icol,K) = MAX(10., re_snow(I,K,J)*1.E6)
11919                ENDDO
11920             ELSE
11921                DO K=kts,kte
11922                   resnow1D(icol,K) = 10.
11923                ENDDO
11924             ENDIF
11925
11926 ! special case for P3 microphysics
11927 ! put ice into snow category for optics, then set ice to zero
11928             IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
11929                inflgsw  = 5
11930                iceflgsw = 5
11931                DO K=kts,kte
11932                   resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
11933                   QS1D(K)=QI3D(I,K,J)
11934                   QI1D(K)=0.
11935                   reice1D(ncol,K)=10.
11936                END DO
11937
11938             END IF
11939
11940          ENDIF
11941
11942 ! Set cosine of solar zenith angle
11943          coszen(icol) = coszrs
11944 ! Set solar constant
11945          scon = solcon
11946 ! For Earth/Sun distance adjustment in RRTMG
11947 !         dyofyr = julday
11948 !         adjes = 0.0
11949 ! For WRF, solar constant is already provided with eccentricity adjustment,
11950 ! so do not do this in RRTMG
11951          dyofyr = 0
11952          adjes = 1.0
11953
11954 ! Layer indexing goes bottom to top here for all fields.
11955 ! Water vapor and ozone are converted from mmr to vmr.
11956 ! Pressures are in units of mb here.
11957          plev(icol,1) = pw1d(1)
11958          tlev(icol,1) = tw1d(1)
11959          tsfc(icol) = tsk(i,j)
11960          do k = kts, kte
11961             play(icol,k) = p1d(k)
11962             plev(icol,k+1) = pw1d(k+1)
11963             pdel(icol,k) = plev(icol,k) - plev(icol,k+1)
11964             tlay(icol,k) = t1d(k)
11965             tlev(icol,k+1) = tw1d(k+1)
11966             h2ovmr(icol,k) = qv1d(k) * amdw
11967             co2vmr(icol,k) = co2
11968             o2vmr(icol,k) = o2
11969             ch4vmr(icol,k) = ch4
11970             n2ovmr(icol,k) = n2o
11971          enddo
11972
11973 !  Define profile values for extra layer from model top to top of atmosphere.
11974 !  The top layer temperature for all gridpoints is set to the top layer-1
11975 !  temperature plus a constant (0 K) that represents an isothermal layer
11976 !  above ptop.  Top layer interface temperatures are linearly interpolated
11977 !  from the layer temperatures.
11978
11979          play(icol,kte+1) = 0.5 * plev(icol,kte+1)
11980          tlay(icol,kte+1) = tlev(icol,kte+1) + 0.0
11981          plev(icol,kte+2) = 1.0e-5
11982          tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0
11983          tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0
11984          h2ovmr(icol,kte+1) = h2ovmr(icol,kte)
11985          co2vmr(icol,kte+1) = co2vmr(icol,kte)
11986          o2vmr(icol,kte+1) = o2vmr(icol,kte)
11987          ch4vmr(icol,kte+1) = ch4vmr(icol,kte)
11988          n2ovmr(icol,kte+1) = n2ovmr(icol,kte)
11989
11990 ! Get ozone profile including amount in extra layer above model top
11991 !         call inirad (o3mmr,plev,kts,kte)
11992          call inirad (o3mmr,plev(icol,:),kts,kte)
11993
11994         if(o3input.eq.2) then
11995          do k = kts, kte+1
11996             o3vmr(icol,k) = o3mmr(k) * amdo
11997             if(k.le.kte)then
11998                o3vmr(icol,k) = o31d(k)
11999             else
12000 ! apply shifted climatology profile above model top
12001                o3vmr(icol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
12002                if(o3vmr(icol,k) .le. 0.)o3vmr(icol,k) = o3mmr(k)*amdo
12003             endif
12004          enddo
12005         else
12006          do k = kts, kte+1
12007             o3vmr(icol,k) = o3mmr(k) * amdo
12008          enddo
12009         endif
12010
12011 ! Set surface albedo for direct and diffuse radiation in UV/visible and
12012 ! near-IR spectral regions
12013 ! -------------- Zhenxin 2011-06-20 ----------- !
12014
12015 ! ------- 1.  Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
12016 !         asdir(icol) = albedo(i,j)
12017 !         asdif(icol) = albedo(i,j)
12018 !         aldir(icol) = albedo(i,j)
12019 !         aldif(icol) = albedo(i,j)
12020 ! -------    End of Comments    ------ !
12021
12022 ! ------- 2. New Addition  ------ !
12023     IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
12024          asdir(icol) = ALSWVISDIR(I,J)
12025          asdif(icol) = ALSWVISDIF(I,J)
12026          aldir(icol) = ALSWNIRDIR(I,J)
12027          aldif(icol) = ALSWNIRDIF(I,J)
12028     ELSE
12029          asdir(icol) = albedo(i,j)
12030          asdif(icol) = albedo(i,j)
12031          aldir(icol) = albedo(i,j)
12032          aldif(icol) = albedo(i,j)
12033     ENDIF
12034
12035 ! ---------- End of Addition ------!
12036 ! ----------  End of fds_Zhenxin 2011-06-20   --------------!
12037
12038 ! Define cloud optical properties for radiation (inflgsw = 0)
12039 ! This option is not currently active
12040 ! Cloud and precipitation paths in g/m2
12041 ! qi=0 if no ice phase
12042 ! qs=0 if no ice phase
12043          if (inflgsw .eq. 0) then
12044
12045 ! Set cloud fraction and cloud optical properties here; not yet active
12046             do k = kts, kte
12047                cldfrac(icol,k) = cldfra1d(k)
12048                do nb = 1, nbndsw
12049                   taucld(icol,k,nb) = 0.0
12050                   ssacld(icol,k,nb) = 1.0
12051                   asmcld(icol,k,nb) = 0.0
12052                   fsfcld(icol,k,nb) = 0.0
12053                enddo
12054             enddo
12055
12056 ! Zero out cloud physical property arrays; not used when passing optical properties
12057 ! into radiation
12058             do k = kts, kte
12059                clwpth(icol,k) = 0.0
12060                ciwpth(icol,k) = 0.0
12061                rel(icol,k) = 10.0
12062                rei(icol,k) = 10.
12063             enddo
12064          endif
12065
12066 ! Define cloud physical properties for radiation (inflgsw = 1 or 2)
12067 ! Cloud fraction
12068 ! Set cloud arrays if passing cloud physical properties into radiation
12069          if (inflgsw .gt. 0) then
12070             do k = kts, kte
12071                cldfrac(icol,k) = cldfra1d(k)
12072             enddo
12073
12074 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
12075             pcols = ncol
12076             pver = kte - kts + 1
12077             gravmks = g
12078             landfrac(icol) = 2.-XLAND(I,J)
12079             landm(icol) = landfrac(icol)
12080             snowh(icol) = 0.001*SNOW(I,J)
12081             icefrac(icol) = XICE(I,J)
12082
12083 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
12084 ! pdel is in mb here; convert back to Pa (*100.)
12085 ! Water paths are in units of g/m2
12086 ! snow added as ice cloud (JD 091022)
12087             do k = kts, kte
12088                gicewp = (qi1d(k)+qs1d(k)) * pdel(icol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
12089                gliqwp = qc1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0     ! Grid box liquid water path.
12090                cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k))               ! In-cloud ice water path.
12091                cliqwp(icol,k) = gliqwp / max(0.01,cldfrac(icol,k))               ! In-cloud liquid water path.
12092             end do
12093
12094 ! Mukul
12095 !..The ice water path is already sum of cloud ice and snow, but when we have explicit
12096 !.. ice effective radius, overwrite the ice path with only the cloud ice variable,
12097 !.. leaving out the snow for its own effect.
12098            if(iceflgsw.ge.4)then
12099               do k = kts, kte
12100                      gicewp = qi1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
12101                      cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k))               ! In-cloud ice water path.
12102               end do
12103            end if
12104
12105 !..Here the snow path is adjusted if (radiation) effective radius of snow is
12106 !.. larger than what we currently have in the lookup tables.  Since mass goes
12107 !.. rather close to diameter squared, adjust the mixing ratio of snow used
12108 !.. to compute its water path in combination with the max diameter.  Not a
12109 !.. perfect fix, but certainly better than using all snow mass when diameter is
12110 !.. far larger than table currently contains and crystal sizes much larger than
12111 !.. about 140 microns have lesser impact than those much smaller sizes.
12112
12113            if(iceflgsw.eq.5)then
12114               do k = kts, kte
12115                  snow_mass_factor = 0.99        ! Assume 1% of snow overlaps the cloud ice category
12116                  gicewp = gicewp + (qs1d(k)*(1.0-snow_mass_factor) * pdel(ncol,k)*100.0 / gravmks * 1000.0)
12117                  if (resnow1d(icol,k) .gt. 130.)then
12118                      snow_mass_factor = MIN(snow_mass_factor,                       &
12119      &                         (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)))
12120                      resnow1d(icol,k)   = 130.0
12121                  endif
12122                  gsnowp = qs1d(k) * snow_mass_factor * pdel(icol,k)*100.0 / gravmks * 1000.0     ! Grid box snow water path.
12123                  csnowp(icol,k) = gsnowp / max(0.01,cldfrac(icol,k))
12124               end do
12125            end if
12126
12127
12128 !link the aerosol feedback to cloud  -czhao
12129   if( PRESENT( progn ) ) then
12130     if (progn == 1) then
12131 !jdfcz     if(prescribe==0) then
12132
12133       pi = 4.*atan(1.0)
12134       third=1./3.
12135       rhoh2o=1.e3
12136       relconst=3/(4.*pi*rhoh2o)
12137 !     minimun liquid water path to calculate rel
12138 !     corresponds to optical depth of 1.e-3 for radius 4 microns.
12139       lwpmin=3.e-5
12140       do k = kts, kte
12141          reliq(icol,k) = 10.
12142          if( PRESENT( F_QNDROP ) ) then
12143             if( F_QNDROP ) then
12144               if ( qc1d(k)*pdel(icol,k).gt.lwpmin.and. &
12145                    qndrop1d(k).gt.1000. ) then
12146                reliq(icol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
12147 !           apply scaling from Martin et al., JAS 51, 1830.
12148                reliq(icol,k)=1.1*reliq(icol,k)
12149                reliq(icol,k)=reliq(icol,k)*1.e6 ! convert from m to microns
12150                reliq(icol,k)=max(reliq(icol,k),4.)
12151                reliq(icol,k)=min(reliq(icol,k),20.)
12152               end if
12153             end if
12154          end if
12155       end do
12156 !jdfcz     else ! prescribe
12157 ! following Kiehl
12158 !      call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12159 !      write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
12160 !jdfcz     endif
12161     else  ! progn   (progn=1)
12162       call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12163     endif
12164   else   !progn   (PRESENT)
12165       call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
12166   endif
12167
12168 ! following Kristjansson and Mitchell
12169       call reicalc(icol, pcols, pver, tlay, reice)
12170
12171
12172
12173 !..If we already have effective radius of cloud and ice, then just overwrite what
12174 !.. was computed in the relcalc and reicalc subroutines above.
12175
12176       if (inflgsw .ge. 3) then
12177          do k = kts, kte
12178             reliq(icol,k) = recloud1d(icol,k)
12179          end do
12180       endif
12181       if (iceflgsw .ge. 4) then
12182          do k = kts, kte
12183             reice(icol,k) = reice1d(icol,k)
12184          end do
12185       endif
12186
12187
12188 ! Limit upper bound of reice for Fu ice parameterization and convert
12189 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
12190             if (iceflgsw .eq. 3) then
12191                do k = kts, kte
12192                   reice(icol,k) = reice(icol,k) * 1.0315
12193                   reice(icol,k) = min(140.0,reice(icol,k))
12194                end do
12195             endif
12196
12197 !if CAMMGMP is used, use output from CAMMGMP
12198 !PMA
12199             if(is_CAMMGMP_used) then
12200                do k = kts, kte
12201                   if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
12202                      reice(icol,k) = iradius(i,k,j)
12203                   else
12204                      reice(icol,k) = 25.
12205                   end if
12206                   reice(icol,k) = max(5., min(140.0,reice(icol,k)))
12207                   if ( qc1d(k) .gt. 1.e-20) then
12208                      reliq(icol,k) = lradius(i,k,j)
12209                   else
12210                      reliq(icol,k) = 10.
12211                   end if
12212                   reliq(icol,k) = max(2.5, min(60.0,reliq(icol,k)))
12213                enddo
12214             endif
12215
12216 ! Set cloud physical property arrays
12217             do k = kts, kte
12218                clwpth(icol,k) = cliqwp(icol,k)
12219                ciwpth(icol,k) = cicewp(icol,k)
12220                rel(icol,k) = reliq(icol,k)
12221                rei(icol,k) = reice(icol,k)
12222             enddo
12223
12224 !Mukul
12225             if (inflgsw .eq. 5) then
12226                do k = kts, kte
12227                   cswpth(icol,k) = csnowp(icol,k)
12228                   res(icol,k) = resnow1d(icol,k)
12229                end do
12230             else
12231                do k = kts, kte
12232                   cswpth(icol,k) = 0.0
12233                   res(icol,k) = 10.0
12234                end do
12235             endif
12236
12237 ! Zero out cloud optical properties here, calculated in radiation
12238             do k = kts, kte
12239                do nb = 1, nbndsw
12240                   taucld(icol,k,nb) = 0.0
12241                   ssacld(icol,k,nb) = 1.0
12242                   asmcld(icol,k,nb) = 0.0
12243                   fsfcld(icol,k,nb) = 0.0
12244                enddo
12245             enddo
12246          endif
12247
12248 ! No clouds are allowed in the extra layer from model top to TOA
12249          clwpth(icol,kte+1) = 0.
12250          ciwpth(icol,kte+1) = 0.
12251          cswpth(icol,kte+1) = 0.
12252          rel(icol,kte+1) = 10.
12253          rei(icol,kte+1) = 10.
12254          res(icol,kte+1) = 10.
12255          cldfrac(icol,kte+1) = 0.
12256          do nb = 1, nbndsw
12257             taucld(icol,kte+1,nb) = 0.
12258             ssacld(icol,kte+1,nb) = 1.
12259             asmcld(icol,kte+1,nb) = 0.
12260             fsfcld(icol,kte+1,nb) = 0.
12261          enddo
12262
12263 ! mji - mcica sub-column generator called inside rrtmg_sw for gpu
12264 !         iplon = 1
12265 !         irng = 0
12266 !         permuteseed = 1
12267 ! Sub-column generator for McICA
12268 !         call mcica_subcol_sw(iplon, icol, nlay, icld, permuteseed, irng, play, &
12269 !                       cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
12270 !                       cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
12271 !                       taucmcl, ssacmcl, asmcmcl, fsfcmcl)
12272
12273 !--------------------------------------------------------------------------
12274 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
12275 !--------------------------------------------------------------------------
12276 ! by layer for each RRTMG shortwave band
12277 ! No aerosols in top layer above model top (kte+1).
12278 !cz        do nb = 1, nbndsw
12279 !cz           do k = kts, kte+1
12280 !cz              tauaer(icol,k,nb) = 0.
12281 !cz              ssaaer(icol,k,nb) = 1.
12282 !cz              asmaer(icol,k,nb) = 0.
12283 !cz           enddo
12284 !cz        enddo
12285
12286 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
12287 !
12288       do nb = 1, nbndsw
12289       do k = kts,kte+1
12290          tauaer(icol,k,nb) = 0.
12291          ssaaer(icol,k,nb) = 1.
12292          asmaer(icol,k,nb) = 0.
12293       end do
12294       end do
12295
12296       if ( associated (tauaer3d_sw) ) then
12297 ! ---- jararias 11/2012
12298             do nb=1,nbndsw
12299                do k=kts,kte
12300                   tauaer(icol,k,nb)=tauaer3d_sw(i,k,j,nb)
12301                   ssaaer(icol,k,nb)=ssaaer3d_sw(i,k,j,nb)
12302                   asmaer(icol,k,nb)=asyaer3d_sw(i,k,j,nb)
12303                end do
12304             end do
12305       end if
12306
12307 #if ( WRF_CHEM == 1 )
12308    IF ( AER_RA_FEEDBACK == 1) then
12309       do nb = 1, nbndsw
12310          wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb))  ! um
12311       do k = kts,kte      !wig
12312
12313 ! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
12314 ! tauaer - use angstrom exponent
12315         if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
12316            ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
12317            tauaer(icol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
12318            !tauaer(icol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
12319 !jm TODO need to fix these so they are not writing to stderr, stdout 20141218
12320            if (i==30.and.j==49.and.k==2.and.nb==12) then
12321             write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
12322             print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
12323             write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
12324             print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
12325            endif
12326 ! ssa - linear interpolation; extrapolation
12327            slope=(waer600(i,k,j)-waer400(i,k,j))/.2
12328            ssaaer(icol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
12329            if(ssaaer(icol,k,nb).lt.0.4) ssaaer(icol,k,nb)=0.4
12330            if(ssaaer(icol,k,nb).ge.1.0) ssaaer(icol,k,nb)=1.0
12331 ! g - linear interpolation;extrapolation
12332            slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
12333            asmaer(icol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
12334            if(asmaer(icol,k,nb).lt.0.5) asmaer(icol,k,nb)=0.5
12335            if(asmaer(icol,k,nb).ge.1.0) asmaer(icol,k,nb)=1.0
12336         endif
12337       end do ! k
12338       end do ! nb
12339
12340 !wig beg
12341       do nb = 1, nbndsw
12342          slope = 0.  !use slope as a sum holder
12343          do k = kts,kte
12344             slope = slope + tauaer(icol,k,nb)
12345          end do
12346          if( slope < 0. ) then
12347             write(msg,'("ERROR: Negative total optical depth of ",f8.2,&
12348            & " at point i,j,nb=",3i5)') slope,i,j,nb
12349             call wrf_error_fatal(msg)
12350          else if( slope > 6. ) then
12351             call wrf_message("-------------------------")
12352             write(msg,'("WARNING: Large total sw optical depth of ",f8.2,&
12353            & " at point i,j,nb=",3i5)') slope,i,j,nb
12354             call wrf_message(msg)
12355
12356             call wrf_message("Diagnostics 1: k, tauaer300, tauaer400,&
12357              & tauaer600, tauaer999, tauaer")
12358             do k=kts,kte
12359                write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
12360                     tauaer600(i,k,j), tauaer999(i,k,j),tauaer(icol,k,nb)
12361                call wrf_message(msg)
12362                !czhao set an up-limit here to avoid segmentation fault
12363                !from extreme AOD
12364                tauaer(icol,k,nb)=tauaer(icol,k,nb)*6.0/slope
12365             end do
12366
12367             call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600,&
12368              & gaer999")
12369             do k=kts,kte
12370                write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
12371                     gaer600(i,k,j), gaer999(i,k,j)
12372                call wrf_message(msg)
12373             end do
12374
12375             call wrf_message("Diagnostics 3: k, waer300, waer400, waer600,&
12376              & waer999")
12377             do k=kts,kte
12378                write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
12379                     waer600(i,k,j), waer999(i,k,j)
12380                call wrf_message(msg)
12381             end do
12382
12383             call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
12384             do k=kts-1,kte
12385                write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
12386                call wrf_message(msg)
12387             end do
12388             call wrf_message("-------------------------")
12389          endif
12390       enddo  ! nb
12391       endif  ! aer_ra_feedback
12392 #endif
12393
12394
12395 ! Zero array for input of aerosol optical thickness for use with
12396 ! ECMWF aerosol types (not used)
12397       iaer = 0
12398       do na = 1, naerec
12399          do k = kts, kte+1
12400             ecaer(icol,k,na) = 0.
12401          enddo
12402       enddo
12403
12404       IF ( PRESENT( aerod ) ) THEN
12405       if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 .or. aer_opt .eq. 3 ) then
12406          iaer = 10
12407          do na = 1, naerec
12408             do k = kts, kte+1
12409                ecaer(icol,k,na) = 0.
12410             enddo
12411          enddo
12412       else if ( aer_opt .eq. 1 ) then
12413          iaer = 6
12414          do na = 1, naerec
12415             do k = kts, kte
12416                ecaer(icol,k,na) = aerod(i,k,j,na)
12417             enddo
12418 ! assuming 0 or same value at the top?
12419 !           ecaer(icol,kte+1,na) = ecaer(icol,kte,na)
12420             ecaer(icol,kte+1,na) = 0.
12421          enddo
12422       endif
12423       ENDIF
12424 !
12425 ! End of dorrsw check
12426       endif
12427 ! End of grid loops
12428       enddo i_loop
12429    enddo j_loop
12430
12431 ! Call RRTMG shortwave radiation model
12432 ! Perform shortwave calculation if sun above horizon in any part of grid
12433 ! Do not perform shortwave calculations if all of grid is in darkness
12434       if (icnt .eq. 0) dorrsw = .false.
12435       if (dorrsw) then
12436
12437          call rrtmg_sw &
12438             (rpart   ,ncol    ,nlay    ,icld    ,iaer   , &
12439              play    ,plev    ,tlay    ,tlev    ,tsfc   , &
12440              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr , &
12441              asdir   ,asdif   ,aldir   ,aldif   , &
12442              coszen  ,adjes   ,dyofyr  ,scon    , &
12443              inflgsw ,iceflgsw,liqflgsw,cldfrac , &
12444              taucld  ,ssacld  ,asmcld  ,fsfcld  , &
12445              ciwpth  ,clwpth  ,cswpth  ,rei     ,rel     ,res, &
12446              tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
12447              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc, &
12448 ! -----      Zhenxin added for ssib coupiling 2011-06-20 --------!
12449              sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
12450 ! --------------------   End of addition by Zhenxin 2011-06-20 ------!
12451              swdkdir, swdkdif , swdkdirc          &  ! jararias, 2012/08/10
12452                                                   )
12453
12454       endif
12455
12456
12457 ! Output net absorbed shortwave surface flux and shortwave cloud forcing
12458 ! at the top of atmosphere (W/m2)
12459
12460 ! latitude loop
12461    j_loop2: do j = jts,jte
12462 ! longitude loop
12463       i_loop2: do i = its,ite
12464
12465 ! Use calculated output only if in daylight, otherwise output is zero
12466       dorrsw = .true.
12467       if (coszr(i,j).le.0.0) dorrsw = .false.
12468 ! Complete shortwave calculation if sun above horizon
12469       if (dorrsw) then
12470
12471          if (present(xcoszen)) then
12472             coszr(i,j)=xcoszen(i,j)
12473             coszrs=xcoszen(i,j)
12474          else
12475             call wrf_error_fatal('xcoszen must be passed into RRTMG_SWRAD_FAST')
12476          endif
12477
12478
12479          icol = i-its+1 + (j-jts)*(ite-its+1)
12480
12481          gsw(i,j) = swdflx(icol,1) - swuflx(icol,1)
12482          swcf(i,j) = (swdflx(icol,kte+2) - swuflx(icol,kte+2)) - (swdflxc(icol,kte+2) - swuflxc(icol,kte+2))
12483
12484 ! mji - write
12485 !         swut(i,j) = swuflx(icol,kte+2)
12486 !         swdb(i,j) = swdflx(icol,1)
12487 !
12488          if (present(swupt)) then
12489 ! Output up and down toa fluxes for total and clear sky
12490             swupt(i,j)     = swuflx(icol,kte+2)
12491             swuptc(i,j)    = swuflxc(icol,kte+2)
12492             swdnt(i,j)     = swdflx(icol,kte+2)
12493             swdntc(i,j)    = swdflxc(icol,kte+2)
12494 ! Output up and down surface fluxes for total and clear sky
12495             swupb(i,j)     = swuflx(icol,1)
12496             swupbc(i,j)    = swuflxc(icol,1)
12497             swdnb(i,j)     = swdflx(icol,1)
12498 ! Added by Zhenxin for 4 compenants of swdown radiation
12499             swvisdir(i,j)  = sibvisdir(icol,1)
12500             swvisdif(i,j)  = sibvisdif(icol,1)
12501             swnirdir(i,j)  = sibnirdir(icol,1)
12502             swnirdif(i,j)  = sibnirdif(icol,1)
12503 !  Ended, Zhenxin (2011/06/20)
12504             swdnbc(i,j)    = swdflxc(icol,1)
12505          endif
12506             swddir(i,j)    = swdkdir(icol,1)       ! jararias 2013/08/10
12507             swddni(i,j)    = swddir(i,j) / coszrs  ! jararias 2013/08/10
12508             swddif(i,j)    = swdkdif(icol,1)          ! jararias 2013/08/10
12509             swdownc(i, j)  = swdflxc(1,1)          ! PAJ: clear-sky GHI
12510             swddirc(i,j)   = swdkdirc(1,1)         ! PAJ: clear-sky direct normal irradiance
12511             swddnic(i,j)   = swddirc(i,j) / coszrs ! PAJ: clear-sky direct normal irradiance
12512
12513 ! Output up and down layer fluxes for total and clear sky.
12514 ! Vertical ordering is from bottom to top in units of W m-2.
12515          if ( present (swupflx) ) then
12516          do k=kts,kte+2
12517             swupflx(i,k,j)  = swuflx(icol,k)
12518             swupflxc(i,k,j) = swuflxc(icol,k)
12519             swdnflx(i,k,j)  = swdflx(icol,k)
12520             swdnflxc(i,k,j) = swdflxc(icol,k)
12521          enddo
12522          endif
12523
12524 ! Output heating rate tendency; convert heating rate from K/d to K/s
12525 ! Heating rate arrays are ordered vertically from bottom to top here.
12526          do k=kts,kte
12527             tten1d(k) = swhr(icol,k)/86400.
12528             rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
12529             tten1d(k) = swhrc(icol,k)/86400.
12530             rthratenswc(i,k,j) = tten1d(k)/pi3d(i,k,j)
12531          enddo
12532
12533       else
12534          if (present(swupt)) then
12535 ! Output up and down toa fluxes for total and clear sky
12536             swupt(i,j)     = 0.
12537             swuptc(i,j)    = 0.
12538             swdnt(i,j)     = 0.
12539             swdntc(i,j)    = 0.
12540 ! Output up and down surface fluxes for total and clear sky
12541             swupb(i,j)     = 0.
12542             swupbc(i,j)    = 0.
12543             swdnb(i,j)     = 0.
12544             swdnbc(i,j)    = 0.
12545             swvisdir(i,j)  = 0.  ! Add by Zhenxin (2011/06/20)
12546             swvisdif(i,j)  = 0.
12547             swnirdir(i,j)  = 0.
12548             swnirdif(i,j)  = 0.  ! Add by Zhenxin (2011/06/20)
12549          endif
12550             swddir(i,j)    = 0.  ! jararias 2013/08/10
12551             swddni(i,j)    = 0.  ! jararias 2013/08/10
12552             swddif(i,j)    = 0.  ! jararias 2013/08/10
12553             swdownc(i, j)  = 0.0 ! PAJ
12554             swddnic(i,j)   = 0.0 ! PAJ
12555             swddirc(i,j)   = 0.0 ! PAJ
12556             swcf(i,j)      = 0.
12557
12558       endif
12559
12560       end do i_loop2
12561    end do j_loop2
12562
12563 ! mji - write
12564 !      do j=jts,jte
12565 !      write(62,995) (swut(i,j),i=its,ite)
12566 !      enddo
12567 !      do j=jts,jte
12568 !      write(62,995) (swdb(i,j),i=its,ite)
12569 !      enddo
12570 ! 995  format(1p6e12.5)
12571
12572 !-------------------------------------------------------------------
12573
12574    END SUBROUTINE RRTMG_SWRAD_FAST
12575
12576
12577 !====================================================================
12578    SUBROUTINE rrtmg_swinit_fast(                                         &
12579                        allowed_to_read ,                            &
12580                        ids, ide, jds, jde, kds, kde,                &
12581                        ims, ime, jms, jme, kms, kme,                &
12582                        its, ite, jts, jte, kts, kte                 )
12583 !--------------------------------------------------------------------
12584    IMPLICIT NONE
12585 !--------------------------------------------------------------------
12586
12587    LOGICAL , INTENT(IN)           :: allowed_to_read
12588    INTEGER , INTENT(IN)           :: ids, ide, jds, jde, kds, kde,  &
12589                                      ims, ime, jms, jme, kms, kme,  &
12590                                      its, ite, jts, jte, kts, kte
12591
12592 ! Read in absorption coefficients and other data
12593    IF ( allowed_to_read ) THEN
12594      CALL rrtmg_swlookuptable
12595    ENDIF
12596
12597 ! Perform g-point reduction and other initializations
12598 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
12599    call rrtmg_sw_ini(cp)
12600
12601    END SUBROUTINE rrtmg_swinit_fast
12602
12603
12604 ! **************************************************************************
12605       SUBROUTINE rrtmg_swlookuptable
12606 ! **************************************************************************
12607
12608       IMPLICIT NONE
12609
12610 ! Local
12611       INTEGER :: i
12612       LOGICAL                 :: opened
12613       LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
12614
12615       CHARACTER*80 errmess
12616       INTEGER rrtmg_unit
12617
12618       IF ( wrf_dm_on_monitor() ) THEN
12619         DO i = 10,99
12620           INQUIRE ( i , OPENED = opened )
12621           IF ( .NOT. opened ) THEN
12622             rrtmg_unit = i
12623             GOTO 2010
12624           ENDIF
12625         ENDDO
12626         rrtmg_unit = -1
12627  2010   CONTINUE
12628       ENDIF
12629       CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
12630       IF ( rrtmg_unit < 0 ) THEN
12631         CALL wrf_error_fatal ( 'module_ra_rrtmg_swf: rrtm_swlookuptable: Can not '// &
12632                                'find unused fortran unit to read in lookup table.' )
12633       ENDIF
12634
12635       IF ( wrf_dm_on_monitor() ) THEN
12636         OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA',                  &
12637              FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
12638       ENDIF
12639
12640       call sw_kgb16(rrtmg_unit)
12641       call sw_kgb17(rrtmg_unit)
12642       call sw_kgb18(rrtmg_unit)
12643       call sw_kgb19(rrtmg_unit)
12644       call sw_kgb20(rrtmg_unit)
12645       call sw_kgb21(rrtmg_unit)
12646       call sw_kgb22(rrtmg_unit)
12647       call sw_kgb23(rrtmg_unit)
12648       call sw_kgb24(rrtmg_unit)
12649       call sw_kgb25(rrtmg_unit)
12650       call sw_kgb26(rrtmg_unit)
12651       call sw_kgb27(rrtmg_unit)
12652       call sw_kgb28(rrtmg_unit)
12653       call sw_kgb29(rrtmg_unit)
12654
12655       IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
12656
12657       RETURN
12658 9009  CONTINUE
12659       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error opening '// &
12660                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
12661       CALL wrf_error_fatal(errmess)
12662
12663       END SUBROUTINE rrtmg_swlookuptable
12664
12665 ! **************************************************************************
12666 !  RRTMG Shortwave Radiative Transfer Model
12667 !  Atmospheric and Environmental Research, Inc., Cambridge, MA
12668 !
12669 !  Original by J.Delamere, Atmospheric & Environmental Research.
12670 !  Reformatted for F90: JJMorcrette, ECMWF
12671 !  Revision for GCMs:  Michael J. Iacono, AER, July 2002
12672 !  Further F90 reformatting:  Michael J. Iacono, AER, June 2006
12673 !
12674 !  This file contains 14 READ statements that include the
12675 !  absorption coefficients and other data for each of the 14 shortwave
12676 !  spectral bands used in RRTMG_SW.  Here, the data are defined for 16
12677 !  g-points, or sub-intervals, per band.  These data are combined and
12678 !  weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
12679 !  the total number of g-points from 224 to 112 for use in the GCM.
12680 ! **************************************************************************
12681
12682 ! **************************************************************************
12683       subroutine sw_kgb16(rrtmg_unit)
12684 ! **************************************************************************
12685
12686       use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12687                             rayl, strrat1, layreffr
12688 !      use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
12689 !      use rrtmg_sw_taumol, only : strrat1, layreffr
12690
12691       implicit none
12692       save
12693
12694 ! Input
12695       integer, intent(in) :: rrtmg_unit
12696
12697 ! Local
12698       character*80 errmess
12699       logical, external  :: wrf_dm_on_monitor
12700
12701 !     Array sfluxrefo contains the Kurucz solar source function for this band.
12702
12703 !     Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
12704
12705 !     The array KAO contains absorption coefs at the 16 chosen g-values
12706 !     for a range of pressure levels> ~100mb, temperatures, and binary
12707 !     species parameters (see taumol.f for definition).  The first
12708 !     index in the array, JS, runs from 1 to 9, and corresponds to
12709 !     different values of the binary species parameter.  For instance,
12710 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12711 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
12712 !     in the array, JT, which runs from 1 to 5, corresponds to different
12713 !     temperatures.  More specifically, JT = 3 means that the data are for
12714 !     the reference temperature TREF for this  pressure level, JT = 2 refers
12715 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12716 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12717 !     to the JPth reference pressure level (see taumol.f for these levels
12718 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
12719 !     which g-interval the absorption coefficients are for.
12720
12721 !     The array KBO contains absorption coefs at the 16 chosen g-values
12722 !     for a range of pressure levels < ~100mb and temperatures. The first
12723 !     index in the array, JT, which runs from 1 to 5, corresponds to
12724 !     different temperatures.  More specifically, JT = 3 means that the
12725 !     data are for the reference temperature TREF for this pressure
12726 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12727 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12728 !     The second index, JP, runs from 13 to 59 and refers to the JPth
12729 !     reference pressure level (see taumol.f for the value of these
12730 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
12731 !     and tells us which g-interval the absorption coefficients are for.
12732
12733 !     The array FORREFO contains the coefficient of the water vapor
12734 !     foreign-continuum (including the energy term).  The first
12735 !     index refers to reference temperature (296,260,224,260) and
12736 !     pressure (970,475,219,3 mbar) levels.  The second index
12737 !     runs over the g-channel (1 to 16).
12738
12739 !     The array SELFREFO contains the coefficient of the water vapor
12740 !     self-continuum (including the energy term).  The first index
12741 !     refers to temperature in 7.2 degree increments.  For instance,
12742 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12743 !     etc.  The second index runs over the g-channel (1 to 16).
12744
12745 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12746 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12747 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12748
12749       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12750          rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12751       DM_BCAST_REAL(rayl)
12752       DM_BCAST_REAL(strrat1)
12753       DM_BCAST_INTEGER(layreffr)
12754       DM_BCAST_MACRO(kao)
12755       DM_BCAST_MACRO(kbo)
12756       DM_BCAST_MACRO(selfrefo)
12757       DM_BCAST_MACRO(forrefo)
12758       DM_BCAST_MACRO(sfluxrefo)
12759
12760       RETURN
12761 9010  CONTINUE
12762       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
12763                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
12764       CALL wrf_error_fatal(errmess)
12765
12766       end subroutine sw_kgb16
12767
12768 ! **************************************************************************
12769       subroutine sw_kgb17(rrtmg_unit)
12770 ! **************************************************************************
12771
12772       use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12773                             rayl, strrat, layreffr
12774 !      use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
12775 !      use rrtmg_sw_taumol, only : strrat, layreffr
12776
12777       implicit none
12778       save
12779
12780 ! Input
12781       integer, intent(in) :: rrtmg_unit
12782
12783 ! Local
12784       character*80 errmess
12785       logical, external  :: wrf_dm_on_monitor
12786
12787 !     Array sfluxrefo contains the Kurucz solar source function for this band.
12788
12789 !     Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
12790
12791 !     The array KAO contains absorption coefs at the 16 chosen g-values
12792 !     for a range of pressure levels> ~100mb, temperatures, and binary
12793 !     species parameters (see taumol.f for definition).  The first
12794 !     index in the array, JS, runs from 1 to 9, and corresponds to
12795 !     different values of the binary species parameter.  For instance,
12796 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12797 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
12798 !     in the array, JT, which runs from 1 to 5, corresponds to different
12799 !     temperatures.  More specifically, JT = 3 means that the data are for
12800 !     the reference temperature TREF for this  pressure level, JT = 2 refers
12801 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12802 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12803 !     to the JPth reference pressure level (see taumol.f for these levels
12804 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
12805 !     which g-interval the absorption coefficients are for.
12806
12807 !     The array KBO contains absorption coefs at the 16 chosen g-values
12808 !     for a range of pressure levels < ~100mb and temperatures. The first
12809 !     index in the array, JT, which runs from 1 to 5, corresponds to
12810 !     different temperatures.  More specifically, JT = 3 means that the
12811 !     data are for the reference temperature TREF for this pressure
12812 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12813 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12814 !     The second index, JP, runs from 13 to 59 and refers to the JPth
12815 !     reference pressure level (see taumol.f for the value of these
12816 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
12817 !     and tells us which g-interval the absorption coefficients are for.
12818
12819 !     The array FORREFO contains the coefficient of the water vapor
12820 !     foreign-continuum (including the energy term).  The first
12821 !     index refers to reference temperature (296,260,224,260) and
12822 !     pressure (970,475,219,3 mbar) levels.  The second index
12823 !     runs over the g-channel (1 to 16).
12824
12825 !     The array SELFREFO contains the coefficient of the water vapor
12826 !     self-continuum (including the energy term).  The first index
12827 !     refers to temperature in 7.2 degree increments.  For instance,
12828 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12829 !     etc.  The second index runs over the g-channel (1 to 16).
12830
12831 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12832 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12833 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12834
12835       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12836          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12837       DM_BCAST_REAL(rayl)
12838       DM_BCAST_REAL(strrat)
12839       DM_BCAST_INTEGER(layreffr)
12840       DM_BCAST_MACRO(kao)
12841       DM_BCAST_MACRO(kbo)
12842       DM_BCAST_MACRO(selfrefo)
12843       DM_BCAST_MACRO(forrefo)
12844       DM_BCAST_MACRO(sfluxrefo)
12845
12846       RETURN
12847 9010  CONTINUE
12848       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
12849                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
12850       CALL wrf_error_fatal(errmess)
12851
12852       end subroutine sw_kgb17
12853
12854 ! **************************************************************************
12855       subroutine sw_kgb18(rrtmg_unit)
12856 ! **************************************************************************
12857
12858       use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12859                             rayl, strrat, layreffr
12860 !      use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
12861 !      use rrtmg_sw_taumol, only : strrat, layreffr
12862
12863       implicit none
12864       save
12865
12866 ! Input
12867       integer, intent(in) :: rrtmg_unit
12868
12869 ! Local
12870       character*80 errmess
12871       logical, external  :: wrf_dm_on_monitor
12872
12873 !     Array sfluxrefo contains the Kurucz solar source function for this band.
12874
12875 !     Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
12876
12877 !     The array KAO contains absorption coefs at the 16 chosen g-values
12878 !     for a range of pressure levels> ~100mb, temperatures, and binary
12879 !     species parameters (see taumol.f for definition).  The first
12880 !     index in the array, JS, runs from 1 to 9, and corresponds to
12881 !     different values of the binary species parameter.  For instance,
12882 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12883 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
12884 !     in the array, JT, which runs from 1 to 5, corresponds to different
12885 !     temperatures.  More specifically, JT = 3 means that the data are for
12886 !     the reference temperature TREF for this  pressure level, JT = 2 refers
12887 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12888 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12889 !     to the JPth reference pressure level (see taumol.f for these levels
12890 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
12891 !     which g-interval the absorption coefficients are for.
12892
12893 !     The array KBO contains absorption coefs at the 16 chosen g-values
12894 !     for a range of pressure levels < ~100mb and temperatures. The first
12895 !     index in the array, JT, which runs from 1 to 5, corresponds to
12896 !     different temperatures.  More specifically, JT = 3 means that the
12897 !     data are for the reference temperature TREF for this pressure
12898 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12899 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12900 !     The second index, JP, runs from 13 to 59 and refers to the JPth
12901 !     reference pressure level (see taumol.f for the value of these
12902 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
12903 !     and tells us which g-interval the absorption coefficients are for.
12904
12905 !     The array FORREFO contains the coefficient of the water vapor
12906 !     foreign-continuum (including the energy term).  The first
12907 !     index refers to reference temperature (296,260,224,260) and
12908 !     pressure (970,475,219,3 mbar) levels.  The second index
12909 !     runs over the g-channel (1 to 16).
12910
12911 !     The array SELFREFO contains the coefficient of the water vapor
12912 !     self-continuum (including the energy term).  The first index
12913 !     refers to temperature in 7.2 degree increments.  For instance,
12914 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
12915 !     etc.  The second index runs over the g-channel (1 to 16).
12916
12917 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
12918 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
12919 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
12920
12921       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
12922          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
12923       DM_BCAST_REAL(rayl)
12924       DM_BCAST_REAL(strrat)
12925       DM_BCAST_INTEGER(layreffr)
12926       DM_BCAST_MACRO(kao)
12927       DM_BCAST_MACRO(kbo)
12928       DM_BCAST_MACRO(selfrefo)
12929       DM_BCAST_MACRO(forrefo)
12930       DM_BCAST_MACRO(sfluxrefo)
12931
12932       RETURN
12933 9010  CONTINUE
12934       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
12935                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
12936       CALL wrf_error_fatal(errmess)
12937
12938       end subroutine sw_kgb18
12939
12940 ! **************************************************************************
12941       subroutine sw_kgb19(rrtmg_unit)
12942 ! **************************************************************************
12943
12944       use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
12945                             rayl, strrat, layreffr
12946 !      use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
12947 !      use rrtmg_sw_taumol, only : strrat, layreffr
12948
12949       implicit none
12950       save
12951
12952 ! Input
12953       integer, intent(in) :: rrtmg_unit
12954
12955 ! Local
12956       character*80 errmess
12957       logical, external  :: wrf_dm_on_monitor
12958
12959 !     Array sfluxrefo contains the Kurucz solar source function for this band.
12960
12961 !     Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
12962
12963 !     The array KAO contains absorption coefs at the 16 chosen g-values
12964 !     for a range of pressure levels> ~100mb, temperatures, and binary
12965 !     species parameters (see taumol.f for definition).  The first
12966 !     index in the array, JS, runs from 1 to 9, and corresponds to
12967 !     different values of the binary species parameter.  For instance,
12968 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
12969 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
12970 !     in the array, JT, which runs from 1 to 5, corresponds to different
12971 !     temperatures.  More specifically, JT = 3 means that the data are for
12972 !     the reference temperature TREF for this  pressure level, JT = 2 refers
12973 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
12974 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
12975 !     to the JPth reference pressure level (see taumol.f for these levels
12976 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
12977 !     which g-interval the absorption coefficients are for.
12978
12979 !     The array KBO contains absorption coefs at the 16 chosen g-values
12980 !     for a range of pressure levels < ~100mb and temperatures. The first
12981 !     index in the array, JT, which runs from 1 to 5, corresponds to
12982 !     different temperatures.  More specifically, JT = 3 means that the
12983 !     data are for the reference temperature TREF for this pressure
12984 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
12985 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
12986 !     The second index, JP, runs from 13 to 59 and refers to the JPth
12987 !     reference pressure level (see taumol.f for the value of these
12988 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
12989 !     and tells us which g-interval the absorption coefficients are for.
12990
12991 !     The array FORREFO contains the coefficient of the water vapor
12992 !     foreign-continuum (including the energy term).  The first
12993 !     index refers to reference temperature (296,260,224,260) and
12994 !     pressure (970,475,219,3 mbar) levels.  The second index
12995 !     runs over the g-channel (1 to 16).
12996
12997 !     The array SELFREFO contains the coefficient of the water vapor
12998 !     self-continuum (including the energy term).  The first index
12999 !     refers to temperature in 7.2 degree increments.  For instance,
13000 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13001 !     etc.  The second index runs over the g-channel (1 to 16).
13002
13003 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13004 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13005 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13006
13007       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13008          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
13009       DM_BCAST_REAL(rayl)
13010       DM_BCAST_REAL(strrat)
13011       DM_BCAST_INTEGER(layreffr)
13012       DM_BCAST_MACRO(kao)
13013       DM_BCAST_MACRO(kbo)
13014       DM_BCAST_MACRO(selfrefo)
13015       DM_BCAST_MACRO(forrefo)
13016       DM_BCAST_MACRO(sfluxrefo)
13017
13018       RETURN
13019 9010  CONTINUE
13020       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13021                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13022       CALL wrf_error_fatal(errmess)
13023
13024       end subroutine sw_kgb19
13025
13026 ! **************************************************************************
13027       subroutine sw_kgb20(rrtmg_unit)
13028 ! **************************************************************************
13029
13030       use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13031                             absch4o, rayl, layreffr
13032 !      use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13033 !                            absch4o, rayl
13034 !      use rrtmg_sw_taumol, only : layreffr
13035
13036       implicit none
13037       save
13038
13039 ! Input
13040       integer, intent(in) :: rrtmg_unit
13041
13042 ! Local
13043       character*80 errmess
13044       logical, external  :: wrf_dm_on_monitor
13045
13046 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13047
13048 !     Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
13049
13050 !     Array absch4o contains the absorption coefficients for methane.
13051
13052 !     The array KAO contains absorption coefs at the 16 chosen g-values
13053 !     for a range of pressure levels> ~100mb, temperatures, and binary
13054 !     species parameters (see taumol.f for definition).  The first
13055 !     index in the array, JS, runs from 1 to 9, and corresponds to
13056 !     different values of the binary species parameter.  For instance,
13057 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13058 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13059 !     in the array, JT, which runs from 1 to 5, corresponds to different
13060 !     temperatures.  More specifically, JT = 3 means that the data are for
13061 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13062 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13063 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13064 !     to the JPth reference pressure level (see taumol.f for these levels
13065 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13066 !     which g-interval the absorption coefficients are for.
13067
13068 !     The array KBO contains absorption coefs at the 16 chosen g-values
13069 !     for a range of pressure levels < ~100mb and temperatures. The first
13070 !     index in the array, JT, which runs from 1 to 5, corresponds to
13071 !     different temperatures.  More specifically, JT = 3 means that the
13072 !     data are for the reference temperature TREF for this pressure
13073 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13074 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13075 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13076 !     reference pressure level (see taumol.f for the value of these
13077 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13078 !     and tells us which g-interval the absorption coefficients are for.
13079
13080 !     The array FORREFO contains the coefficient of the water vapor
13081 !     foreign-continuum (including the energy term).  The first
13082 !     index refers to reference temperature (296,260,224,260) and
13083 !     pressure (970,475,219,3 mbar) levels.  The second index
13084 !     runs over the g-channel (1 to 16).
13085
13086 !     The array SELFREFO contains the coefficient of the water vapor
13087 !     self-continuum (including the energy term).  The first index
13088 !     refers to temperature in 7.2 degree increments.  For instance,
13089 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13090 !     etc.  The second index runs over the g-channel (1 to 16).
13091
13092 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13093 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13094 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13095
13096       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13097          rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
13098       DM_BCAST_REAL(rayl)
13099       DM_BCAST_INTEGER(layreffr)
13100       DM_BCAST_MACRO(absch4o)
13101       DM_BCAST_MACRO(kao)
13102       DM_BCAST_MACRO(kbo)
13103       DM_BCAST_MACRO(selfrefo)
13104       DM_BCAST_MACRO(forrefo)
13105       DM_BCAST_MACRO(sfluxrefo)
13106
13107       RETURN
13108 9010  CONTINUE
13109       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13110                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13111       CALL wrf_error_fatal(errmess)
13112
13113       end subroutine sw_kgb20
13114
13115 ! **************************************************************************
13116       subroutine sw_kgb21(rrtmg_unit)
13117 ! **************************************************************************
13118
13119       use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13120                             rayl, strrat, layreffr
13121 !      use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
13122 !      use rrtmg_sw_taumol, only : strrat, layreffr
13123
13124       implicit none
13125       save
13126
13127 ! Input
13128       integer, intent(in) :: rrtmg_unit
13129
13130 ! Local
13131       character*80 errmess
13132       logical, external  :: wrf_dm_on_monitor
13133
13134 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13135
13136 !     Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
13137
13138 !     The array KAO contains absorption coefs at the 16 chosen g-values
13139 !     for a range of pressure levels> ~100mb, temperatures, and binary
13140 !     species parameters (see taumol.f for definition).  The first
13141 !     index in the array, JS, runs from 1 to 9, and corresponds to
13142 !     different values of the binary species parameter.  For instance,
13143 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13144 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13145 !     in the array, JT, which runs from 1 to 5, corresponds to different
13146 !     temperatures.  More specifically, JT = 3 means that the data are for
13147 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13148 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13149 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13150 !     to the JPth reference pressure level (see taumol.f for these levels
13151 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13152 !     which g-interval the absorption coefficients are for.
13153
13154 !     The array KBO contains absorption coefs at the 16 chosen g-values
13155 !     for a range of pressure levels < ~100mb and temperatures. The first
13156 !     index in the array, JT, which runs from 1 to 5, corresponds to
13157 !     different temperatures.  More specifically, JT = 3 means that the
13158 !     data are for the reference temperature TREF for this pressure
13159 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13160 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13161 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13162 !     reference pressure level (see taumol.f for the value of these
13163 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13164 !     and tells us which g-interval the absorption coefficients are for.
13165
13166 !     The array FORREFO contains the coefficient of the water vapor
13167 !     foreign-continuum (including the energy term).  The first
13168 !     index refers to reference temperature (296,260,224,260) and
13169 !     pressure (970,475,219,3 mbar) levels.  The second index
13170 !     runs over the g-channel (1 to 16).
13171
13172 !     The array SELFREFO contains the coefficient of the water vapor
13173 !     self-continuum (including the energy term).  The first index
13174 !     refers to temperature in 7.2 degree increments.  For instance,
13175 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13176 !     etc.  The second index runs over the g-channel (1 to 16).
13177
13178 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13179 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13180 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13181
13182       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13183          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
13184       DM_BCAST_REAL(rayl)
13185       DM_BCAST_REAL(strrat)
13186       DM_BCAST_INTEGER(layreffr)
13187       DM_BCAST_MACRO(kao)
13188       DM_BCAST_MACRO(kbo)
13189       DM_BCAST_MACRO(selfrefo)
13190       DM_BCAST_MACRO(forrefo)
13191       DM_BCAST_MACRO(sfluxrefo)
13192
13193       RETURN
13194 9010  CONTINUE
13195       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13196                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13197       CALL wrf_error_fatal(errmess)
13198
13199       end subroutine sw_kgb21
13200
13201 ! **************************************************************************
13202       subroutine sw_kgb22(rrtmg_unit)
13203 ! **************************************************************************
13204
13205       use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13206                             rayl, strrat, layreffr
13207 !      use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
13208 !      use rrtmg_sw_taumol, only : strrat, layreffr
13209
13210       implicit none
13211       save
13212
13213 ! Input
13214       integer, intent(in) :: rrtmg_unit
13215
13216 ! Local
13217       character*80 errmess
13218       logical, external  :: wrf_dm_on_monitor
13219
13220 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13221
13222 !     Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
13223
13224 !     The array KAO contains absorption coefs at the 16 chosen g-values
13225 !     for a range of pressure levels> ~100mb, temperatures, and binary
13226 !     species parameters (see taumol.f for definition).  The first
13227 !     index in the array, JS, runs from 1 to 9, and corresponds to
13228 !     different values of the binary species parameter.  For instance,
13229 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13230 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13231 !     in the array, JT, which runs from 1 to 5, corresponds to different
13232 !     temperatures.  More specifically, JT = 3 means that the data are for
13233 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13234 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13235 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13236 !     to the JPth reference pressure level (see taumol.f for these levels
13237 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13238 !     which g-interval the absorption coefficients are for.
13239
13240 !     The array KBO contains absorption coefs at the 16 chosen g-values
13241 !     for a range of pressure levels < ~100mb and temperatures. The first
13242 !     index in the array, JT, which runs from 1 to 5, corresponds to
13243 !     different temperatures.  More specifically, JT = 3 means that the
13244 !     data are for the reference temperature TREF for this pressure
13245 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13246 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13247 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13248 !     reference pressure level (see taumol.f for the value of these
13249 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13250 !     and tells us which g-interval the absorption coefficients are for.
13251
13252 !     The array FORREFO contains the coefficient of the water vapor
13253 !     foreign-continuum (including the energy term).  The first
13254 !     index refers to reference temperature (296,260,224,260) and
13255 !     pressure (970,475,219,3 mbar) levels.  The second index
13256 !     runs over the g-channel (1 to 16).
13257
13258 !     The array SELFREFO contains the coefficient of the water vapor
13259 !     self-continuum (including the energy term).  The first index
13260 !     refers to temperature in 7.2 degree increments.  For instance,
13261 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13262 !     etc.  The second index runs over the g-channel (1 to 16).
13263
13264 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13265 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13266 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13267
13268       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13269          rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
13270       DM_BCAST_REAL(rayl)
13271       DM_BCAST_REAL(strrat)
13272       DM_BCAST_INTEGER(layreffr)
13273       DM_BCAST_MACRO(kao)
13274       DM_BCAST_MACRO(kbo)
13275       DM_BCAST_MACRO(selfrefo)
13276       DM_BCAST_MACRO(forrefo)
13277       DM_BCAST_MACRO(sfluxrefo)
13278
13279       RETURN
13280 9010  CONTINUE
13281       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13282                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13283       CALL wrf_error_fatal(errmess)
13284
13285       end subroutine sw_kgb22
13286
13287 ! **************************************************************************
13288       subroutine sw_kgb23(rrtmg_unit)
13289 ! **************************************************************************
13290
13291       use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, &
13292                             raylo, givfac, layreffr
13293 !      use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo
13294 !      use rrtmg_sw_taumol, only : givfac, layreffr
13295
13296       implicit none
13297       save
13298
13299 ! Input
13300       integer, intent(in) :: rrtmg_unit
13301
13302 ! Local
13303       character*80 errmess
13304       logical, external  :: wrf_dm_on_monitor
13305
13306 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13307
13308 !     Array raylo contains the Rayleigh extinction coefficient at all v for this band
13309
13310 !     Array givfac is the average Giver et al. correction factor for this band.
13311
13312 !     The array KAO contains absorption coefs at the 16 chosen g-values
13313 !     for a range of pressure levels> ~100mb, temperatures, and binary
13314 !     species parameters (see taumol.f for definition).  The first
13315 !     index in the array, JS, runs from 1 to 9, and corresponds to
13316 !     different values of the binary species parameter.  For instance,
13317 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13318 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13319 !     in the array, JT, which runs from 1 to 5, corresponds to different
13320 !     temperatures.  More specifically, JT = 3 means that the data are for
13321 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13322 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13323 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13324 !     to the JPth reference pressure level (see taumol.f for these levels
13325 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13326 !     which g-interval the absorption coefficients are for.
13327
13328 !     The array FORREFO contains the coefficient of the water vapor
13329 !     foreign-continuum (including the energy term).  The first
13330 !     index refers to reference temperature (296,260,224,260) and
13331 !     pressure (970,475,219,3 mbar) levels.  The second index
13332 !     runs over the g-channel (1 to 16).
13333
13334 !     The array SELFREFO contains the coefficient of the water vapor
13335 !     self-continuum (including the energy term).  The first index
13336 !     refers to temperature in 7.2 degree increments.  For instance,
13337 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13338 !     etc.  The second index runs over the g-channel (1 to 16).
13339
13340 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13341 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13342 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13343
13344       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13345          raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
13346       DM_BCAST_MACRO(raylo)
13347       DM_BCAST_REAL(givfac)
13348       DM_BCAST_INTEGER(layreffr)
13349       DM_BCAST_MACRO(kao)
13350       DM_BCAST_MACRO(selfrefo)
13351       DM_BCAST_MACRO(forrefo)
13352       DM_BCAST_MACRO(sfluxrefo)
13353
13354       RETURN
13355 9010  CONTINUE
13356       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13357                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13358       CALL wrf_error_fatal(errmess)
13359
13360       end subroutine sw_kgb23
13361
13362 ! **************************************************************************
13363       subroutine sw_kgb24(rrtmg_unit)
13364 ! **************************************************************************
13365
13366       use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13367                             raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
13368 !      use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13369 !                            raylao, raylbo, abso3ao, abso3bo
13370 !      use rrtmg_sw_taumol, only : strrat, layreffr
13371
13372       implicit none
13373       save
13374
13375 ! Input
13376       integer, intent(in) :: rrtmg_unit
13377
13378 ! Local
13379       character*80 errmess
13380       logical, external  :: wrf_dm_on_monitor
13381
13382 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13383
13384 !     Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
13385 !     all v for this band for the upper and lower atmosphere.
13386
13387 !     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
13388 !     all v for this band for the upper and lower atmosphere.
13389
13390 !     The array KAO contains absorption coefs at the 16 chosen g-values
13391 !     for a range of pressure levels> ~100mb, temperatures, and binary
13392 !     species parameters (see taumol.f for definition).  The first
13393 !     index in the array, JS, runs from 1 to 9, and corresponds to
13394 !     different values of the binary species parameter.  For instance,
13395 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13396 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13397 !     in the array, JT, which runs from 1 to 5, corresponds to different
13398 !     temperatures.  More specifically, JT = 3 means that the data are for
13399 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13400 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13401 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13402 !     to the JPth reference pressure level (see taumol.f for these levels
13403 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13404 !     which g-interval the absorption coefficients are for.
13405
13406 !     The array KBO contains absorption coefs at the 16 chosen g-values
13407 !     for a range of pressure levels < ~100mb and temperatures. The first
13408 !     index in the array, JT, which runs from 1 to 5, corresponds to
13409 !     different temperatures.  More specifically, JT = 3 means that the
13410 !     data are for the reference temperature TREF for this pressure
13411 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13412 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13413 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13414 !     reference pressure level (see taumol.f for the value of these
13415 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13416 !     and tells us which g-interval the absorption coefficients are for.
13417
13418 !     The array FORREFO contains the coefficient of the water vapor
13419 !     foreign-continuum (including the energy term).  The first
13420 !     index refers to reference temperature (296,260,224,260) and
13421 !     pressure (970,475,219,3 mbar) levels.  The second index
13422 !     runs over the g-channel (1 to 16).
13423
13424 !     The array SELFREFO contains the coefficient of the water vapor
13425 !     self-continuum (including the energy term).  The first index
13426 !     refers to temperature in 7.2 degree increments.  For instance,
13427 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13428 !     etc.  The second index runs over the g-channel (1 to 16).
13429
13430 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13431 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13432 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13433
13434       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13435          raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
13436          forrefo, sfluxrefo
13437       DM_BCAST_MACRO(raylao)
13438       DM_BCAST_MACRO(raylbo)
13439       DM_BCAST_REAL(strrat)
13440       DM_BCAST_INTEGER(layreffr)
13441       DM_BCAST_MACRO(abso3ao)
13442       DM_BCAST_MACRO(abso3bo)
13443       DM_BCAST_MACRO(kao)
13444       DM_BCAST_MACRO(kbo)
13445       DM_BCAST_MACRO(selfrefo)
13446       DM_BCAST_MACRO(forrefo)
13447       DM_BCAST_MACRO(sfluxrefo)
13448
13449       RETURN
13450 9010  CONTINUE
13451       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13452                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13453       CALL wrf_error_fatal(errmess)
13454
13455       end subroutine sw_kgb24
13456
13457 ! **************************************************************************
13458       subroutine sw_kgb25(rrtmg_unit)
13459 ! **************************************************************************
13460
13461       use rrsw_kg25_f, only : kao, sfluxrefo, &
13462                             raylo, abso3ao, abso3bo, layreffr
13463 !      use rrsw_kg25_f, only : kao, sfluxrefo, raylo, abso3ao, abso3bo
13464 !      use rrtmg_sw_taumol, only : layreffr
13465
13466       implicit none
13467       save
13468
13469 ! Input
13470       integer, intent(in) :: rrtmg_unit
13471
13472 ! Local
13473       character*80 errmess
13474       logical, external  :: wrf_dm_on_monitor
13475
13476 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13477
13478 !     Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
13479
13480 !     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
13481 !     all v for this band for the upper and lower atmosphere.
13482
13483 !     The array KAO contains absorption coefs at the 16 chosen g-values
13484 !     for a range of pressure levels> ~100mb, temperatures, and binary
13485 !     species parameters (see taumol.f for definition).  The first
13486 !     index in the array, JS, runs from 1 to 9, and corresponds to
13487 !     different values of the binary species parameter.  For instance,
13488 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13489 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13490 !     in the array, JT, which runs from 1 to 5, corresponds to different
13491 !     temperatures.  More specifically, JT = 3 means that the data are for
13492 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13493 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13494 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13495 !     to the JPth reference pressure level (see taumol.f for these levels
13496 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13497 !     which g-interval the absorption coefficients are for.
13498
13499 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13500 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13501
13502       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13503          raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
13504       DM_BCAST_MACRO(raylo)
13505       DM_BCAST_INTEGER(layreffr)
13506       DM_BCAST_MACRO(abso3ao)
13507       DM_BCAST_MACRO(abso3bo)
13508       DM_BCAST_MACRO(kao)
13509       DM_BCAST_MACRO(sfluxrefo)
13510
13511       RETURN
13512 9010  CONTINUE
13513       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13514                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13515       CALL wrf_error_fatal(errmess)
13516
13517       end subroutine sw_kgb25
13518
13519 ! **************************************************************************
13520       subroutine sw_kgb26(rrtmg_unit)
13521 ! **************************************************************************
13522
13523       use rrsw_kg26_f, only : sfluxrefo, raylo
13524
13525       implicit none
13526       save
13527
13528 ! Input
13529       integer, intent(in) :: rrtmg_unit
13530
13531 ! Local
13532       character*80 errmess
13533       logical, external  :: wrf_dm_on_monitor
13534
13535 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13536
13537 !     Array raylo contains the Rayleigh extinction coefficient at all v for this band.
13538
13539 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13540
13541       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13542          raylo, sfluxrefo
13543       DM_BCAST_MACRO(raylo)
13544       DM_BCAST_MACRO(sfluxrefo)
13545
13546       RETURN
13547 9010  CONTINUE
13548       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13549                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13550       CALL wrf_error_fatal(errmess)
13551
13552       end subroutine sw_kgb26
13553
13554 ! **************************************************************************
13555       subroutine sw_kgb27(rrtmg_unit)
13556 ! **************************************************************************
13557
13558       use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, &
13559                             scalekur, layreffr
13560 !      use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo
13561 !      use rrtmg_sw_taumol, only : scalekur, layreffr
13562
13563       implicit none
13564       save
13565
13566 ! Input
13567       integer, intent(in) :: rrtmg_unit
13568
13569 ! Local
13570       character*80 errmess
13571       logical, external  :: wrf_dm_on_monitor
13572
13573 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13574 !     The values in array sfluxrefo were obtained using the "low resolution"
13575 !     version of the Kurucz solar source function.  For unknown reasons,
13576 !     the total irradiance in this band differs from the corresponding
13577 !     total in the "high-resolution" version of the Kurucz function.
13578 !     Therefore, these values are scaled by the factor SCALEKUR.
13579
13580 !     Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
13581
13582 !     The array KAO contains absorption coefs at the 16 chosen g-values
13583 !     for a range of pressure levels> ~100mb, temperatures, and binary
13584 !     species parameters (see taumol.f for definition).  The first
13585 !     index in the array, JS, runs from 1 to 9, and corresponds to
13586 !     different values of the binary species parameter.  For instance,
13587 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13588 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13589 !     in the array, JT, which runs from 1 to 5, corresponds to different
13590 !     temperatures.  More specifically, JT = 3 means that the data are for
13591 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13592 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13593 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13594 !     to the JPth reference pressure level (see taumol.f for these levels
13595 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13596 !     which g-interval the absorption coefficients are for.
13597
13598 !     The array KBO contains absorption coefs at the 16 chosen g-values
13599 !     for a range of pressure levels < ~100mb and temperatures. The first
13600 !     index in the array, JT, which runs from 1 to 5, corresponds to
13601 !     different temperatures.  More specifically, JT = 3 means that the
13602 !     data are for the reference temperature TREF for this pressure
13603 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13604 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13605 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13606 !     reference pressure level (see taumol.f for the value of these
13607 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13608 !     and tells us which g-interval the absorption coefficients are for.
13609
13610 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13611 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13612 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13613
13614       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13615          raylo, scalekur, layreffr, kao, kbo, sfluxrefo
13616       DM_BCAST_MACRO(raylo)
13617       DM_BCAST_REAL(scalekur)
13618       DM_BCAST_INTEGER(layreffr)
13619       DM_BCAST_MACRO(kao)
13620       DM_BCAST_MACRO(kbo)
13621       DM_BCAST_MACRO(sfluxrefo)
13622
13623       RETURN
13624 9010  CONTINUE
13625       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13626                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13627       CALL wrf_error_fatal(errmess)
13628
13629       end subroutine sw_kgb27
13630
13631 ! **************************************************************************
13632       subroutine sw_kgb28(rrtmg_unit)
13633 ! **************************************************************************
13634
13635       use rrsw_kg28_f, only : kao, kbo, sfluxrefo, &
13636                             rayl, strrat, layreffr
13637 !      use rrsw_kg28_f, only : kao, kbo, sfluxrefo, rayl
13638 !      use rrtmg_sw_taumol, only : strrat, layreffr
13639
13640       implicit none
13641       save
13642
13643 ! Input
13644       integer, intent(in) :: rrtmg_unit
13645
13646 ! Local
13647       character*80 errmess
13648       logical, external  :: wrf_dm_on_monitor
13649
13650 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13651
13652 !     Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
13653
13654 !     The array KAO contains absorption coefs at the 16 chosen g-values
13655 !     for a range of pressure levels> ~100mb, temperatures, and binary
13656 !     species parameters (see taumol.f for definition).  The first
13657 !     index in the array, JS, runs from 1 to 9, and corresponds to
13658 !     different values of the binary species parameter.  For instance,
13659 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13660 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13661 !     in the array, JT, which runs from 1 to 5, corresponds to different
13662 !     temperatures.  More specifically, JT = 3 means that the data are for
13663 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13664 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13665 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13666 !     to the JPth reference pressure level (see taumol.f for these levels
13667 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13668 !     which g-interval the absorption coefficients are for.
13669
13670 !     The array KBO contains absorption coefs at the 16 chosen g-values
13671 !     for a range of pressure levels < ~100mb and temperatures. The first
13672 !     index in the array, JT, which runs from 1 to 5, corresponds to
13673 !     different temperatures.  More specifically, JT = 3 means that the
13674 !     data are for the reference temperature TREF for this pressure
13675 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13676 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13677 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13678 !     reference pressure level (see taumol.f for the value of these
13679 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13680 !     and tells us which g-interval the absorption coefficients are for.
13681
13682 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13683 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13684 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13685
13686       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13687          rayl, strrat, layreffr, kao, kbo, sfluxrefo
13688       DM_BCAST_REAL(rayl)
13689       DM_BCAST_REAL(strrat)
13690       DM_BCAST_INTEGER(layreffr)
13691       DM_BCAST_MACRO(kao)
13692       DM_BCAST_MACRO(kbo)
13693       DM_BCAST_MACRO(sfluxrefo)
13694
13695       RETURN
13696 9010  CONTINUE
13697       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13698                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13699       CALL wrf_error_fatal(errmess)
13700
13701       end subroutine sw_kgb28
13702
13703 ! **************************************************************************
13704       subroutine sw_kgb29(rrtmg_unit)
13705 ! **************************************************************************
13706
13707       use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13708                             absh2oo, absco2o, rayl, layreffr
13709 !      use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
13710 !                            absh2oo, absco2o, rayl
13711 !      use rrtmg_sw_taumol, only : layreffr
13712
13713       implicit none
13714       save
13715
13716 ! Input
13717       integer, intent(in) :: rrtmg_unit
13718
13719 ! Local
13720       character*80 errmess
13721       logical, external  :: wrf_dm_on_monitor
13722
13723 !     Array sfluxrefo contains the Kurucz solar source function for this band.
13724
13725 !     Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
13726
13727 !     Array absh2oo contains the water vapor absorption coefficient for this band.
13728
13729 !     Array absco2o contains the carbon dioxide absorption coefficient for this band.
13730
13731 !     The array KAO contains absorption coefs at the 16 chosen g-values
13732 !     for a range of pressure levels> ~100mb, temperatures, and binary
13733 !     species parameters (see taumol.f for definition).  The first
13734 !     index in the array, JS, runs from 1 to 9, and corresponds to
13735 !     different values of the binary species parameter.  For instance,
13736 !     JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
13737 !     JS = 3 corresponds to the parameter value 2/8, etc.  The second index
13738 !     in the array, JT, which runs from 1 to 5, corresponds to different
13739 !     temperatures.  More specifically, JT = 3 means that the data are for
13740 !     the reference temperature TREF for this  pressure level, JT = 2 refers
13741 !     to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
13742 !     is for TREF+30.  The third index, JP, runs from 1 to 13 and refers
13743 !     to the JPth reference pressure level (see taumol.f for these levels
13744 !     in mb).  The fourth index, IG, goes from 1 to 16, and indicates
13745 !     which g-interval the absorption coefficients are for.
13746
13747 !     The array KBO contains absorption coefs at the 16 chosen g-values
13748 !     for a range of pressure levels < ~100mb and temperatures. The first
13749 !     index in the array, JT, which runs from 1 to 5, corresponds to
13750 !     different temperatures.  More specifically, JT = 3 means that the
13751 !     data are for the reference temperature TREF for this pressure
13752 !     level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
13753 !     TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
13754 !     The second index, JP, runs from 13 to 59 and refers to the JPth
13755 !     reference pressure level (see taumol.f for the value of these
13756 !     pressure levels in mb).  The third index, IG, goes from 1 to 16,
13757 !     and tells us which g-interval the absorption coefficients are for.
13758
13759 !     The array FORREFO contains the coefficient of the water vapor
13760 !     foreign-continuum (including the energy term).  The first
13761 !     index refers to reference temperature (296,260,224,260) and
13762 !     pressure (970,475,219,3 mbar) levels.  The second index
13763 !     runs over the g-channel (1 to 16).
13764
13765 !     The array SELFREFO contains the coefficient of the water vapor
13766 !     self-continuum (including the energy term).  The first index
13767 !     refers to temperature in 7.2 degree increments.  For instance,
13768 !     JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
13769 !     etc.  The second index runs over the g-channel (1 to 16).
13770
13771 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
13772 #define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
13773 #define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
13774
13775       IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
13776          rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
13777       DM_BCAST_REAL(rayl)
13778       DM_BCAST_INTEGER(layreffr)
13779       DM_BCAST_MACRO(absh2oo)
13780       DM_BCAST_MACRO(absco2o)
13781       DM_BCAST_MACRO(kao)
13782       DM_BCAST_MACRO(kbo)
13783       DM_BCAST_MACRO(selfrefo)
13784       DM_BCAST_MACRO(forrefo)
13785       DM_BCAST_MACRO(sfluxrefo)
13786
13787       RETURN
13788 9010  CONTINUE
13789       WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
13790                                   'RRTMG_SW_DATA on unit ',rrtmg_unit
13791       CALL wrf_error_fatal(errmess)
13792
13793       end subroutine sw_kgb29
13794
13795 !------------------------------------------------------------------
13796
13797       END MODULE module_ra_rrtmg_swf
13798 #endif