!!MODULE module_ra_rrtmg_swf
#define CHNK 8
!#define CHNK 1849
!#define CHNK 43
!#define CHNK 1
! --------------------------------------------------------------------------
! | |
! | Copyright 2002-2013, Atmospheric & Environmental Research, Inc. (AER). |
! | This software may be used, copied, or redistributed as long as it is |
! | not sold and this copyright notice is reproduced on each copy made. |
! | This model is provided as is without any express or implied warranties. |
! | (http://www.rtweb.aer.com/) |
! | |
! --------------------------------------------------------------------------
#ifndef _ACCEL
! this set of macros reverses the storage order of some of the array variables
! defined in rrtmg_sw_sub and used in various sections of the code. Here is a
! correspondencet table for the variables as they are known in rrtmg_sw_sub and
! in the subroutines that rrtmg_sw_sub calls:
!jm rrtmg_sw_sub
!jm | mcica_sw
!jm | | cldprmc_sw
!jm | | | spcvmc_sw
!jm | | | | reftra_sw
!jm tauc tauc | | |
!jm ssac ssac | | |
!jm asmc asmc | | |
!jm fsfc fsfc | | |
!jm taucmc tauc_stoch | ptaucmc |
!jm taormc | | ptaormc |
!jm ssacmc ssac_stoch | pomgcmc |
!jm asmcmc asmc_stoch | pasycmc |
!jm fsfcmc fsfc_stoch | | |
!jm cldfmcl cld_stoch cldmfc pcldfmc pcldfmc
!jm ciwpmcl ciwp_stoch ciwpmc |
!jm clwpmcl clwp_stoch clwpmc |
!jm cswpmcl cswp_stoch cswpmc |
!jm ztauc |
!jm ztaucorig |
!jm zasyc |
!jm zomgc |
!jm taua ptaua
!jm asya pasya
!jm omga pomga
#define tauc(A,B,C) TAUC(A,C,B)
#define ssac(A,B,C) SSAC(A,C,B)
#define asmc(A,B,C) ASMC(A,C,B)
#define fsfc(A,B,C) FSFC(A,C,B)
#define taucmc(A,B,C) TAUCMC(A,C,B)
#define tauc_stoch(A,B,C) TAUC_STOCH(A,C,B)
#define ptaucmc(A,B,C) pTAUCMC(A,C,B)
#define taormc(A,B,C) TAORMC(A,C,B)
#define ptaormc(A,B,C) pTAORMC(A,C,B)
#define ssacmc(A,B,C) SSACMC(A,C,B)
#define ssac_stoch(A,B,C) SSAC_STOCH(A,C,B)
#define pomgcmc(A,B,C) pOMGCMC(A,C,B)
#define asmcmc(A,B,C) ASMCMC(A,C,B)
#define asmc_stoch(A,B,C) ASMC_STOCH(A,C,B)
#define pasycmc(A,B,C) pASYCMC(A,C,B)
#define fsfcmc(A,B,C) FSFCMC(A,C,B)
#define fsfc_stoch(A,B,C) FSFC_STOCH(A,C,B)
#define cldfmcl(A,B,C) CLDFMCL(A,C,B)
#define cld_stoch(A,B,C) CLD_STOCH(A,C,B)
#define cldfmc(A,B,C) CLDFMC(A,C,B)
#define pcldfmc(A,B,C) pCLDFMC(A,C,B)
#define ciwpmcl(A,B,C) CIWPMCL(A,C,B)
#define ciwp_stoch(A,B,C) CIWP_STOCH(A,C,B)
#define ciwpmc(A,B,C) CIWPMC(A,C,B)
#define clwpmcl(A,B,C) CLWPMCL(A,C,B)
#define clwp_stoch(A,B,C) CLWP_STOCH(A,C,B)
#define clwpmc(A,B,C) CLWPMC(A,C,B)
#define cswpmcl(A,B,C) CSWPMCL(A,C,B)
#define cswp_stoch(A,B,C) CSWP_STOCH(A,C,B)
#define cswpmc(A,B,C) CSWPMC(A,C,B)
#define taua(A,B,C) TAUA(A,C,B)
#define asya(A,B,C) ASYA(A,C,B)
#define omga(A,B,C) OMGA(A,C,B)
#define ptaua(A,B,C) pTAUA(A,C,B)
#define pasya(A,B,C) pASYA(A,C,B)
#define pomga(A,B,C) pOMGA(A,C,B)
#endif
! Uncomment to use GPU, or comment to use CPU
!#define _ACCEL
#ifdef _ACCEL
#define gpu_device ,device
#else
#define gpu_device
#endif
module parrrsw_f 38
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw main parameters
!
! Initial version: JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
! mxlay : integer: maximum number of layers
! mg : integer: number of original g-intervals per spectral band
! nbndsw : integer: number of spectral bands
! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option)
! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw
! ngNN : integer: number of reduced g-intervals per spectral band
! ngsNN : integer: cumulative number of g-intervals per band
!------------------------------------------------------------------
integer , parameter :: mxlay = 203 !jplay, klev
integer , parameter :: mg = 16 !jpg
integer , parameter :: nbndsw = 14 !jpsw, ksw
integer , parameter :: naerec = 6 !jpaer
integer , parameter :: mxmol = 38
integer , parameter :: nstr = 2
integer , parameter :: nmol = 7
! Use for 112 g-point model
integer , parameter :: ngptsw = 112 !jpgpt
! Use for 224 g-point model
! integer , parameter :: ngptsw = 224 !jpgpt
! may need to rename these - from v2.6
integer , parameter :: jpband = 29
integer , parameter :: jpb1 = 16 !istart
integer , parameter :: jpb2 = 29 !iend
integer , parameter :: jmcmu = 32
integer , parameter :: jmumu = 32
integer , parameter :: jmphi = 3
integer , parameter :: jmxang = 4
integer , parameter :: jmxstr = 16
! ^
! Use for 112 g-point model
integer , parameter :: ng16 = 6
integer , parameter :: ng17 = 12
integer , parameter :: ng18 = 8
integer , parameter :: ng19 = 8
integer , parameter :: ng20 = 10
integer , parameter :: ng21 = 10
integer , parameter :: ng22 = 2
integer , parameter :: ng23 = 10
integer , parameter :: ng24 = 8
integer , parameter :: ng25 = 6
integer , parameter :: ng26 = 6
integer , parameter :: ng27 = 8
integer , parameter :: ng28 = 6
integer , parameter :: ng29 = 12
integer , parameter :: ngs16 = 6
integer , parameter :: ngs17 = 18
integer , parameter :: ngs18 = 26
integer , parameter :: ngs19 = 34
integer , parameter :: ngs20 = 44
integer , parameter :: ngs21 = 54
integer , parameter :: ngs22 = 56
integer , parameter :: ngs23 = 66
integer , parameter :: ngs24 = 74
integer , parameter :: ngs25 = 80
integer , parameter :: ngs26 = 86
integer , parameter :: ngs27 = 94
integer , parameter :: ngs28 = 100
integer , parameter :: ngs29 = 112
! Use for 224 g-point model
! integer , parameter :: ng16 = 16
! integer , parameter :: ng17 = 16
! integer , parameter :: ng18 = 16
! integer , parameter :: ng19 = 16
! integer , parameter :: ng20 = 16
! integer , parameter :: ng21 = 16
! integer , parameter :: ng22 = 16
! integer , parameter :: ng23 = 16
! integer , parameter :: ng24 = 16
! integer , parameter :: ng25 = 16
! integer , parameter :: ng26 = 16
! integer , parameter :: ng27 = 16
! integer , parameter :: ng28 = 16
! integer , parameter :: ng29 = 16
! integer , parameter :: ngs16 = 16
! integer , parameter :: ngs17 = 32
! integer , parameter :: ngs18 = 48
! integer , parameter :: ngs19 = 64
! integer , parameter :: ngs20 = 80
! integer , parameter :: ngs21 = 96
! integer , parameter :: ngs22 = 112
! integer , parameter :: ngs23 = 128
! integer , parameter :: ngs24 = 144
! integer , parameter :: ngs25 = 160
! integer , parameter :: ngs26 = 176
! integer , parameter :: ngs27 = 192
! integer , parameter :: ngs28 = 208
! integer , parameter :: ngs29 = 224
! Source function solar constant
real , parameter :: rrsw_scon = 1.36822e+03 ! W/m2
end module parrrsw_f
module rrsw_aer_f 3,1
use parrrsw_f
, only : nbndsw, naerec
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw aerosol optical properties
!
! Data derived from six ECMWF aerosol types and defined for
! the rrtmg_sw spectral intervals
!
! Initial: J.-J. Morcrette, ECMWF, mar2003
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
!
!-- The six ECMWF aerosol types are respectively:
!
! 1/ continental average 2/ maritime
! 3/ desert 4/ urban
! 5/ volcanic active 6/ stratospheric background
!
! computed from Hess and Koepke (con, mar, des, urb)
! from Bonnel et al. (vol, str)
!
! rrtmg_sw 14 spectral intervals (microns):
! 3.846 - 3.077
! 3.077 - 2.500
! 2.500 - 2.150
! 2.150 - 1.942
! 1.942 - 1.626
! 1.626 - 1.299
! 1.299 - 1.242
! 1.242 - 0.7782
! 0.7782- 0.6250
! 0.6250- 0.4415
! 0.4415- 0.3448
! 0.3448- 0.2632
! 0.2632- 0.2000
! 12.195 - 3.846
!
!------------------------------------------------------------------
!
! name type purpose
! ----- : ---- : ----------------------------------------------
! rsrtaua : real : ratio of average optical thickness in
! spectral band to that at 0.55 micron
! rsrpiza : real : average single scattering albedo (unitless)
! rsrasya : real : average asymmetry parameter (unitless)
!------------------------------------------------------------------
real :: rsrtaua(nbndsw,naerec)
real :: rsrpiza(nbndsw,naerec)
real :: rsrasya(nbndsw,naerec)
end module rrsw_aer_f
module rrsw_cld_f 4
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw cloud property coefficients
!
! Initial: J.-J. Morcrette, ECMWF, oct1999
! Revised: J. Delamere/MJIacono, AER, aug2005
! Revised: MJIacono, AER, nov2005
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
!
! name type purpose
! ----- : ---- : ----------------------------------------------
! xxxliq1 : real : optical properties (extinction coefficient, single
! scattering albedo, assymetry factor) from
! Hu & Stamnes, j. clim., 6, 728-742, 1993.
! xxxice2 : real : optical properties (extinction coefficient, single
! scattering albedo, assymetry factor) from streamer v3.0,
! Key, streamer user's guide, cooperative institude
! for meteorological studies, 95 pp., 2001.
! xxxice3 : real : optical properties (extinction coefficient, single
! scattering albedo, assymetry factor) from
! Fu, j. clim., 9, 1996.
! xbari : real : optical property coefficients for five spectral
! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
! and 14285-40000 wavenumbers) following
! Ebert and Curry, jgr, 97, 3831-3836, 1992.
!------------------------------------------------------------------
real :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29)
real :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29)
real :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29)
real :: fdlice3(46,16:29)
real :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5)
end module rrsw_cld_f
module rrsw_con_f 6
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw constants
! Initial version: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
! fluxfac: real : radiance to flux conversion factor
! heatfac: real : flux to heating rate conversion factor
!oneminus: real : 1.-1.e-6
! pi : real : pi
! grav : real : acceleration of gravity
! planck : real : planck constant
! boltz : real : boltzmann constant
! clight : real : speed of light
! avogad : real : avogadro constant
! alosmt : real : loschmidt constant
! gascon : real : molar gas constant
! radcn1 : real : first radiation constant
! radcn2 : real : second radiation constant
! sbcnst : real : stefan-boltzmann constant
! secdy : real : seconds per day
!------------------------------------------------------------------
real :: fluxfac, heatfac
real :: oneminus, pi, grav
real :: planck, boltz, clight
real :: avogad, alosmt, gascon
real :: radcn1, radcn2
real :: sbcnst, secdy
end module rrsw_con_f
module rrsw_kg16_f 5,1
use parrrsw_f, only : ng16
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 16
! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no16 = 16
real :: kao(9,5,13,no16)
real :: kbo(5,13:59,no16)
real :: selfrefo(10,no16), forrefo(3,no16)
real :: sfluxrefo(no16)
integer :: layreffr
real :: rayl, strrat1
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 16
! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng16) , absa(585,ng16)
real :: kb(5,13:59,ng16), absb(235,ng16)
real :: selfref(10,ng16), forref(3,ng16)
real :: sfluxref(ng16)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg16_f
module rrsw_kg17_f 5,1
use parrrsw_f, only : ng17
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 17
! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no17 = 16
real :: kao(9,5,13,no17)
real :: kbo(5,5,13:59,no17)
real :: selfrefo(10,no17), forrefo(4,no17)
real :: sfluxrefo(no17,5)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 17
! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng17) , absa(585,ng17)
real :: kb(5,5,13:59,ng17), absb(1175,ng17)
real :: selfref(10,ng17), forref(4,ng17)
real :: sfluxref(ng17,5)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
end module rrsw_kg17_f
module rrsw_kg18_f 5,1
use parrrsw_f, only : ng18
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 18
! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no18 = 16
real :: kao(9,5,13,no18)
real :: kbo(5,13:59,no18)
real :: selfrefo(10,no18), forrefo(3,no18)
real :: sfluxrefo(no18,9)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 18
! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng18), absa(585,ng18)
real :: kb(5,13:59,ng18), absb(235,ng18)
real :: selfref(10,ng18), forref(3,ng18)
real :: sfluxref(ng18,9)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg18_f
module rrsw_kg19_f 5,1
use parrrsw_f, only : ng19
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 19
! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no19 = 16
real :: kao(9,5,13,no19)
real :: kbo(5,13:59,no19)
real :: selfrefo(10,no19), forrefo(3,no19)
real :: sfluxrefo(no19,9)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 19
! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng19), absa(585,ng19)
real :: kb(5,13:59,ng19), absb(235,ng19)
real :: selfref(10,ng19), forref(3,ng19)
real :: sfluxref(ng19,9)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg19_f
module rrsw_kg20_f 5,1
use parrrsw_f, only : ng20
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 20
! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
! absch4o : real
!-----------------------------------------------------------------
integer , parameter :: no20 = 16
real :: kao(5,13,no20)
real :: kbo(5,13:59,no20)
real :: selfrefo(10,no20), forrefo(4,no20)
real :: sfluxrefo(no20)
real :: absch4o(no20)
integer :: layreffr
real :: rayl
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 20
! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
! absch4 : real
!-----------------------------------------------------------------
real :: ka(5,13,ng20), absa(65,ng20)
real :: kb(5,13:59,ng20), absb(235,ng20)
real :: selfref(10,ng20), forref(4,ng20)
real :: sfluxref(ng20)
real :: absch4(ng20)
equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg20_f
module rrsw_kg21_f 5,1
use parrrsw_f, only : ng21
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 21
! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no21 = 16
real :: kao(9,5,13,no21)
real :: kbo(5,5,13:59,no21)
real :: selfrefo(10,no21), forrefo(4,no21)
real :: sfluxrefo(no21,9)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 21
! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng21), absa(585,ng21)
real :: kb(5,5,13:59,ng21), absb(1175,ng21)
real :: selfref(10,ng21), forref(4,ng21)
real :: sfluxref(ng21,9)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
end module rrsw_kg21_f
module rrsw_kg22_f 5,1
use parrrsw_f, only : ng22
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 22
! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no22 = 16
real :: kao(9,5,13,no22)
real :: kbo(5,13:59,no22)
real :: selfrefo(10,no22), forrefo(3,no22)
real :: sfluxrefo(no22,9)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 22
! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng22), absa(585,ng22)
real :: kb(5,13:59,ng22), absb(235,ng22)
real :: selfref(10,ng22), forref(3,ng22)
real :: sfluxref(ng22,9)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg22_f
module rrsw_kg23_f 5,1
use parrrsw_f, only : ng23
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 23
! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no23 = 16
real :: kao(5,13,no23)
real :: selfrefo(10,no23), forrefo(3,no23)
real :: sfluxrefo(no23)
real :: raylo(no23)
integer :: layreffr
real :: givfac
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 23
! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(5,13,ng23), absa(65,ng23)
real :: selfref(10,ng23), forref(3,ng23)
real :: sfluxref(ng23), rayl(ng23)
equivalence (ka(1,1,1),absa(1,1))
end module rrsw_kg23_f
module rrsw_kg24_f 7,1
use parrrsw_f, only : ng24
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 24
! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
! abso3ao : real
! abso3bo : real
! raylao : real
! raylbo : real
!-----------------------------------------------------------------
integer , parameter :: no24 = 16
real :: kao(9,5,13,no24)
real :: kbo(5,13:59,no24)
real :: selfrefo(10,no24), forrefo(3,no24)
real :: sfluxrefo(no24,9)
real :: abso3ao(no24), abso3bo(no24)
real :: raylao(no24,9), raylbo(no24)
integer :: layreffr
real :: strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 24
! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! selfref : real
! forref : real
! sfluxref: real
! abso3a : real
! abso3b : real
! rayla : real
! raylb : real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng24), absa(585,ng24)
real :: kb(5,13:59,ng24), absb(235,ng24)
real :: selfref(10,ng24), forref(3,ng24)
real :: sfluxref(ng24,9)
real :: abso3a(ng24), abso3b(ng24)
real :: rayla(ng24,9), raylb(ng24)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg24_f
module rrsw_kg25_f 7,1
use parrrsw_f, only : ng25
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 25
! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
!sfluxrefo: real
! abso3ao : real
! abso3bo : real
! raylo : real
!-----------------------------------------------------------------
integer , parameter :: no25 = 16
real :: kao(5,13,no25)
real :: sfluxrefo(no25)
real :: abso3ao(no25), abso3bo(no25)
real :: raylo(no25)
integer :: layreffr
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 25
! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! absa : real
! sfluxref: real
! abso3a : real
! abso3b : real
! rayl : real
!-----------------------------------------------------------------
real :: ka(5,13,ng25), absa(65,ng25)
real :: sfluxref(ng25)
real :: abso3a(ng25), abso3b(ng25)
real :: rayl(ng25)
equivalence (ka(1,1,1),absa(1,1))
end module rrsw_kg25_f
module rrsw_kg26_f 5,1
use parrrsw_f, only : ng26
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
!sfluxrefo: real
! raylo : real
!-----------------------------------------------------------------
integer , parameter :: no26 = 16
real :: sfluxrefo(no26)
real :: raylo(no26)
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! sfluxref: real
! rayl : real
!-----------------------------------------------------------------
real :: sfluxref(ng26)
real :: rayl(ng26)
end module rrsw_kg26_f
module rrsw_kg27_f 5,1
use parrrsw_f, only : ng27
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 27
! band 27: 29000-38000 cm-1 (low - o3; high - o3)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
!sfluxrefo: real
! raylo : real
!-----------------------------------------------------------------
integer , parameter :: no27 = 16
real :: kao(5,13,no27)
real :: kbo(5,13:59,no27)
real :: sfluxrefo(no27)
real :: raylo(no27)
integer :: layreffr
real :: scalekur
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 27
! band 27: 29000-38000 cm-1 (low - o3; high - o3)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! absa : real
! absb : real
! sfluxref: real
! rayl : real
!-----------------------------------------------------------------
real :: ka(5,13,ng27), absa(65,ng27)
real :: kb(5,13:59,ng27), absb(235,ng27)
real :: sfluxref(ng27)
real :: rayl(ng27)
equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg27_f
module rrsw_kg28_f 5,1
use parrrsw_f, only : ng28
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 28
! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
!sfluxrefo: real
!-----------------------------------------------------------------
integer , parameter :: no28 = 16
real :: kao(9,5,13,no28)
real :: kbo(5,5,13:59,no28)
real :: sfluxrefo(no28,5)
integer :: layreffr
real :: rayl, strrat
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 28
! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! sfluxref: real
!-----------------------------------------------------------------
real :: ka(9,5,13,ng28), absa(585,ng28)
real :: kb(5,5,13:59,ng28), absb(1175,ng28)
real :: sfluxref(ng28,5)
equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
end module rrsw_kg28_f
module rrsw_kg29_f 7,1
use parrrsw_f, only : ng29
! implicit none
save
!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 29
! band 29: 820-2600 cm-1 (low - h2o; high - co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! kao : real
! kbo : real
! selfrefo: real
! forrefo : real
!sfluxrefo: real
! absh2oo : real
! absco2o : real
!-----------------------------------------------------------------
integer , parameter :: no29 = 16
real :: kao(5,13,no29)
real :: kbo(5,13:59,no29)
real :: selfrefo(10,no29), forrefo(4,no29)
real :: sfluxrefo(no29)
real :: absh2oo(no29), absco2o(no29)
integer :: layreffr
real :: rayl
!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 29
! band 29: 820-2600 cm-1 (low - h2o; high - co2)
!
! Initial version: JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!-----------------------------------------------------------------
!
! name type purpose
! ---- : ---- : ---------------------------------------------
! ka : real
! kb : real
! selfref : real
! forref : real
! sfluxref: real
! absh2o : real
! absco2 : real
!-----------------------------------------------------------------
real :: ka(5,13,ng29), absa(65,ng29)
real :: kb(5,13:59,ng29), absb(235,ng29)
real :: selfref(10,ng29), forref(4,ng29)
real :: sfluxref(ng29)
real :: absh2o(ng29), absco2(ng29)
equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
end module rrsw_kg29_f
module rrsw_ref_f 3
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw reference atmosphere
! Based on standard mid-latitude summer profile
!
! Initial version: JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jun2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
! pref : real : Reference pressure levels
! preflog: real : Reference pressure levels, ln(pref)
! tref : real : Reference temperature levels for MLS profile
!------------------------------------------------------------------
real , dimension(59) :: pref
real , dimension(59) :: preflog
real , dimension(59) :: tref
end module rrsw_ref_f
module rrsw_tbl_f 2
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw lookup table arrays
! Initial version: MJIacono, AER, may2007
! Revised: MJIacono, AER, aug2007
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
! ntbl : integer: Lookup table dimension
! tblint : real : Lookup table conversion factor
! tau_tbl: real : Clear-sky optical depth
! exp_tbl: real : Exponential lookup table for transmittance
! od_lo : real : Value of tau below which expansion is used
! : in place of lookup table
! pade : real : Pade approximation constant
! bpade : real : Inverse of Pade constant
!------------------------------------------------------------------
integer , parameter :: ntbl = 10000
real , parameter :: tblint = 10000.0
real , parameter :: od_lo = 0.06
real :: tau_tbl
real , dimension(0:ntbl) :: exp_tbl
real , parameter :: pade = 0.278
real :: bpade
end module rrsw_tbl_f
module rrsw_vsn_f 8
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw version information
! Initial version: JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
!hnamrtm :character:
!hnamini :character:
!hnamcld :character:
!hnamclc :character:
!hnamrft :character:
!hnamspv :character:
!hnamspc :character:
!hnamset :character:
!hnamtau :character:
!hnamvqd :character:
!hnamatm :character:
!hnamutl :character:
!hnamext :character:
!hnamkg :character:
!
! hvrrtm :character:
! hvrini :character:
! hvrcld :character:
! hvrclc :character:
! hvrrft :character:
! hvrspv :character:
! hvrspc :character:
! hvrset :character:
! hvrtau :character:
! hvrvqd :character:
! hvratm :character:
! hvrutl :character:
! hvrext :character:
! hvrkg :character:
!------------------------------------------------------------------
character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
character*18 hvrkg
character*20 hnamkg
end module rrsw_vsn_f
module rrsw_wvn_f 9,1
use parrrsw_f, only : nbndsw, mg, ngptsw, jpb1, jpb2
! implicit none
save
!------------------------------------------------------------------
! rrtmg_sw spectral information
! Initial version: JJMorcrette, ECMWF, jul1998
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
!------------------------------------------------------------------
! name type purpose
! ----- : ---- : ----------------------------------------------
! ng : integer: Number of original g-intervals in each spectral band
! nspa : integer:
! nspb : integer:
!wavenum1: real : Spectral band lower boundary in wavenumbers
!wavenum2: real : Spectral band upper boundary in wavenumbers
! delwave: real : Spectral band width in wavenumbers
!
! ngc : integer: The number of new g-intervals in each band
! ngs : integer: The cumulative sum of new g-intervals for each band
! ngm : integer: The index of each new g-interval relative to the
! original 16 g-intervals in each band
! ngn : integer: The number of original g-intervals that are
! combined to make each new g-intervals in each band
! ngb : integer: The band index for each new g-interval
! wt : real : RRTM weights for the original 16 g-intervals
! rwgt : real : Weights for combining original 16 g-intervals
! (224 total) into reduced set of g-intervals
! (112 total)
!------------------------------------------------------------------
integer :: ng(jpb1:jpb2)
integer :: nspa(jpb1:jpb2)
integer :: nspb(jpb1:jpb2)
real :: wavenum1(jpb1:jpb2)
real :: wavenum2(jpb1:jpb2)
real :: delwave(jpb1:jpb2)
integer :: icxa(jpb1:jpb2)
integer :: ngc(nbndsw)
integer :: ngs(nbndsw)
integer :: ngn(ngptsw)
integer :: ngb(ngptsw)
integer :: ngm(nbndsw*mg)
real :: wt(mg)
real :: rwgt(nbndsw*mg)
end module rrsw_wvn_f
module mcica_subcol_gen_sw_f 1,4
use parrrsw_f, only : nbndsw, ngptsw
use rrsw_con_f, only: grav
use rrsw_wvn_f, only: ngb
use rrsw_vsn_f
implicit none
public :: mcica_sw
contains
!-------------------------------------------------------------------------------------------------
subroutine mcica_sw(ncol, nlay, nsubcol, icld, irng, play, cld, ciwp, clwp, cswp, & 1,3
tauc, ssac, asmc, fsfc, cld_stoch, ciwp_stoch, clwp_stoch, cswp_stoch, &
tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed )
!-------------------------------------------------------------------------------------------------
!----------------------------------------------------------------------------------------------------------------
! ---------------------
! Contact: Cecile Hannay (hannay@ucar.edu)
!
! Original code: Based on Raisanen et al., QJRMS, 2004.
!
! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
! random number generator, which can be changed to the optional kissvec random number generator
! with flag 'irng'. Some extra functionality has been commented or removed.
! Michael J. Iacono, AER, Inc., February 2007
!
! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
! and uniform cloud liquid and cloud ice concentration.
! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
! and obeys an overlap assumption in the vertical.
!
! Overlap assumption:
! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
! The default option is maximum-random (option 3)
! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
! This is set with the variable "overlap"
!mji - Exponential overlap option (overlap=4) has been deactivated in this version
! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
!
! Seed:
! If the stochastic cloud generator is called several times during the same timestep,
! one should change the seed between the call to insure that the subcolumns are different.
! This is done by changing the argument 'changeSeed'
! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
!
! PDF assumption:
! We can use arbitrary complicated PDFS.
! In the present version, we produce homogeneuous clouds (the simplest case).
! Future developments include using the PDF scheme of Ben Johnson.
!
! History file:
! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
! nsubcol = number of subcolumns
! overlap = overlap type (1-3)
! Zo = length scale
! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
! CLDLIQ_S = mean of the subcolumn cloud water
! CLDICE_S = mean of the subcolumn cloud ice
!
! Note:
! Here: we force that the cloud condensate to be consistent with the cloud fraction
! i.e we only have cloud condensate when the cell is cloudy.
! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
! without cloud condensate or the opposite).
!---------------------------------------------------------------------------------------------------------------
use mcica_random_numbers_f
! The Mersenne Twister random number engine
!use MersenneTwister, only: randomNumberSequence, &
! new_RandomNumberSequence, getRandomReal
!type(randomNumberSequence) :: randomNumbers
! -- Arguments
integer , intent(in) :: ncol ! number of layers
integer , intent(in) :: nlay ! number of layers
integer , intent(in) :: icld ! clear/cloud, cloud overlap flag
integer , intent(inout) :: irng ! flag for random number generator
! 0 = kissvec
! 1 = Mersenne Twister
integer , intent(in) :: nsubcol ! number of sub-columns (g-point intervals)
integer , optional, intent(in) :: changeSeed ! allows permuting seed
! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state
real , intent(in) :: play(:,:) ! layer pressure (Pa)
! Dimensions: (ncol,nlay)
real , intent(in) :: cld(:,:) ! cloud fraction
! Dimensions: (ncol,nlay)
real , intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled)
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled)
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled)
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled)
! Dimensions: (ncol,nlay,nbndsw)
real , intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
! Dimensions: (ngptsw,ncol,nlay)
real , intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
! Dimensions: (ngptsw,ncol,nlay)
real , intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
! Dimensions: (ngptsw,ncol,nlay)
real , intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
! Dimensions: (ngptsw,ncol,nlay)
real , intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
! Dimensions: (ncol,nlay,ngptsw)
real , intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
! Dimensions: (ncol,nlay,ngptsw)
real , intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter
! Dimensions: (ncol,nlay,ngptsw)
real , intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction
! Dimensions: (ncol,nlay,ngptsw)
! -- Local variables
! Constants (min value for cloud fraction and cloud water and ice)
real , parameter :: cldmin = 1.0e-20 ! min cloud fraction
#ifndef _ACCEL
# define ncol CHNK
#endif
! Variables related to random number and seed
real, dimension(ncol, nlay, nsubcol) gpu_device :: CDF
#ifdef _ACCEL
integer :: seed1, seed2, seed3, seed4 ! seed to create random number
#else
integer, dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number
#endif
integer :: iseed ! seed to create random number (Mersenne Twister)
! real :: rand_num_mt ! random number (Mersenne Twister)
real :: kiss
! Indices
integer :: ilev, isubcol, i, n, ngbm, iplon ! indices
#ifndef _ACCEL
integer :: m, k
! inline function
m(k, n) = ieor (k, ishft (k, n) )
#endif
!------------------------------------------------------------------------------------------
! Check that irng is in bounds; if not, set to default
! Note: in GPU version of code, only kissvec method is used, Mersenne Twister not installed
! Pass input cloud overlap setting to local variable
! ------ Apply overlap assumption --------
! generate the random numbers
! Random cloud overlap
if (icld==1) then
!$acc kernels
#ifdef _ACCEL
do ilev = 1,nlay
do i = 1, ncol
seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev
seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev
seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2
seed4 = (play(i,4) - int(play(i,4))) * 100000000
do isubcol = 1,nsubcol
seed1 = 69069 * seed1 + 132721785
seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 )
seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 )
seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 )
kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5
end do
end do
end do
#else
CALL wrf_error_fatal("icld == 1 not supported in module_ra_rrtmg_swf.F")
#endif
!$acc end kernels
endif
! Maximum-Random cloud overlap
if (icld==2) then
#ifdef _ACCEL
!$acc kernels
do ilev = 1,nlay
do i = 1, ncol
seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev
seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev
seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2
seed4 = (play(i,4) - int(play(i,4))) * 100000000
do isubcol = 1,nsubcol
seed1 = 69069 * seed1 + 132721785
seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 )
seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 )
seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 )
kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5
end do
end do
end do
do ilev = 2,nlay
do i = 1, ncol
do isubcol = 1,nsubcol
if (CDF(i,ilev-1,isubcol) > 1. - cld(i, ilev-1)) then
CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol)
else
CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1))
end if
end do
end do
end do
!$acc end kernels
#else
!jm set up to match the ra_sw_physics=4 random number generator '
!jm moved isubcol loop out of here and put in the ilev.eq.1 conditional for initial
!jm computation of seeds so we get the same results as the ra_sw_physics=4 option
do isubcol = 1,nsubcol
do ilev = 1,nlay
do i = 1, ncol
if (ilev.eq.1.and.isubcol.eq.1)then
seed1(i) = (play(i,1)*100 - int(play(i,1)*100)) * 1000000000 !jm
seed2(i) = (play(i,2)*100 - int(play(i,2)*100)) * 1000000000 !jm
seed3(i) = (play(i,3)*100 - int(play(i,3)*100)) * 1000000000 !jm
seed4(i) = (play(i,4)*100 - int(play(i,4)*100)) * 1000000000
seed1(i) = 69069 * seed1(i) + 1327217885
seed2(i) = m (m (m (seed2(i), 13), - 17), 5)
seed3(i) = 18000 * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 )
seed4(i) = 30903 * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 )
kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i)
endif
seed1(i) = 69069 * seed1(i) + 1327217885
seed2(i) = m (m (m (seed2(i), 13), - 17), 5)
seed3(i) = 18000 * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 )
seed4(i) = 30903 * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 )
kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i)
CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5
end do
end do
end do
do ilev = 2,nlay
do i = 1, ncol
do isubcol = 1,nsubcol
if (CDF(i,ilev-1,isubcol) > 1. - cld(i, ilev-1)) then
CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol)
else
CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1))
end if
end do
end do
end do
#endif
endif
! Maximum cloud overlap
if (icld==3) then
!$acc kernels
#ifdef _ACCEL
do i = 1, ncol
seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev
seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev
seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2
seed4 = (play(i,4) - int(play(i,4))) * 100000000
do isubcol = 1,nsubcol
seed1 = 69069 * seed1 + 132721785
seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 )
seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 )
seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 )
kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4
do ilev = 1,nlay
CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5
end do
end do
end do
#else
CALL wrf_error_fatal("icld == 3 not supported in module_ra_rrtmg_swf.F")
#endif
!$acc end kernels
endif
ngbm = ngb(1) - 1
!$acc kernels
do ilev = 1,nlay
do i = 1, ncol
do isubcol = 1, nsubcol
if ( CDF(i,ilev,isubcol)>=(1.0 - cld(i,ilev)) ) then
cld_stoch(i,ilev,isubcol) = 1.0
clwp_stoch(i,ilev,isubcol) = clwp(i,ilev)
ciwp_stoch(i,ilev,isubcol) = ciwp(i,ilev)
cswp_stoch(i,ilev,isubcol) = cswp(i,ilev)
n = ngb(isubcol) - ngbm
tauc_stoch(i,ilev,isubcol) = tauc(i,ilev,n)
ssac_stoch(i,ilev,isubcol) = ssac(i,ilev,n)
asmc_stoch(i,ilev,isubcol) = asmc(i,ilev,n)
fsfc_stoch(i,ilev,isubcol) = fsfc(i,ilev,n)
else
cld_stoch(i,ilev,isubcol) = 0.
clwp_stoch(i,ilev,isubcol) = 0.
ciwp_stoch(i,ilev,isubcol) = 0.
cswp_stoch(i,ilev,isubcol) = 0.
tauc_stoch(i,ilev,isubcol) = 0.
ssac_stoch(i,ilev,isubcol) = 1.
asmc_stoch(i,ilev,isubcol) = 0.
fsfc_stoch(i,ilev,isubcol) = 0.
endif
enddo
enddo
enddo
!$acc end kernels
#ifndef _ACCEL
# undef ncol
#endif
end subroutine mcica_sw
end module mcica_subcol_gen_sw_f
module rrtmg_sw_cldprmc_f 1,4
! ------- Modules -------
use parrrsw_f, only : ngptsw, jpband, jpb1, jpb2
use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
extice2, ssaice2, asyice2, &
extice3, ssaice3, asyice3, fdlice3, &
abari, bbari, cbari, dbari, ebari, fbari
use rrsw_wvn_f, only : wavenum2, ngb, icxa
use rrsw_vsn_f, only : hvrclc, hnamclc
implicit none
contains
! ----------------------------------------------------------------------------
subroutine cldprmc_sw(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, & 2,11
ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
taormc, taucmc, ssacmc, asmcmc, fsfcmc)
! ----------------------------------------------------------------------------
! Purpose: Compute the cloud optical properties for each cloudy layer
! and g-point interval for use by the McICA method.
! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=1,2,3 are available;
! (Hu & Stamnes, Ebert and Curry, Key, and Fu) are implemented.
! ------- Input -------
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: inflag ! see definitions
integer , intent(in) :: iceflag ! see definitions
integer , intent(in) :: liqflag ! see definitions
integer , intent(in) :: ncol
real , intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica]
! Dimensions: (ngptsw,nlayers)
real , intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica]
! Dimensions: (ngptsw,nlayers)
real , intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica]
! Dimensions: (ngptsw,nlayers)
real , intent(in) :: cswpmc(:,:,:) ! cloud snow water path [mcica]
! Dimensions: (ngptsw,nlayers)
real , intent(in) :: relqmc(:,:) ! cloud liquid particle effective radius (microns)
! Dimensions: (nlayers)
real , intent(in) :: resnmc(:,:) ! cloud snow particle effective radius (microns)
! Dimensions: (nlayers)
real , intent(in) :: reicmc(:,:) ! cloud ice particle effective radius (microns)
! Dimensions: (nlayers)
! specific definition of reicmc depends on setting of iceflag:
! iceflag = 0: (inactive)
!
! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
! r_ec range is limited to 13.0 to 130.0 microns
! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
! r_k range is limited to 5.0 to 131.0 microns
! iceflag = 3: generalized effective size, dge, (Fu, 1996),
! dge range is limited to 5.0 to 140.0 microns
! [dge = 1.0315 * r_ec]
real , intent(in) :: fsfcmc(:,:,:) ! cloud forward scattering fraction
! Dimensions: (ngptsw,nlayers)
! ------- Output -------
real , intent(inout) :: taucmc(:,:,:) ! cloud optical depth (delta scaled)
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(inout) :: ssacmc(:,:,:) ! single scattering albedo (delta scaled)
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(inout) :: asmcmc(:,:,:) ! asymmetry parameter (delta scaled)
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(out) :: taormc(:,:,:) ! cloud optical depth (non-delta scaled)
! Dimensions: (ncol,nlayers,ngptsw)
! ------- Local -------
! integer :: ncbands
integer :: ib, lay, istr, index, icx, ig, iplon
real , parameter :: eps = 1.e-06 ! epsilon
real , parameter :: cldmin = 1.e-20 ! minimum value for cloud quantities
real :: cwp ! total cloud water path
real :: radliq ! cloud liquid droplet radius (microns)
real :: radice ! cloud ice effective size (microns)
real :: radsno ! cloud snow effective size (microns)
real :: factor
real :: fint
real :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
real :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
real :: tausnoorig, scatsno, ssasno, tausno
real :: fdelta
real :: extcoice, gice
real :: ssacoice, forwice
real :: extcoliq, gliq
real :: ssacoliq, forwliq
real :: extcosno, gsno
real :: ssacosno, forwsno
! Initialize
!$acc kernels
taormc = taucmc
!$acc end kernels
#ifndef _ACCEL
# define ncol CHNK
#endif
! Main layer loop
!$acc kernels loop present(cldfmc, ciwpmc, clwpmc, cswpmc, relqmc, reicmc, resnmc, fsfcmc,taucmc, ssacmc, asmcmc, taormc)
do iplon = 1, ncol
!$acc loop
do lay = 1, nlayers
!$acc loop private(fdelta,extcoice,gice,ssacoice,forwice,extcoliq,gliq,ssacoliq,forwliq,gsno,forwsno,scatsno)
do ig = 1, ngptsw
cwp = ciwpmc(iplon,lay,ig) + clwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig)
if (cldfmc(iplon,lay,ig) .ge. cldmin .and. &
(cwp .ge. cldmin .or. taucmc(iplon,lay,ig) .ge. cldmin)) then
! (inflag=0): Cloud optical properties input directly
if (inflag .eq. 0) then
! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled;
! Apply delta-M scaling here (using Henyey-Greenstein approximation)
taucldorig_a = taucmc(iplon,lay,ig)
ffp = fsfcmc(iplon,lay,ig)
ffp1 = 1.0 - ffp
ffpssa = 1.0 - ffp * ssacmc(iplon,lay,ig)
ssacloud_a = ffp1 * ssacmc(iplon,lay,ig) / ffpssa
taucloud_a = ffpssa * taucldorig_a
taormc(iplon,lay,ig) = taucldorig_a
ssacmc(iplon,lay,ig) = ssacloud_a
taucmc(iplon,lay,ig) = taucloud_a
asmcmc(iplon,lay,ig) = (asmcmc(iplon,lay,ig) - ffp) / (ffp1)
! (inflag=2): Separate treatement of ice clouds and water clouds.
elseif (inflag .ge. 2) then
radice = reicmc(iplon,lay)
! Calculation of absorption coefficients due to ice clouds.
if (ciwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig) .eq. 0.0 ) then
extcoice = 0.0
ssacoice = 0.0
gice = 0.0
forwice = 0.0
extcosno = 0.0
ssacosno = 0.0
gsno = 0.0
forwsno = 0.0
! (iceflag = 1):
! Note: This option uses Ebert and Curry approach for all particle sizes similar to
! CAM3 implementation, though this is somewhat unjustified for large ice particles
elseif (iceflag .eq. 1) then
ib = ngb(ig )
ib = icxa(ib)
extcoice = (abari(ib) + bbari(ib)/radice)
ssacoice = 1. - cbari(ib) - dbari(ib) * radice
gice = ebari(ib) + fbari(ib) * radice
! Check to ensure upper limit of gice is within physical limits for large particles
if (gice.ge.1. ) gice = 1. - eps
forwice = gice*gice
! Check to ensure all calculated quantities are within physical limits.
! mji - added checks below
if (extcoice .lt. 0.0) extcoice = 0.0
if (ssacoice .gt. 1.0) ssacoice = 1.0
if (ssacoice .lt. 0.0) ssacoice = 0.0
if (gice .gt. 1.0) gice = 1.0
if (gice .lt. 0.0) gice = 0.0
! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
elseif (iceflag .eq. 2) then
factor = (radice - 2. )/3.
index = int(factor)
! mji - temporary fix to prevent out of range subscripts
if (index .le. 0) index = 1
if (index .ge. 43) index = 42
! if (index .eq. 43) index = 42
fint = factor - float(index)
ib = ngb(ig)
extcoice = extice2(index,ib) + fint * &
(extice2(index+1,ib) - extice2(index,ib))
ssacoice = ssaice2(index,ib) + fint * &
(ssaice2(index+1,ib) - ssaice2(index,ib))
gice = asyice2(index,ib) + fint * &
(asyice2(index+1,ib) - asyice2(index,ib))
forwice = gice*gice
! Check to ensure all calculated quantities are within physical limits.
! mji - added checks below
if (extcoice .lt. 0.0) extcoice = 0.0
if (ssacoice .gt. 1.0) ssacoice = 1.0
if (ssacoice .lt. 0.0) ssacoice = 0.0
if (gice .gt. 1.0) gice = 1.0
if (gice .lt. 0.0) gice = 0.0
! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
elseif (iceflag .ge. 3) then
factor = (radice - 2. )/3.
index = int(factor)
! mji - temporary fix to prevent out of range subscripts
if (index .le. 0) index = 1
if (index .ge. 46) index = 45
! if (index .eq. 46) index = 45
fint = factor - float(index)
ib = ngb(ig)
extcoice = extice3(index,ib) + fint * &
(extice3(index+1,ib) - extice3(index,ib))
ssacoice = ssaice3(index,ib) + fint * &
(ssaice3(index+1,ib) - ssaice3(index,ib))
gice = asyice3(index,ib) + fint * &
(asyice3(index+1,ib) - asyice3(index,ib))
fdelta = fdlice3(index,ib) + fint * &
(fdlice3(index+1,ib) - fdlice3(index,ib))
forwice = fdelta + 0.5 / ssacoice
! See Fu 1996 p. 2067
if (forwice .gt. gice) forwice = gice
! Check to ensure all calculated quantities are within physical limits.
! mji - added checks below
if (extcoice .lt. 0.0) extcoice = 0.0
if (ssacoice .gt. 1.0) ssacoice = 1.0
if (ssacoice .lt. 0.0) ssacoice = 0.0
if (gice .gt. 1.0) gice = 1.0
if (gice .lt. 0.0) gice = 0.0
endif
!!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
!!!! Although far from perfect, the snow will utilize the
!!!! same lookup table constants as cloud ice. Changes
!!!! to those constants for larger particle snow would be
!!!! an improvement.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if (cswpmc(iplon,lay,ig).gt.0.0 .and. iceflag .eq. 5) then
radsno = resnmc(iplon,lay)
factor = (radsno - 2.)/3.
index = int(factor)
! mji - temporary fix to prevent out of range subscripts
if (index .le. 0) index = 1
if (index .ge. 46) index = 45
! if (index .eq. 46) index = 45
fint = factor - float(index)
ib = ngb(ig)
extcosno = extice3(index,ib) + fint * &
(extice3(index+1,ib) - extice3(index,ib))
ssacosno = ssaice3(index,ib) + fint * &
(ssaice3(index+1,ib) - ssaice3(index,ib))
gsno = asyice3(index,ib) + fint * &
(asyice3(index+1,ib) - asyice3(index,ib))
fdelta = fdlice3(index,ib) + fint * &
(fdlice3(index+1,ib) - fdlice3(index,ib))
forwsno = fdelta + 0.5 / ssacosno
! See Fu 1996 p. 2067
if (forwsno .gt. gsno) forwsno = gsno
! Check to ensure all calculated quantities are within physical limits.
! mji - added checks below
if (extcosno .lt. 0.0) extcosno = 0.0
if (ssacosno .gt. 1.0) ssacosno = 1.0
if (ssacosno .lt. 0.0) ssacosno = 0.0
if (gsno .gt. 1.0) gsno = 1.0
if (gsno .lt. 0.0) gsno = 0.0
!
else
extcosno = 0.0
ssacosno = 0.0
gsno = 0.0
forwsno = 0.0
endif
! Calculation of absorption coefficients due to water clouds.
if (clwpmc(iplon,lay,ig) .eq. 0.0 ) then
extcoliq = 0.0
ssacoliq = 0.0
gliq = 0.0
forwliq = 0.0
elseif (liqflag .eq. 1) then
radliq = relqmc(iplon,lay)
index = int(radliq - 1.5 )
! mji - temporary fix to prevent out of range subscripts
if (index .le. 0) index = 1
if (index .ge. 58) index = 57
! if (index .eq. 0) index = 1
! if (index .eq. 58) index = 57
fint = radliq - 1.5 - float(index)
ib = ngb(ig)
extcoliq = extliq1(index,ib) + fint * &
(extliq1(index+1,ib) - extliq1(index,ib))
ssacoliq = ssaliq1(index,ib) + fint * &
(ssaliq1(index+1,ib) - ssaliq1(index,ib))
if (fint .lt. 0. .and. ssacoliq .gt. 1. ) &
ssacoliq = ssaliq1(index,ib)
gliq = asyliq1(index,ib) + fint * &
(asyliq1(index+1,ib) - asyliq1(index,ib))
forwliq = gliq*gliq
! Check to ensure all calculated quantities are within physical limits.
! mji - added checks below
if (extcoliq .lt. 0.0) extcoliq = 0.0
if (ssacoliq .gt. 1.0) ssacoliq = 1.0
if (ssacoliq .lt. 0.0) ssacoliq = 0.0
if (gliq .gt. 1.0) gliq = 1.0
if (gliq .lt. 0.0) gliq = 0.0
!
endif
if (iceflag .lt. 5) then
tauliqorig = clwpmc(iplon,lay,ig) * extcoliq
tauiceorig = ciwpmc(iplon,lay,ig) * extcoice
taormc(iplon,lay,ig) = tauliqorig + tauiceorig
ssaliq = ssacoliq * (1. - forwliq) / &
(1. - forwliq * ssacoliq)
tauliq = (1. - forwliq * ssacoliq) * tauliqorig
ssaice = ssacoice * (1. - forwice) / &
(1. - forwice * ssacoice)
tauice = (1. - forwice * ssacoice) * tauiceorig
scatliq = ssaliq * tauliq
scatice = ssaice * tauice
taucmc(iplon,lay,ig) = tauliq + tauice
else
tauliqorig = clwpmc(iplon,lay,ig) * extcoliq
tauiceorig = ciwpmc(iplon,lay,ig) * extcoice
tausnoorig = cswpmc(iplon,lay,ig) * extcosno
taormc(iplon,lay,ig) = tauliqorig + tauiceorig + tausnoorig
ssaliq = ssacoliq * (1. - forwliq) / &
(1. - forwliq * ssacoliq)
tauliq = (1. - forwliq * ssacoliq) * tauliqorig
ssaice = ssacoice * (1. - forwice) / &
(1. - forwice * ssacoice)
tauice = (1. - forwice * ssacoice) * tauiceorig
ssasno = ssacosno * (1. - forwsno) / &
(1. - forwsno * ssacosno)
tausno = (1. - forwsno * ssacosno) * tausnoorig
scatliq = ssaliq * tauliq
scatice = ssaice * tauice
scatsno = ssasno * tausno
taucmc(iplon,lay,ig) = tauliq + tauice + tausno
endif
! Ensure non-zero taucmc and scatice
if(taucmc(iplon,lay,ig) .eq.0.) taucmc(iplon,lay,ig) = cldmin
if(scatice.eq.0.) scatice = cldmin
if(scatsno.eq.0.) scatsno = cldmin
if (iceflag .lt. 5) then
ssacmc(iplon,lay,ig) = (scatliq + scatice) / taucmc(iplon,lay,ig)
else
ssacmc(iplon,lay,ig) = (scatliq + scatice + scatsno) / taucmc(iplon,lay,ig)
endif
if (iceflag .eq. 3 .or. iceflag.eq.4) then
! In accordance with the 1996 Fu paper, equation A.3,
! the moments for ice were calculated depending on whether using spheres
! or hexagonal ice crystals.
! Set asymetry parameter to first moment (istr=1)
istr = 1
asmcmc(iplon,lay,ig) = (1.0 /(scatliq+scatice))* &
(scatliq*(gliq**istr - forwliq) / &
(1.0 - forwliq) + scatice * ((gice-forwice)/ &
(1.0 - forwice))**istr)
elseif (iceflag .eq. 5) then
istr = 1
asmcmc(iplon,lay,ig) = (1.0 /(scatliq+scatice+scatsno)) * &
(scatliq*(gliq**istr - forwliq)/(1.0 - forwliq) &
+ scatice * ((gice-forwice)/(1.0 - forwice)) &
+ scatsno * ((gsno-forwsno)/(1.0 - forwsno))**istr)
else
! This code is the standard method for delta-m scaling.
! Set asymetry parameter to first moment (istr=1)
istr = 1
asmcmc(iplon,lay,ig) = (scatliq * &
(gliq**istr - forwliq) / &
(1.0 - forwliq) + scatice * (gice**istr - forwice) / &
(1.0 - forwice))/(scatliq + scatice)
endif
endif
endif
! End g-point interval loop
enddo
! End layer loop
enddo
! End column loop
enddo
!$acc end kernels
#ifndef _ACCEL
# undef ncol
#endif
end subroutine cldprmc_sw
end module rrtmg_sw_cldprmc_f
module rrtmg_sw_setcoef_f 2,3
! ------- Modules -------
use parrrsw_f, only : mxmol
use rrsw_ref_f, only : pref, preflog, tref
use rrsw_vsn_f, only : hvrset, hnamset
implicit none
contains
!----------------------------------------------------------------------------
subroutine setcoef_sw(ncol, nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, & 2
laytrop, layswtch, laylow, jp, jt, jt1, &
co2mult, colch4, colco2, colh2o, colmol, coln2o, &
colo2, colo3, fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor)
!----------------------------------------------------------------------------
!
! Purpose: For a given atmosphere, calculate the indices and
! fractions related to the pressure and temperature interpolations.
! Modifications:
! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01)
! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224
! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006
! ------ Declarations -------
! ----- Input -----
integer, intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
real , intent(in) :: pavel(:,:) ! layer pressures (mb)
! Dimensions: (nlayers)
real , intent(in) :: tavel(:,:) ! layer temperatures (K)
! Dimensions: (nlayers)
real , intent(in) :: pz(:,0:) ! level (interface) pressures (hPa, mb)
! Dimensions: (0:nlayers)
real , intent(in) :: tz(:,0:) ! level (interface) temperatures (K)
! Dimensions: (0:nlayers)
real , intent(in) :: tbound(:) ! surface temperature (K)
real , intent(in) :: coldry(:,:) ! dry air column density (mol/cm2)
! Dimensions: (nlayers)
real , intent(in) :: wkl(:,:,:) ! molecular amounts (mol/cm-2)
! Dimensions: (mxmol,nlayers)
! ----- Output -----
integer , intent(out) :: laytrop(:) ! tropopause layer index
integer , intent(out) :: layswtch(:) !
integer , intent(out) :: laylow(:) !
integer , intent(out) :: jp(:,:) !
! Dimensions: (nlayers)
integer , intent(out) :: jt(:,:) !
! Dimensions: (nlayers)
integer , intent(out) :: jt1(:,:) !
! Dimensions: (nlayers)
real , intent(out) :: colh2o(:,:) ! column amount (h2o)
! Dimensions: (nlayers)
real , intent(out) :: colco2(:,:) ! column amount (co2)
! Dimensions: (nlayers)
real , intent(out) :: colo3(:,:) ! column amount (o3)
! Dimensions: (nlayers)
real , intent(out) :: coln2o(:,:) ! column amount (n2o)
! Dimensions: (nlayers)
real , intent(out) :: colch4(:,:) ! column amount (ch4)
! Dimensions: (nlayers)
real , intent(out) :: colo2(:,:) ! column amount (o2)
! Dimensions: (nlayers)
real , intent(out) :: colmol(:,:) !
! Dimensions: (nlayers)
real , intent(out) :: co2mult(:,:) !
! Dimensions: (nlayers)
integer , intent(out) :: indself(:,:)
! Dimensions: (nlayers)
integer , intent(out) :: indfor(:,:)
! Dimensions: (nlayers)
real , intent(out) :: selffac(:,:)
! Dimensions: (nlayers)
real , intent(out) :: selffrac(:,:)
! Dimensions: (nlayers)
real , intent(out) :: forfac(:,:)
! Dimensions: (nlayers)
real , intent(out) :: forfrac(:,:)
! Dimensions: (nlayers)
real , intent(out) :: fac00(:,:) , fac01(:,:) , fac10(:,:) , fac11(:,:)
! ----- Local -----
integer :: indbound
integer :: indlev0
integer :: lay
integer :: jp1
integer :: iplon
real :: stpfac
real :: tbndfrac
real :: t0frac
real :: plog
real :: fp
real :: ft
real :: ft1
real :: water
real :: scalefac
real :: factor
real :: co2reg
real :: compfp
#ifndef _ACCEL
# define ncol CHNK
#endif
! Initializations
stpfac = 296. /1013.
!$acc kernels present(pavel, layswtch, laytrop, laylow)
layswtch = 0
laytrop = 0
laylow = 0
do iplon = 1, ncol
do lay = 1, nlayers
plog = log(pavel(iplon,lay) )
if (plog .ge. 4.56) laytrop(iplon) = laytrop(iplon) + 1
if (plog .ge. 6.62) laylow(iplon) = laylow(iplon) + 1
end do
end do
!$acc end kernels
!$acc kernels loop present(pavel, tavel, pz, tz, tbound) &
!$acc present(coldry, wkl, jp, jt, jt1, colh2o, colco2) &
!$acc present(colo3, coln2o, colch4, colo2, colmol, co2mult, indself) &
!$acc present(indfor, selffac, selffrac, forfac, forfrac, fac00, fac01, fac10, fac11)
! Begin column loop
do iplon = 1, ncol
indbound = tbound(iplon) - 159.
tbndfrac = tbound(iplon) - int(tbound(iplon))
indlev0 = tz(iplon,0) - 159.
t0frac = tz(iplon,0) - int(tz(iplon,0) )
! Begin layer loop
do lay = 1, nlayers
! Find the two reference pressures on either side of the
! layer pressure. Store them in JP and JP1. Store in FP the
! fraction of the difference (in ln(pressure)) between these
! two values that the layer pressure lies.
plog = log(pavel(iplon,lay) )
jp(iplon,lay) = int(36. - 5*(plog+0.04 ))
if (jp(iplon,lay) .lt. 1) then
jp(iplon,lay) = 1
elseif (jp(iplon,lay) .gt. 58) then
jp(iplon,lay) = 58
endif
jp1 = jp(iplon,lay) + 1
fp = 5. * (preflog(jp(iplon,lay) ) - plog)
! Determine, for each reference pressure (JP and JP1), which
! reference temperature (these are different for each
! reference pressure) is nearest the layer temperature but does
! not exceed it. Store these indices in JT and JT1, resp.
! Store in FT (resp. FT1) the fraction of the way between JT
! (JT1) and the next highest reference temperature that the
! layer temperature falls.
jt(iplon,lay) = int(3. + (tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. )
if (jt(iplon,lay) .lt. 1) then
jt(iplon,lay) = 1
elseif (jt(iplon,lay) .gt. 4) then
jt(iplon,lay) = 4
endif
ft = ((tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. ) - float(jt(iplon,lay) -3)
jt1(iplon,lay) = int(3. + (tavel(iplon,lay) -tref(jp1))/15. )
if (jt1(iplon,lay) .lt. 1) then
jt1(iplon,lay) = 1
elseif (jt1(iplon,lay) .gt. 4) then
jt1(iplon,lay) = 4
endif
ft1 = ((tavel(iplon,lay) -tref(jp1))/15. ) - float(jt1(iplon,lay) -3)
water = wkl(iplon,1,lay) /coldry(iplon,lay)
scalefac = pavel(iplon,lay) * stpfac / tavel(iplon,lay)
! If the pressure is less than ~100mb, perform a different
! set of species interpolations.
if (plog .le. 4.56 ) then
forfac(iplon,lay) = scalefac / (1.+water)
factor = (tavel(iplon,lay) -188.0 )/36.0
indfor(iplon,lay) = 3
forfrac(iplon,lay) = factor - 1.0
! Calculate needed column amounts.
colh2o(iplon,lay) = 1.e-20 * wkl(iplon,1,lay)
colco2(iplon,lay) = 1.e-20 * wkl(iplon,2,lay)
colo3(iplon,lay) = 1.e-20 * wkl(iplon,3,lay)
coln2o(iplon,lay) = 1.e-20 * wkl(iplon,4,lay)
colch4(iplon,lay) = 1.e-20 * wkl(iplon,6,lay)
colo2(iplon,lay) = 1.e-20 * wkl(iplon,7,lay)
colmol(iplon,lay) = 1.e-20 * coldry(iplon,lay) + colh2o(iplon,lay)
if (colco2(iplon,lay) .eq. 0. ) colco2(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (coln2o(iplon,lay) .eq. 0. ) coln2o(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (colch4(iplon,lay) .eq. 0. ) colch4(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (colo2(iplon,lay) .eq. 0. ) colo2(iplon,lay) = 1.e-32 * coldry(iplon,lay)
co2reg = 3.55e-24 * coldry(iplon,lay)
co2mult(iplon,lay) = (colco2(iplon,lay) - co2reg) * &
272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) )
selffac(iplon,lay) = 0.
selffrac(iplon,lay) = 0.
indself(iplon,lay) = 0
else
! Set up factors needed to separately include the water vapor
! foreign-continuum in the calculation of absorption coefficient.
forfac(iplon,lay) = scalefac / (1.+water)
factor = (332.0 -tavel(iplon,lay) )/36.0
indfor(iplon,lay) = min(2, max(1, int(factor)))
forfrac(iplon,lay) = factor - float(indfor(iplon,lay) )
! Set up factors needed to separately include the water vapor
! self-continuum in the calculation of absorption coefficient.
selffac(iplon,lay) = water * forfac(iplon,lay)
factor = (tavel(iplon,lay) -188.0 )/7.2
indself(iplon,lay) = min(9, max(1, int(factor)-7))
selffrac(iplon,lay) = factor - float(indself(iplon,lay) + 7)
! Calculate needed column amounts.
colh2o(iplon,lay) = 1.e-20 * wkl(iplon,1,lay)
colco2(iplon,lay) = 1.e-20 * wkl(iplon,2,lay)
colo3(iplon,lay) = 1.e-20 * wkl(iplon,3,lay)
! colo3(lay) = 0.
! colo3(lay) = colo3(lay)/1.16
coln2o(iplon,lay) = 1.e-20 * wkl(iplon,4,lay)
colch4(iplon,lay) = 1.e-20 * wkl(iplon,6,lay)
colo2(iplon,lay) = 1.e-20 * wkl(iplon,7,lay)
colmol(iplon,lay) = 1.e-20 * coldry(iplon,lay) + colh2o(iplon,lay)
! colco2(lay) = 0.
! colo3(lay) = 0.
! coln2o(lay) = 0.
! colch4(lay) = 0.
! colo2(lay) = 0.
! colmol(lay) = 0.
if (colco2(iplon,lay) .eq. 0. ) colco2(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (coln2o(iplon,lay) .eq. 0. ) coln2o(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (colch4(iplon,lay) .eq. 0. ) colch4(iplon,lay) = 1.e-32 * coldry(iplon,lay)
if (colo2(iplon,lay) .eq. 0. ) colo2(iplon,lay) = 1.e-32 * coldry(iplon,lay)
! Using E = 1334.2 cm-1.
co2reg = 3.55e-24 * coldry(iplon,lay)
co2mult(iplon,lay) = (colco2(iplon,lay) - co2reg) * &
272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) )
end if
! We have now isolated the layer ln pressure and temperature,
! between two reference pressures and two reference temperatures
! (for each reference pressure). We multiply the pressure
! fraction FP with the appropriate temperature fractions to get
! the factors that will be needed for the interpolation that yields
! the optical depths (performed in routines TAUGBn for band n).
compfp = 1. - fp
fac10(iplon,lay) = compfp * ft
fac00(iplon,lay) = compfp * (1. - ft)
fac11(iplon,lay) = fp * ft1
fac01(iplon,lay) = fp * (1. - ft1)
! End layer loop
end do
! End column loop
end do
!$acc end kernels
#ifndef _ACCEL
# undef ncol
#endif
end subroutine setcoef_sw
!***************************************************************************
subroutine swatmref 2
!***************************************************************************
save
! These pressures are chosen such that the ln of the first pressure
! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
! each subsequent ln(pressure) differs from the previous one by 0.2.
pref(:) = (/ &
1.05363e+03 ,8.62642e+02 ,7.06272e+02 ,5.78246e+02 ,4.73428e+02 , &
3.87610e+02 ,3.17348e+02 ,2.59823e+02 ,2.12725e+02 ,1.74164e+02 , &
1.42594e+02 ,1.16746e+02 ,9.55835e+01 ,7.82571e+01 ,6.40715e+01 , &
5.24573e+01 ,4.29484e+01 ,3.51632e+01 ,2.87892e+01 ,2.35706e+01 , &
1.92980e+01 ,1.57998e+01 ,1.29358e+01 ,1.05910e+01 ,8.67114e+00 , &
7.09933e+00 ,5.81244e+00 ,4.75882e+00 ,3.89619e+00 ,3.18993e+00 , &
2.61170e+00 ,2.13828e+00 ,1.75067e+00 ,1.43333e+00 ,1.17351e+00 , &
9.60789e-01 ,7.86628e-01 ,6.44036e-01 ,5.27292e-01 ,4.31710e-01 , &
3.53455e-01 ,2.89384e-01 ,2.36928e-01 ,1.93980e-01 ,1.58817e-01 , &
1.30029e-01 ,1.06458e-01 ,8.71608e-02 ,7.13612e-02 ,5.84256e-02 , &
4.78349e-02 ,3.91639e-02 ,3.20647e-02 ,2.62523e-02 ,2.14936e-02 , &
1.75975e-02 ,1.44076e-02 ,1.17959e-02 ,9.65769e-03 /)
preflog(:) = (/ &
6.9600e+00 , 6.7600e+00 , 6.5600e+00 , 6.3600e+00 , 6.1600e+00 , &
5.9600e+00 , 5.7600e+00 , 5.5600e+00 , 5.3600e+00 , 5.1600e+00 , &
4.9600e+00 , 4.7600e+00 , 4.5600e+00 , 4.3600e+00 , 4.1600e+00 , &
3.9600e+00 , 3.7600e+00 , 3.5600e+00 , 3.3600e+00 , 3.1600e+00 , &
2.9600e+00 , 2.7600e+00 , 2.5600e+00 , 2.3600e+00 , 2.1600e+00 , &
1.9600e+00 , 1.7600e+00 , 1.5600e+00 , 1.3600e+00 , 1.1600e+00 , &
9.6000e-01 , 7.6000e-01 , 5.6000e-01 , 3.6000e-01 , 1.6000e-01 , &
-4.0000e-02 ,-2.4000e-01 ,-4.4000e-01 ,-6.4000e-01 ,-8.4000e-01 , &
-1.0400e+00 ,-1.2400e+00 ,-1.4400e+00 ,-1.6400e+00 ,-1.8400e+00 , &
-2.0400e+00 ,-2.2400e+00 ,-2.4400e+00 ,-2.6400e+00 ,-2.8400e+00 , &
-3.0400e+00 ,-3.2400e+00 ,-3.4400e+00 ,-3.6400e+00 ,-3.8400e+00 , &
-4.0400e+00 ,-4.2400e+00 ,-4.4400e+00 ,-4.6400e+00 /)
! These are the temperatures associated with the respective
! pressures for the MLS standard atmosphere.
tref(:) = (/ &
2.9420e+02 , 2.8799e+02 , 2.7894e+02 , 2.6925e+02 , 2.5983e+02 , &
2.5017e+02 , 2.4077e+02 , 2.3179e+02 , 2.2306e+02 , 2.1578e+02 , &
2.1570e+02 , 2.1570e+02 , 2.1570e+02 , 2.1706e+02 , 2.1858e+02 , &
2.2018e+02 , 2.2174e+02 , 2.2328e+02 , 2.2479e+02 , 2.2655e+02 , &
2.2834e+02 , 2.3113e+02 , 2.3401e+02 , 2.3703e+02 , 2.4022e+02 , &
2.4371e+02 , 2.4726e+02 , 2.5085e+02 , 2.5457e+02 , 2.5832e+02 , &
2.6216e+02 , 2.6606e+02 , 2.6999e+02 , 2.7340e+02 , 2.7536e+02 , &
2.7568e+02 , 2.7372e+02 , 2.7163e+02 , 2.6955e+02 , 2.6593e+02 , &
2.6211e+02 , 2.5828e+02 , 2.5360e+02 , 2.4854e+02 , 2.4348e+02 , &
2.3809e+02 , 2.3206e+02 , 2.2603e+02 , 2.2000e+02 , 2.1435e+02 , &
2.0887e+02 , 2.0340e+02 , 1.9792e+02 , 1.9290e+02 , 1.8809e+02 , &
1.8329e+02 , 1.7849e+02 , 1.7394e+02 , 1.7212e+02 /)
end subroutine swatmref
end module rrtmg_sw_setcoef_f
module rrtmg_sw_taumol_f 1,3
! ------- Modules -------
use rrsw_con_f, only: oneminus
use rrsw_wvn_f, only: nspa, nspb
use rrsw_vsn_f, only: hvrtau, hnamtau
implicit none
contains
!----------------------------------------------------------------------------
subroutine taumol_sw(ncol, nlayers, & 2,28
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real , intent(inout) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real , intent(inout) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(inout) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Calculate gaseous optical depth and planck fractions for each spectral band.
call taumol16(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol17(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol18(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol19(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol20(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol21(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol22(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol23(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol24(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol25(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol26(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol27(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol28(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
call taumol29(ncol, nlayers, &
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
end subroutine
!----------------------------------------------------------------------------
subroutine taumol16(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng16
use rrsw_kg16_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat1
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(inout) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(inout) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(inout) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
# define IKLOOP1_S do iplon=1,ncol;do lay=1,nlayers
# define IKLOOP1_E enddo;enddo
# 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
# define IKLOOP2_E
#else
# define ncol CHNK
# define IKLOOP1_S do lay = 1, nlayers ; do iplon = 1, ncol
# define IKLOOP1_E enddo;enddo
# define IKLOOP2_S do lay=2,nlayers;do iplon=1,ncol;if(lay>laytrop(iplon))then;laysolfr=nlayers
# define IKLOOP2_E endif;enddo;enddo
#endif
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat1
integer :: iplon
! strrat1 = 252.131
! layreffr = 18
!$acc kernels
#ifdef _ACCEL
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
do lay = 1, nlayers
#else
IKLOOP1_S
#endif
if (lay <= laytrop(iplon)) then
speccomb = colh2o(iplon,lay) + strrat1*colch4(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(16) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(16) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng16
taug(iplon,lay,ig) = speccomb * &
(fac000 * absa(ind0 ,ig) + &
fac100 * absa(ind0 +1,ig) + &
fac010 * absa(ind0 +9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1 ,ig) + &
fac101 * absa(ind1 +1,ig) + &
fac011 * absa(ind1 +9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ig) = tauray/taug(lay,ig)
taur(iplon,lay,ig) = tauray
enddo
end if
#ifdef _ACCEL
enddo
enddo
!$acc end kernels
! Upper atmosphere loop
!$acc kernels
do iplon=1,ncol
laysolfr = nlayers
! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL
do lay = laytrop(iplon)+1, nlayers
! if (lay > laytrop(iplon)) then
! !do lay = laytrop(iplon) +1, nlayers
if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) then
laysolfr = lay
end if
#else
IKLOOP1_E
IKLOOP2_S
#endif
!#ifdef _ACCEL
! do iplon=1,ncol
! laysolfr = nlayers
!! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL
! do lay = laytrop(iplon)+1, nlayers
!! if (lay > laytrop(iplon)) then
!! !do lay = laytrop(iplon) +1, nlayers
! if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) then
! laysolfr = lay
! end if
!#else
! do lay = minval(laytrop(1:ncol)),nlayers
! do iplon=1,ncol
! if (lay > laytrop(iplon)) then
! laysolfr = nlayers
!
!#endif
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(16) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(16) + 1
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng16
taug(iplon,lay,ig) = colch4(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0 ,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1 ,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig))
if (laysolfr == lay) sfluxzen(iplon,ig) = sfluxref(ig)
taur(iplon,lay,ig) = tauray
enddo
#ifdef _ACCEL
enddo
enddo
#else
IKLOOP2_E
#endif
!$acc end kernels
# undef ncol
end subroutine taumol16
!----------------------------------------------------------------------------
subroutine taumol17(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng17, ngs16
use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifndef _ACCEL
# define ncol CHNK
#endif
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
! layreffr = 30
! strrat = 0.364641
#ifdef _ACCEL
!$acc kernels loop
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
!$acc loop private(js, fs)
do lay = 1, nlayers
#else
IKLOOP1_S
#endif
if (lay <= laytrop(iplon)) then
!do lay = 1, laytrop(iplon)
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(17) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(17) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng17
taug(iplon,lay,ngs16+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
taur(iplon,lay,ngs16+ig) = tauray
enddo
else
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 4. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(17) + js
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(17) + js
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng17
taug(iplon,lay,ngs16+ig) = speccomb * &
(fac000 * absb(ind0,ig) + &
fac100 * absb(ind0+1,ig) + &
fac010 * absb(ind0+5,ig) + &
fac110 * absb(ind0+6,ig) + &
fac001 * absb(ind1,ig) + &
fac101 * absb(ind1+1,ig) + &
fac011 * absb(ind1+5,ig) + &
fac111 * absb(ind1+6,ig)) + &
colh2o(iplon,lay) * &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))
! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
taur(iplon,lay,ngs16+ig) = tauray
enddo
endif
enddo
enddo
!$acc end kernels
!$acc kernels
#ifdef _ACCEL
do iplon = 1, ncol
! Upper atmosphere loop
laysolfr = nlayers
do lay = 2, nlayers
if (lay > laytrop(iplon)) then
#else
IKLOOP2_S
#endif
if ((jp(iplon,lay-1) .lt. layreffr) .and. (jp(iplon,lay) .ge. layreffr)) then
laysolfr = lay
end if
if (lay == laysolfr) then
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 4. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
do ig = 1, ng17
sfluxzen(iplon,ngs16+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
end if
#ifdef _ACCEL
end if
enddo
enddo
#else
IKLOOP2_E
#endif
!$acc end kernels
# undef ncol
end subroutine taumol17
!----------------------------------------------------------------------------
subroutine taumol18(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng18, ngs17
use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifndef _ACCEL
# define ncol CHNK
#endif
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
! strrat = 38.9589
! layreffr = 6
!$acc kernels
#ifdef _ACCEL
do iplon = 1, ncol
laysolfr = laytrop(iplon)
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
#define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
speccomb = colh2o(iplon,lay) + strrat*colch4(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
do ig = 1, ng18
if (lay .eq. laysolfr) sfluxzen(iplon,ngs17+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
!$acc kernels
IKLOOP1_S
if (lay <= laytrop(iplon)) then
!do lay = 1, laytrop(iplon)
speccomb = colh2o(iplon,lay) + strrat*colch4(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(18) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(18) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng18
taug(iplon,lay,ngs17+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
taur(iplon,lay,ngs17+ig) = tauray
enddo
else
! Upper atmosphere loop
!do lay = laytrop(iplon) +1, nlayers
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(18) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(18) + 1
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng18
taug(iplon,lay,ngs17+ig) = colch4(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig))
! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
taur(iplon,lay,ngs17+ig) = tauray
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol18
!----------------------------------------------------------------------------
subroutine taumol19(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng19, ngs18
use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
#else
# define ncol CHNK
#endif
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
strrat = 5.49281
layreffr = 3
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
laysolfr = laytrop(iplon)
! Lower atmosphere loop
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
do ig = 1 , ng19
sfluxzen(iplon,ngs18+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
endif
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
!$acc kernels
IKLOOP1_S
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
if (lay <= laytrop(iplon)) then
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(19) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(19) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1 , ng19
taug(iplon,lay,ngs18+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
taur(iplon,lay,ngs18+ig) = tauray
enddo
else
! Upper atmosphere loop
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(19) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(19) + 1
tauray = colmol(iplon,lay) * rayl
do ig = 1 , ng19
taug(iplon,lay,ngs18+ig) = colco2(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig))
! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
taur(iplon,lay,ngs18+ig) = tauray
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol19
!----------------------------------------------------------------------------
subroutine taumol20(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng20, ngs19
use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, absch4, rayl, layreffr
! use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, absch4, rayl
implicit none
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
integer :: iplon
! layreffr = 3
#ifdef _ACCEL
!$acc kernels loop independent private(laysolfr)
do iplon = 1, ncol
laysolfr = laytrop(iplon)
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
do ig = 1, ng20
sfluxzen(iplon,ngs19+ig) = sfluxref(ig)
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
!$acc kernels
IKLOOP1_S
if (lay <= laytrop(iplon)) then
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(20) + 1
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(20) + 1
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng20
taug(iplon,lay,ngs19+ig) = colh2o(iplon,lay) * &
((fac00(iplon,lay) * absa(ind0,ig) + &
fac10(iplon,lay) * absa(ind0+1,ig) + &
fac01(iplon,lay) * absa(ind1,ig) + &
fac11(iplon,lay) * absa(ind1+1,ig)) + &
selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))) &
+ colch4(iplon,lay) * absch4(ig)
! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
taur(iplon,lay,ngs19+ig) = tauray
enddo
else
! Upper atmosphere loop
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(20) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(20) + 1
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng20
taug(iplon,lay,ngs19+ig) = colh2o(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))) + &
colch4(iplon,lay) * absch4(ig)
! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
taur(iplon,lay,ngs19+ig) = tauray
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol20
!----------------------------------------------------------------------------
subroutine taumol21(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng21, ngs20
use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
! strrat = 0.0045321
! layreffr = 8
#ifdef _ACCEL
!$acc kernels loop independent private(laysolfr)
do iplon = 1, ncol
laysolfr = laytrop(iplon)
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
do ig = 1, ng21
sfluxzen(iplon,ngs20+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
!$acc kernels
IKLOOP1_S
if (lay <= laytrop(iplon)) then
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(21) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(21) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng21
taug(iplon,lay,ngs20+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
taur(iplon,lay,ngs20+ig) = tauray
enddo
else
! Upper atmosphere loop
speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 4. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(21) + js
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(21) + js
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng21
taug(iplon,lay,ngs20+ig) = speccomb * &
(fac000 * absb(ind0,ig) + &
fac100 * absb(ind0+1,ig) + &
fac010 * absb(ind0+5,ig) + &
fac110 * absb(ind0+6,ig) + &
fac001 * absb(ind1,ig) + &
fac101 * absb(ind1+1,ig) + &
fac011 * absb(ind1+5,ig) + &
fac111 * absb(ind1+6,ig)) + &
colh2o(iplon,lay) * &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))
! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
taur(iplon,lay,ngs20+ig) = tauray
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol21
!----------------------------------------------------------------------------
subroutine taumol22(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng22, ngs21
use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray, o2adj, o2cont
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, o2adj, o2cont, strrat
integer :: iplon
! The following factor is the ratio of total O2 band intensity (lines
! and Mate continuum) to O2 band intensity (line only). It is needed
! to adjust the optical depths since the k's include only lines.
o2adj = 1.6
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! strrat = 0.022708
! layreffr = 2
#ifdef _ACCEL
!$acc kernels loop independent private(laysolfr)
do iplon=1,ncol
laysolfr = laytrop(iplon)
! Lower atmosphere loop
!$acc loop seq
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
speccomb = colh2o(iplon,lay) + o2adj*strrat*colo2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
! odadj = specparm + o2adj * (1. - specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
do ig = 1, ng22
sfluxzen(iplon,ngs21+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
! Lower atmosphere loop
!$acc kernels
IKLOOP1_S
if (lay<=laytrop(iplon)) then
o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 )
speccomb = colh2o(iplon,lay) + o2adj*strrat*colo2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
! odadj = specparm + o2adj * (1. - specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(22) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(22) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng22
taug(iplon,lay,ngs21+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))) &
+ o2cont
! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
taur(iplon,lay,ngs21+ig) = tauray
enddo
else
! Upper atmosphere loop
o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 )
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(22) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(22) + 1
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng22
taug(iplon,lay,ngs21+ig) = colo2(iplon,lay) * o2adj * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig)) + &
o2cont
! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
taur(iplon,lay,ngs21+ig) = tauray
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol22
!----------------------------------------------------------------------------
subroutine taumol23(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng23, ngs22
use rrsw_kg23_f, only : absa, ka, forref, selfref, &
sfluxref, rayl, layreffr, givfac
! use rrsw_kg23_f, only : absa, ka, forref, selfref, &
! sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, givfac
integer :: iplon
! Average Giver et al. correction factor for this band.
! givfac = 1.029
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! layreffr = 6
#ifdef _ACCEL
!$acc kernels loop independent private(laysolfr)
do iplon=1,ncol
laysolfr = laytrop(iplon)
! Lower atmosphere loop
!$acc loop seq
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
do ig = 1, ng23
sfluxzen(iplon,ngs22+ig) = sfluxref(ig)
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
! Lower atmosphere loop
!$acc kernels
IKLOOP1_S
if (lay <= laytrop(iplon)) then
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(23) + 1
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(23) + 1
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
do ig = 1, ng23
tauray = colmol(iplon,lay) * rayl(ig)
taug(iplon,lay,ngs22+ig) = colh2o(iplon,lay) * &
(givfac * (fac00(iplon,lay) * absa(ind0,ig) + &
fac10(iplon,lay) * absa(ind0+1,ig) + &
fac01(iplon,lay) * absa(ind1,ig) + &
fac11(iplon,lay) * absa(ind1+1,ig)) + &
selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
taur(iplon,lay,ngs22+ig) = tauray
enddo
else
! Upper atmosphere loop
do ig = 1, ng23
! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
! ssa(lay,ngs22+ig) = 1.0
taug(iplon,lay,ngs22+ig) = 0.
taur(iplon,lay,ngs22+ig) = colmol(iplon,lay) * rayl(ig)
enddo
end if
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol23
!----------------------------------------------------------------------------
subroutine taumol24(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng24, ngs23
use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, abso3a, abso3b, rayla, raylb, &
layreffr, strrat
! use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, abso3a, abso3b, rayla, raylb
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
! strrat = 0.124692
! layreffr = 1
#ifdef _ACCEL
!$acc kernels loop independent private(laysolfr)
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
laysolfr = laytrop(iplon)
! Lower atmosphere loop
!$acc loop independent
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
if (lay .eq. laysolfr) then
speccomb = colh2o(iplon,lay) + strrat*colo2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
do ig = 1, ng24
sfluxzen(iplon,ngs23+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
!$acc kernels
IKLOOP1_S
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
if (lay <= laytrop(iplon)) then
speccomb = colh2o(iplon,lay) + strrat*colo2(iplon,lay)
specparm = colh2o(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(24) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(24) + js
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
do ig = 1, ng24
tauray = colmol(iplon,lay) * (rayla(ig,js) + &
fs * (rayla(ig,js+1) - rayla(ig,js)))
taug(iplon,lay,ngs23+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig)) + &
colo3(iplon,lay) * abso3a(ig) + &
colh2o(iplon,lay) * &
(selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig))))
! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
taur(iplon,lay,ngs23+ig) = tauray
enddo
else
! Upper atmosphere loop
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(24) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(24) + 1
do ig = 1, ng24
tauray = colmol(iplon,lay) * raylb(ig)
taug(iplon,lay,ngs23+ig) = colo2(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig)) + &
colo3(iplon,lay) * abso3b(ig)
! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
taur(iplon,lay,ngs23+ig) = tauray
enddo
endif
IKLOOP1_E
!$acc end kernels
# undef ncol
end subroutine taumol24
!----------------------------------------------------------------------------
subroutine taumol25(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng25, ngs24
use rrsw_kg25_f, only : absa, ka, &
sfluxref, abso3a, abso3b, rayl, layreffr
! use rrsw_kg25_f, only : absa, ka, &
! sfluxref, abso3a, abso3b, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
integer :: iplon
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! layreffr = 2
laysolfr = laytrop(iplon)
! Lower atmosphere loop
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) &
laysolfr = min(lay+1,laytrop(iplon) )
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(25) + 1
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(25) + 1
do ig = 1, ng25
tauray = colmol(iplon,lay) * rayl(ig)
taug(iplon,lay,ngs24+ig) = colh2o(iplon,lay) * &
(fac00(iplon,lay) * absa(ind0,ig) + &
fac10(iplon,lay) * absa(ind0+1,ig) + &
fac01(iplon,lay) * absa(ind1,ig) + &
fac11(iplon,lay) * absa(ind1+1,ig)) + &
colo3(iplon,lay) * abso3a(ig)
! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
if (lay .eq. laysolfr) sfluxzen(iplon,ngs24+ig) = sfluxref(ig)
taur(iplon,lay,ngs24+ig) = tauray
enddo
#ifdef _ACCEL
enddo
! Upper atmosphere loop
do lay = laytrop(iplon) +1, nlayers
#else
else
#endif
do ig = 1, ng25
tauray = colmol(iplon,lay) * rayl(ig)
taug(iplon,lay,ngs24+ig) = colo3(iplon,lay) * abso3b(ig)
! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
taur(iplon,lay,ngs24+ig) = tauray
enddo
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
enddo
enddo
!$acc end kernels
# undef ncol
end subroutine taumol25
!----------------------------------------------------------------------------
subroutine taumol26(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng26, ngs25
use rrsw_kg26_f, only : sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
integer :: iplon
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
laysolfr = laytrop(iplon)
! Lower atmosphere loop
do lay = 1, laytrop(iplon)
#else
laysolfr = laytrop
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
do ig = 1, ng26
! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
! ssa(lay,ngs25+ig) = 1.0
if (lay .eq. laysolfr) sfluxzen(iplon,ngs25+ig) = sfluxref(ig)
taug(iplon,lay,ngs25+ig) = 0.
taur(iplon,lay,ngs25+ig) = colmol(iplon,lay) * rayl(ig)
enddo
#ifdef _ACCEL
enddo
do lay = laytrop(iplon) +1, nlayers
#else
else
#endif
! Upper atmosphere loop
do ig = 1, ng26
! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
! ssa(lay,ngs25+ig) = 1.0
taug(iplon,lay,ngs25+ig) = 0.
taur(iplon,lay,ngs25+ig) = colmol(iplon,lay) * rayl(ig)
enddo
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
enddo
enddo
!$acc end kernels
# undef ncol
end subroutine taumol26
!----------------------------------------------------------------------------
subroutine taumol27(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 27: 29000-38000 cm-1 (low - o3; high - o3)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng27, ngs26
use rrsw_kg27_f, only : absa, ka, absb, kb, &
sfluxref, rayl, layreffr, scalekur
! use rrsw_kg27_f, only : absa, ka, absb, kb, sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, scalekur
integer :: iplon
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Kurucz solar source function
! The values in sfluxref were obtained using the "low resolution"
! version of the Kurucz solar source function. For unknown reasons,
! the total irradiance in this band differs from the corresponding
! total in the "high-resolution" version of the Kurucz function.
! Therefore, these values are scaled below by the factor SCALEKUR.
! scalekur = 50.15 /48.37
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! layreffr = 32
! Lower atmosphere loop
do lay = 1, laytrop(iplon)
#else
laysolfr = nlayers
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(27) + 1
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(27) + 1
do ig = 1, ng27
tauray = colmol(iplon,lay) * rayl(ig)
taug(iplon,lay,ngs26+ig) = colo3(iplon,lay) * &
(fac00(iplon,lay) * absa(ind0,ig) + &
fac10(iplon,lay) * absa(ind0+1,ig) + &
fac01(iplon,lay) * absa(ind1,ig) + &
fac11(iplon,lay) * absa(ind1+1,ig))
! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
taur(iplon,lay,ngs26+ig) = tauray
enddo
#ifdef _ACCEL
enddo
laysolfr = nlayers
! Upper atmosphere loop
do lay = laytrop(iplon) +1, nlayers
#else
else
#endif
if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) &
laysolfr = lay
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(27) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(27) + 1
do ig = 1, ng27
tauray = colmol(iplon,lay) * rayl(ig)
taug(iplon,lay,ngs26+ig) = colo3(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig))
! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
if (lay.eq.laysolfr) sfluxzen(iplon,ngs26+ig) = scalekur * sfluxref(ig)
taur(iplon,lay,ngs26+ig) = tauray
enddo
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
enddo
enddo
!$acc end kernels
# undef ncol
end subroutine taumol27
!----------------------------------------------------------------------------
subroutine taumol28(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng28, ngs27
use rrsw_kg28_f, only : absa, ka, absb, kb, &
sfluxref, rayl, layreffr, strrat
! use rrsw_kg28_f, only : absa, ka, absb, kb, sfluxref, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
! real :: fac000, fac001, fac010, fac011, fac100, fac101, &
! fac110, fac111, fs, speccomb, specmult, specparm, &
! tauray, strrat
integer :: iplon
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! strrat = 6.67029e-07
! layreffr = 58
! Lower atmosphere loop
do lay = 1, laytrop(iplon)
#else
laysolfr = nlayers
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay <= laytrop(iplon)) then
#endif
speccomb = colo3(iplon,lay) + strrat*colo2(iplon,lay)
specparm = colo3(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 8. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(28) + js
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(28) + js
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng28
taug(iplon,lay,ngs27+ig) = speccomb * &
(fac000 * absa(ind0,ig) + &
fac100 * absa(ind0+1,ig) + &
fac010 * absa(ind0+9,ig) + &
fac110 * absa(ind0+10,ig) + &
fac001 * absa(ind1,ig) + &
fac101 * absa(ind1+1,ig) + &
fac011 * absa(ind1+9,ig) + &
fac111 * absa(ind1+10,ig))
! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
taur(iplon,lay,ngs27+ig) = tauray
enddo
#ifdef _ACCEL
enddo
laysolfr = nlayers
! Upper atmosphere loop
do lay = laytrop(iplon) +1, nlayers
#else
else
#endif
if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) &
laysolfr = lay
speccomb = colo3(iplon,lay) + strrat*colo2(iplon,lay)
specparm = colo3(iplon,lay) /speccomb
if (specparm .ge. oneminus) specparm = oneminus
specmult = 4. *(specparm)
js = 1 + int(specmult)
fs = mod(specmult, 1. )
fac000 = (1. - fs) * fac00(iplon,lay)
fac010 = (1. - fs) * fac10(iplon,lay)
fac100 = fs * fac00(iplon,lay)
fac110 = fs * fac10(iplon,lay)
fac001 = (1. - fs) * fac01(iplon,lay)
fac011 = (1. - fs) * fac11(iplon,lay)
fac101 = fs * fac01(iplon,lay)
fac111 = fs * fac11(iplon,lay)
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(28) + js
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(28) + js
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng28
taug(iplon,lay,ngs27+ig) = speccomb * &
(fac000 * absb(ind0,ig) + &
fac100 * absb(ind0+1,ig) + &
fac010 * absb(ind0+5,ig) + &
fac110 * absb(ind0+6,ig) + &
fac001 * absb(ind1,ig) + &
fac101 * absb(ind1+1,ig) + &
fac011 * absb(ind1+5,ig) + &
fac111 * absb(ind1+6,ig))
! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
if (lay .eq. laysolfr) sfluxzen(iplon,ngs27+ig) = sfluxref(ig,js) &
+ fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
taur(iplon,lay,ngs27+ig) = tauray
enddo
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
enddo
enddo
!$acc end kernels
# undef ncol
end subroutine taumol28
!----------------------------------------------------------------------------
subroutine taumol29(ncol, nlayers, & 2,4
colh2o, colco2, colch4, colo2, colo3, colmol, &
laytrop, jp, jt, jt1, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
sfluxzen, taug, taur)
!----------------------------------------------------------------------------
!
! band 29: 820-2600 cm-1 (low - h2o; high - co2)
!
!----------------------------------------------------------------------------
! ------- Modules -------
use parrrsw_f, only : ng29, ngs28
use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, &
sfluxref, absh2o, absco2, rayl, layreffr
! use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, &
! sfluxref, absh2o, absco2, rayl
! ------- Declarations -------
integer , intent(in) :: ncol
integer , intent(in) :: nlayers ! total number of layers
integer , intent(in) :: laytrop(:) ! tropopause layer index
integer , intent(in) :: jp(:,:) !
integer , intent(in) :: jt(:,:) !
integer , intent(in) :: jt1(:,:) !
! Dimensions: (ncol,nlayers)
real , intent(in) :: colh2o(:,:) ! column amount (h2o)
real , intent(in) :: colco2(:,:) ! column amount (co2)
real , intent(in) :: colo3(:,:) ! column amount (o3)
real , intent(in) :: colch4(:,:) ! column amount (ch4)
real , intent(in) :: colo2(:,:) ! column amount (o2)
real , intent(in) :: colmol(:,:) !
! Dimensions: (ncol,nlayers)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: indfor(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: & !
fac00(:,:) , fac01(:,:) , &
fac10(:,:) , fac11(:,:)
! Dimensions: (ncol,nlayers)
! ----- Output -----
real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function
! Dimensions: (ncol,ngptsw)
real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth
! Dimensions: (ncol,nlayers,ngptsw)
real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh
! Dimensions: (ncol,nlayers,ngptsw)
! Local
#ifdef _ACCEL
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
#else
# define ncol CHNK
integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol)
#endif
! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, &
! layreffr
real :: fac000, fac001, fac010, fac011, fac100, fac101, &
fac110, fac111, fs, speccomb, specmult, specparm, &
tauray
integer :: iplon
! layreffr = 49
#ifdef _ACCEL
!$acc kernels loop independent private (laysolfr)
do iplon=1,ncol
laysolfr = nlayers
!$acc loop seq
do lay = laytrop(iplon) +1, nlayers
#else
laysolfr = nlayers
# define laysolfr LAYSOLFR(iplon)
do lay = 1, nlayers
do iplon = 1, ncol
if (lay > laytrop(iplon)) then
#endif
if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) &
laysolfr = lay
if (lay .eq. laysolfr) then
do ig = 1, ng29
sfluxzen(iplon,ngs28+ig) = sfluxref(ig)
end do
end if
#ifdef _ACCEL
#else
# undef laysolfr
endif
#endif
end do
end do
!$acc end kernels
#ifdef _ACCEL
!$acc kernels
do iplon=1,ncol
! Compute the optical depth by interpolating in ln(pressure),
! temperature, and appropriate species. Below LAYTROP, the water
! vapor self-continuum is interpolated (in temperature) separately.
! Lower atmosphere loop
do lay = 1, nlayers
#else
do lay = 1, nlayers
do iplon=1,ncol
#endif
if (lay <= laytrop(iplon)) then
ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(29) + 1
ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(29) + 1
inds = indself(iplon,lay)
indf = indfor(iplon,lay)
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng29
taug(iplon,lay,ngs28+ig) = colh2o(iplon,lay) * &
((fac00(iplon,lay) * absa(ind0,ig) + &
fac10(iplon,lay) * absa(ind0+1,ig) + &
fac01(iplon,lay) * absa(ind1,ig) + &
fac11(iplon,lay) * absa(ind1+1,ig)) + &
selffac(iplon,lay) * (selfref(inds,ig) + &
selffrac(iplon,lay) * &
(selfref(inds+1,ig) - selfref(inds,ig))) + &
forfac(iplon,lay) * (forref(indf,ig) + &
forfrac(iplon,lay) * &
(forref(indf+1,ig) - forref(indf,ig)))) &
+ colco2(iplon,lay) * absco2(ig)
! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
taur(iplon,lay,ngs28+ig) = tauray
enddo
else
! Upper atmosphere loop
ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(29) + 1
ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(29) + 1
tauray = colmol(iplon,lay) * rayl
do ig = 1, ng29
taug(iplon,lay,ngs28+ig) = colco2(iplon,lay) * &
(fac00(iplon,lay) * absb(ind0,ig) + &
fac10(iplon,lay) * absb(ind0+1,ig) + &
fac01(iplon,lay) * absb(ind1,ig) + &
fac11(iplon,lay) * absb(ind1+1,ig)) &
+ colh2o(iplon,lay) * absh2o(ig)
! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
taur(iplon,lay,ngs28+ig) = tauray
enddo
end if
enddo
enddo
!$acc end kernels
# undef ncol
end subroutine taumol29
# undef IKLOOP1_S
# undef IKLOOP1_E
# undef IKLOOP2_S
# undef IKLOOP2_E
end module rrtmg_sw_taumol_f
module rrtmg_sw_init_f 1,2
! ------- Modules -------
use rrsw_wvn_f
use rrtmg_sw_setcoef_f, only: swatmref
implicit none
public rrtmg_sw_ini
contains
! **************************************************************************
subroutine rrtmg_sw_ini(cpdair) 2,44
! **************************************************************************
!
! Original version: Michael J. Iacono; February, 2004
! Revision for F90 formatting: M. J. Iacono, July, 2006
!
! This subroutine performs calculations necessary for the initialization
! of the shortwave model. Lookup tables are computed for use in the SW
! radiative transfer, and input absorption coefficient data for each
! spectral band are reduced from 224 g-point intervals to 112.
! **************************************************************************
use parrrsw_f, only : mg, nbndsw, ngptsw
use rrsw_tbl_f, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
use rrsw_vsn_f, only: hvrini, hnamini
real , intent(in) :: cpdair ! Specific heat capacity of dry air
! at constant pressure at 273 K
! (J kg-1 K-1)
! ------- Local -------
integer :: ibnd, igc, ig, ind, ipr
integer :: igcsm, iprsm
integer :: itr
real :: wtsum, wtsm(mg)
real :: tfn
real , parameter :: expeps = 1.e-20 ! Smallest value for exponential table
! ------- Definitions -------
! Arrays for 10000-point look-up tables:
! TAU_TBL Clear-sky optical depth
! EXP_TBL Exponential lookup table for transmittance
! PADE Pade approximation constant (= 0.278)
! BPADE Inverse of the Pade approximation constant
!
hvrini = '$Revision: 1.5 $'
! Initialize model data
call swdatinit(cpdair)
call swcmbdat ! g-point interval reduction data
call swaerpr ! aerosol optical properties
call swcldpr ! cloud optical properties
call swatmref ! reference MLS profile
! Moved to module_ra_rrtmg_swf for WRF
! call sw_kgb16 ! molecular absorption coefficients
! call sw_kgb17
! call sw_kgb18
! call sw_kgb19
! call sw_kgb20
! call sw_kgb21
! call sw_kgb22
! call sw_kgb23
! call sw_kgb24
! call sw_kgb25
! call sw_kgb26
! call sw_kgb27
! call sw_kgb28
! call sw_kgb29
! Define exponential lookup tables for transmittance. Tau is
! computed as a function of the tau transition function, and transmittance
! is calculated as a function of tau. All tables are computed at intervals
! of 0.0001. The inverse of the constant used in the Pade approximation to
! the tau transition function is set to bpade.
exp_tbl(0) = 1.0
exp_tbl(ntbl) = expeps
bpade = 1.0 / pade
do itr = 1, ntbl-1
tfn = float(itr) / float(ntbl)
tau_tbl = bpade * tfn / (1. - tfn)
exp_tbl(itr) = exp(-tau_tbl)
if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
enddo
! Perform g-point reduction from 16 per band (224 total points) to
! a band dependent number (112 total points) for all absorption
! coefficient input data and Planck fraction input data.
! Compute relative weighting for new g-point combinations.
igcsm = 0
do ibnd = 1,nbndsw
iprsm = 0
if (ngc(ibnd).lt.mg) then
do igc = 1,ngc(ibnd)
igcsm = igcsm + 1
wtsum = 0.
do ipr = 1, ngn(igcsm)
iprsm = iprsm + 1
wtsum = wtsum + wt(iprsm)
enddo
wtsm(igc) = wtsum
enddo
do ig = 1, ng(ibnd+15)
ind = (ibnd-1)*mg + ig
rwgt(ind) = wt(ig)/wtsm(ngm(ind))
enddo
else
do ig = 1, ng(ibnd+15)
igcsm = igcsm + 1
ind = (ibnd-1)*mg + ig
rwgt(ind) = 1.0
enddo
endif
enddo
! Reduce g-points for absorption coefficient data in each LW spectral band.
call cmbgb16s
call cmbgb17
call cmbgb18
call cmbgb19
call cmbgb20
call cmbgb21
call cmbgb22
call cmbgb23
call cmbgb24
call cmbgb25
call cmbgb26
call cmbgb27
call cmbgb28
call cmbgb29
end subroutine rrtmg_sw_ini
!***************************************************************************
subroutine swdatinit(cpdair) 2,4
!***************************************************************************
! --------- Modules ----------
use rrsw_con_f, only: heatfac, grav, planck, boltz, &
clight, avogad, alosmt, gascon, radcn1, radcn2, &
sbcnst, secdy
use rrsw_vsn_f
save
real , intent(in) :: cpdair ! Specific heat capacity of dry air
! at constant pressure at 273 K
! (J kg-1 K-1)
! Shortwave spectral band limits (wavenumbers)
wavenum1(:) = (/2600. , 3250. , 4000. , 4650. , 5150. , 6150. , 7700. , &
8050. ,12850. ,16000. ,22650. ,29000. ,38000. , 820. /)
wavenum2(:) = (/3250. , 4000. , 4650. , 5150. , 6150. , 7700. , 8050. , &
12850. ,16000. ,22650. ,29000. ,38000. ,50000. , 2600. /)
delwave(:) = (/ 650. , 750. , 650. , 500. , 1000. , 1550. , 350. , &
4800. , 3150. , 6650. , 6350. , 9000. ,12000. , 1780. /)
! Spectral band information
ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
icxa(:) = (/ 5 ,5 ,4 ,4 ,3 ,3 ,2 ,2 ,1 ,1 ,1 ,1 ,1 ,5/)
! Fundamental physical constants from NIST 2002
grav = 9.8066 ! Acceleration of gravity
! (m s-2)
planck = 6.62606876e-27 ! Planck constant
! (ergs s; g cm2 s-1)
boltz = 1.3806503e-16 ! Boltzmann constant
! (ergs K-1; g cm2 s-2 K-1)
clight = 2.99792458e+10 ! Speed of light in a vacuum
! (cm s-1)
avogad = 6.02214199e+23 ! Avogadro constant
! (mol-1)
alosmt = 2.6867775e+19 ! Loschmidt constant
! (cm-3)
gascon = 8.31447200e+07 ! Molar gas constant
! (ergs mol-1 K-1)
radcn1 = 1.191042772e-12 ! First radiation constant
! (W cm2 sr-1)
radcn2 = 1.4387752 ! Second radiation constant
! (cm K)
sbcnst = 5.670400e-04 ! Stefan-Boltzmann constant
! (W cm-2 K-4)
secdy = 8.6400e4 ! Number of seconds per day
! (s d-1)
!
! units are generally cgs
!
! The first and second radiation constants are taken from NIST.
! They were previously obtained from the relations:
! radcn1 = 2.*planck*clight*clight*1.e-07
! radcn2 = planck*clight/boltz
! Heatfac is the factor by which delta-flux / delta-pressure is
! multiplied, with flux in W/m-2 and pressure in mbar, to get
! the heating rate in units of degrees/day. It is equal to:
! Original value:
! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
! Here, cpdair (1.004) is in units of J g-1 K-1, and the
! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
! = (9.8066)(86400)(1e-5)/(1.004)
! heatfac = 8.4391
!
! Modified value for consistency with CAM3:
! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
! = (9.80616)(86400)(1e-5)/(1.00464)
! heatfac = 8.43339130434
!
! Calculated value (from constants above and input cpdair)
! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
heatfac = grav * secdy / (cpdair * 1.e2 )
end subroutine swdatinit
!***************************************************************************
subroutine swcmbdat 2
!***************************************************************************
save
! ------- Definitions -------
! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
! This mapping from 224 to 112 points has been carefully selected to
! minimize the effect on the resulting fluxes and cooling rates, and
! caution should be used if the mapping is modified. The full 224
! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
! ngpt The total number of new g-points
! ngc The number of new g-points in each band
! ngs The cumulative sum of new g-points for each band
! ngm The index of each new g-point relative to the original
! 16 g-points for each band.
! ngn The number of original g-points that are combined to make
! each new g-point in each band.
! ngb The band index for each new g-point.
! wt RRTM weights for 16 g-points.
! Use this set for 112 quadrature point (g-point) model
! ------- Data statements -------
ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16
1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17
1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18
1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19
1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20
1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21
1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22
1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23
1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24
1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25
1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26
1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27
1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28
1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29
ngn(:) = (/ 2,2,2,2,4,4, & ! band 16
1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17
1,1,1,1,2,2,4,4, & ! band 18
1,1,1,1,2,2,4,4, & ! band 19
1,1,1,1,1,1,1,1,2,6, & ! band 20
1,1,1,1,1,1,1,1,2,6, & ! band 21
8,8, & ! band 22
2,2,1,1,1,1,1,1,2,4, & ! band 23
2,2,2,2,2,2,2,2, & ! band 24
1,1,2,2,4,6, & ! band 25
1,1,2,2,4,6, & ! band 26
1,1,1,1,1,1,4,6, & ! band 27
1,1,2,2,4,6, & ! band 28
1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29
ngb(:) = (/ 16,16,16,16,16,16, & ! band 16
17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
18,18,18,18,18,18,18,18, & ! band 18
19,19,19,19,19,19,19,19, & ! band 19
20,20,20,20,20,20,20,20,20,20, & ! band 20
21,21,21,21,21,21,21,21,21,21, & ! band 21
22,22, & ! band 22
23,23,23,23,23,23,23,23,23,23, & ! band 23
24,24,24,24,24,24,24,24, & ! band 24
25,25,25,25,25,25, & ! band 25
26,26,26,26,26,26, & ! band 26
27,27,27,27,27,27,27,27, & ! band 27
28,28,28,28,28,28, & ! band 28
29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
! Use this set for full 224 quadrature point (g-point) model
! ------- Data statements -------
! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28
! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29
! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28
! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29
! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16
! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17
! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18
! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19
! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20
! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21
! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22
! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23
! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24
! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25
! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26
! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27
! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28
! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29
wt(:) = (/ 0.1527534276 , 0.1491729617 , 0.1420961469 , &
0.1316886544 , 0.1181945205 , 0.1019300893 , &
0.0832767040 , 0.0626720116 , 0.0424925000 , &
0.0046269894 , 0.0038279891 , 0.0030260086 , &
0.0022199750 , 0.0014140010 , 0.0005330000 , &
0.0000750000 /)
end subroutine swcmbdat
!***************************************************************************
subroutine swaerpr 2,2
!***************************************************************************
! Purpose: Define spectral aerosol properties for six ECMWF aerosol types
! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
!
! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003
! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
save
rsrtaua( 1, :) = (/ &
0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
rsrtaua( 2, :) = (/ &
0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
rsrtaua( 3, :) = (/ &
0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
rsrtaua( 4, :) = (/ &
0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
rsrtaua( 5, :) = (/ &
0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
rsrtaua( 6, :) = (/ &
0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
rsrtaua( 7, :) = (/ &
0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /)
rsrtaua( 8, :) = (/ &
0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /)
rsrtaua( 9, :) = (/ &
0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /)
rsrtaua(10, :) = (/ &
1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
rsrtaua(11, :) = (/ &
1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
rsrtaua(12, :) = (/ &
1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
rsrtaua(13, :) = (/ &
1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /)
rsrtaua(14, :) = (/ &
0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /)
rsrpiza( 1, :) = (/ &
.5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
rsrpiza( 2, :) = (/ &
.5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
rsrpiza( 3, :) = (/ &
.8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
rsrpiza( 4, :) = (/ &
.8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
rsrpiza( 5, :) = (/ &
.8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
rsrpiza( 6, :) = (/ &
.8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
rsrpiza( 7, :) = (/ &
.8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /)
rsrpiza( 8, :) = (/ &
.8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /)
rsrpiza( 9, :) = (/ &
.8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /)
rsrpiza(10, :) = (/ &
.9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
rsrpiza(11, :) = (/ &
.9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
rsrpiza(12, :) = (/ &
.9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
rsrpiza(13, :) = (/ &
.9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /)
rsrpiza(14, :) = (/ &
.5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /)
rsrasya( 1, :) = (/ &
0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
rsrasya( 2, :) = (/ &
0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
rsrasya( 3, :) = (/ &
0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
rsrasya( 4, :) = (/ &
0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
rsrasya( 5, :) = (/ &
0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
rsrasya( 6, :) = (/ &
0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
rsrasya( 7, :) = (/ &
0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /)
rsrasya( 8, :) = (/ &
0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /)
rsrasya( 9, :) = (/ &
0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /)
rsrasya(10, :) = (/ &
0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
rsrasya(11, :) = (/ &
0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
rsrasya(12, :) = (/ &
0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
rsrasya(13, :) = (/ &
0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /)
rsrasya(14, :) = (/ &
0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /)
end subroutine swaerpr
!***************************************************************************
subroutine cmbgb16s 2,2
!***************************************************************************
!
! Original version: MJIacono; July 1998
! Revision for RRTM_SW: MJIacono; November 2002
! Revision for RRTMG_SW: MJIacono; December 2003
! Revision for F90 reformatting: MJIacono; July 2006
!
! The subroutines CMBGB16->CMBGB29 input the absorption coefficient
! data for each band, which are defined for 16 g-points and 14 spectral
! bands. The data are combined with appropriate weighting following the
! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source
! function data in array SFLUXREF are combined without weighting. All
! g-point reduced data are put into new arrays for use in RRTMG_SW.
!
! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
!
!-----------------------------------------------------------------------
use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(1)
sumk = 0.
do ipr = 1, ngn(igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(1)
sumk = 0.
do ipr = 1, ngn(igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(1)
sumk = 0.
do ipr = 1, ngn(igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(1)
sumk = 0.
do ipr = 1, ngn(igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
enddo
forref(jt,igc) = sumk
enddo
enddo
iprsm = 0
do igc = 1,ngc(1)
sumf = 0.
do ipr = 1, ngn(igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm)
enddo
sfluxref(igc) = sumf
enddo
end subroutine cmbgb16s
!***************************************************************************
subroutine cmbgb17 2,2
!***************************************************************************
!
! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
!-----------------------------------------------------------------------
use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(2)
sumk = 0.
do ipr = 1, ngn(ngs(1)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jn = 1,5
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(2)
sumk = 0.
do ipr = 1, ngn(ngs(1)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
enddo
kb(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(2)
sumk = 0.
do ipr = 1, ngn(ngs(1)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,4
iprsm = 0
do igc = 1,ngc(2)
sumk = 0.
do ipr = 1, ngn(ngs(1)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
enddo
forref(jt,igc) = sumk
enddo
enddo
do jp = 1,5
iprsm = 0
do igc = 1,ngc(2)
sumf = 0.
do ipr = 1, ngn(ngs(1)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb17
!***************************************************************************
subroutine cmbgb18 2,2
!***************************************************************************
!
! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4)
!-----------------------------------------------------------------------
use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(3)
sumk = 0.
do ipr = 1, ngn(ngs(2)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(3)
sumk = 0.
do ipr = 1, ngn(ngs(2)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(3)
sumk = 0.
do ipr = 1, ngn(ngs(2)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(3)
sumk = 0.
do ipr = 1, ngn(ngs(2)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
enddo
forref(jt,igc) = sumk
enddo
enddo
do jp = 1,9
iprsm = 0
do igc = 1,ngc(3)
sumf = 0.
do ipr = 1, ngn(ngs(2)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb18
!***************************************************************************
subroutine cmbgb19 2,2
!***************************************************************************
!
! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2)
!-----------------------------------------------------------------------
use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(4)
sumk = 0.
do ipr = 1, ngn(ngs(3)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(4)
sumk = 0.
do ipr = 1, ngn(ngs(3)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(4)
sumk = 0.
do ipr = 1, ngn(ngs(3)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(4)
sumk = 0.
do ipr = 1, ngn(ngs(3)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
enddo
forref(jt,igc) = sumk
enddo
enddo
do jp = 1,9
iprsm = 0
do igc = 1,ngc(4)
sumf = 0.
do ipr = 1, ngn(ngs(3)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb19
!***************************************************************************
subroutine cmbgb20 2,2
!***************************************************************************
!
! band 20: 5150-6150 cm-1 (low - h2o; high - h2o)
!-----------------------------------------------------------------------
use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
absa, ka, absb, kb, selfref, forref, sfluxref, absch4
! ------- Local -------
integer :: jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(5)
sumk = 0.
do ipr = 1, ngn(ngs(4)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
enddo
ka(jt,jp,igc) = sumk
enddo
enddo
do jp = 13,59
iprsm = 0
do igc = 1,ngc(5)
sumk = 0.
do ipr = 1, ngn(ngs(4)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(5)
sumk = 0.
do ipr = 1, ngn(ngs(4)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,4
iprsm = 0
do igc = 1,ngc(5)
sumk = 0.
do ipr = 1, ngn(ngs(4)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
enddo
forref(jt,igc) = sumk
enddo
enddo
iprsm = 0
do igc = 1,ngc(5)
sumf1 = 0.
sumf2 = 0.
do ipr = 1, ngn(ngs(4)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm)
sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
enddo
sfluxref(igc) = sumf1
absch4(igc) = sumf2
enddo
end subroutine cmbgb20
!***************************************************************************
subroutine cmbgb21 2,2
!***************************************************************************
!
! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
!-----------------------------------------------------------------------
use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(6)
sumk = 0.
do ipr = 1, ngn(ngs(5)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jn = 1,5
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(6)
sumk = 0.
do ipr = 1, ngn(ngs(5)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
enddo
kb(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(6)
sumk = 0.
do ipr = 1, ngn(ngs(5)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,4
iprsm = 0
do igc = 1,ngc(6)
sumk = 0.
do ipr = 1, ngn(ngs(5)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
enddo
forref(jt,igc) = sumk
enddo
enddo
do jp = 1,9
iprsm = 0
do igc = 1,ngc(6)
sumf = 0.
do ipr = 1, ngn(ngs(5)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb21
!***************************************************************************
subroutine cmbgb22 2,2
!***************************************************************************
!
! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2)
!-----------------------------------------------------------------------
use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absa, ka, absb, kb, selfref, forref, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(7)
sumk = 0.
do ipr = 1, ngn(ngs(6)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(7)
sumk = 0.
do ipr = 1, ngn(ngs(6)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(7)
sumk = 0.
do ipr = 1, ngn(ngs(6)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(7)
sumk = 0.
do ipr = 1, ngn(ngs(6)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
enddo
forref(jt,igc) = sumk
enddo
enddo
do jp = 1,9
iprsm = 0
do igc = 1,ngc(7)
sumf = 0.
do ipr = 1, ngn(ngs(6)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb22
!***************************************************************************
subroutine cmbgb23 2,2
!***************************************************************************
!
! band 23: 8050-12850 cm-1 (low - h2o; high - nothing)
!-----------------------------------------------------------------------
use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
absa, ka, selfref, forref, sfluxref, rayl
! ------- Local -------
integer :: jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(8)
sumk = 0.
do ipr = 1, ngn(ngs(7)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
enddo
ka(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(8)
sumk = 0.
do ipr = 1, ngn(ngs(7)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(8)
sumk = 0.
do ipr = 1, ngn(ngs(7)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
enddo
forref(jt,igc) = sumk
enddo
enddo
iprsm = 0
do igc = 1,ngc(8)
sumf1 = 0.
sumf2 = 0.
do ipr = 1, ngn(ngs(7)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm)
sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
enddo
sfluxref(igc) = sumf1
rayl(igc) = sumf2
enddo
end subroutine cmbgb23
!***************************************************************************
subroutine cmbgb24 2,2
!***************************************************************************
!
! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
!-----------------------------------------------------------------------
use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
abso3ao, abso3bo, raylao, raylbo, &
absa, ka, absb, kb, selfref, forref, sfluxref, &
abso3a, abso3b, rayla, raylb
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2, sumf3
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(9)
sumk = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(9)
sumk = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(9)
sumk = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,3
iprsm = 0
do igc = 1,ngc(9)
sumk = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
enddo
forref(jt,igc) = sumk
enddo
enddo
iprsm = 0
do igc = 1,ngc(9)
sumf1 = 0.
sumf2 = 0.
sumf3 = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
enddo
raylb(igc) = sumf1
abso3a(igc) = sumf2
abso3b(igc) = sumf3
enddo
do jp = 1,9
iprsm = 0
do igc = 1,ngc(9)
sumf1 = 0.
sumf2 = 0.
do ipr = 1, ngn(ngs(8)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm,jp)
sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
enddo
sfluxref(igc,jp) = sumf1
rayla(igc,jp) = sumf2
enddo
enddo
end subroutine cmbgb24
!***************************************************************************
subroutine cmbgb25 2,2
!***************************************************************************
!
! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
!-----------------------------------------------------------------------
use rrsw_kg25_f, only : kao, sfluxrefo, &
abso3ao, abso3bo, raylo, &
absa, ka, sfluxref, &
abso3a, abso3b, rayl
! ------- Local -------
integer :: jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2, sumf3, sumf4
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(10)
sumk = 0.
do ipr = 1, ngn(ngs(9)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
enddo
ka(jt,jp,igc) = sumk
enddo
enddo
enddo
iprsm = 0
do igc = 1,ngc(10)
sumf1 = 0.
sumf2 = 0.
sumf3 = 0.
sumf4 = 0.
do ipr = 1, ngn(ngs(9)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm)
sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
enddo
sfluxref(igc) = sumf1
abso3a(igc) = sumf2
abso3b(igc) = sumf3
rayl(igc) = sumf4
enddo
end subroutine cmbgb25
!***************************************************************************
subroutine cmbgb26 2,2
!***************************************************************************
!
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!-----------------------------------------------------------------------
use rrsw_kg26_f, only : sfluxrefo, raylo, &
sfluxref, rayl
! ------- Local -------
integer :: igc, ipr, iprsm
real :: sumf1, sumf2
iprsm = 0
do igc = 1,ngc(11)
sumf1 = 0.
sumf2 = 0.
do ipr = 1, ngn(ngs(10)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
sumf2 = sumf2 + sfluxrefo(iprsm)
enddo
rayl(igc) = sumf1
sfluxref(igc) = sumf2
enddo
end subroutine cmbgb26
!***************************************************************************
subroutine cmbgb27 2,2
!***************************************************************************
!
! band 27: 29000-38000 cm-1 (low - o3; high - o3)
!-----------------------------------------------------------------------
use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, &
absa, ka, absb, kb, sfluxref, rayl
! ------- Local -------
integer :: jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(12)
sumk = 0.
do ipr = 1, ngn(ngs(11)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
enddo
ka(jt,jp,igc) = sumk
enddo
enddo
do jp = 13,59
iprsm = 0
do igc = 1,ngc(12)
sumk = 0.
do ipr = 1, ngn(ngs(11)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
iprsm = 0
do igc = 1,ngc(12)
sumf1 = 0.
sumf2 = 0.
do ipr = 1, ngn(ngs(11)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm)
sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
enddo
sfluxref(igc) = sumf1
rayl(igc) = sumf2
enddo
end subroutine cmbgb27
!***************************************************************************
subroutine cmbgb28 2,2
!***************************************************************************
!
! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2)
!-----------------------------------------------------------------------
use rrsw_kg28_f, only : kao, kbo, sfluxrefo, &
absa, ka, absb, kb, sfluxref
! ------- Local -------
integer :: jn, jt, jp, igc, ipr, iprsm
real :: sumk, sumf
do jn = 1,9
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(13)
sumk = 0.
do ipr = 1, ngn(ngs(12)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
enddo
ka(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jn = 1,5
do jt = 1,5
do jp = 13,59
iprsm = 0
do igc = 1,ngc(13)
sumk = 0.
do ipr = 1, ngn(ngs(12)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
enddo
kb(jn,jt,jp,igc) = sumk
enddo
enddo
enddo
enddo
do jp = 1,5
iprsm = 0
do igc = 1,ngc(13)
sumf = 0.
do ipr = 1, ngn(ngs(12)+igc)
iprsm = iprsm + 1
sumf = sumf + sfluxrefo(iprsm,jp)
enddo
sfluxref(igc,jp) = sumf
enddo
enddo
end subroutine cmbgb28
!***************************************************************************
subroutine cmbgb29 2,2
!***************************************************************************
!
! band 29: 820-2600 cm-1 (low - h2o; high - co2)
!-----------------------------------------------------------------------
use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absh2oo, absco2o, &
absa, ka, absb, kb, selfref, forref, sfluxref, &
absh2o, absco2
! ------- Local -------
integer :: jt, jp, igc, ipr, iprsm
real :: sumk, sumf1, sumf2, sumf3
do jt = 1,5
do jp = 1,13
iprsm = 0
do igc = 1,ngc(14)
sumk = 0.
do ipr = 1, ngn(ngs(13)+igc)
iprsm = iprsm + 1
sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
enddo
ka(jt,jp,igc) = sumk
enddo
enddo
do jp = 13,59
iprsm = 0
do igc = 1,ngc(14)
sumk = 0.
do ipr = 1, ngn(ngs(13)+igc)
iprsm = iprsm + 1
sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
enddo
kb(jt,jp,igc) = sumk
enddo
enddo
enddo
do jt = 1,10
iprsm = 0
do igc = 1,ngc(14)
sumk = 0.
do ipr = 1, ngn(ngs(13)+igc)
iprsm = iprsm + 1
sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
enddo
selfref(jt,igc) = sumk
enddo
enddo
do jt = 1,4
iprsm = 0
do igc = 1,ngc(14)
sumk = 0.
do ipr = 1, ngn(ngs(13)+igc)
iprsm = iprsm + 1
sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
enddo
forref(jt,igc) = sumk
enddo
enddo
iprsm = 0
do igc = 1,ngc(14)
sumf1 = 0.
sumf2 = 0.
sumf3 = 0.
do ipr = 1, ngn(ngs(13)+igc)
iprsm = iprsm + 1
sumf1 = sumf1 + sfluxrefo(iprsm)
sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
enddo
sfluxref(igc) = sumf1
absco2(igc) = sumf2
absh2o(igc) = sumf3
enddo
end subroutine cmbgb29
!***********************************************************************
subroutine swcldpr 2,2
!***********************************************************************
! Purpose: Define cloud extinction coefficient, single scattering albedo
! and asymmetry parameter data.
!
! ------- Modules -------
use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
extice2, ssaice2, asyice2, &
extice3, ssaice3, asyice3, fdlice3, &
abari, bbari, cbari, dbari, ebari, fbari
save
!-----------------------------------------------------------------------
!
! Explanation of the method for each value of INFLAG. A value of
! 0 for INFLAG do not distingish being liquid and ice clouds.
! INFLAG = 2 does distinguish between liquid and ice clouds, and
! requires further user input to specify the method to be used to
! compute the aborption due to each.
! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical
! depth, the cloud single-scattering albedo, and the
! moments of the phase function (0:NSTREAM). Note
! that these values are delta-m scaled within this
! subroutine.
! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
! water path (g/m2), and cloud ice fraction are input.
! ICEFLAG = 2: The ice effective radius (microns) is input and the
! optical properties due to ice clouds are computed from
! the optical properties stored in the RT code, STREAMER v3.0
! (Reference: Key. J., Streamer User's Guide, Cooperative
! Institute for Meteorological Satellite Studies, 2001, 96 pp.).
! Valid range of values for re are between 5.0 and
! 131.0 micron.
! This version uses Ebert and Curry, JGR, (1992) method for
! ice particles larger than 131.0 microns.
! ICEFLAG = 3: The ice generalized effective size (dge) is input
! and the optical depths, single-scattering albedo,
! and phase function moments are calculated as in
! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
! tables which were appropriately averaged for the
! bands in RRTM_SW. Linear interpolation is used to
! get the coefficients from the stored tables.
! Valid range of values for dge are between 5.0 and
! 140.0 micron.
! This version uses Ebert and Curry, JGR, (1992) method for
! ice particles larger than 140.0 microns.
! LIQFLAG = 1: The water droplet effective radius (microns) is input
! and the optical depths due to water clouds are computed
! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with
! modified coefficients derived from Mie scattering calculations.
! The values for absorption coefficients appropriate for
! the spectral bands in RRTM/RRTMG have been obtained for a
! range of effective radii by an averaging procedure
! based on the work of J. Pinto (private communication).
! Linear interpolation is used to get the absorption
! coefficients for the input effective radius.
! ..Updated tables suggested by Peter Blossey (Univ. Washington)
! and came from RRTMG_SW_v3.9 from AER, Inc.
!
! ------------------------------------------------------------------
! Everything below is for INFLAG = 2.
! Coefficients for Ebert and Curry method
abari(:) = (/ &
& 3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03 /)
bbari(:) = (/ &
& 2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00 /)
cbari(:) = (/ &
& 1.000e-05 ,1.100e-04 ,1.240e-02 ,3.779e-02 ,4.666e-01 /)
dbari(:) = (/ &
& 0.000e+00 ,1.405e-05 ,6.867e-04 ,1.284e-03 ,2.050e-05 /)
ebari(:) = (/ &
& 7.661e-01 ,7.730e-01 ,7.865e-01 ,8.172e-01 ,9.595e-01 /)
fbari(:) = (/ &
& 5.851e-04 ,5.665e-04 ,7.204e-04 ,7.463e-04 ,1.076e-04 /)
! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters
! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients
! Extinction coefficient
! BAND 16
extliq1(:, 16) = (/ &
& 9.004493E-01,6.366723E-01,4.542354E-01,3.468253E-01,2.816431E-01,&
& 2.383415E-01,2.070854E-01,1.831854E-01,1.642115E-01,1.487539E-01,&
& 1.359169E-01,1.250900E-01,1.158354E-01,1.078400E-01,1.008646E-01,&
& 9.472307E-02,8.928000E-02,8.442308E-02,8.005924E-02,7.612231E-02,&
& 7.255153E-02,6.929539E-02,6.631769E-02,6.358153E-02,6.106231E-02,&
& 5.873077E-02,5.656924E-02,5.455769E-02,5.267846E-02,5.091923E-02,&
& 4.926692E-02,4.771154E-02,4.623923E-02,4.484385E-02,4.351539E-02,&
& 4.224615E-02,4.103385E-02,3.986538E-02,3.874077E-02,3.765462E-02,&
& 3.660077E-02,3.557384E-02,3.457615E-02,3.360308E-02,3.265000E-02,&
& 3.171770E-02,3.080538E-02,2.990846E-02,2.903000E-02,2.816461E-02,&
& 2.731539E-02,2.648231E-02,2.566308E-02,2.485923E-02,2.407000E-02,&
& 2.329615E-02,2.253769E-02,2.179615E-02 /)
! BAND 17
extliq1(:, 17) = (/ &
& 6.741200e-01,5.390739e-01,4.198767e-01,3.332553e-01,2.735633e-01,&
& 2.317727e-01,2.012760e-01,1.780400e-01,1.596927e-01,1.447980e-01,&
& 1.324480e-01,1.220347e-01,1.131327e-01,1.054313e-01,9.870534e-02,&
& 9.278200e-02,8.752599e-02,8.282933e-02,7.860600e-02,7.479133e-02,&
& 7.132800e-02,6.816733e-02,6.527401e-02,6.261266e-02,6.015934e-02,&
& 5.788867e-02,5.578134e-02,5.381667e-02,5.198133e-02,5.026067e-02,&
& 4.864466e-02,4.712267e-02,4.568066e-02,4.431200e-02,4.300867e-02,&
& 4.176600e-02,4.057400e-02,3.942534e-02,3.832066e-02,3.725068e-02,&
& 3.621400e-02,3.520533e-02,3.422333e-02,3.326400e-02,3.232467e-02,&
& 3.140535e-02,3.050400e-02,2.962000e-02,2.875267e-02,2.789800e-02,&
& 2.705934e-02,2.623667e-02,2.542667e-02,2.463200e-02,2.385267e-02,&
& 2.308667e-02,2.233667e-02,2.160067e-02 /)
! BAND 18
extliq1(:, 18) = (/ &
& 9.250861e-01,6.245692e-01,4.347038e-01,3.320208e-01,2.714869e-01,&
& 2.309516e-01,2.012592e-01,1.783315e-01,1.600369e-01,1.451000e-01,&
& 1.326838e-01,1.222069e-01,1.132554e-01,1.055146e-01,9.876000e-02,&
& 9.281386e-02,8.754000e-02,8.283078e-02,7.860077e-02,7.477769e-02,&
& 7.130847e-02,6.814461e-02,6.524615e-02,6.258462e-02,6.012847e-02,&
& 5.785462e-02,5.574231e-02,5.378000e-02,5.194461e-02,5.022462e-02,&
& 4.860846e-02,4.708462e-02,4.564154e-02,4.427462e-02,4.297231e-02,&
& 4.172769e-02,4.053693e-02,3.939000e-02,3.828462e-02,3.721692e-02,&
& 3.618000e-02,3.517077e-02,3.418923e-02,3.323077e-02,3.229154e-02,&
& 3.137154e-02,3.047154e-02,2.959077e-02,2.872308e-02,2.786846e-02,&
& 2.703077e-02,2.620923e-02,2.540077e-02,2.460615e-02,2.382693e-02,&
& 2.306231e-02,2.231231e-02,2.157923e-02 /)
! BAND 19
extliq1(:, 19) = (/ &
& 9.298960e-01,5.776460e-01,4.083450e-01,3.211160e-01,2.666390e-01,&
& 2.281990e-01,1.993250e-01,1.768080e-01,1.587810e-01,1.440390e-01,&
& 1.317720e-01,1.214150e-01,1.125540e-01,1.048890e-01,9.819600e-02,&
& 9.230201e-02,8.706900e-02,8.239698e-02,7.819500e-02,7.439899e-02,&
& 7.095300e-02,6.780700e-02,6.492900e-02,6.228600e-02,5.984600e-02,&
& 5.758599e-02,5.549099e-02,5.353801e-02,5.171400e-02,5.000500e-02,&
& 4.840000e-02,4.688500e-02,4.545100e-02,4.409300e-02,4.279700e-02,&
& 4.156100e-02,4.037700e-02,3.923800e-02,3.813800e-02,3.707600e-02,&
& 3.604500e-02,3.504300e-02,3.406500e-02,3.310800e-02,3.217700e-02,&
& 3.126600e-02,3.036800e-02,2.948900e-02,2.862400e-02,2.777500e-02,&
& 2.694200e-02,2.612300e-02,2.531700e-02,2.452800e-02,2.375100e-02,&
& 2.299100e-02,2.224300e-02,2.151201e-02 /)
! BAND 20
extliq1(:, 20) = (/ &
& 8.780964e-01,5.407031e-01,3.961100e-01,3.166645e-01,2.640455e-01,&
& 2.261070e-01,1.974820e-01,1.751775e-01,1.573415e-01,1.427725e-01,&
& 1.306535e-01,1.204195e-01,1.116650e-01,1.040915e-01,9.747550e-02,&
& 9.164800e-02,8.647649e-02,8.185501e-02,7.770200e-02,7.394749e-02,&
& 7.053800e-02,6.742700e-02,6.457999e-02,6.196149e-02,5.954450e-02,&
& 5.730650e-02,5.522949e-02,5.329450e-02,5.148500e-02,4.979000e-02,&
& 4.819600e-02,4.669301e-02,4.527050e-02,4.391899e-02,4.263500e-02,&
& 4.140500e-02,4.022850e-02,3.909500e-02,3.800199e-02,3.694600e-02,&
& 3.592000e-02,3.492250e-02,3.395050e-02,3.300150e-02,3.207250e-02,&
& 3.116250e-02,3.027100e-02,2.939500e-02,2.853500e-02,2.768900e-02,&
& 2.686000e-02,2.604350e-02,2.524150e-02,2.445350e-02,2.368049e-02,&
& 2.292150e-02,2.217800e-02,2.144800e-02 /)
! BAND 21
extliq1(:, 21) = (/ &
& 7.937480e-01,5.123036e-01,3.858181e-01,3.099622e-01,2.586829e-01,&
& 2.217587e-01,1.939755e-01,1.723397e-01,1.550258e-01,1.408600e-01,&
& 1.290545e-01,1.190661e-01,1.105039e-01,1.030848e-01,9.659387e-02,&
& 9.086775e-02,8.577807e-02,8.122452e-02,7.712711e-02,7.342193e-02,&
& 7.005387e-02,6.697840e-02,6.416000e-02,6.156903e-02,5.917484e-02,&
& 5.695807e-02,5.489968e-02,5.298097e-02,5.118806e-02,4.950645e-02,&
& 4.792710e-02,4.643581e-02,4.502484e-02,4.368547e-02,4.241001e-02,&
& 4.118936e-02,4.002193e-02,3.889711e-02,3.781322e-02,3.676387e-02,&
& 3.574549e-02,3.475548e-02,3.379033e-02,3.284678e-02,3.192420e-02,&
& 3.102032e-02,3.013484e-02,2.926258e-02,2.840839e-02,2.756742e-02,&
& 2.674258e-02,2.593064e-02,2.513258e-02,2.435000e-02,2.358064e-02,&
& 2.282581e-02,2.208548e-02,2.135936e-02 /)
! BAND 22
extliq1(:, 22) = (/ &
& 7.533129e-01,5.033129e-01,3.811271e-01,3.062757e-01,2.558729e-01,&
& 2.196828e-01,1.924372e-01,1.711714e-01,1.541086e-01,1.401114e-01,&
& 1.284257e-01,1.185200e-01,1.100243e-01,1.026529e-01,9.620142e-02,&
& 9.050714e-02,8.544428e-02,8.091714e-02,7.684000e-02,7.315429e-02,&
& 6.980143e-02,6.673999e-02,6.394000e-02,6.136000e-02,5.897715e-02,&
& 5.677000e-02,5.472285e-02,5.281286e-02,5.102858e-02,4.935429e-02,&
& 4.778000e-02,4.629714e-02,4.489142e-02,4.355857e-02,4.228715e-02,&
& 4.107285e-02,3.990857e-02,3.879000e-02,3.770999e-02,3.666429e-02,&
& 3.565000e-02,3.466286e-02,3.370143e-02,3.276143e-02,3.184143e-02,&
& 3.094000e-02,3.005714e-02,2.919000e-02,2.833714e-02,2.750000e-02,&
& 2.667714e-02,2.586714e-02,2.507143e-02,2.429143e-02,2.352428e-02,&
& 2.277143e-02,2.203429e-02,2.130857e-02 /)
! BAND 23
extliq1(:, 23) = (/ &
& 7.079894e-01,4.878198e-01,3.719852e-01,3.001873e-01,2.514795e-01,&
& 2.163013e-01,1.897100e-01,1.689033e-01,1.521793e-01,1.384449e-01,&
& 1.269666e-01,1.172326e-01,1.088745e-01,1.016224e-01,9.527085e-02,&
& 8.966240e-02,8.467543e-02,8.021144e-02,7.619344e-02,7.255676e-02,&
& 6.924996e-02,6.623030e-02,6.346261e-02,6.091499e-02,5.856325e-02,&
& 5.638385e-02,5.435930e-02,5.247156e-02,5.070699e-02,4.905230e-02,&
& 4.749499e-02,4.602611e-02,4.463581e-02,4.331543e-02,4.205647e-02,&
& 4.085241e-02,3.969978e-02,3.859033e-02,3.751877e-02,3.648168e-02,&
& 3.547468e-02,3.449553e-02,3.354072e-02,3.260732e-02,3.169438e-02,&
& 3.079969e-02,2.992146e-02,2.905875e-02,2.821201e-02,2.737873e-02,&
& 2.656052e-02,2.575586e-02,2.496511e-02,2.418783e-02,2.342500e-02,&
& 2.267646e-02,2.194177e-02,2.122146e-02 /)
! BAND 24
extliq1(:, 24) = (/ &
& 6.850164e-01,4.762468e-01,3.642001e-01,2.946012e-01,2.472001e-01,&
& 2.128588e-01,1.868537e-01,1.664893e-01,1.501142e-01,1.366620e-01,&
& 1.254147e-01,1.158721e-01,1.076732e-01,1.005530e-01,9.431306e-02,&
& 8.879891e-02,8.389232e-02,7.949714e-02,7.553857e-02,7.195474e-02,&
& 6.869413e-02,6.571444e-02,6.298286e-02,6.046779e-02,5.814474e-02,&
& 5.599141e-02,5.399114e-02,5.212443e-02,5.037870e-02,4.874321e-02,&
& 4.720219e-02,4.574813e-02,4.437160e-02,4.306460e-02,4.181810e-02,&
& 4.062603e-02,3.948252e-02,3.838256e-02,3.732049e-02,3.629192e-02,&
& 3.529301e-02,3.432190e-02,3.337412e-02,3.244842e-02,3.154175e-02,&
& 3.065253e-02,2.978063e-02,2.892367e-02,2.808221e-02,2.725478e-02,&
& 2.644174e-02,2.564175e-02,2.485508e-02,2.408303e-02,2.332365e-02,&
& 2.257890e-02,2.184824e-02,2.113224e-02 /)
! BAND 25
extliq1(:, 25) = (/ &
& 6.673017e-01,4.664520e-01,3.579398e-01,2.902234e-01,2.439904e-01,&
& 2.104149e-01,1.849277e-01,1.649234e-01,1.488087e-01,1.355515e-01,&
& 1.244562e-01,1.150329e-01,1.069321e-01,9.989310e-02,9.372070e-02,&
& 8.826450e-02,8.340622e-02,7.905378e-02,7.513109e-02,7.157859e-02,&
& 6.834588e-02,6.539114e-02,6.268150e-02,6.018621e-02,5.788098e-02,&
& 5.574351e-02,5.375699e-02,5.190412e-02,5.017099e-02,4.854497e-02,&
& 4.701490e-02,4.557030e-02,4.420249e-02,4.290304e-02,4.166427e-02,&
& 4.047820e-02,3.934232e-02,3.824778e-02,3.719236e-02,3.616931e-02,&
& 3.517597e-02,3.420856e-02,3.326566e-02,3.234346e-02,3.144122e-02,&
& 3.055684e-02,2.968798e-02,2.883519e-02,2.799635e-02,2.717228e-02,&
& 2.636182e-02,2.556424e-02,2.478114e-02,2.401086e-02,2.325657e-02,&
& 2.251506e-02,2.178594e-02,2.107301e-02 /)
! BAND 26
extliq1(:, 26) = (/ &
& 6.552414e-01,4.599454e-01,3.538626e-01,2.873547e-01,2.418033e-01,&
& 2.086660e-01,1.834885e-01,1.637142e-01,1.477767e-01,1.346583e-01,&
& 1.236734e-01,1.143412e-01,1.063148e-01,9.933905e-02,9.322026e-02,&
& 8.780979e-02,8.299230e-02,7.867554e-02,7.478450e-02,7.126053e-02,&
& 6.805276e-02,6.512143e-02,6.243211e-02,5.995541e-02,5.766712e-02,&
& 5.554484e-02,5.357246e-02,5.173222e-02,5.001069e-02,4.839505e-02,&
& 4.687471e-02,4.543861e-02,4.407857e-02,4.278577e-02,4.155331e-02,&
& 4.037322e-02,3.924302e-02,3.815376e-02,3.710172e-02,3.608296e-02,&
& 3.509330e-02,3.412980e-02,3.319009e-02,3.227106e-02,3.137157e-02,&
& 3.048950e-02,2.962365e-02,2.877297e-02,2.793726e-02,2.711500e-02,&
& 2.630666e-02,2.551206e-02,2.473052e-02,2.396287e-02,2.320861e-02,&
& 2.246810e-02,2.174162e-02,2.102927e-02 /)
! BAND 27
extliq1(:, 27) = (/ &
& 6.430901e-01,4.532134e-01,3.496132e-01,2.844655e-01,2.397347e-01,&
& 2.071236e-01,1.822976e-01,1.627640e-01,1.469961e-01,1.340006e-01,&
& 1.231069e-01,1.138441e-01,1.058706e-01,9.893678e-02,9.285166e-02,&
& 8.746871e-02,8.267411e-02,7.837656e-02,7.450257e-02,7.099318e-02,&
& 6.779929e-02,6.487987e-02,6.220168e-02,5.973530e-02,5.745636e-02,&
& 5.534344e-02,5.337986e-02,5.154797e-02,4.983404e-02,4.822582e-02,&
& 4.671228e-02,4.528321e-02,4.392997e-02,4.264325e-02,4.141647e-02,&
& 4.024259e-02,3.911767e-02,3.803309e-02,3.698782e-02,3.597140e-02,&
& 3.498774e-02,3.402852e-02,3.309340e-02,3.217818e-02,3.128292e-02,&
& 3.040486e-02,2.954230e-02,2.869545e-02,2.786261e-02,2.704372e-02,&
& 2.623813e-02,2.544668e-02,2.466788e-02,2.390313e-02,2.315136e-02,&
& 2.241391e-02,2.168921e-02,2.097903e-02 /)
! BAND 28
extliq1(:, 28) = (/ &
& 6.367074e-01,4.495768e-01,3.471263e-01,2.826149e-01,2.382868e-01,&
& 2.059640e-01,1.813562e-01,1.619881e-01,1.463436e-01,1.334402e-01,&
& 1.226166e-01,1.134096e-01,1.054829e-01,9.858838e-02,9.253790e-02,&
& 8.718582e-02,8.241830e-02,7.814482e-02,7.429212e-02,7.080165e-02,&
& 6.762385e-02,6.471838e-02,6.205388e-02,5.959726e-02,5.732871e-02,&
& 5.522402e-02,5.326793e-02,5.144230e-02,4.973440e-02,4.813188e-02,&
& 4.662283e-02,4.519798e-02,4.384833e-02,4.256541e-02,4.134253e-02,&
& 4.017136e-02,3.904911e-02,3.796779e-02,3.692364e-02,3.591182e-02,&
& 3.492930e-02,3.397230e-02,3.303920e-02,3.212572e-02,3.123278e-02,&
& 3.035519e-02,2.949493e-02,2.864985e-02,2.781840e-02,2.700197e-02,&
& 2.619682e-02,2.540674e-02,2.462966e-02,2.386613e-02,2.311602e-02,&
& 2.237846e-02,2.165660e-02,2.094756e-02 /)
! BAND 29
extliq1(:, 29) = (/ &
& 4.298416e-01,4.391639e-01,3.975030e-01,3.443028e-01,2.957345e-01,&
& 2.556461e-01,2.234755e-01,1.976636e-01,1.767428e-01,1.595611e-01,&
& 1.452636e-01,1.332156e-01,1.229481e-01,1.141059e-01,1.064208e-01,&
& 9.968527e-02,9.373833e-02,8.845221e-02,8.372112e-02,7.946667e-02,&
& 7.561807e-02,7.212029e-02,6.893166e-02,6.600944e-02,6.332277e-02,&
& 6.084277e-02,5.854721e-02,5.641361e-02,5.442639e-02,5.256750e-02,&
& 5.082499e-02,4.918556e-02,4.763694e-02,4.617222e-02,4.477861e-02,&
& 4.344861e-02,4.217999e-02,4.096111e-02,3.978638e-02,3.865361e-02,&
& 3.755473e-02,3.649028e-02,3.545361e-02,3.444361e-02,3.345666e-02,&
& 3.249167e-02,3.154722e-02,3.062083e-02,2.971250e-02,2.882083e-02,&
& 2.794611e-02,2.708778e-02,2.624500e-02,2.541750e-02,2.460528e-02,&
& 2.381194e-02,2.303250e-02,2.226833e-02 /)
! Single scattering albedo
! BAND 16
ssaliq1(:, 16) = (/ &
& 8.362119e-01,8.098460e-01,7.762291e-01,7.486042e-01,7.294172e-01,&
& 7.161000e-01,7.060656e-01,6.978387e-01,6.907193e-01,6.843551e-01,&
& 6.785668e-01,6.732450e-01,6.683191e-01,6.637264e-01,6.594307e-01,&
& 6.554033e-01,6.516115e-01,6.480295e-01,6.446429e-01,6.414306e-01,&
& 6.383783e-01,6.354750e-01,6.327068e-01,6.300665e-01,6.275376e-01,&
& 6.251245e-01,6.228136e-01,6.205944e-01,6.184720e-01,6.164330e-01,&
& 6.144742e-01,6.125962e-01,6.108004e-01,6.090740e-01,6.074200e-01,&
& 6.058381e-01,6.043209e-01,6.028681e-01,6.014836e-01,6.001626e-01,&
& 5.988957e-01,5.976864e-01,5.965390e-01,5.954379e-01,5.943972e-01,&
& 5.934019e-01,5.924624e-01,5.915579e-01,5.907025e-01,5.898913e-01,&
& 5.891213e-01,5.883815e-01,5.876851e-01,5.870158e-01,5.863868e-01,&
& 5.857821e-01,5.852111e-01,5.846579e-01 /)
! BAND 17
ssaliq1(:, 17) = (/ &
& 6.995459e-01,7.158012e-01,7.076001e-01,6.927244e-01,6.786434e-01,&
& 6.673545e-01,6.585859e-01,6.516314e-01,6.459010e-01,6.410225e-01,&
& 6.367574e-01,6.329554e-01,6.295119e-01,6.263595e-01,6.234462e-01,&
& 6.207274e-01,6.181755e-01,6.157678e-01,6.134880e-01,6.113173e-01,&
& 6.092495e-01,6.072689e-01,6.053717e-01,6.035507e-01,6.018001e-01,&
& 6.001134e-01,5.984951e-01,5.969294e-01,5.954256e-01,5.939698e-01,&
& 5.925716e-01,5.912265e-01,5.899270e-01,5.886771e-01,5.874746e-01,&
& 5.863185e-01,5.852077e-01,5.841460e-01,5.831249e-01,5.821474e-01,&
& 5.812078e-01,5.803173e-01,5.794616e-01,5.786443e-01,5.778617e-01,&
& 5.771236e-01,5.764191e-01,5.757400e-01,5.750971e-01,5.744842e-01,&
& 5.739012e-01,5.733482e-01,5.728175e-01,5.723214e-01,5.718383e-01,&
& 5.713827e-01,5.709471e-01,5.705330e-01 /)
! BAND 18
ssaliq1(:, 18) = (/ &
& 9.929711e-01,9.896942e-01,9.852408e-01,9.806820e-01,9.764512e-01,&
& 9.725375e-01,9.688677e-01,9.653832e-01,9.620552e-01,9.588522e-01,&
& 9.557475e-01,9.527265e-01,9.497731e-01,9.468756e-01,9.440270e-01,&
& 9.412230e-01,9.384592e-01,9.357287e-01,9.330369e-01,9.303778e-01,&
& 9.277502e-01,9.251546e-01,9.225907e-01,9.200553e-01,9.175521e-01,&
& 9.150773e-01,9.126352e-01,9.102260e-01,9.078485e-01,9.055057e-01,&
& 9.031978e-01,9.009306e-01,8.987010e-01,8.965177e-01,8.943774e-01,&
& 8.922869e-01,8.902430e-01,8.882551e-01,8.863182e-01,8.844373e-01,&
& 8.826143e-01,8.808499e-01,8.791413e-01,8.774940e-01,8.759019e-01,&
& 8.743650e-01,8.728941e-01,8.714712e-01,8.701065e-01,8.688008e-01,&
& 8.675409e-01,8.663295e-01,8.651714e-01,8.640637e-01,8.629943e-01,&
& 8.619762e-01,8.609995e-01,8.600581e-01 /)
! BAND 19
ssaliq1(:, 19) = (/ &
& 9.910612e-01,9.854226e-01,9.795008e-01,9.742920e-01,9.695996e-01,&
& 9.652274e-01,9.610648e-01,9.570521e-01,9.531397e-01,9.493086e-01,&
& 9.455413e-01,9.418362e-01,9.381902e-01,9.346016e-01,9.310718e-01,&
& 9.275957e-01,9.241757e-01,9.208038e-01,9.174802e-01,9.142058e-01,&
& 9.109753e-01,9.077895e-01,9.046433e-01,9.015409e-01,8.984784e-01,&
& 8.954572e-01,8.924748e-01,8.895367e-01,8.866395e-01,8.837864e-01,&
& 8.809819e-01,8.782267e-01,8.755231e-01,8.728712e-01,8.702802e-01,&
& 8.677443e-01,8.652733e-01,8.628678e-01,8.605300e-01,8.582593e-01,&
& 8.560596e-01,8.539352e-01,8.518782e-01,8.498915e-01,8.479790e-01,&
& 8.461384e-01,8.443645e-01,8.426613e-01,8.410229e-01,8.394495e-01,&
& 8.379428e-01,8.364967e-01,8.351117e-01,8.337820e-01,8.325091e-01,&
& 8.312874e-01,8.301169e-01,8.289985e-01 /)
! BAND 20
ssaliq1(:, 20) = (/ &
& 9.969802e-01,9.950445e-01,9.931448e-01,9.914272e-01,9.898652e-01,&
& 9.884250e-01,9.870637e-01,9.857482e-01,9.844558e-01,9.831755e-01,&
& 9.819068e-01,9.806477e-01,9.794000e-01,9.781666e-01,9.769461e-01,&
& 9.757386e-01,9.745459e-01,9.733650e-01,9.721953e-01,9.710398e-01,&
& 9.698936e-01,9.687583e-01,9.676334e-01,9.665192e-01,9.654132e-01,&
& 9.643208e-01,9.632374e-01,9.621625e-01,9.611003e-01,9.600518e-01,&
& 9.590144e-01,9.579922e-01,9.569864e-01,9.559948e-01,9.550239e-01,&
& 9.540698e-01,9.531382e-01,9.522280e-01,9.513409e-01,9.504772e-01,&
& 9.496360e-01,9.488220e-01,9.480327e-01,9.472693e-01,9.465333e-01,&
& 9.458211e-01,9.451344e-01,9.444732e-01,9.438372e-01,9.432268e-01,&
& 9.426391e-01,9.420757e-01,9.415308e-01,9.410102e-01,9.405115e-01,&
& 9.400326e-01,9.395716e-01,9.391313e-01 /)
! BAND 21
ssaliq1(:, 21) = (/ &
& 9.980034e-01,9.968572e-01,9.958696e-01,9.949747e-01,9.941241e-01,&
& 9.933043e-01,9.924971e-01,9.916978e-01,9.909023e-01,9.901046e-01,&
& 9.893087e-01,9.885146e-01,9.877195e-01,9.869283e-01,9.861379e-01,&
& 9.853523e-01,9.845715e-01,9.837945e-01,9.830217e-01,9.822567e-01,&
& 9.814935e-01,9.807356e-01,9.799815e-01,9.792332e-01,9.784845e-01,&
& 9.777424e-01,9.770042e-01,9.762695e-01,9.755416e-01,9.748152e-01,&
& 9.740974e-01,9.733873e-01,9.726813e-01,9.719861e-01,9.713010e-01,&
& 9.706262e-01,9.699647e-01,9.693144e-01,9.686794e-01,9.680596e-01,&
& 9.674540e-01,9.668657e-01,9.662926e-01,9.657390e-01,9.652019e-01,&
& 9.646820e-01,9.641784e-01,9.636945e-01,9.632260e-01,9.627743e-01,&
& 9.623418e-01,9.619227e-01,9.615194e-01,9.611341e-01,9.607629e-01,&
& 9.604057e-01,9.600622e-01,9.597322e-01 /)
! BAND 22
ssaliq1(:, 22) = (/ &
& 9.988219e-01,9.981767e-01,9.976168e-01,9.971066e-01,9.966195e-01,&
& 9.961566e-01,9.956995e-01,9.952481e-01,9.947982e-01,9.943495e-01,&
& 9.938955e-01,9.934368e-01,9.929825e-01,9.925239e-01,9.920653e-01,&
& 9.916096e-01,9.911552e-01,9.907067e-01,9.902594e-01,9.898178e-01,&
& 9.893791e-01,9.889453e-01,9.885122e-01,9.880837e-01,9.876567e-01,&
& 9.872331e-01,9.868121e-01,9.863938e-01,9.859790e-01,9.855650e-01,&
& 9.851548e-01,9.847491e-01,9.843496e-01,9.839521e-01,9.835606e-01,&
& 9.831771e-01,9.827975e-01,9.824292e-01,9.820653e-01,9.817124e-01,&
& 9.813644e-01,9.810291e-01,9.807020e-01,9.803864e-01,9.800782e-01,&
& 9.797821e-01,9.794958e-01,9.792179e-01,9.789509e-01,9.786940e-01,&
& 9.784460e-01,9.782090e-01,9.779789e-01,9.777553e-01,9.775425e-01,&
& 9.773387e-01,9.771420e-01,9.769529e-01 /)
! BAND 23
ssaliq1(:, 23) = (/ &
& 9.998902e-01,9.998395e-01,9.997915e-01,9.997442e-01,9.997016e-01,&
& 9.996600e-01,9.996200e-01,9.995806e-01,9.995411e-01,9.995005e-01,&
& 9.994589e-01,9.994178e-01,9.993766e-01,9.993359e-01,9.992948e-01,&
& 9.992533e-01,9.992120e-01,9.991723e-01,9.991313e-01,9.990906e-01,&
& 9.990510e-01,9.990113e-01,9.989716e-01,9.989323e-01,9.988923e-01,&
& 9.988532e-01,9.988140e-01,9.987761e-01,9.987373e-01,9.986989e-01,&
& 9.986597e-01,9.986239e-01,9.985861e-01,9.985485e-01,9.985123e-01,&
& 9.984762e-01,9.984415e-01,9.984065e-01,9.983722e-01,9.983398e-01,&
& 9.983078e-01,9.982758e-01,9.982461e-01,9.982157e-01,9.981872e-01,&
& 9.981595e-01,9.981324e-01,9.981068e-01,9.980811e-01,9.980580e-01,&
& 9.980344e-01,9.980111e-01,9.979908e-01,9.979690e-01,9.979492e-01,&
& 9.979316e-01,9.979116e-01,9.978948e-01 /)
! BAND 24
ssaliq1(:, 24) = (/ &
& 9.999978e-01,9.999948e-01,9.999915e-01,9.999905e-01,9.999896e-01,&
& 9.999887e-01,9.999888e-01,9.999888e-01,9.999870e-01,9.999854e-01,&
& 9.999855e-01,9.999856e-01,9.999839e-01,9.999834e-01,9.999829e-01,&
& 9.999809e-01,9.999816e-01,9.999793e-01,9.999782e-01,9.999779e-01,&
& 9.999772e-01,9.999764e-01,9.999756e-01,9.999744e-01,9.999744e-01,&
& 9.999736e-01,9.999729e-01,9.999716e-01,9.999706e-01,9.999692e-01,&
& 9.999690e-01,9.999675e-01,9.999673e-01,9.999660e-01,9.999654e-01,&
& 9.999647e-01,9.999647e-01,9.999625e-01,9.999620e-01,9.999614e-01,&
& 9.999613e-01,9.999607e-01,9.999604e-01,9.999594e-01,9.999589e-01,&
& 9.999586e-01,9.999567e-01,9.999550e-01,9.999557e-01,9.999542e-01,&
& 9.999546e-01,9.999539e-01,9.999536e-01,9.999526e-01,9.999523e-01,&
& 9.999508e-01,9.999534e-01,9.999507e-01 /)
! BAND 25
ssaliq1(:, 25) = (/ &
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999995e-01,&
& 9.999995e-01,9.999990e-01,9.999991e-01,9.999991e-01,9.999990e-01,&
& 9.999989e-01,9.999988e-01,9.999988e-01,9.999986e-01,9.999988e-01,&
& 9.999986e-01,9.999987e-01,9.999986e-01,9.999985e-01,9.999985e-01,&
& 9.999985e-01,9.999985e-01,9.999983e-01,9.999983e-01,9.999981e-01,&
& 9.999981e-01,9.999986e-01,9.999985e-01,9.999983e-01,9.999984e-01,&
& 9.999982e-01,9.999983e-01,9.999982e-01,9.999980e-01,9.999981e-01,&
& 9.999978e-01,9.999979e-01,9.999985e-01,9.999985e-01,9.999983e-01,&
& 9.999983e-01,9.999983e-01,9.999983e-01 /)
! BAND 26
ssaliq1(:, 26) = (/ &
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,&
& 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999991e-01,&
& 9.999990e-01,9.999992e-01,9.999995e-01,9.999986e-01,9.999994e-01,&
& 9.999985e-01,9.999980e-01,9.999984e-01,9.999983e-01,9.999979e-01,&
& 9.999969e-01,9.999977e-01,9.999971e-01,9.999969e-01,9.999969e-01,&
& 9.999965e-01,9.999970e-01,9.999985e-01,9.999973e-01,9.999961e-01,&
& 9.999968e-01,9.999952e-01,9.999970e-01,9.999974e-01,9.999965e-01,&
& 9.999969e-01,9.999970e-01,9.999970e-01,9.999960e-01,9.999923e-01,&
& 9.999958e-01,9.999937e-01,9.999960e-01,9.999953e-01,9.999946e-01,&
& 9.999946e-01,9.999957e-01,9.999951e-01 /)
! BAND 27
ssaliq1(:, 27) = (/ &
& 1.000000e+00,1.000000e+00,9.999983e-01,9.999979e-01,9.999965e-01,&
& 9.999949e-01,9.999948e-01,9.999918e-01,9.999917e-01,9.999923e-01,&
& 9.999908e-01,9.999889e-01,9.999902e-01,9.999895e-01,9.999881e-01,&
& 9.999882e-01,9.999876e-01,9.999866e-01,9.999866e-01,9.999858e-01,&
& 9.999860e-01,9.999852e-01,9.999836e-01,9.999831e-01,9.999818e-01,&
& 9.999808e-01,9.999816e-01,9.999800e-01,9.999783e-01,9.999780e-01,&
& 9.999763e-01,9.999746e-01,9.999731e-01,9.999713e-01,9.999762e-01,&
& 9.999740e-01,9.999670e-01,9.999703e-01,9.999687e-01,9.999666e-01,&
& 9.999683e-01,9.999667e-01,9.999611e-01,9.999635e-01,9.999600e-01,&
& 9.999635e-01,9.999594e-01,9.999601e-01,9.999586e-01,9.999559e-01,&
& 9.999569e-01,9.999558e-01,9.999523e-01,9.999535e-01,9.999529e-01,&
& 9.999553e-01,9.999495e-01,9.999490e-01 /)
! BAND 28
ssaliq1(:, 28) = (/ &
& 9.999920e-01,9.999873e-01,9.999855e-01,9.999832e-01,9.999807e-01,&
& 9.999778e-01,9.999754e-01,9.999721e-01,9.999692e-01,9.999651e-01,&
& 9.999621e-01,9.999607e-01,9.999567e-01,9.999546e-01,9.999521e-01,&
& 9.999491e-01,9.999457e-01,9.999439e-01,9.999403e-01,9.999374e-01,&
& 9.999353e-01,9.999315e-01,9.999282e-01,9.999244e-01,9.999234e-01,&
& 9.999189e-01,9.999130e-01,9.999117e-01,9.999073e-01,9.999020e-01,&
& 9.998993e-01,9.998987e-01,9.998922e-01,9.998893e-01,9.998869e-01,&
& 9.998805e-01,9.998778e-01,9.998751e-01,9.998708e-01,9.998676e-01,&
& 9.998624e-01,9.998642e-01,9.998582e-01,9.998547e-01,9.998546e-01,&
& 9.998477e-01,9.998487e-01,9.998466e-01,9.998403e-01,9.998412e-01,&
& 9.998406e-01,9.998342e-01,9.998326e-01,9.998333e-01,9.998328e-01,&
& 9.998290e-01,9.998276e-01,9.998249e-01 /)
! BAND 29
ssaliq1(:, 29) = (/ &
& 8.383753e-01,8.461471e-01,8.373325e-01,8.212889e-01,8.023834e-01,&
& 7.829501e-01,7.641777e-01,7.466000e-01,7.304023e-01,7.155998e-01,&
& 7.021259e-01,6.898840e-01,6.787615e-01,6.686479e-01,6.594414e-01,&
& 6.510417e-01,6.433668e-01,6.363335e-01,6.298788e-01,6.239398e-01,&
& 6.184633e-01,6.134055e-01,6.087228e-01,6.043786e-01,6.003439e-01,&
& 5.965910e-01,5.930917e-01,5.898280e-01,5.867798e-01,5.839264e-01,&
& 5.812576e-01,5.787592e-01,5.764163e-01,5.742189e-01,5.721598e-01,&
& 5.702286e-01,5.684182e-01,5.667176e-01,5.651237e-01,5.636253e-01,&
& 5.622228e-01,5.609074e-01,5.596713e-01,5.585089e-01,5.574223e-01,&
& 5.564002e-01,5.554411e-01,5.545397e-01,5.536914e-01,5.528967e-01,&
& 5.521495e-01,5.514457e-01,5.507818e-01,5.501623e-01,5.495750e-01,&
& 5.490192e-01,5.484980e-01,5.480046e-01 /)
! Asymmetry parameter
! BAND 16
asyliq1(:, 16) = (/ &
& 8.038165e-01,8.014154e-01,7.942381e-01,7.970521e-01,8.086621e-01,&
& 8.233392e-01,8.374127e-01,8.495742e-01,8.596945e-01,8.680497e-01,&
& 8.750005e-01,8.808589e-01,8.858749e-01,8.902403e-01,8.940939e-01,&
& 8.975379e-01,9.006450e-01,9.034741e-01,9.060659e-01,9.084561e-01,&
& 9.106675e-01,9.127198e-01,9.146332e-01,9.164194e-01,9.180970e-01,&
& 9.196658e-01,9.211421e-01,9.225352e-01,9.238443e-01,9.250841e-01,&
& 9.262541e-01,9.273620e-01,9.284081e-01,9.294002e-01,9.303395e-01,&
& 9.312285e-01,9.320715e-01,9.328716e-01,9.336271e-01,9.343427e-01,&
& 9.350219e-01,9.356647e-01,9.362728e-01,9.368495e-01,9.373956e-01,&
& 9.379113e-01,9.383987e-01,9.388608e-01,9.392986e-01,9.397132e-01,&
& 9.401063e-01,9.404776e-01,9.408299e-01,9.411641e-01,9.414800e-01,&
& 9.417787e-01,9.420633e-01,9.423364e-01 /)
! BAND 17
asyliq1(:, 17) = (/ &
& 8.941000e-01,9.054049e-01,9.049510e-01,9.027216e-01,9.021636e-01,&
& 9.037878e-01,9.069852e-01,9.109817e-01,9.152013e-01,9.193040e-01,&
& 9.231177e-01,9.265712e-01,9.296606e-01,9.324048e-01,9.348419e-01,&
& 9.370131e-01,9.389529e-01,9.406954e-01,9.422727e-01,9.437088e-01,&
& 9.450221e-01,9.462308e-01,9.473488e-01,9.483830e-01,9.493492e-01,&
& 9.502541e-01,9.510999e-01,9.518971e-01,9.526455e-01,9.533554e-01,&
& 9.540249e-01,9.546571e-01,9.552551e-01,9.558258e-01,9.563603e-01,&
& 9.568713e-01,9.573569e-01,9.578141e-01,9.582485e-01,9.586604e-01,&
& 9.590525e-01,9.594218e-01,9.597710e-01,9.601052e-01,9.604181e-01,&
& 9.607159e-01,9.609979e-01,9.612655e-01,9.615184e-01,9.617564e-01,&
& 9.619860e-01,9.622009e-01,9.624031e-01,9.625957e-01,9.627792e-01,&
& 9.629530e-01,9.631171e-01,9.632746e-01 /)
! BAND 18
asyliq1(:, 18) = (/ &
& 8.574638e-01,8.351383e-01,8.142977e-01,8.083068e-01,8.129284e-01,&
& 8.215827e-01,8.307238e-01,8.389963e-01,8.460481e-01,8.519273e-01,&
& 8.568153e-01,8.609116e-01,8.643892e-01,8.673941e-01,8.700248e-01,&
& 8.723707e-01,8.744902e-01,8.764240e-01,8.782057e-01,8.798593e-01,&
& 8.814063e-01,8.828573e-01,8.842261e-01,8.855196e-01,8.867497e-01,&
& 8.879164e-01,8.890316e-01,8.900941e-01,8.911118e-01,8.920832e-01,&
& 8.930156e-01,8.939091e-01,8.947663e-01,8.955888e-01,8.963786e-01,&
& 8.971350e-01,8.978617e-01,8.985590e-01,8.992243e-01,8.998631e-01,&
& 9.004753e-01,9.010602e-01,9.016192e-01,9.021542e-01,9.026644e-01,&
& 9.031535e-01,9.036194e-01,9.040656e-01,9.044894e-01,9.048933e-01,&
& 9.052789e-01,9.056481e-01,9.060004e-01,9.063343e-01,9.066544e-01,&
& 9.069604e-01,9.072512e-01,9.075290e-01 /)
! BAND 19
asyliq1(:, 19) = (/ &
& 8.349569e-01,8.034579e-01,7.932136e-01,8.010156e-01,8.137083e-01,&
& 8.255339e-01,8.351938e-01,8.428286e-01,8.488944e-01,8.538187e-01,&
& 8.579255e-01,8.614473e-01,8.645338e-01,8.672908e-01,8.697947e-01,&
& 8.720843e-01,8.742015e-01,8.761718e-01,8.780160e-01,8.797479e-01,&
& 8.813810e-01,8.829250e-01,8.843907e-01,8.857822e-01,8.871059e-01,&
& 8.883724e-01,8.895810e-01,8.907384e-01,8.918456e-01,8.929083e-01,&
& 8.939284e-01,8.949060e-01,8.958463e-01,8.967486e-01,8.976129e-01,&
& 8.984463e-01,8.992439e-01,9.000094e-01,9.007438e-01,9.014496e-01,&
& 9.021235e-01,9.027699e-01,9.033859e-01,9.039772e-01,9.045419e-01,&
& 9.050819e-01,9.055975e-01,9.060907e-01,9.065607e-01,9.070093e-01,&
& 9.074389e-01,9.078475e-01,9.082388e-01,9.086117e-01,9.089678e-01,&
& 9.093081e-01,9.096307e-01,9.099410e-01 /)
! BAND 20
asyliq1(:, 20) = (/ &
& 8.109692e-01,7.846657e-01,7.881928e-01,8.009509e-01,8.131208e-01,&
& 8.230400e-01,8.309448e-01,8.372920e-01,8.424837e-01,8.468166e-01,&
& 8.504947e-01,8.536642e-01,8.564256e-01,8.588513e-01,8.610011e-01,&
& 8.629122e-01,8.646262e-01,8.661720e-01,8.675752e-01,8.688582e-01,&
& 8.700379e-01,8.711300e-01,8.721485e-01,8.731027e-01,8.740010e-01,&
& 8.748499e-01,8.756564e-01,8.764239e-01,8.771542e-01,8.778523e-01,&
& 8.785211e-01,8.791601e-01,8.797725e-01,8.803589e-01,8.809173e-01,&
& 8.814552e-01,8.819705e-01,8.824611e-01,8.829311e-01,8.833791e-01,&
& 8.838078e-01,8.842148e-01,8.846044e-01,8.849756e-01,8.853291e-01,&
& 8.856645e-01,8.859841e-01,8.862904e-01,8.865801e-01,8.868551e-01,&
& 8.871182e-01,8.873673e-01,8.876059e-01,8.878307e-01,8.880462e-01,&
& 8.882501e-01,8.884453e-01,8.886339e-01 /)
! BAND 21
asyliq1(:, 21) = (/ &
& 7.838510e-01,7.803151e-01,7.980477e-01,8.144160e-01,8.261784e-01,&
& 8.344240e-01,8.404278e-01,8.450391e-01,8.487593e-01,8.518741e-01,&
& 8.545484e-01,8.568890e-01,8.589560e-01,8.607983e-01,8.624504e-01,&
& 8.639408e-01,8.652945e-01,8.665301e-01,8.676634e-01,8.687121e-01,&
& 8.696855e-01,8.705933e-01,8.714448e-01,8.722454e-01,8.730014e-01,&
& 8.737180e-01,8.743982e-01,8.750436e-01,8.756598e-01,8.762481e-01,&
& 8.768089e-01,8.773427e-01,8.778532e-01,8.783434e-01,8.788089e-01,&
& 8.792530e-01,8.796784e-01,8.800845e-01,8.804716e-01,8.808411e-01,&
& 8.811923e-01,8.815276e-01,8.818472e-01,8.821504e-01,8.824408e-01,&
& 8.827155e-01,8.829777e-01,8.832269e-01,8.834631e-01,8.836892e-01,&
& 8.839034e-01,8.841075e-01,8.843021e-01,8.844866e-01,8.846631e-01,&
& 8.848304e-01,8.849910e-01,8.851425e-01 /)
! BAND 22
asyliq1(:, 22) = (/ &
& 7.760783e-01,7.890215e-01,8.090192e-01,8.230252e-01,8.321369e-01,&
& 8.384258e-01,8.431529e-01,8.469558e-01,8.501499e-01,8.528899e-01,&
& 8.552899e-01,8.573956e-01,8.592570e-01,8.609098e-01,8.623897e-01,&
& 8.637169e-01,8.649184e-01,8.660097e-01,8.670096e-01,8.679338e-01,&
& 8.687896e-01,8.695880e-01,8.703365e-01,8.710422e-01,8.717092e-01,&
& 8.723378e-01,8.729363e-01,8.735063e-01,8.740475e-01,8.745661e-01,&
& 8.750560e-01,8.755275e-01,8.759731e-01,8.764000e-01,8.768071e-01,&
& 8.771942e-01,8.775628e-01,8.779126e-01,8.782483e-01,8.785626e-01,&
& 8.788610e-01,8.791482e-01,8.794180e-01,8.796765e-01,8.799207e-01,&
& 8.801522e-01,8.803707e-01,8.805777e-01,8.807749e-01,8.809605e-01,&
& 8.811362e-01,8.813047e-01,8.814647e-01,8.816131e-01,8.817588e-01,&
& 8.818930e-01,8.820230e-01,8.821445e-01 /)
! BAND 23
asyliq1(:, 23) = (/ &
& 7.847907e-01,8.099917e-01,8.257428e-01,8.350423e-01,8.411971e-01,&
& 8.457241e-01,8.493010e-01,8.522565e-01,8.547660e-01,8.569311e-01,&
& 8.588181e-01,8.604729e-01,8.619296e-01,8.632208e-01,8.643725e-01,&
& 8.654050e-01,8.663363e-01,8.671835e-01,8.679590e-01,8.686707e-01,&
& 8.693308e-01,8.699433e-01,8.705147e-01,8.710490e-01,8.715497e-01,&
& 8.720219e-01,8.724669e-01,8.728849e-01,8.732806e-01,8.736550e-01,&
& 8.740099e-01,8.743435e-01,8.746601e-01,8.749610e-01,8.752449e-01,&
& 8.755143e-01,8.757688e-01,8.760095e-01,8.762375e-01,8.764532e-01,&
& 8.766579e-01,8.768506e-01,8.770323e-01,8.772049e-01,8.773690e-01,&
& 8.775226e-01,8.776679e-01,8.778062e-01,8.779360e-01,8.780587e-01,&
& 8.781747e-01,8.782852e-01,8.783892e-01,8.784891e-01,8.785824e-01,&
& 8.786705e-01,8.787546e-01,8.788336e-01 /)
! BAND 24
asyliq1(:, 24) = (/ &
& 8.054324e-01,8.266282e-01,8.378075e-01,8.449848e-01,8.502166e-01,&
& 8.542268e-01,8.573477e-01,8.598022e-01,8.617689e-01,8.633859e-01,&
& 8.647536e-01,8.659354e-01,8.669807e-01,8.679143e-01,8.687577e-01,&
& 8.695222e-01,8.702207e-01,8.708591e-01,8.714446e-01,8.719836e-01,&
& 8.724812e-01,8.729426e-01,8.733689e-01,8.737665e-01,8.741373e-01,&
& 8.744834e-01,8.748070e-01,8.751131e-01,8.754011e-01,8.756676e-01,&
& 8.759219e-01,8.761599e-01,8.763857e-01,8.765984e-01,8.767999e-01,&
& 8.769889e-01,8.771669e-01,8.773373e-01,8.774969e-01,8.776469e-01,&
& 8.777894e-01,8.779237e-01,8.780505e-01,8.781703e-01,8.782820e-01,&
& 8.783886e-01,8.784894e-01,8.785844e-01,8.786736e-01,8.787584e-01,&
& 8.788379e-01,8.789130e-01,8.789849e-01,8.790506e-01,8.791141e-01,&
& 8.791750e-01,8.792324e-01,8.792867e-01 /)
! BAND 25
asyliq1(:, 25) = (/ &
& 8.249534e-01,8.391988e-01,8.474107e-01,8.526860e-01,8.563983e-01,&
& 8.592389e-01,8.615144e-01,8.633790e-01,8.649325e-01,8.662504e-01,&
& 8.673841e-01,8.683741e-01,8.692495e-01,8.700309e-01,8.707328e-01,&
& 8.713650e-01,8.719432e-01,8.724676e-01,8.729498e-01,8.733922e-01,&
& 8.737981e-01,8.741745e-01,8.745225e-01,8.748467e-01,8.751512e-01,&
& 8.754315e-01,8.756962e-01,8.759450e-01,8.761774e-01,8.763945e-01,&
& 8.766021e-01,8.767970e-01,8.769803e-01,8.771511e-01,8.773151e-01,&
& 8.774689e-01,8.776147e-01,8.777533e-01,8.778831e-01,8.780050e-01,&
& 8.781197e-01,8.782301e-01,8.783323e-01,8.784312e-01,8.785222e-01,&
& 8.786096e-01,8.786916e-01,8.787688e-01,8.788411e-01,8.789122e-01,&
& 8.789762e-01,8.790373e-01,8.790954e-01,8.791514e-01,8.792018e-01,&
& 8.792517e-01,8.792990e-01,8.793429e-01 /)
! BAND 26
asyliq1(:, 26) = (/ &
& 8.323091e-01,8.429776e-01,8.498123e-01,8.546929e-01,8.584295e-01,&
& 8.613489e-01,8.636324e-01,8.654303e-01,8.668675e-01,8.680404e-01,&
& 8.690174e-01,8.698495e-01,8.705666e-01,8.711961e-01,8.717556e-01,&
& 8.722546e-01,8.727063e-01,8.731170e-01,8.734933e-01,8.738382e-01,&
& 8.741590e-01,8.744525e-01,8.747295e-01,8.749843e-01,8.752210e-01,&
& 8.754437e-01,8.756524e-01,8.758472e-01,8.760288e-01,8.762030e-01,&
& 8.763603e-01,8.765122e-01,8.766539e-01,8.767894e-01,8.769130e-01,&
& 8.770310e-01,8.771422e-01,8.772437e-01,8.773419e-01,8.774355e-01,&
& 8.775221e-01,8.776047e-01,8.776802e-01,8.777539e-01,8.778216e-01,&
& 8.778859e-01,8.779473e-01,8.780031e-01,8.780562e-01,8.781097e-01,&
& 8.781570e-01,8.782021e-01,8.782463e-01,8.782845e-01,8.783235e-01,&
& 8.783610e-01,8.783953e-01,8.784273e-01 /)
! BAND 27
asyliq1(:, 27) = (/ &
& 8.396448e-01,8.480172e-01,8.535934e-01,8.574145e-01,8.600835e-01,&
& 8.620347e-01,8.635500e-01,8.648003e-01,8.658758e-01,8.668248e-01,&
& 8.676697e-01,8.684220e-01,8.690893e-01,8.696807e-01,8.702046e-01,&
& 8.706676e-01,8.710798e-01,8.714478e-01,8.717778e-01,8.720747e-01,&
& 8.723431e-01,8.725889e-01,8.728144e-01,8.730201e-01,8.732129e-01,&
& 8.733907e-01,8.735541e-01,8.737100e-01,8.738533e-01,8.739882e-01,&
& 8.741164e-01,8.742362e-01,8.743485e-01,8.744530e-01,8.745512e-01,&
& 8.746471e-01,8.747373e-01,8.748186e-01,8.748973e-01,8.749732e-01,&
& 8.750443e-01,8.751105e-01,8.751747e-01,8.752344e-01,8.752902e-01,&
& 8.753412e-01,8.753917e-01,8.754393e-01,8.754843e-01,8.755282e-01,&
& 8.755662e-01,8.756039e-01,8.756408e-01,8.756722e-01,8.757072e-01,&
& 8.757352e-01,8.757653e-01,8.757932e-01 /)
! BAND 28
asyliq1(:, 28) = (/ &
& 8.374590e-01,8.465669e-01,8.518701e-01,8.547627e-01,8.565745e-01,&
& 8.579065e-01,8.589717e-01,8.598632e-01,8.606363e-01,8.613268e-01,&
& 8.619560e-01,8.625340e-01,8.630689e-01,8.635601e-01,8.640084e-01,&
& 8.644180e-01,8.647885e-01,8.651220e-01,8.654218e-01,8.656908e-01,&
& 8.659294e-01,8.661422e-01,8.663334e-01,8.665037e-01,8.666543e-01,&
& 8.667913e-01,8.669156e-01,8.670242e-01,8.671249e-01,8.672161e-01,&
& 8.672993e-01,8.673733e-01,8.674457e-01,8.675103e-01,8.675713e-01,&
& 8.676267e-01,8.676798e-01,8.677286e-01,8.677745e-01,8.678178e-01,&
& 8.678601e-01,8.678986e-01,8.679351e-01,8.679693e-01,8.680013e-01,&
& 8.680334e-01,8.680624e-01,8.680915e-01,8.681178e-01,8.681428e-01,&
& 8.681654e-01,8.681899e-01,8.682103e-01,8.682317e-01,8.682498e-01,&
& 8.682677e-01,8.682861e-01,8.683041e-01 /)
! BAND 29
asyliq1(:, 29) = (/ &
& 7.877069e-01,8.244281e-01,8.367971e-01,8.409074e-01,8.429859e-01,&
& 8.454386e-01,8.489350e-01,8.534141e-01,8.585814e-01,8.641267e-01,&
& 8.697999e-01,8.754223e-01,8.808785e-01,8.860944e-01,8.910354e-01,&
& 8.956837e-01,9.000392e-01,9.041091e-01,9.079071e-01,9.114479e-01,&
& 9.147462e-01,9.178234e-01,9.206903e-01,9.233663e-01,9.258668e-01,&
& 9.282006e-01,9.303847e-01,9.324288e-01,9.343418e-01,9.361356e-01,&
& 9.378176e-01,9.393939e-01,9.408736e-01,9.422622e-01,9.435670e-01,&
& 9.447900e-01,9.459395e-01,9.470199e-01,9.480335e-01,9.489852e-01,&
& 9.498782e-01,9.507168e-01,9.515044e-01,9.522470e-01,9.529409e-01,&
& 9.535946e-01,9.542071e-01,9.547838e-01,9.553256e-01,9.558351e-01,&
& 9.563139e-01,9.567660e-01,9.571915e-01,9.575901e-01,9.579685e-01,&
& 9.583239e-01,9.586602e-01,9.589766e-01 /)
! Spherical Ice Particle Parameterization
! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
extice2(:, 16) = (/ &
! band 16
& 4.101824e-01 ,2.435514e-01 ,1.713697e-01 ,1.314865e-01 ,1.063406e-01 ,&
& 8.910701e-02 ,7.659480e-02 ,6.711784e-02 ,5.970353e-02 ,5.375249e-02 ,&
& 4.887577e-02 ,4.481025e-02 ,4.137171e-02 ,3.842744e-02 ,3.587948e-02 ,&
& 3.365396e-02 ,3.169419e-02 ,2.995593e-02 ,2.840419e-02 ,2.701091e-02 ,&
& 2.575336e-02 ,2.461293e-02 ,2.357423e-02 ,2.262443e-02 ,2.175276e-02 ,&
& 2.095012e-02 ,2.020875e-02 ,1.952199e-02 ,1.888412e-02 ,1.829018e-02 ,&
& 1.773586e-02 ,1.721738e-02 ,1.673144e-02 ,1.627510e-02 ,1.584579e-02 ,&
& 1.544122e-02 ,1.505934e-02 ,1.469833e-02 ,1.435654e-02 ,1.403251e-02 ,&
& 1.372492e-02 ,1.343255e-02 ,1.315433e-02 /)
extice2(:, 17) = (/ &
! band 17
& 3.836650e-01 ,2.304055e-01 ,1.637265e-01 ,1.266681e-01 ,1.031602e-01 ,&
& 8.695191e-02 ,7.511544e-02 ,6.610009e-02 ,5.900909e-02 ,5.328833e-02 ,&
& 4.857728e-02 ,4.463133e-02 ,4.127880e-02 ,3.839567e-02 ,3.589013e-02 ,&
& 3.369280e-02 ,3.175027e-02 ,3.002079e-02 ,2.847121e-02 ,2.707493e-02 ,&
& 2.581031e-02 ,2.465962e-02 ,2.360815e-02 ,2.264363e-02 ,2.175571e-02 ,&
& 2.093563e-02 ,2.017592e-02 ,1.947015e-02 ,1.881278e-02 ,1.819901e-02 ,&
& 1.762463e-02 ,1.708598e-02 ,1.657982e-02 ,1.610330e-02 ,1.565390e-02 ,&
& 1.522937e-02 ,1.482768e-02 ,1.444706e-02 ,1.408588e-02 ,1.374270e-02 ,&
& 1.341619e-02 ,1.310517e-02 ,1.280857e-02 /)
extice2(:, 18) = (/ &
! band 18
& 4.152673e-01 ,2.436816e-01 ,1.702243e-01 ,1.299704e-01 ,1.047528e-01 ,&
& 8.756039e-02 ,7.513327e-02 ,6.575690e-02 ,5.844616e-02 ,5.259609e-02 ,&
& 4.781531e-02 ,4.383980e-02 ,4.048517e-02 ,3.761891e-02 ,3.514342e-02 ,&
& 3.298525e-02 ,3.108814e-02 ,2.940825e-02 ,2.791096e-02 ,2.656858e-02 ,&
& 2.535869e-02 ,2.426297e-02 ,2.326627e-02 ,2.235602e-02 ,2.152164e-02 ,&
& 2.075420e-02 ,2.004613e-02 ,1.939091e-02 ,1.878296e-02 ,1.821744e-02 ,&
& 1.769015e-02 ,1.719741e-02 ,1.673600e-02 ,1.630308e-02 ,1.589615e-02 ,&
& 1.551298e-02 ,1.515159e-02 ,1.481021e-02 ,1.448726e-02 ,1.418131e-02 ,&
& 1.389109e-02 ,1.361544e-02 ,1.335330e-02 /)
extice2(:, 19) = (/ &
! band 19
& 3.873250e-01 ,2.331609e-01 ,1.655002e-01 ,1.277753e-01 ,1.038247e-01 ,&
& 8.731780e-02 ,7.527638e-02 ,6.611873e-02 ,5.892850e-02 ,5.313885e-02 ,&
& 4.838068e-02 ,4.440356e-02 ,4.103167e-02 ,3.813804e-02 ,3.562870e-02 ,&
& 3.343269e-02 ,3.149539e-02 ,2.977414e-02 ,2.823510e-02 ,2.685112e-02 ,&
& 2.560015e-02 ,2.446411e-02 ,2.342805e-02 ,2.247948e-02 ,2.160789e-02 ,&
& 2.080438e-02 ,2.006139e-02 ,1.937238e-02 ,1.873177e-02 ,1.813469e-02 ,&
& 1.757689e-02 ,1.705468e-02 ,1.656479e-02 ,1.610435e-02 ,1.567081e-02 ,&
& 1.526192e-02 ,1.487565e-02 ,1.451020e-02 ,1.416396e-02 ,1.383546e-02 ,&
& 1.352339e-02 ,1.322657e-02 ,1.294392e-02 /)
extice2(:, 20) = (/ &
! band 20
& 3.784280e-01 ,2.291396e-01 ,1.632551e-01 ,1.263775e-01 ,1.028944e-01 ,&
& 8.666975e-02 ,7.480952e-02 ,6.577335e-02 ,5.866714e-02 ,5.293694e-02 ,&
& 4.822153e-02 ,4.427547e-02 ,4.092626e-02 ,3.804918e-02 ,3.555184e-02 ,&
& 3.336440e-02 ,3.143307e-02 ,2.971577e-02 ,2.817912e-02 ,2.679632e-02 ,&
& 2.554558e-02 ,2.440903e-02 ,2.337187e-02 ,2.242173e-02 ,2.154821e-02 ,&
& 2.074249e-02 ,1.999706e-02 ,1.930546e-02 ,1.866212e-02 ,1.806221e-02 ,&
& 1.750152e-02 ,1.697637e-02 ,1.648352e-02 ,1.602010e-02 ,1.558358e-02 ,&
& 1.517172e-02 ,1.478250e-02 ,1.441413e-02 ,1.406498e-02 ,1.373362e-02 ,&
& 1.341872e-02 ,1.311911e-02 ,1.283371e-02 /)
extice2(:, 21) = (/ &
! band 21
& 3.719909e-01 ,2.259490e-01 ,1.613144e-01 ,1.250648e-01 ,1.019462e-01 ,&
& 8.595358e-02 ,7.425064e-02 ,6.532618e-02 ,5.830218e-02 ,5.263421e-02 ,&
& 4.796697e-02 ,4.405891e-02 ,4.074013e-02 ,3.788776e-02 ,3.541071e-02 ,&
& 3.324008e-02 ,3.132280e-02 ,2.961733e-02 ,2.809071e-02 ,2.671645e-02 ,&
& 2.547302e-02 ,2.434276e-02 ,2.331102e-02 ,2.236558e-02 ,2.149614e-02 ,&
& 2.069397e-02 ,1.995163e-02 ,1.926272e-02 ,1.862174e-02 ,1.802389e-02 ,&
& 1.746500e-02 ,1.694142e-02 ,1.644994e-02 ,1.598772e-02 ,1.555225e-02 ,&
& 1.514129e-02 ,1.475286e-02 ,1.438515e-02 ,1.403659e-02 ,1.370572e-02 ,&
& 1.339124e-02 ,1.309197e-02 ,1.280685e-02 /)
extice2(:, 22) = (/ &
! band 22
& 3.713158e-01 ,2.253816e-01 ,1.608461e-01 ,1.246718e-01 ,1.016109e-01 ,&
& 8.566332e-02 ,7.399666e-02 ,6.510199e-02 ,5.810290e-02 ,5.245608e-02 ,&
& 4.780702e-02 ,4.391478e-02 ,4.060989e-02 ,3.776982e-02 ,3.530374e-02 ,&
& 3.314296e-02 ,3.123458e-02 ,2.953719e-02 ,2.801794e-02 ,2.665043e-02 ,&
& 2.541321e-02 ,2.428868e-02 ,2.326224e-02 ,2.232173e-02 ,2.145688e-02 ,&
& 2.065899e-02 ,1.992067e-02 ,1.923552e-02 ,1.859808e-02 ,1.800356e-02 ,&
& 1.744782e-02 ,1.692721e-02 ,1.643855e-02 ,1.597900e-02 ,1.554606e-02 ,&
& 1.513751e-02 ,1.475137e-02 ,1.438586e-02 ,1.403938e-02 ,1.371050e-02 ,&
& 1.339793e-02 ,1.310050e-02 ,1.281713e-02 /)
extice2(:, 23) = (/ &
! band 23
& 3.605883e-01 ,2.204388e-01 ,1.580431e-01 ,1.229033e-01 ,1.004203e-01 ,&
& 8.482616e-02 ,7.338941e-02 ,6.465105e-02 ,5.776176e-02 ,5.219398e-02 ,&
& 4.760288e-02 ,4.375369e-02 ,4.048111e-02 ,3.766539e-02 ,3.521771e-02 ,&
& 3.307079e-02 ,3.117277e-02 ,2.948303e-02 ,2.796929e-02 ,2.660560e-02 ,&
& 2.537086e-02 ,2.424772e-02 ,2.322182e-02 ,2.228114e-02 ,2.141556e-02 ,&
& 2.061649e-02 ,1.987661e-02 ,1.918962e-02 ,1.855009e-02 ,1.795330e-02 ,&
& 1.739514e-02 ,1.687199e-02 ,1.638069e-02 ,1.591845e-02 ,1.548276e-02 ,&
& 1.507143e-02 ,1.468249e-02 ,1.431416e-02 ,1.396486e-02 ,1.363318e-02 ,&
& 1.331781e-02 ,1.301759e-02 ,1.273147e-02 /)
extice2(:, 24) = (/ &
! band 24
& 3.527890e-01 ,2.168469e-01 ,1.560090e-01 ,1.216216e-01 ,9.955787e-02 ,&
& 8.421942e-02 ,7.294827e-02 ,6.432192e-02 ,5.751081e-02 ,5.199888e-02 ,&
& 4.744835e-02 ,4.362899e-02 ,4.037847e-02 ,3.757910e-02 ,3.514351e-02 ,&
& 3.300546e-02 ,3.111382e-02 ,2.942853e-02 ,2.791775e-02 ,2.655584e-02 ,&
& 2.532195e-02 ,2.419892e-02 ,2.317255e-02 ,2.223092e-02 ,2.136402e-02 ,&
& 2.056334e-02 ,1.982160e-02 ,1.913258e-02 ,1.849087e-02 ,1.789178e-02 ,&
& 1.733124e-02 ,1.680565e-02 ,1.631187e-02 ,1.584711e-02 ,1.540889e-02 ,&
& 1.499502e-02 ,1.460354e-02 ,1.423269e-02 ,1.388088e-02 ,1.354670e-02 ,&
& 1.322887e-02 ,1.292620e-02 ,1.263767e-02 /)
extice2(:, 25) = (/ &
! band 25
& 3.477874e-01 ,2.143515e-01 ,1.544887e-01 ,1.205942e-01 ,9.881779e-02 ,&
& 8.366261e-02 ,7.251586e-02 ,6.397790e-02 ,5.723183e-02 ,5.176908e-02 ,&
& 4.725658e-02 ,4.346715e-02 ,4.024055e-02 ,3.746055e-02 ,3.504080e-02 ,&
& 3.291583e-02 ,3.103507e-02 ,2.935891e-02 ,2.785582e-02 ,2.650042e-02 ,&
& 2.527206e-02 ,2.415376e-02 ,2.313142e-02 ,2.219326e-02 ,2.132934e-02 ,&
& 2.053122e-02 ,1.979169e-02 ,1.910456e-02 ,1.846448e-02 ,1.786680e-02 ,&
& 1.730745e-02 ,1.678289e-02 ,1.628998e-02 ,1.582595e-02 ,1.538835e-02 ,&
& 1.497499e-02 ,1.458393e-02 ,1.421341e-02 ,1.386187e-02 ,1.352788e-02 ,&
& 1.321019e-02 ,1.290762e-02 ,1.261913e-02 /)
extice2(:, 26) = (/ &
! band 26
& 3.453721e-01 ,2.130744e-01 ,1.536698e-01 ,1.200140e-01 ,9.838078e-02 ,&
& 8.331940e-02 ,7.223803e-02 ,6.374775e-02 ,5.703770e-02 ,5.160290e-02 ,&
& 4.711259e-02 ,4.334110e-02 ,4.012923e-02 ,3.736150e-02 ,3.495208e-02 ,&
& 3.283589e-02 ,3.096267e-02 ,2.929302e-02 ,2.779560e-02 ,2.644517e-02 ,&
& 2.522119e-02 ,2.410677e-02 ,2.308788e-02 ,2.215281e-02 ,2.129165e-02 ,&
& 2.049602e-02 ,1.975874e-02 ,1.907365e-02 ,1.843542e-02 ,1.783943e-02 ,&
& 1.728162e-02 ,1.675847e-02 ,1.626685e-02 ,1.580401e-02 ,1.536750e-02 ,&
& 1.495515e-02 ,1.456502e-02 ,1.419537e-02 ,1.384463e-02 ,1.351139e-02 ,&
& 1.319438e-02 ,1.289246e-02 ,1.260456e-02 /)
extice2(:, 27) = (/ &
! band 27
& 3.417883e-01 ,2.113379e-01 ,1.526395e-01 ,1.193347e-01 ,9.790253e-02 ,&
& 8.296715e-02 ,7.196979e-02 ,6.353806e-02 ,5.687024e-02 ,5.146670e-02 ,&
& 4.700001e-02 ,4.324667e-02 ,4.004894e-02 ,3.729233e-02 ,3.489172e-02 ,&
& 3.278257e-02 ,3.091499e-02 ,2.924987e-02 ,2.775609e-02 ,2.640859e-02 ,&
& 2.518695e-02 ,2.407439e-02 ,2.305697e-02 ,2.212303e-02 ,2.126273e-02 ,&
& 2.046774e-02 ,1.973090e-02 ,1.904610e-02 ,1.840801e-02 ,1.781204e-02 ,&
& 1.725417e-02 ,1.673086e-02 ,1.623902e-02 ,1.577590e-02 ,1.533906e-02 ,&
& 1.492634e-02 ,1.453580e-02 ,1.416571e-02 ,1.381450e-02 ,1.348078e-02 ,&
& 1.316327e-02 ,1.286082e-02 ,1.257240e-02 /)
extice2(:, 28) = (/ &
! band 28
& 3.416111e-01 ,2.114124e-01 ,1.527734e-01 ,1.194809e-01 ,9.804612e-02 ,&
& 8.310287e-02 ,7.209595e-02 ,6.365442e-02 ,5.697710e-02 ,5.156460e-02 ,&
& 4.708957e-02 ,4.332850e-02 ,4.012361e-02 ,3.736037e-02 ,3.495364e-02 ,&
& 3.283879e-02 ,3.096593e-02 ,2.929589e-02 ,2.779751e-02 ,2.644571e-02 ,&
& 2.522004e-02 ,2.410369e-02 ,2.308271e-02 ,2.214542e-02 ,2.128195e-02 ,&
& 2.048396e-02 ,1.974429e-02 ,1.905679e-02 ,1.841614e-02 ,1.781774e-02 ,&
& 1.725754e-02 ,1.673203e-02 ,1.623807e-02 ,1.577293e-02 ,1.533416e-02 ,&
& 1.491958e-02 ,1.452727e-02 ,1.415547e-02 ,1.380262e-02 ,1.346732e-02 ,&
& 1.314830e-02 ,1.284439e-02 ,1.255456e-02 /)
extice2(:, 29) = (/ &
! band 29
& 4.196611e-01 ,2.493642e-01 ,1.761261e-01 ,1.357197e-01 ,1.102161e-01 ,&
& 9.269376e-02 ,7.992985e-02 ,7.022538e-02 ,6.260168e-02 ,5.645603e-02 ,&
& 5.139732e-02 ,4.716088e-02 ,4.356133e-02 ,4.046498e-02 ,3.777303e-02 ,&
& 3.541094e-02 ,3.332137e-02 ,3.145954e-02 ,2.978998e-02 ,2.828419e-02 ,&
& 2.691905e-02 ,2.567559e-02 ,2.453811e-02 ,2.349350e-02 ,2.253072e-02 ,&
& 2.164042e-02 ,2.081464e-02 ,2.004652e-02 ,1.933015e-02 ,1.866041e-02 ,&
& 1.803283e-02 ,1.744348e-02 ,1.688894e-02 ,1.636616e-02 ,1.587244e-02 ,&
& 1.540539e-02 ,1.496287e-02 ,1.454295e-02 ,1.414392e-02 ,1.376423e-02 ,&
& 1.340247e-02 ,1.305739e-02 ,1.272784e-02 /)
! single-scattering albedo: unitless
ssaice2(:, 16) = (/ &
! band 16
& 6.630615e-01 ,6.451169e-01 ,6.333696e-01 ,6.246927e-01 ,6.178420e-01 ,&
& 6.121976e-01 ,6.074069e-01 ,6.032505e-01 ,5.995830e-01 ,5.963030e-01 ,&
& 5.933372e-01 ,5.906311e-01 ,5.881427e-01 ,5.858395e-01 ,5.836955e-01 ,&
& 5.816896e-01 ,5.798046e-01 ,5.780264e-01 ,5.763429e-01 ,5.747441e-01 ,&
& 5.732213e-01 ,5.717672e-01 ,5.703754e-01 ,5.690403e-01 ,5.677571e-01 ,&
& 5.665215e-01 ,5.653297e-01 ,5.641782e-01 ,5.630643e-01 ,5.619850e-01 ,&
& 5.609381e-01 ,5.599214e-01 ,5.589328e-01 ,5.579707e-01 ,5.570333e-01 ,&
& 5.561193e-01 ,5.552272e-01 ,5.543558e-01 ,5.535041e-01 ,5.526708e-01 ,&
& 5.518551e-01 ,5.510561e-01 ,5.502729e-01 /)
ssaice2(:, 17) = (/ &
! band 17
& 7.689749e-01 ,7.398171e-01 ,7.205819e-01 ,7.065690e-01 ,6.956928e-01 ,&
& 6.868989e-01 ,6.795813e-01 ,6.733606e-01 ,6.679838e-01 ,6.632742e-01 ,&
& 6.591036e-01 ,6.553766e-01 ,6.520197e-01 ,6.489757e-01 ,6.461991e-01 ,&
& 6.436531e-01 ,6.413075e-01 ,6.391375e-01 ,6.371221e-01 ,6.352438e-01 ,&
& 6.334876e-01 ,6.318406e-01 ,6.302918e-01 ,6.288315e-01 ,6.274512e-01 ,&
& 6.261436e-01 ,6.249022e-01 ,6.237211e-01 ,6.225953e-01 ,6.215201e-01 ,&
& 6.204914e-01 ,6.195055e-01 ,6.185592e-01 ,6.176492e-01 ,6.167730e-01 ,&
& 6.159280e-01 ,6.151120e-01 ,6.143228e-01 ,6.135587e-01 ,6.128177e-01 ,&
& 6.120984e-01 ,6.113993e-01 ,6.107189e-01 /)
ssaice2(:, 18) = (/ &
! band 18
& 9.956167e-01 ,9.814770e-01 ,9.716104e-01 ,9.639746e-01 ,9.577179e-01 ,&
& 9.524010e-01 ,9.477672e-01 ,9.436527e-01 ,9.399467e-01 ,9.365708e-01 ,&
& 9.334672e-01 ,9.305921e-01 ,9.279118e-01 ,9.253993e-01 ,9.230330e-01 ,&
& 9.207954e-01 ,9.186719e-01 ,9.166501e-01 ,9.147199e-01 ,9.128722e-01 ,&
& 9.110997e-01 ,9.093956e-01 ,9.077544e-01 ,9.061708e-01 ,9.046406e-01 ,&
& 9.031598e-01 ,9.017248e-01 ,9.003326e-01 ,8.989804e-01 ,8.976655e-01 ,&
& 8.963857e-01 ,8.951389e-01 ,8.939233e-01 ,8.927370e-01 ,8.915785e-01 ,&
& 8.904464e-01 ,8.893392e-01 ,8.882559e-01 ,8.871951e-01 ,8.861559e-01 ,&
& 8.851373e-01 ,8.841383e-01 ,8.831581e-01 /)
ssaice2(:, 19) = (/ &
! band 19
& 9.723177e-01 ,9.452119e-01 ,9.267592e-01 ,9.127393e-01 ,9.014238e-01 ,&
& 8.919334e-01 ,8.837584e-01 ,8.765773e-01 ,8.701736e-01 ,8.643950e-01 ,&
& 8.591299e-01 ,8.542942e-01 ,8.498230e-01 ,8.456651e-01 ,8.417794e-01 ,&
& 8.381324e-01 ,8.346964e-01 ,8.314484e-01 ,8.283687e-01 ,8.254408e-01 ,&
& 8.226505e-01 ,8.199854e-01 ,8.174348e-01 ,8.149891e-01 ,8.126403e-01 ,&
& 8.103808e-01 ,8.082041e-01 ,8.061044e-01 ,8.040765e-01 ,8.021156e-01 ,&
& 8.002174e-01 ,7.983781e-01 ,7.965941e-01 ,7.948622e-01 ,7.931795e-01 ,&
& 7.915432e-01 ,7.899508e-01 ,7.884002e-01 ,7.868891e-01 ,7.854156e-01 ,&
& 7.839779e-01 ,7.825742e-01 ,7.812031e-01 /)
ssaice2(:, 20) = (/ &
! band 20
& 9.933294e-01 ,9.860917e-01 ,9.811564e-01 ,9.774008e-01 ,9.743652e-01 ,&
& 9.718155e-01 ,9.696159e-01 ,9.676810e-01 ,9.659531e-01 ,9.643915e-01 ,&
& 9.629667e-01 ,9.616561e-01 ,9.604426e-01 ,9.593125e-01 ,9.582548e-01 ,&
& 9.572607e-01 ,9.563227e-01 ,9.554347e-01 ,9.545915e-01 ,9.537888e-01 ,&
& 9.530226e-01 ,9.522898e-01 ,9.515874e-01 ,9.509130e-01 ,9.502643e-01 ,&
& 9.496394e-01 ,9.490366e-01 ,9.484542e-01 ,9.478910e-01 ,9.473456e-01 ,&
& 9.468169e-01 ,9.463039e-01 ,9.458056e-01 ,9.453212e-01 ,9.448499e-01 ,&
& 9.443910e-01 ,9.439438e-01 ,9.435077e-01 ,9.430821e-01 ,9.426666e-01 ,&
& 9.422607e-01 ,9.418638e-01 ,9.414756e-01 /)
ssaice2(:, 21) = (/ &
! band 21
& 9.900787e-01 ,9.828880e-01 ,9.779258e-01 ,9.741173e-01 ,9.710184e-01 ,&
& 9.684012e-01 ,9.661332e-01 ,9.641301e-01 ,9.623352e-01 ,9.607083e-01 ,&
& 9.592198e-01 ,9.578474e-01 ,9.565739e-01 ,9.553856e-01 ,9.542715e-01 ,&
& 9.532226e-01 ,9.522314e-01 ,9.512919e-01 ,9.503986e-01 ,9.495472e-01 ,&
& 9.487337e-01 ,9.479549e-01 ,9.472077e-01 ,9.464897e-01 ,9.457985e-01 ,&
& 9.451322e-01 ,9.444890e-01 ,9.438673e-01 ,9.432656e-01 ,9.426826e-01 ,&
& 9.421173e-01 ,9.415684e-01 ,9.410351e-01 ,9.405164e-01 ,9.400115e-01 ,&
& 9.395198e-01 ,9.390404e-01 ,9.385728e-01 ,9.381164e-01 ,9.376707e-01 ,&
& 9.372350e-01 ,9.368091e-01 ,9.363923e-01 /)
ssaice2(:, 22) = (/ &
! band 22
& 9.986793e-01 ,9.985239e-01 ,9.983911e-01 ,9.982715e-01 ,9.981606e-01 ,&
& 9.980562e-01 ,9.979567e-01 ,9.978613e-01 ,9.977691e-01 ,9.976798e-01 ,&
& 9.975929e-01 ,9.975081e-01 ,9.974251e-01 ,9.973438e-01 ,9.972640e-01 ,&
& 9.971855e-01 ,9.971083e-01 ,9.970322e-01 ,9.969571e-01 ,9.968830e-01 ,&
& 9.968099e-01 ,9.967375e-01 ,9.966660e-01 ,9.965951e-01 ,9.965250e-01 ,&
& 9.964555e-01 ,9.963867e-01 ,9.963185e-01 ,9.962508e-01 ,9.961836e-01 ,&
& 9.961170e-01 ,9.960508e-01 ,9.959851e-01 ,9.959198e-01 ,9.958550e-01 ,&
& 9.957906e-01 ,9.957266e-01 ,9.956629e-01 ,9.955997e-01 ,9.955367e-01 ,&
& 9.954742e-01 ,9.954119e-01 ,9.953500e-01 /)
ssaice2(:, 23) = (/ &
! band 23
& 9.997944e-01 ,9.997791e-01 ,9.997664e-01 ,9.997547e-01 ,9.997436e-01 ,&
& 9.997327e-01 ,9.997219e-01 ,9.997110e-01 ,9.996999e-01 ,9.996886e-01 ,&
& 9.996771e-01 ,9.996653e-01 ,9.996533e-01 ,9.996409e-01 ,9.996282e-01 ,&
& 9.996152e-01 ,9.996019e-01 ,9.995883e-01 ,9.995743e-01 ,9.995599e-01 ,&
& 9.995453e-01 ,9.995302e-01 ,9.995149e-01 ,9.994992e-01 ,9.994831e-01 ,&
& 9.994667e-01 ,9.994500e-01 ,9.994329e-01 ,9.994154e-01 ,9.993976e-01 ,&
& 9.993795e-01 ,9.993610e-01 ,9.993422e-01 ,9.993230e-01 ,9.993035e-01 ,&
& 9.992837e-01 ,9.992635e-01 ,9.992429e-01 ,9.992221e-01 ,9.992008e-01 ,&
& 9.991793e-01 ,9.991574e-01 ,9.991352e-01 /)
ssaice2(:, 24) = (/ &
! band 24
& 9.999949e-01 ,9.999947e-01 ,9.999943e-01 ,9.999939e-01 ,9.999934e-01 ,&
& 9.999927e-01 ,9.999920e-01 ,9.999913e-01 ,9.999904e-01 ,9.999895e-01 ,&
& 9.999885e-01 ,9.999874e-01 ,9.999863e-01 ,9.999851e-01 ,9.999838e-01 ,&
& 9.999824e-01 ,9.999810e-01 ,9.999795e-01 ,9.999780e-01 ,9.999764e-01 ,&
& 9.999747e-01 ,9.999729e-01 ,9.999711e-01 ,9.999692e-01 ,9.999673e-01 ,&
& 9.999653e-01 ,9.999632e-01 ,9.999611e-01 ,9.999589e-01 ,9.999566e-01 ,&
& 9.999543e-01 ,9.999519e-01 ,9.999495e-01 ,9.999470e-01 ,9.999444e-01 ,&
& 9.999418e-01 ,9.999392e-01 ,9.999364e-01 ,9.999336e-01 ,9.999308e-01 ,&
& 9.999279e-01 ,9.999249e-01 ,9.999219e-01 /)
ssaice2(:, 25) = (/ &
! band 25
& 9.999997e-01 ,9.999997e-01 ,9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,&
& 9.999995e-01 ,9.999994e-01 ,9.999993e-01 ,9.999993e-01 ,9.999992e-01 ,&
& 9.999991e-01 ,9.999989e-01 ,9.999988e-01 ,9.999987e-01 ,9.999986e-01 ,&
& 9.999984e-01 ,9.999983e-01 ,9.999981e-01 ,9.999980e-01 ,9.999978e-01 ,&
& 9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999971e-01 ,9.999969e-01 ,&
& 9.999966e-01 ,9.999964e-01 ,9.999962e-01 ,9.999960e-01 ,9.999957e-01 ,&
& 9.999955e-01 ,9.999953e-01 ,9.999950e-01 ,9.999947e-01 ,9.999945e-01 ,&
& 9.999942e-01 ,9.999939e-01 ,9.999936e-01 ,9.999934e-01 ,9.999931e-01 ,&
& 9.999928e-01 ,9.999925e-01 ,9.999921e-01 /)
ssaice2(:, 26) = (/ &
! band 26
& 9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,9.999995e-01 ,9.999994e-01 ,&
& 9.999993e-01 ,9.999992e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,&
& 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999982e-01 ,9.999980e-01 ,&
& 9.999978e-01 ,9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999970e-01 ,&
& 9.999967e-01 ,9.999965e-01 ,9.999962e-01 ,9.999959e-01 ,9.999956e-01 ,&
& 9.999954e-01 ,9.999951e-01 ,9.999947e-01 ,9.999944e-01 ,9.999941e-01 ,&
& 9.999938e-01 ,9.999934e-01 ,9.999931e-01 ,9.999927e-01 ,9.999923e-01 ,&
& 9.999920e-01 ,9.999916e-01 ,9.999912e-01 ,9.999908e-01 ,9.999904e-01 ,&
& 9.999899e-01 ,9.999895e-01 ,9.999891e-01 /)
ssaice2(:, 27) = (/ &
! band 27
& 9.999987e-01 ,9.999987e-01 ,9.999985e-01 ,9.999984e-01 ,9.999982e-01 ,&
& 9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,9.999973e-01 ,9.999970e-01 ,&
& 9.999967e-01 ,9.999964e-01 ,9.999960e-01 ,9.999956e-01 ,9.999952e-01 ,&
& 9.999948e-01 ,9.999944e-01 ,9.999939e-01 ,9.999934e-01 ,9.999929e-01 ,&
& 9.999924e-01 ,9.999918e-01 ,9.999913e-01 ,9.999907e-01 ,9.999901e-01 ,&
& 9.999894e-01 ,9.999888e-01 ,9.999881e-01 ,9.999874e-01 ,9.999867e-01 ,&
& 9.999860e-01 ,9.999853e-01 ,9.999845e-01 ,9.999837e-01 ,9.999829e-01 ,&
& 9.999821e-01 ,9.999813e-01 ,9.999804e-01 ,9.999796e-01 ,9.999787e-01 ,&
& 9.999778e-01 ,9.999768e-01 ,9.999759e-01 /)
ssaice2(:, 28) = (/ &
! band 28
& 9.999989e-01 ,9.999989e-01 ,9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,&
& 9.999982e-01 ,9.999980e-01 ,9.999978e-01 ,9.999975e-01 ,9.999972e-01 ,&
& 9.999969e-01 ,9.999966e-01 ,9.999962e-01 ,9.999958e-01 ,9.999954e-01 ,&
& 9.999950e-01 ,9.999945e-01 ,9.999941e-01 ,9.999936e-01 ,9.999931e-01 ,&
& 9.999925e-01 ,9.999920e-01 ,9.999914e-01 ,9.999908e-01 ,9.999902e-01 ,&
& 9.999896e-01 ,9.999889e-01 ,9.999883e-01 ,9.999876e-01 ,9.999869e-01 ,&
& 9.999861e-01 ,9.999854e-01 ,9.999846e-01 ,9.999838e-01 ,9.999830e-01 ,&
& 9.999822e-01 ,9.999814e-01 ,9.999805e-01 ,9.999796e-01 ,9.999787e-01 ,&
& 9.999778e-01 ,9.999769e-01 ,9.999759e-01 /)
ssaice2(:, 29) = (/ &
! band 29
& 7.042143e-01 ,6.691161e-01 ,6.463240e-01 ,6.296590e-01 ,6.166381e-01 ,&
& 6.060183e-01 ,5.970908e-01 ,5.894144e-01 ,5.826968e-01 ,5.767343e-01 ,&
& 5.713804e-01 ,5.665256e-01 ,5.620867e-01 ,5.579987e-01 ,5.542101e-01 ,&
& 5.506794e-01 ,5.473727e-01 ,5.442620e-01 ,5.413239e-01 ,5.385389e-01 ,&
& 5.358901e-01 ,5.333633e-01 ,5.309460e-01 ,5.286277e-01 ,5.263988e-01 ,&
& 5.242512e-01 ,5.221777e-01 ,5.201719e-01 ,5.182280e-01 ,5.163410e-01 ,&
& 5.145062e-01 ,5.127197e-01 ,5.109776e-01 ,5.092766e-01 ,5.076137e-01 ,&
& 5.059860e-01 ,5.043911e-01 ,5.028266e-01 ,5.012904e-01 ,4.997805e-01 ,&
& 4.982951e-01 ,4.968326e-01 ,4.953913e-01 /)
! asymmetry factor: unitless
asyice2(:, 16) = (/ &
! band 16
& 7.946655e-01 ,8.547685e-01 ,8.806016e-01 ,8.949880e-01 ,9.041676e-01 ,&
& 9.105399e-01 ,9.152249e-01 ,9.188160e-01 ,9.216573e-01 ,9.239620e-01 ,&
& 9.258695e-01 ,9.274745e-01 ,9.288441e-01 ,9.300267e-01 ,9.310584e-01 ,&
& 9.319665e-01 ,9.327721e-01 ,9.334918e-01 ,9.341387e-01 ,9.347236e-01 ,&
& 9.352551e-01 ,9.357402e-01 ,9.361850e-01 ,9.365942e-01 ,9.369722e-01 ,&
& 9.373225e-01 ,9.376481e-01 ,9.379516e-01 ,9.382352e-01 ,9.385010e-01 ,&
& 9.387505e-01 ,9.389854e-01 ,9.392070e-01 ,9.394163e-01 ,9.396145e-01 ,&
& 9.398024e-01 ,9.399809e-01 ,9.401508e-01 ,9.403126e-01 ,9.404670e-01 ,&
& 9.406144e-01 ,9.407555e-01 ,9.408906e-01 /)
asyice2(:, 17) = (/ &
! band 17
& 9.078091e-01 ,9.195850e-01 ,9.267250e-01 ,9.317083e-01 ,9.354632e-01 ,&
& 9.384323e-01 ,9.408597e-01 ,9.428935e-01 ,9.446301e-01 ,9.461351e-01 ,&
& 9.474555e-01 ,9.486259e-01 ,9.496722e-01 ,9.506146e-01 ,9.514688e-01 ,&
& 9.522476e-01 ,9.529612e-01 ,9.536181e-01 ,9.542251e-01 ,9.547883e-01 ,&
& 9.553124e-01 ,9.558019e-01 ,9.562601e-01 ,9.566904e-01 ,9.570953e-01 ,&
& 9.574773e-01 ,9.578385e-01 ,9.581806e-01 ,9.585054e-01 ,9.588142e-01 ,&
& 9.591083e-01 ,9.593888e-01 ,9.596569e-01 ,9.599135e-01 ,9.601593e-01 ,&
& 9.603952e-01 ,9.606219e-01 ,9.608399e-01 ,9.610499e-01 ,9.612523e-01 ,&
& 9.614477e-01 ,9.616365e-01 ,9.618192e-01 /)
asyice2(:, 18) = (/ &
! band 18
& 8.322045e-01 ,8.528693e-01 ,8.648167e-01 ,8.729163e-01 ,8.789054e-01 ,&
& 8.835845e-01 ,8.873819e-01 ,8.905511e-01 ,8.932532e-01 ,8.955965e-01 ,&
& 8.976567e-01 ,8.994887e-01 ,9.011334e-01 ,9.026221e-01 ,9.039791e-01 ,&
& 9.052237e-01 ,9.063715e-01 ,9.074349e-01 ,9.084245e-01 ,9.093489e-01 ,&
& 9.102154e-01 ,9.110303e-01 ,9.117987e-01 ,9.125253e-01 ,9.132140e-01 ,&
& 9.138682e-01 ,9.144910e-01 ,9.150850e-01 ,9.156524e-01 ,9.161955e-01 ,&
& 9.167160e-01 ,9.172157e-01 ,9.176959e-01 ,9.181581e-01 ,9.186034e-01 ,&
& 9.190330e-01 ,9.194478e-01 ,9.198488e-01 ,9.202368e-01 ,9.206126e-01 ,&
& 9.209768e-01 ,9.213301e-01 ,9.216731e-01 /)
asyice2(:, 19) = (/ &
! band 19
& 8.116560e-01 ,8.488278e-01 ,8.674331e-01 ,8.788148e-01 ,8.865810e-01 ,&
& 8.922595e-01 ,8.966149e-01 ,9.000747e-01 ,9.028980e-01 ,9.052513e-01 ,&
& 9.072468e-01 ,9.089632e-01 ,9.104574e-01 ,9.117713e-01 ,9.129371e-01 ,&
& 9.139793e-01 ,9.149174e-01 ,9.157668e-01 ,9.165400e-01 ,9.172473e-01 ,&
& 9.178970e-01 ,9.184962e-01 ,9.190508e-01 ,9.195658e-01 ,9.200455e-01 ,&
& 9.204935e-01 ,9.209130e-01 ,9.213067e-01 ,9.216771e-01 ,9.220262e-01 ,&
& 9.223560e-01 ,9.226680e-01 ,9.229636e-01 ,9.232443e-01 ,9.235112e-01 ,&
& 9.237652e-01 ,9.240074e-01 ,9.242385e-01 ,9.244594e-01 ,9.246708e-01 ,&
& 9.248733e-01 ,9.250674e-01 ,9.252536e-01 /)
asyice2(:, 20) = (/ &
! band 20
& 8.047113e-01 ,8.402864e-01 ,8.570332e-01 ,8.668455e-01 ,8.733206e-01 ,&
& 8.779272e-01 ,8.813796e-01 ,8.840676e-01 ,8.862225e-01 ,8.879904e-01 ,&
& 8.894682e-01 ,8.907228e-01 ,8.918019e-01 ,8.927404e-01 ,8.935645e-01 ,&
& 8.942943e-01 ,8.949452e-01 ,8.955296e-01 ,8.960574e-01 ,8.965366e-01 ,&
& 8.969736e-01 ,8.973740e-01 ,8.977422e-01 ,8.980820e-01 ,8.983966e-01 ,&
& 8.986889e-01 ,8.989611e-01 ,8.992153e-01 ,8.994533e-01 ,8.996766e-01 ,&
& 8.998865e-01 ,9.000843e-01 ,9.002709e-01 ,9.004474e-01 ,9.006146e-01 ,&
& 9.007731e-01 ,9.009237e-01 ,9.010670e-01 ,9.012034e-01 ,9.013336e-01 ,&
& 9.014579e-01 ,9.015767e-01 ,9.016904e-01 /)
asyice2(:, 21) = (/ &
! band 21
& 8.179122e-01 ,8.480726e-01 ,8.621945e-01 ,8.704354e-01 ,8.758555e-01 ,&
& 8.797007e-01 ,8.825750e-01 ,8.848078e-01 ,8.865939e-01 ,8.880564e-01 ,&
& 8.892765e-01 ,8.903105e-01 ,8.911982e-01 ,8.919689e-01 ,8.926446e-01 ,&
& 8.932419e-01 ,8.937738e-01 ,8.942506e-01 ,8.946806e-01 ,8.950702e-01 ,&
& 8.954251e-01 ,8.957497e-01 ,8.960477e-01 ,8.963223e-01 ,8.965762e-01 ,&
& 8.968116e-01 ,8.970306e-01 ,8.972347e-01 ,8.974255e-01 ,8.976042e-01 ,&
& 8.977720e-01 ,8.979298e-01 ,8.980784e-01 ,8.982188e-01 ,8.983515e-01 ,&
& 8.984771e-01 ,8.985963e-01 ,8.987095e-01 ,8.988171e-01 ,8.989195e-01 ,&
& 8.990172e-01 ,8.991104e-01 ,8.991994e-01 /)
asyice2(:, 22) = (/ &
! band 22
& 8.169789e-01 ,8.455024e-01 ,8.586925e-01 ,8.663283e-01 ,8.713217e-01 ,&
& 8.748488e-01 ,8.774765e-01 ,8.795122e-01 ,8.811370e-01 ,8.824649e-01 ,&
& 8.835711e-01 ,8.845073e-01 ,8.853103e-01 ,8.860068e-01 ,8.866170e-01 ,&
& 8.871560e-01 ,8.876358e-01 ,8.880658e-01 ,8.884533e-01 ,8.888044e-01 ,&
& 8.891242e-01 ,8.894166e-01 ,8.896851e-01 ,8.899324e-01 ,8.901612e-01 ,&
& 8.903733e-01 ,8.905706e-01 ,8.907545e-01 ,8.909265e-01 ,8.910876e-01 ,&
& 8.912388e-01 ,8.913812e-01 ,8.915153e-01 ,8.916419e-01 ,8.917617e-01 ,&
& 8.918752e-01 ,8.919829e-01 ,8.920851e-01 ,8.921824e-01 ,8.922751e-01 ,&
& 8.923635e-01 ,8.924478e-01 ,8.925284e-01 /)
asyice2(:, 23) = (/ &
! band 23
& 8.387642e-01 ,8.569979e-01 ,8.658630e-01 ,8.711825e-01 ,8.747605e-01 ,&
& 8.773472e-01 ,8.793129e-01 ,8.808621e-01 ,8.821179e-01 ,8.831583e-01 ,&
& 8.840361e-01 ,8.847875e-01 ,8.854388e-01 ,8.860094e-01 ,8.865138e-01 ,&
& 8.869634e-01 ,8.873668e-01 ,8.877310e-01 ,8.880617e-01 ,8.883635e-01 ,&
& 8.886401e-01 ,8.888947e-01 ,8.891298e-01 ,8.893477e-01 ,8.895504e-01 ,&
& 8.897393e-01 ,8.899159e-01 ,8.900815e-01 ,8.902370e-01 ,8.903833e-01 ,&
& 8.905214e-01 ,8.906518e-01 ,8.907753e-01 ,8.908924e-01 ,8.910036e-01 ,&
& 8.911094e-01 ,8.912101e-01 ,8.913062e-01 ,8.913979e-01 ,8.914856e-01 ,&
& 8.915695e-01 ,8.916498e-01 ,8.917269e-01 /)
asyice2(:, 24) = (/ &
! band 24
& 8.522208e-01 ,8.648132e-01 ,8.711224e-01 ,8.749901e-01 ,8.776354e-01 ,&
& 8.795743e-01 ,8.810649e-01 ,8.822518e-01 ,8.832225e-01 ,8.840333e-01 ,&
& 8.847224e-01 ,8.853162e-01 ,8.858342e-01 ,8.862906e-01 ,8.866962e-01 ,&
& 8.870595e-01 ,8.873871e-01 ,8.876842e-01 ,8.879551e-01 ,8.882032e-01 ,&
& 8.884316e-01 ,8.886425e-01 ,8.888380e-01 ,8.890199e-01 ,8.891895e-01 ,&
& 8.893481e-01 ,8.894968e-01 ,8.896366e-01 ,8.897683e-01 ,8.898926e-01 ,&
& 8.900102e-01 ,8.901215e-01 ,8.902272e-01 ,8.903276e-01 ,8.904232e-01 ,&
& 8.905144e-01 ,8.906014e-01 ,8.906845e-01 ,8.907640e-01 ,8.908402e-01 ,&
& 8.909132e-01 ,8.909834e-01 ,8.910507e-01 /)
asyice2(:, 25) = (/ &
! band 25
& 8.578202e-01 ,8.683033e-01 ,8.735431e-01 ,8.767488e-01 ,8.789378e-01 ,&
& 8.805399e-01 ,8.817701e-01 ,8.827485e-01 ,8.835480e-01 ,8.842152e-01 ,&
& 8.847817e-01 ,8.852696e-01 ,8.856949e-01 ,8.860694e-01 ,8.864020e-01 ,&
& 8.866997e-01 ,8.869681e-01 ,8.872113e-01 ,8.874330e-01 ,8.876360e-01 ,&
& 8.878227e-01 ,8.879951e-01 ,8.881548e-01 ,8.883033e-01 ,8.884418e-01 ,&
& 8.885712e-01 ,8.886926e-01 ,8.888066e-01 ,8.889139e-01 ,8.890152e-01 ,&
& 8.891110e-01 ,8.892017e-01 ,8.892877e-01 ,8.893695e-01 ,8.894473e-01 ,&
& 8.895214e-01 ,8.895921e-01 ,8.896597e-01 ,8.897243e-01 ,8.897862e-01 ,&
& 8.898456e-01 ,8.899025e-01 ,8.899572e-01 /)
asyice2(:, 26) = (/ &
! band 26
& 8.625615e-01 ,8.713831e-01 ,8.755799e-01 ,8.780560e-01 ,8.796983e-01 ,&
& 8.808714e-01 ,8.817534e-01 ,8.824420e-01 ,8.829953e-01 ,8.834501e-01 ,&
& 8.838310e-01 ,8.841549e-01 ,8.844338e-01 ,8.846767e-01 ,8.848902e-01 ,&
& 8.850795e-01 ,8.852484e-01 ,8.854002e-01 ,8.855374e-01 ,8.856620e-01 ,&
& 8.857758e-01 ,8.858800e-01 ,8.859759e-01 ,8.860644e-01 ,8.861464e-01 ,&
& 8.862225e-01 ,8.862935e-01 ,8.863598e-01 ,8.864218e-01 ,8.864800e-01 ,&
& 8.865347e-01 ,8.865863e-01 ,8.866349e-01 ,8.866809e-01 ,8.867245e-01 ,&
& 8.867658e-01 ,8.868050e-01 ,8.868423e-01 ,8.868778e-01 ,8.869117e-01 ,&
& 8.869440e-01 ,8.869749e-01 ,8.870044e-01 /)
asyice2(:, 27) = (/ &
! band 27
& 8.587495e-01 ,8.684764e-01 ,8.728189e-01 ,8.752872e-01 ,8.768846e-01 ,&
& 8.780060e-01 ,8.788386e-01 ,8.794824e-01 ,8.799960e-01 ,8.804159e-01 ,&
& 8.807660e-01 ,8.810626e-01 ,8.813175e-01 ,8.815390e-01 ,8.817335e-01 ,&
& 8.819057e-01 ,8.820593e-01 ,8.821973e-01 ,8.823220e-01 ,8.824353e-01 ,&
& 8.825387e-01 ,8.826336e-01 ,8.827209e-01 ,8.828016e-01 ,8.828764e-01 ,&
& 8.829459e-01 ,8.830108e-01 ,8.830715e-01 ,8.831283e-01 ,8.831817e-01 ,&
& 8.832320e-01 ,8.832795e-01 ,8.833244e-01 ,8.833668e-01 ,8.834071e-01 ,&
& 8.834454e-01 ,8.834817e-01 ,8.835164e-01 ,8.835495e-01 ,8.835811e-01 ,&
& 8.836113e-01 ,8.836402e-01 ,8.836679e-01 /)
asyice2(:, 28) = (/ &
! band 28
& 8.561110e-01 ,8.678583e-01 ,8.727554e-01 ,8.753892e-01 ,8.770154e-01 ,&
& 8.781109e-01 ,8.788949e-01 ,8.794812e-01 ,8.799348e-01 ,8.802952e-01 ,&
& 8.805880e-01 ,8.808300e-01 ,8.810331e-01 ,8.812058e-01 ,8.813543e-01 ,&
& 8.814832e-01 ,8.815960e-01 ,8.816956e-01 ,8.817839e-01 ,8.818629e-01 ,&
& 8.819339e-01 ,8.819979e-01 ,8.820560e-01 ,8.821089e-01 ,8.821573e-01 ,&
& 8.822016e-01 ,8.822425e-01 ,8.822801e-01 ,8.823150e-01 ,8.823474e-01 ,&
& 8.823775e-01 ,8.824056e-01 ,8.824318e-01 ,8.824564e-01 ,8.824795e-01 ,&
& 8.825011e-01 ,8.825215e-01 ,8.825408e-01 ,8.825589e-01 ,8.825761e-01 ,&
& 8.825924e-01 ,8.826078e-01 ,8.826224e-01 /)
asyice2(:, 29) = (/ &
! band 29
& 8.311124e-01 ,8.688197e-01 ,8.900274e-01 ,9.040696e-01 ,9.142334e-01 ,&
& 9.220181e-01 ,9.282195e-01 ,9.333048e-01 ,9.375689e-01 ,9.412085e-01 ,&
& 9.443604e-01 ,9.471230e-01 ,9.495694e-01 ,9.517549e-01 ,9.537224e-01 ,&
& 9.555057e-01 ,9.571316e-01 ,9.586222e-01 ,9.599952e-01 ,9.612656e-01 ,&
& 9.624458e-01 ,9.635461e-01 ,9.645756e-01 ,9.655418e-01 ,9.664513e-01 ,&
& 9.673098e-01 ,9.681222e-01 ,9.688928e-01 ,9.696256e-01 ,9.703237e-01 ,&
& 9.709903e-01 ,9.716280e-01 ,9.722391e-01 ,9.728258e-01 ,9.733901e-01 ,&
& 9.739336e-01 ,9.744579e-01 ,9.749645e-01 ,9.754546e-01 ,9.759294e-01 ,&
& 9.763901e-01 ,9.768376e-01 ,9.772727e-01 /)
! Hexagonal Ice Particle Parameterization
! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
extice3(:, 16) = (/ &
! band 16
& 5.194013e-01 ,3.215089e-01 ,2.327917e-01 ,1.824424e-01 ,1.499977e-01 ,&
& 1.273492e-01 ,1.106421e-01 ,9.780982e-02 ,8.764435e-02 ,7.939266e-02 ,&
& 7.256081e-02 ,6.681137e-02 ,6.190600e-02 ,5.767154e-02 ,5.397915e-02 ,&
& 5.073102e-02 ,4.785151e-02 ,4.528125e-02 ,4.297296e-02 ,4.088853e-02 ,&
& 3.899690e-02 ,3.727251e-02 ,3.569411e-02 ,3.424393e-02 ,3.290694e-02 ,&
& 3.167040e-02 ,3.052340e-02 ,2.945654e-02 ,2.846172e-02 ,2.753188e-02 ,&
& 2.666085e-02 ,2.584322e-02 ,2.507423e-02 ,2.434967e-02 ,2.366579e-02 ,&
& 2.301926e-02 ,2.240711e-02 ,2.182666e-02 ,2.127551e-02 ,2.075150e-02 ,&
& 2.025267e-02 ,1.977725e-02 ,1.932364e-02 ,1.889035e-02 ,1.847607e-02 ,&
& 1.807956e-02 /)
extice3(:, 17) = (/ &
! band 17
& 4.901155e-01 ,3.065286e-01 ,2.230800e-01 ,1.753951e-01 ,1.445402e-01 ,&
& 1.229417e-01 ,1.069777e-01 ,9.469760e-02 ,8.495824e-02 ,7.704501e-02 ,&
& 7.048834e-02 ,6.496693e-02 ,6.025353e-02 ,5.618286e-02 ,5.263186e-02 ,&
& 4.950698e-02 ,4.673585e-02 ,4.426164e-02 ,4.203904e-02 ,4.003153e-02 ,&
& 3.820932e-02 ,3.654790e-02 ,3.502688e-02 ,3.362919e-02 ,3.234041e-02 ,&
& 3.114829e-02 ,3.004234e-02 ,2.901356e-02 ,2.805413e-02 ,2.715727e-02 ,&
& 2.631705e-02 ,2.552828e-02 ,2.478637e-02 ,2.408725e-02 ,2.342734e-02 ,&
& 2.280343e-02 ,2.221264e-02 ,2.165242e-02 ,2.112043e-02 ,2.061461e-02 ,&
& 2.013308e-02 ,1.967411e-02 ,1.923616e-02 ,1.881783e-02 ,1.841781e-02 ,&
& 1.803494e-02 /)
extice3(:, 18) = (/ &
! band 18
& 5.056264e-01 ,3.160261e-01 ,2.298442e-01 ,1.805973e-01 ,1.487318e-01 ,&
& 1.264258e-01 ,1.099389e-01 ,9.725656e-02 ,8.719819e-02 ,7.902576e-02 ,&
& 7.225433e-02 ,6.655206e-02 ,6.168427e-02 ,5.748028e-02 ,5.381296e-02 ,&
& 5.058572e-02 ,4.772383e-02 ,4.516857e-02 ,4.287317e-02 ,4.079990e-02 ,&
& 3.891801e-02 ,3.720217e-02 ,3.563133e-02 ,3.418786e-02 ,3.285686e-02 ,&
& 3.162569e-02 ,3.048352e-02 ,2.942104e-02 ,2.843018e-02 ,2.750395e-02 ,&
& 2.663621e-02 ,2.582160e-02 ,2.505539e-02 ,2.433337e-02 ,2.365185e-02 ,&
& 2.300750e-02 ,2.239736e-02 ,2.181878e-02 ,2.126937e-02 ,2.074699e-02 ,&
& 2.024968e-02 ,1.977567e-02 ,1.932338e-02 ,1.889134e-02 ,1.847823e-02 ,&
& 1.808281e-02 /)
extice3(:, 19) = (/ &
! band 19
& 4.881605e-01 ,3.055237e-01 ,2.225070e-01 ,1.750688e-01 ,1.443736e-01 ,&
& 1.228869e-01 ,1.070054e-01 ,9.478893e-02 ,8.509997e-02 ,7.722769e-02 ,&
& 7.070495e-02 ,6.521211e-02 ,6.052311e-02 ,5.647351e-02 ,5.294088e-02 ,&
& 4.983217e-02 ,4.707539e-02 ,4.461398e-02 ,4.240288e-02 ,4.040575e-02 ,&
& 3.859298e-02 ,3.694016e-02 ,3.542701e-02 ,3.403655e-02 ,3.275444e-02 ,&
& 3.156849e-02 ,3.046827e-02 ,2.944481e-02 ,2.849034e-02 ,2.759812e-02 ,&
& 2.676226e-02 ,2.597757e-02 ,2.523949e-02 ,2.454400e-02 ,2.388750e-02 ,&
& 2.326682e-02 ,2.267909e-02 ,2.212176e-02 ,2.159253e-02 ,2.108933e-02 ,&
& 2.061028e-02 ,2.015369e-02 ,1.971801e-02 ,1.930184e-02 ,1.890389e-02 ,&
& 1.852300e-02 /)
extice3(:, 20) = (/ &
! band 20
& 5.103703e-01 ,3.188144e-01 ,2.317435e-01 ,1.819887e-01 ,1.497944e-01 ,&
& 1.272584e-01 ,1.106013e-01 ,9.778822e-02 ,8.762610e-02 ,7.936938e-02 ,&
& 7.252809e-02 ,6.676701e-02 ,6.184901e-02 ,5.760165e-02 ,5.389651e-02 ,&
& 5.063598e-02 ,4.774457e-02 ,4.516295e-02 ,4.284387e-02 ,4.074922e-02 ,&
& 3.884792e-02 ,3.711438e-02 ,3.552734e-02 ,3.406898e-02 ,3.272425e-02 ,&
& 3.148038e-02 ,3.032643e-02 ,2.925299e-02 ,2.825191e-02 ,2.731612e-02 ,&
& 2.643943e-02 ,2.561642e-02 ,2.484230e-02 ,2.411284e-02 ,2.342429e-02 ,&
& 2.277329e-02 ,2.215686e-02 ,2.157231e-02 ,2.101724e-02 ,2.048946e-02 ,&
& 1.998702e-02 ,1.950813e-02 ,1.905118e-02 ,1.861468e-02 ,1.819730e-02 ,&
& 1.779781e-02 /)
extice3(:, 21) = (/ &
! band 21
& 5.031161e-01 ,3.144511e-01 ,2.286942e-01 ,1.796903e-01 ,1.479819e-01 ,&
& 1.257860e-01 ,1.093803e-01 ,9.676059e-02 ,8.675183e-02 ,7.861971e-02 ,&
& 7.188168e-02 ,6.620754e-02 ,6.136376e-02 ,5.718050e-02 ,5.353127e-02 ,&
& 5.031995e-02 ,4.747218e-02 ,4.492952e-02 ,4.264544e-02 ,4.058240e-02 ,&
& 3.870979e-02 ,3.700242e-02 ,3.543933e-02 ,3.400297e-02 ,3.267854e-02 ,&
& 3.145345e-02 ,3.031691e-02 ,2.925967e-02 ,2.827370e-02 ,2.735203e-02 ,&
& 2.648858e-02 ,2.567798e-02 ,2.491555e-02 ,2.419710e-02 ,2.351893e-02 ,&
& 2.287776e-02 ,2.227063e-02 ,2.169491e-02 ,2.114821e-02 ,2.062840e-02 ,&
& 2.013354e-02 ,1.966188e-02 ,1.921182e-02 ,1.878191e-02 ,1.837083e-02 ,&
& 1.797737e-02 /)
extice3(:, 22) = (/ &
! band 22
& 4.949453e-01 ,3.095918e-01 ,2.253402e-01 ,1.771964e-01 ,1.460446e-01 ,&
& 1.242383e-01 ,1.081206e-01 ,9.572235e-02 ,8.588928e-02 ,7.789990e-02 ,&
& 7.128013e-02 ,6.570559e-02 ,6.094684e-02 ,5.683701e-02 ,5.325183e-02 ,&
& 5.009688e-02 ,4.729909e-02 ,4.480106e-02 ,4.255708e-02 ,4.053025e-02 ,&
& 3.869051e-02 ,3.701310e-02 ,3.547745e-02 ,3.406631e-02 ,3.276512e-02 ,&
& 3.156153e-02 ,3.044494e-02 ,2.940626e-02 ,2.843759e-02 ,2.753211e-02 ,&
& 2.668381e-02 ,2.588744e-02 ,2.513839e-02 ,2.443255e-02 ,2.376629e-02 ,&
& 2.313637e-02 ,2.253990e-02 ,2.197428e-02 ,2.143718e-02 ,2.092649e-02 ,&
& 2.044032e-02 ,1.997694e-02 ,1.953478e-02 ,1.911241e-02 ,1.870855e-02 ,&
& 1.832199e-02 /)
extice3(:, 23) = (/ &
! band 23
& 5.052816e-01 ,3.157665e-01 ,2.296233e-01 ,1.803986e-01 ,1.485473e-01 ,&
& 1.262514e-01 ,1.097718e-01 ,9.709524e-02 ,8.704139e-02 ,7.887264e-02 ,&
& 7.210424e-02 ,6.640454e-02 ,6.153894e-02 ,5.733683e-02 ,5.367116e-02 ,&
& 5.044537e-02 ,4.758477e-02 ,4.503066e-02 ,4.273629e-02 ,4.066395e-02 ,&
& 3.878291e-02 ,3.706784e-02 ,3.549771e-02 ,3.405488e-02 ,3.272448e-02 ,&
& 3.149387e-02 ,3.035221e-02 ,2.929020e-02 ,2.829979e-02 ,2.737397e-02 ,&
& 2.650663e-02 ,2.569238e-02 ,2.492651e-02 ,2.420482e-02 ,2.352361e-02 ,&
& 2.287954e-02 ,2.226968e-02 ,2.169136e-02 ,2.114220e-02 ,2.062005e-02 ,&
& 2.012296e-02 ,1.964917e-02 ,1.919709e-02 ,1.876524e-02 ,1.835231e-02 ,&
& 1.795707e-02 /)
extice3(:, 24) = (/ &
! band 24
& 5.042067e-01 ,3.151195e-01 ,2.291708e-01 ,1.800573e-01 ,1.482779e-01 ,&
& 1.260324e-01 ,1.095900e-01 ,9.694202e-02 ,8.691087e-02 ,7.876056e-02 ,&
& 7.200745e-02 ,6.632062e-02 ,6.146600e-02 ,5.727338e-02 ,5.361599e-02 ,&
& 5.039749e-02 ,4.754334e-02 ,4.499500e-02 ,4.270580e-02 ,4.063815e-02 ,&
& 3.876135e-02 ,3.705016e-02 ,3.548357e-02 ,3.404400e-02 ,3.271661e-02 ,&
& 3.148877e-02 ,3.034969e-02 ,2.929008e-02 ,2.830191e-02 ,2.737818e-02 ,&
& 2.651279e-02 ,2.570039e-02 ,2.493624e-02 ,2.421618e-02 ,2.353650e-02 ,&
& 2.289390e-02 ,2.228541e-02 ,2.170840e-02 ,2.116048e-02 ,2.063950e-02 ,&
& 2.014354e-02 ,1.967082e-02 ,1.921975e-02 ,1.878888e-02 ,1.837688e-02 ,&
& 1.798254e-02 /)
extice3(:, 25) = (/ &
! band 25
& 5.022507e-01 ,3.139246e-01 ,2.283218e-01 ,1.794059e-01 ,1.477544e-01 ,&
& 1.255984e-01 ,1.092222e-01 ,9.662516e-02 ,8.663439e-02 ,7.851688e-02 ,&
& 7.179095e-02 ,6.612700e-02 ,6.129193e-02 ,5.711618e-02 ,5.347351e-02 ,&
& 5.026796e-02 ,4.742530e-02 ,4.488721e-02 ,4.260724e-02 ,4.054790e-02 ,&
& 3.867866e-02 ,3.697435e-02 ,3.541407e-02 ,3.398029e-02 ,3.265824e-02 ,&
& 3.143535e-02 ,3.030085e-02 ,2.924551e-02 ,2.826131e-02 ,2.734130e-02 ,&
& 2.647939e-02 ,2.567026e-02 ,2.490919e-02 ,2.419203e-02 ,2.351509e-02 ,&
& 2.287507e-02 ,2.226903e-02 ,2.169434e-02 ,2.114862e-02 ,2.062975e-02 ,&
& 2.013578e-02 ,1.966496e-02 ,1.921571e-02 ,1.878658e-02 ,1.837623e-02 ,&
& 1.798348e-02 /)
extice3(:, 26) = (/ &
! band 26
& 5.068316e-01 ,3.166869e-01 ,2.302576e-01 ,1.808693e-01 ,1.489122e-01 ,&
& 1.265423e-01 ,1.100080e-01 ,9.728926e-02 ,8.720201e-02 ,7.900612e-02 ,&
& 7.221524e-02 ,6.649660e-02 ,6.161484e-02 ,5.739877e-02 ,5.372093e-02 ,&
& 5.048442e-02 ,4.761431e-02 ,4.505172e-02 ,4.274972e-02 ,4.067050e-02 ,&
& 3.878321e-02 ,3.706244e-02 ,3.548710e-02 ,3.403948e-02 ,3.270466e-02 ,&
& 3.146995e-02 ,3.032450e-02 ,2.925897e-02 ,2.826527e-02 ,2.733638e-02 ,&
& 2.646615e-02 ,2.564920e-02 ,2.488078e-02 ,2.415670e-02 ,2.347322e-02 ,&
& 2.282702e-02 ,2.221513e-02 ,2.163489e-02 ,2.108390e-02 ,2.056002e-02 ,&
& 2.006128e-02 ,1.958591e-02 ,1.913232e-02 ,1.869904e-02 ,1.828474e-02 ,&
& 1.788819e-02 /)
extice3(:, 27) = (/ &
! band 27
& 5.077707e-01 ,3.172636e-01 ,2.306695e-01 ,1.811871e-01 ,1.491691e-01 ,&
& 1.267565e-01 ,1.101907e-01 ,9.744773e-02 ,8.734125e-02 ,7.912973e-02 ,&
& 7.232591e-02 ,6.659637e-02 ,6.170530e-02 ,5.748120e-02 ,5.379634e-02 ,&
& 5.055367e-02 ,4.767809e-02 ,4.511061e-02 ,4.280423e-02 ,4.072104e-02 ,&
& 3.883015e-02 ,3.710611e-02 ,3.552776e-02 ,3.407738e-02 ,3.274002e-02 ,&
& 3.150296e-02 ,3.035532e-02 ,2.928776e-02 ,2.829216e-02 ,2.736150e-02 ,&
& 2.648961e-02 ,2.567111e-02 ,2.490123e-02 ,2.417576e-02 ,2.349098e-02 ,&
& 2.284354e-02 ,2.223049e-02 ,2.164914e-02 ,2.109711e-02 ,2.057222e-02 ,&
& 2.007253e-02 ,1.959626e-02 ,1.914181e-02 ,1.870770e-02 ,1.829261e-02 ,&
& 1.789531e-02 /)
extice3(:, 28) = (/ &
! band 28
& 5.062281e-01 ,3.163402e-01 ,2.300275e-01 ,1.807060e-01 ,1.487921e-01 ,&
& 1.264523e-01 ,1.099403e-01 ,9.723879e-02 ,8.716516e-02 ,7.898034e-02 ,&
& 7.219863e-02 ,6.648771e-02 ,6.161254e-02 ,5.740217e-02 ,5.372929e-02 ,&
& 5.049716e-02 ,4.763092e-02 ,4.507179e-02 ,4.277290e-02 ,4.069649e-02 ,&
& 3.881175e-02 ,3.709331e-02 ,3.552008e-02 ,3.407442e-02 ,3.274141e-02 ,&
& 3.150837e-02 ,3.036447e-02 ,2.930037e-02 ,2.830801e-02 ,2.738037e-02 ,&
& 2.651132e-02 ,2.569547e-02 ,2.492810e-02 ,2.420499e-02 ,2.352243e-02 ,&
& 2.287710e-02 ,2.226604e-02 ,2.168658e-02 ,2.113634e-02 ,2.061316e-02 ,&
& 2.011510e-02 ,1.964038e-02 ,1.918740e-02 ,1.875471e-02 ,1.834096e-02 ,&
& 1.794495e-02 /)
extice3(:, 29) = (/ &
! band 29
& 1.338834e-01 ,1.924912e-01 ,1.755523e-01 ,1.534793e-01 ,1.343937e-01 ,&
& 1.187883e-01 ,1.060654e-01 ,9.559106e-02 ,8.685880e-02 ,7.948698e-02 ,&
& 7.319086e-02 ,6.775669e-02 ,6.302215e-02 ,5.886236e-02 ,5.517996e-02 ,&
& 5.189810e-02 ,4.895539e-02 ,4.630225e-02 ,4.389823e-02 ,4.171002e-02 ,&
& 3.970998e-02 ,3.787493e-02 ,3.618537e-02 ,3.462471e-02 ,3.317880e-02 ,&
& 3.183547e-02 ,3.058421e-02 ,2.941590e-02 ,2.832256e-02 ,2.729724e-02 ,&
& 2.633377e-02 ,2.542675e-02 ,2.457136e-02 ,2.376332e-02 ,2.299882e-02 ,&
& 2.227443e-02 ,2.158707e-02 ,2.093400e-02 ,2.031270e-02 ,1.972091e-02 ,&
& 1.915659e-02 ,1.861787e-02 ,1.810304e-02 ,1.761055e-02 ,1.713899e-02 ,&
& 1.668704e-02 /)
! single-scattering albedo: unitless
ssaice3(:, 16) = (/ &
! band 16
& 6.749442e-01 ,6.649947e-01 ,6.565828e-01 ,6.489928e-01 ,6.420046e-01 ,&
& 6.355231e-01 ,6.294964e-01 ,6.238901e-01 ,6.186783e-01 ,6.138395e-01 ,&
& 6.093543e-01 ,6.052049e-01 ,6.013742e-01 ,5.978457e-01 ,5.946030e-01 ,&
& 5.916302e-01 ,5.889115e-01 ,5.864310e-01 ,5.841731e-01 ,5.821221e-01 ,&
& 5.802624e-01 ,5.785785e-01 ,5.770549e-01 ,5.756759e-01 ,5.744262e-01 ,&
& 5.732901e-01 ,5.722524e-01 ,5.712974e-01 ,5.704097e-01 ,5.695739e-01 ,&
& 5.687747e-01 ,5.679964e-01 ,5.672238e-01 ,5.664415e-01 ,5.656340e-01 ,&
& 5.647860e-01 ,5.638821e-01 ,5.629070e-01 ,5.618452e-01 ,5.606815e-01 ,&
& 5.594006e-01 ,5.579870e-01 ,5.564255e-01 ,5.547008e-01 ,5.527976e-01 ,&
& 5.507005e-01 /)
ssaice3(:, 17) = (/ &
! band 17
& 7.628550e-01 ,7.567297e-01 ,7.508463e-01 ,7.451972e-01 ,7.397745e-01 ,&
& 7.345705e-01 ,7.295775e-01 ,7.247881e-01 ,7.201945e-01 ,7.157894e-01 ,&
& 7.115652e-01 ,7.075145e-01 ,7.036300e-01 ,6.999044e-01 ,6.963304e-01 ,&
& 6.929007e-01 ,6.896083e-01 ,6.864460e-01 ,6.834067e-01 ,6.804833e-01 ,&
& 6.776690e-01 ,6.749567e-01 ,6.723397e-01 ,6.698109e-01 ,6.673637e-01 ,&
& 6.649913e-01 ,6.626870e-01 ,6.604441e-01 ,6.582561e-01 ,6.561163e-01 ,&
& 6.540182e-01 ,6.519554e-01 ,6.499215e-01 ,6.479099e-01 ,6.459145e-01 ,&
& 6.439289e-01 ,6.419468e-01 ,6.399621e-01 ,6.379686e-01 ,6.359601e-01 ,&
& 6.339306e-01 ,6.318740e-01 ,6.297845e-01 ,6.276559e-01 ,6.254825e-01 ,&
& 6.232583e-01 /)
ssaice3(:, 18) = (/ &
! band 18
& 9.924147e-01 ,9.882792e-01 ,9.842257e-01 ,9.802522e-01 ,9.763566e-01 ,&
& 9.725367e-01 ,9.687905e-01 ,9.651157e-01 ,9.615104e-01 ,9.579725e-01 ,&
& 9.544997e-01 ,9.510901e-01 ,9.477416e-01 ,9.444520e-01 ,9.412194e-01 ,&
& 9.380415e-01 ,9.349165e-01 ,9.318421e-01 ,9.288164e-01 ,9.258373e-01 ,&
& 9.229027e-01 ,9.200106e-01 ,9.171589e-01 ,9.143457e-01 ,9.115688e-01 ,&
& 9.088263e-01 ,9.061161e-01 ,9.034362e-01 ,9.007846e-01 ,8.981592e-01 ,&
& 8.955581e-01 ,8.929792e-01 ,8.904206e-01 ,8.878803e-01 ,8.853562e-01 ,&
& 8.828464e-01 ,8.803488e-01 ,8.778616e-01 ,8.753827e-01 ,8.729102e-01 ,&
& 8.704421e-01 ,8.679764e-01 ,8.655112e-01 ,8.630445e-01 ,8.605744e-01 ,&
& 8.580989e-01 /)
ssaice3(:, 19) = (/ &
! band 19
& 9.629413e-01 ,9.517182e-01 ,9.409209e-01 ,9.305366e-01 ,9.205529e-01 ,&
& 9.109569e-01 ,9.017362e-01 ,8.928780e-01 ,8.843699e-01 ,8.761992e-01 ,&
& 8.683536e-01 ,8.608204e-01 ,8.535873e-01 ,8.466417e-01 ,8.399712e-01 ,&
& 8.335635e-01 ,8.274062e-01 ,8.214868e-01 ,8.157932e-01 ,8.103129e-01 ,&
& 8.050336e-01 ,7.999432e-01 ,7.950294e-01 ,7.902798e-01 ,7.856825e-01 ,&
& 7.812250e-01 ,7.768954e-01 ,7.726815e-01 ,7.685711e-01 ,7.645522e-01 ,&
& 7.606126e-01 ,7.567404e-01 ,7.529234e-01 ,7.491498e-01 ,7.454074e-01 ,&
& 7.416844e-01 ,7.379688e-01 ,7.342485e-01 ,7.305118e-01 ,7.267468e-01 ,&
& 7.229415e-01 ,7.190841e-01 ,7.151628e-01 ,7.111657e-01 ,7.070811e-01 ,&
& 7.028972e-01 /)
ssaice3(:, 20) = (/ &
! band 20
& 9.942270e-01 ,9.909206e-01 ,9.876775e-01 ,9.844960e-01 ,9.813746e-01 ,&
& 9.783114e-01 ,9.753049e-01 ,9.723535e-01 ,9.694553e-01 ,9.666088e-01 ,&
& 9.638123e-01 ,9.610641e-01 ,9.583626e-01 ,9.557060e-01 ,9.530928e-01 ,&
& 9.505211e-01 ,9.479895e-01 ,9.454961e-01 ,9.430393e-01 ,9.406174e-01 ,&
& 9.382288e-01 ,9.358717e-01 ,9.335446e-01 ,9.312456e-01 ,9.289731e-01 ,&
& 9.267255e-01 ,9.245010e-01 ,9.222980e-01 ,9.201147e-01 ,9.179496e-01 ,&
& 9.158008e-01 ,9.136667e-01 ,9.115457e-01 ,9.094359e-01 ,9.073358e-01 ,&
& 9.052436e-01 ,9.031577e-01 ,9.010763e-01 ,8.989977e-01 ,8.969203e-01 ,&
& 8.948423e-01 ,8.927620e-01 ,8.906778e-01 ,8.885879e-01 ,8.864907e-01 ,&
& 8.843843e-01 /)
ssaice3(:, 21) = (/ &
! band 21
& 9.934014e-01 ,9.899331e-01 ,9.865537e-01 ,9.832610e-01 ,9.800523e-01 ,&
& 9.769254e-01 ,9.738777e-01 ,9.709069e-01 ,9.680106e-01 ,9.651862e-01 ,&
& 9.624315e-01 ,9.597439e-01 ,9.571212e-01 ,9.545608e-01 ,9.520605e-01 ,&
& 9.496177e-01 ,9.472301e-01 ,9.448954e-01 ,9.426111e-01 ,9.403749e-01 ,&
& 9.381843e-01 ,9.360370e-01 ,9.339307e-01 ,9.318629e-01 ,9.298313e-01 ,&
& 9.278336e-01 ,9.258673e-01 ,9.239302e-01 ,9.220198e-01 ,9.201338e-01 ,&
& 9.182700e-01 ,9.164258e-01 ,9.145991e-01 ,9.127874e-01 ,9.109884e-01 ,&
& 9.091999e-01 ,9.074194e-01 ,9.056447e-01 ,9.038735e-01 ,9.021033e-01 ,&
& 9.003320e-01 ,8.985572e-01 ,8.967766e-01 ,8.949879e-01 ,8.931888e-01 ,&
& 8.913770e-01 /)
ssaice3(:, 22) = (/ &
! band 22
& 9.994833e-01 ,9.992055e-01 ,9.989278e-01 ,9.986500e-01 ,9.983724e-01 ,&
& 9.980947e-01 ,9.978172e-01 ,9.975397e-01 ,9.972623e-01 ,9.969849e-01 ,&
& 9.967077e-01 ,9.964305e-01 ,9.961535e-01 ,9.958765e-01 ,9.955997e-01 ,&
& 9.953230e-01 ,9.950464e-01 ,9.947699e-01 ,9.944936e-01 ,9.942174e-01 ,&
& 9.939414e-01 ,9.936656e-01 ,9.933899e-01 ,9.931144e-01 ,9.928390e-01 ,&
& 9.925639e-01 ,9.922889e-01 ,9.920141e-01 ,9.917396e-01 ,9.914652e-01 ,&
& 9.911911e-01 ,9.909171e-01 ,9.906434e-01 ,9.903700e-01 ,9.900967e-01 ,&
& 9.898237e-01 ,9.895510e-01 ,9.892784e-01 ,9.890062e-01 ,9.887342e-01 ,&
& 9.884625e-01 ,9.881911e-01 ,9.879199e-01 ,9.876490e-01 ,9.873784e-01 ,&
& 9.871081e-01 /)
ssaice3(:, 23) = (/ &
! band 23
& 9.999343e-01 ,9.998917e-01 ,9.998492e-01 ,9.998067e-01 ,9.997642e-01 ,&
& 9.997218e-01 ,9.996795e-01 ,9.996372e-01 ,9.995949e-01 ,9.995528e-01 ,&
& 9.995106e-01 ,9.994686e-01 ,9.994265e-01 ,9.993845e-01 ,9.993426e-01 ,&
& 9.993007e-01 ,9.992589e-01 ,9.992171e-01 ,9.991754e-01 ,9.991337e-01 ,&
& 9.990921e-01 ,9.990505e-01 ,9.990089e-01 ,9.989674e-01 ,9.989260e-01 ,&
& 9.988846e-01 ,9.988432e-01 ,9.988019e-01 ,9.987606e-01 ,9.987194e-01 ,&
& 9.986782e-01 ,9.986370e-01 ,9.985959e-01 ,9.985549e-01 ,9.985139e-01 ,&
& 9.984729e-01 ,9.984319e-01 ,9.983910e-01 ,9.983502e-01 ,9.983094e-01 ,&
& 9.982686e-01 ,9.982279e-01 ,9.981872e-01 ,9.981465e-01 ,9.981059e-01 ,&
& 9.980653e-01 /)
ssaice3(:, 24) = (/ &
! band 24
& 9.999978e-01 ,9.999965e-01 ,9.999952e-01 ,9.999939e-01 ,9.999926e-01 ,&
& 9.999913e-01 ,9.999900e-01 ,9.999887e-01 ,9.999873e-01 ,9.999860e-01 ,&
& 9.999847e-01 ,9.999834e-01 ,9.999821e-01 ,9.999808e-01 ,9.999795e-01 ,&
& 9.999782e-01 ,9.999769e-01 ,9.999756e-01 ,9.999743e-01 ,9.999730e-01 ,&
& 9.999717e-01 ,9.999704e-01 ,9.999691e-01 ,9.999678e-01 ,9.999665e-01 ,&
& 9.999652e-01 ,9.999639e-01 ,9.999626e-01 ,9.999613e-01 ,9.999600e-01 ,&
& 9.999587e-01 ,9.999574e-01 ,9.999561e-01 ,9.999548e-01 ,9.999535e-01 ,&
& 9.999522e-01 ,9.999509e-01 ,9.999496e-01 ,9.999483e-01 ,9.999470e-01 ,&
& 9.999457e-01 ,9.999444e-01 ,9.999431e-01 ,9.999418e-01 ,9.999405e-01 ,&
& 9.999392e-01 /)
ssaice3(:, 25) = (/ &
! band 25
& 9.999994e-01 ,9.999993e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,&
& 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999983e-01 ,9.999982e-01 ,&
& 9.999980e-01 ,9.999979e-01 ,9.999977e-01 ,9.999976e-01 ,9.999975e-01 ,&
& 9.999973e-01 ,9.999972e-01 ,9.999970e-01 ,9.999969e-01 ,9.999967e-01 ,&
& 9.999966e-01 ,9.999965e-01 ,9.999963e-01 ,9.999962e-01 ,9.999960e-01 ,&
& 9.999959e-01 ,9.999957e-01 ,9.999956e-01 ,9.999954e-01 ,9.999953e-01 ,&
& 9.999952e-01 ,9.999950e-01 ,9.999949e-01 ,9.999947e-01 ,9.999946e-01 ,&
& 9.999944e-01 ,9.999943e-01 ,9.999941e-01 ,9.999940e-01 ,9.999939e-01 ,&
& 9.999937e-01 ,9.999936e-01 ,9.999934e-01 ,9.999933e-01 ,9.999931e-01 ,&
& 9.999930e-01 /)
ssaice3(:, 26) = (/ &
! band 26
& 9.999997e-01 ,9.999995e-01 ,9.999992e-01 ,9.999990e-01 ,9.999987e-01 ,&
& 9.999985e-01 ,9.999983e-01 ,9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,&
& 9.999973e-01 ,9.999971e-01 ,9.999969e-01 ,9.999967e-01 ,9.999965e-01 ,&
& 9.999963e-01 ,9.999960e-01 ,9.999958e-01 ,9.999956e-01 ,9.999954e-01 ,&
& 9.999952e-01 ,9.999950e-01 ,9.999948e-01 ,9.999946e-01 ,9.999944e-01 ,&
& 9.999942e-01 ,9.999939e-01 ,9.999937e-01 ,9.999935e-01 ,9.999933e-01 ,&
& 9.999931e-01 ,9.999929e-01 ,9.999927e-01 ,9.999925e-01 ,9.999923e-01 ,&
& 9.999920e-01 ,9.999918e-01 ,9.999916e-01 ,9.999914e-01 ,9.999911e-01 ,&
& 9.999909e-01 ,9.999907e-01 ,9.999905e-01 ,9.999902e-01 ,9.999900e-01 ,&
& 9.999897e-01 /)
ssaice3(:, 27) = (/ &
! band 27
& 9.999991e-01 ,9.999985e-01 ,9.999980e-01 ,9.999974e-01 ,9.999968e-01 ,&
& 9.999963e-01 ,9.999957e-01 ,9.999951e-01 ,9.999946e-01 ,9.999940e-01 ,&
& 9.999934e-01 ,9.999929e-01 ,9.999923e-01 ,9.999918e-01 ,9.999912e-01 ,&
& 9.999907e-01 ,9.999901e-01 ,9.999896e-01 ,9.999891e-01 ,9.999885e-01 ,&
& 9.999880e-01 ,9.999874e-01 ,9.999869e-01 ,9.999863e-01 ,9.999858e-01 ,&
& 9.999853e-01 ,9.999847e-01 ,9.999842e-01 ,9.999836e-01 ,9.999831e-01 ,&
& 9.999826e-01 ,9.999820e-01 ,9.999815e-01 ,9.999809e-01 ,9.999804e-01 ,&
& 9.999798e-01 ,9.999793e-01 ,9.999787e-01 ,9.999782e-01 ,9.999776e-01 ,&
& 9.999770e-01 ,9.999765e-01 ,9.999759e-01 ,9.999754e-01 ,9.999748e-01 ,&
& 9.999742e-01 /)
ssaice3(:, 28) = (/ &
! band 28
& 9.999975e-01 ,9.999961e-01 ,9.999946e-01 ,9.999931e-01 ,9.999917e-01 ,&
& 9.999903e-01 ,9.999888e-01 ,9.999874e-01 ,9.999859e-01 ,9.999845e-01 ,&
& 9.999831e-01 ,9.999816e-01 ,9.999802e-01 ,9.999788e-01 ,9.999774e-01 ,&
& 9.999759e-01 ,9.999745e-01 ,9.999731e-01 ,9.999717e-01 ,9.999702e-01 ,&
& 9.999688e-01 ,9.999674e-01 ,9.999660e-01 ,9.999646e-01 ,9.999631e-01 ,&
& 9.999617e-01 ,9.999603e-01 ,9.999589e-01 ,9.999574e-01 ,9.999560e-01 ,&
& 9.999546e-01 ,9.999532e-01 ,9.999517e-01 ,9.999503e-01 ,9.999489e-01 ,&
& 9.999474e-01 ,9.999460e-01 ,9.999446e-01 ,9.999431e-01 ,9.999417e-01 ,&
& 9.999403e-01 ,9.999388e-01 ,9.999374e-01 ,9.999359e-01 ,9.999345e-01 ,&
& 9.999330e-01 /)
ssaice3(:, 29) = (/ &
! band 29
& 4.526500e-01 ,5.287890e-01 ,5.410487e-01 ,5.459865e-01 ,5.485149e-01 ,&
& 5.498914e-01 ,5.505895e-01 ,5.508310e-01 ,5.507364e-01 ,5.503793e-01 ,&
& 5.498090e-01 ,5.490612e-01 ,5.481637e-01 ,5.471395e-01 ,5.460083e-01 ,&
& 5.447878e-01 ,5.434946e-01 ,5.421442e-01 ,5.407514e-01 ,5.393309e-01 ,&
& 5.378970e-01 ,5.364641e-01 ,5.350464e-01 ,5.336582e-01 ,5.323140e-01 ,&
& 5.310283e-01 ,5.298158e-01 ,5.286914e-01 ,5.276704e-01 ,5.267680e-01 ,&
& 5.260000e-01 ,5.253823e-01 ,5.249311e-01 ,5.246629e-01 ,5.245946e-01 ,&
& 5.247434e-01 ,5.251268e-01 ,5.257626e-01 ,5.266693e-01 ,5.278653e-01 ,&
& 5.293698e-01 ,5.312022e-01 ,5.333823e-01 ,5.359305e-01 ,5.388676e-01 ,&
& 5.422146e-01 /)
! asymmetry factor: unitless
asyice3(:, 16) = (/ &
! band 16
& 8.340752e-01 ,8.435170e-01 ,8.517487e-01 ,8.592064e-01 ,8.660387e-01 ,&
& 8.723204e-01 ,8.780997e-01 ,8.834137e-01 ,8.882934e-01 ,8.927662e-01 ,&
& 8.968577e-01 ,9.005914e-01 ,9.039899e-01 ,9.070745e-01 ,9.098659e-01 ,&
& 9.123836e-01 ,9.146466e-01 ,9.166734e-01 ,9.184817e-01 ,9.200886e-01 ,&
& 9.215109e-01 ,9.227648e-01 ,9.238661e-01 ,9.248304e-01 ,9.256727e-01 ,&
& 9.264078e-01 ,9.270505e-01 ,9.276150e-01 ,9.281156e-01 ,9.285662e-01 ,&
& 9.289806e-01 ,9.293726e-01 ,9.297557e-01 ,9.301435e-01 ,9.305491e-01 ,&
& 9.309859e-01 ,9.314671e-01 ,9.320055e-01 ,9.326140e-01 ,9.333053e-01 ,&
& 9.340919e-01 ,9.349861e-01 ,9.360000e-01 ,9.371451e-01 ,9.384329e-01 ,&
& 9.398744e-01 /)
asyice3(:, 17) = (/ &
! band 17
& 8.728160e-01 ,8.777333e-01 ,8.823754e-01 ,8.867535e-01 ,8.908785e-01 ,&
& 8.947611e-01 ,8.984118e-01 ,9.018408e-01 ,9.050582e-01 ,9.080739e-01 ,&
& 9.108976e-01 ,9.135388e-01 ,9.160068e-01 ,9.183106e-01 ,9.204595e-01 ,&
& 9.224620e-01 ,9.243271e-01 ,9.260632e-01 ,9.276788e-01 ,9.291822e-01 ,&
& 9.305817e-01 ,9.318853e-01 ,9.331012e-01 ,9.342372e-01 ,9.353013e-01 ,&
& 9.363013e-01 ,9.372450e-01 ,9.381400e-01 ,9.389939e-01 ,9.398145e-01 ,&
& 9.406092e-01 ,9.413856e-01 ,9.421511e-01 ,9.429131e-01 ,9.436790e-01 ,&
& 9.444561e-01 ,9.452517e-01 ,9.460729e-01 ,9.469270e-01 ,9.478209e-01 ,&
& 9.487617e-01 ,9.497562e-01 ,9.508112e-01 ,9.519335e-01 ,9.531294e-01 ,&
& 9.544055e-01 /)
asyice3(:, 18) = (/ &
! band 18
& 7.897566e-01 ,7.948704e-01 ,7.998041e-01 ,8.045623e-01 ,8.091495e-01 ,&
& 8.135702e-01 ,8.178290e-01 ,8.219305e-01 ,8.258790e-01 ,8.296792e-01 ,&
& 8.333355e-01 ,8.368524e-01 ,8.402343e-01 ,8.434856e-01 ,8.466108e-01 ,&
& 8.496143e-01 ,8.525004e-01 ,8.552737e-01 ,8.579384e-01 ,8.604990e-01 ,&
& 8.629597e-01 ,8.653250e-01 ,8.675992e-01 ,8.697867e-01 ,8.718916e-01 ,&
& 8.739185e-01 ,8.758715e-01 ,8.777551e-01 ,8.795734e-01 ,8.813308e-01 ,&
& 8.830315e-01 ,8.846799e-01 ,8.862802e-01 ,8.878366e-01 ,8.893534e-01 ,&
& 8.908350e-01 ,8.922854e-01 ,8.937090e-01 ,8.951099e-01 ,8.964925e-01 ,&
& 8.978609e-01 ,8.992192e-01 ,9.005718e-01 ,9.019229e-01 ,9.032765e-01 ,&
& 9.046369e-01 /)
asyice3(:, 19) = (/ &
! band 19
& 7.812615e-01 ,7.887764e-01 ,7.959664e-01 ,8.028413e-01 ,8.094109e-01 ,&
& 8.156849e-01 ,8.216730e-01 ,8.273846e-01 ,8.328294e-01 ,8.380166e-01 ,&
& 8.429556e-01 ,8.476556e-01 ,8.521258e-01 ,8.563753e-01 ,8.604131e-01 ,&
& 8.642481e-01 ,8.678893e-01 ,8.713455e-01 ,8.746254e-01 ,8.777378e-01 ,&
& 8.806914e-01 ,8.834948e-01 ,8.861566e-01 ,8.886854e-01 ,8.910897e-01 ,&
& 8.933779e-01 ,8.955586e-01 ,8.976402e-01 ,8.996311e-01 ,9.015398e-01 ,&
& 9.033745e-01 ,9.051436e-01 ,9.068555e-01 ,9.085185e-01 ,9.101410e-01 ,&
& 9.117311e-01 ,9.132972e-01 ,9.148476e-01 ,9.163905e-01 ,9.179340e-01 ,&
& 9.194864e-01 ,9.210559e-01 ,9.226505e-01 ,9.242784e-01 ,9.259476e-01 ,&
& 9.276661e-01 /)
asyice3(:, 20) = (/ &
! band 20
& 7.640720e-01 ,7.691119e-01 ,7.739941e-01 ,7.787222e-01 ,7.832998e-01 ,&
& 7.877304e-01 ,7.920177e-01 ,7.961652e-01 ,8.001765e-01 ,8.040551e-01 ,&
& 8.078044e-01 ,8.114280e-01 ,8.149294e-01 ,8.183119e-01 ,8.215791e-01 ,&
& 8.247344e-01 ,8.277812e-01 ,8.307229e-01 ,8.335629e-01 ,8.363046e-01 ,&
& 8.389514e-01 ,8.415067e-01 ,8.439738e-01 ,8.463560e-01 ,8.486568e-01 ,&
& 8.508795e-01 ,8.530274e-01 ,8.551039e-01 ,8.571122e-01 ,8.590558e-01 ,&
& 8.609378e-01 ,8.627618e-01 ,8.645309e-01 ,8.662485e-01 ,8.679178e-01 ,&
& 8.695423e-01 ,8.711251e-01 ,8.726697e-01 ,8.741792e-01 ,8.756571e-01 ,&
& 8.771065e-01 ,8.785307e-01 ,8.799331e-01 ,8.813169e-01 ,8.826854e-01 ,&
& 8.840419e-01 /)
asyice3(:, 21) = (/ &
! band 21
& 7.602598e-01 ,7.651572e-01 ,7.699014e-01 ,7.744962e-01 ,7.789452e-01 ,&
& 7.832522e-01 ,7.874205e-01 ,7.914538e-01 ,7.953555e-01 ,7.991290e-01 ,&
& 8.027777e-01 ,8.063049e-01 ,8.097140e-01 ,8.130081e-01 ,8.161906e-01 ,&
& 8.192645e-01 ,8.222331e-01 ,8.250993e-01 ,8.278664e-01 ,8.305374e-01 ,&
& 8.331153e-01 ,8.356030e-01 ,8.380037e-01 ,8.403201e-01 ,8.425553e-01 ,&
& 8.447121e-01 ,8.467935e-01 ,8.488022e-01 ,8.507412e-01 ,8.526132e-01 ,&
& 8.544210e-01 ,8.561675e-01 ,8.578554e-01 ,8.594875e-01 ,8.610665e-01 ,&
& 8.625951e-01 ,8.640760e-01 ,8.655119e-01 ,8.669055e-01 ,8.682594e-01 ,&
& 8.695763e-01 ,8.708587e-01 ,8.721094e-01 ,8.733308e-01 ,8.745255e-01 ,&
& 8.756961e-01 /)
asyice3(:, 22) = (/ &
! band 22
& 7.568957e-01 ,7.606995e-01 ,7.644072e-01 ,7.680204e-01 ,7.715402e-01 ,&
& 7.749682e-01 ,7.783057e-01 ,7.815541e-01 ,7.847148e-01 ,7.877892e-01 ,&
& 7.907786e-01 ,7.936846e-01 ,7.965084e-01 ,7.992515e-01 ,8.019153e-01 ,&
& 8.045011e-01 ,8.070103e-01 ,8.094444e-01 ,8.118048e-01 ,8.140927e-01 ,&
& 8.163097e-01 ,8.184571e-01 ,8.205364e-01 ,8.225488e-01 ,8.244958e-01 ,&
& 8.263789e-01 ,8.281993e-01 ,8.299586e-01 ,8.316580e-01 ,8.332991e-01 ,&
& 8.348831e-01 ,8.364115e-01 ,8.378857e-01 ,8.393071e-01 ,8.406770e-01 ,&
& 8.419969e-01 ,8.432682e-01 ,8.444923e-01 ,8.456706e-01 ,8.468044e-01 ,&
& 8.478952e-01 ,8.489444e-01 ,8.499533e-01 ,8.509234e-01 ,8.518561e-01 ,&
& 8.527528e-01 /)
asyice3(:, 23) = (/ &
! band 23
& 7.575066e-01 ,7.606912e-01 ,7.638236e-01 ,7.669035e-01 ,7.699306e-01 ,&
& 7.729046e-01 ,7.758254e-01 ,7.786926e-01 ,7.815060e-01 ,7.842654e-01 ,&
& 7.869705e-01 ,7.896211e-01 ,7.922168e-01 ,7.947574e-01 ,7.972428e-01 ,&
& 7.996726e-01 ,8.020466e-01 ,8.043646e-01 ,8.066262e-01 ,8.088313e-01 ,&
& 8.109796e-01 ,8.130709e-01 ,8.151049e-01 ,8.170814e-01 ,8.190001e-01 ,&
& 8.208608e-01 ,8.226632e-01 ,8.244071e-01 ,8.260924e-01 ,8.277186e-01 ,&
& 8.292856e-01 ,8.307932e-01 ,8.322411e-01 ,8.336291e-01 ,8.349570e-01 ,&
& 8.362244e-01 ,8.374312e-01 ,8.385772e-01 ,8.396621e-01 ,8.406856e-01 ,&
& 8.416476e-01 ,8.425479e-01 ,8.433861e-01 ,8.441620e-01 ,8.448755e-01 ,&
& 8.455263e-01 /)
asyice3(:, 24) = (/ &
! band 24
& 7.568829e-01 ,7.597947e-01 ,7.626745e-01 ,7.655212e-01 ,7.683337e-01 ,&
& 7.711111e-01 ,7.738523e-01 ,7.765565e-01 ,7.792225e-01 ,7.818494e-01 ,&
& 7.844362e-01 ,7.869819e-01 ,7.894854e-01 ,7.919459e-01 ,7.943623e-01 ,&
& 7.967337e-01 ,7.990590e-01 ,8.013373e-01 ,8.035676e-01 ,8.057488e-01 ,&
& 8.078802e-01 ,8.099605e-01 ,8.119890e-01 ,8.139645e-01 ,8.158862e-01 ,&
& 8.177530e-01 ,8.195641e-01 ,8.213183e-01 ,8.230149e-01 ,8.246527e-01 ,&
& 8.262308e-01 ,8.277483e-01 ,8.292042e-01 ,8.305976e-01 ,8.319275e-01 ,&
& 8.331929e-01 ,8.343929e-01 ,8.355265e-01 ,8.365928e-01 ,8.375909e-01 ,&
& 8.385197e-01 ,8.393784e-01 ,8.401659e-01 ,8.408815e-01 ,8.415240e-01 ,&
& 8.420926e-01 /)
asyice3(:, 25) = (/ &
! band 25
& 7.548616e-01 ,7.575454e-01 ,7.602153e-01 ,7.628696e-01 ,7.655067e-01 ,&
& 7.681249e-01 ,7.707225e-01 ,7.732978e-01 ,7.758492e-01 ,7.783750e-01 ,&
& 7.808735e-01 ,7.833430e-01 ,7.857819e-01 ,7.881886e-01 ,7.905612e-01 ,&
& 7.928983e-01 ,7.951980e-01 ,7.974588e-01 ,7.996789e-01 ,8.018567e-01 ,&
& 8.039905e-01 ,8.060787e-01 ,8.081196e-01 ,8.101115e-01 ,8.120527e-01 ,&
& 8.139416e-01 ,8.157764e-01 ,8.175557e-01 ,8.192776e-01 ,8.209405e-01 ,&
& 8.225427e-01 ,8.240826e-01 ,8.255585e-01 ,8.269688e-01 ,8.283117e-01 ,&
& 8.295856e-01 ,8.307889e-01 ,8.319198e-01 ,8.329767e-01 ,8.339579e-01 ,&
& 8.348619e-01 ,8.356868e-01 ,8.364311e-01 ,8.370930e-01 ,8.376710e-01 ,&
& 8.381633e-01 /)
asyice3(:, 26) = (/ &
! band 26
& 7.491854e-01 ,7.518523e-01 ,7.545089e-01 ,7.571534e-01 ,7.597839e-01 ,&
& 7.623987e-01 ,7.649959e-01 ,7.675737e-01 ,7.701303e-01 ,7.726639e-01 ,&
& 7.751727e-01 ,7.776548e-01 ,7.801084e-01 ,7.825318e-01 ,7.849230e-01 ,&
& 7.872804e-01 ,7.896020e-01 ,7.918862e-01 ,7.941309e-01 ,7.963345e-01 ,&
& 7.984951e-01 ,8.006109e-01 ,8.026802e-01 ,8.047009e-01 ,8.066715e-01 ,&
& 8.085900e-01 ,8.104546e-01 ,8.122636e-01 ,8.140150e-01 ,8.157072e-01 ,&
& 8.173382e-01 ,8.189063e-01 ,8.204096e-01 ,8.218464e-01 ,8.232148e-01 ,&
& 8.245130e-01 ,8.257391e-01 ,8.268915e-01 ,8.279682e-01 ,8.289675e-01 ,&
& 8.298875e-01 ,8.307264e-01 ,8.314824e-01 ,8.321537e-01 ,8.327385e-01 ,&
& 8.332350e-01 /)
asyice3(:, 27) = (/ &
! band 27
& 7.397086e-01 ,7.424069e-01 ,7.450955e-01 ,7.477725e-01 ,7.504362e-01 ,&
& 7.530846e-01 ,7.557159e-01 ,7.583283e-01 ,7.609199e-01 ,7.634888e-01 ,&
& 7.660332e-01 ,7.685512e-01 ,7.710411e-01 ,7.735009e-01 ,7.759288e-01 ,&
& 7.783229e-01 ,7.806814e-01 ,7.830024e-01 ,7.852841e-01 ,7.875246e-01 ,&
& 7.897221e-01 ,7.918748e-01 ,7.939807e-01 ,7.960380e-01 ,7.980449e-01 ,&
& 7.999995e-01 ,8.019000e-01 ,8.037445e-01 ,8.055311e-01 ,8.072581e-01 ,&
& 8.089235e-01 ,8.105255e-01 ,8.120623e-01 ,8.135319e-01 ,8.149326e-01 ,&
& 8.162626e-01 ,8.175198e-01 ,8.187025e-01 ,8.198089e-01 ,8.208371e-01 ,&
& 8.217852e-01 ,8.226514e-01 ,8.234338e-01 ,8.241306e-01 ,8.247399e-01 ,&
& 8.252599e-01 /)
asyice3(:, 28) = (/ &
! band 28
& 7.224533e-01 ,7.251681e-01 ,7.278728e-01 ,7.305654e-01 ,7.332444e-01 ,&
& 7.359078e-01 ,7.385539e-01 ,7.411808e-01 ,7.437869e-01 ,7.463702e-01 ,&
& 7.489291e-01 ,7.514616e-01 ,7.539661e-01 ,7.564408e-01 ,7.588837e-01 ,&
& 7.612933e-01 ,7.636676e-01 ,7.660049e-01 ,7.683034e-01 ,7.705612e-01 ,&
& 7.727767e-01 ,7.749480e-01 ,7.770733e-01 ,7.791509e-01 ,7.811789e-01 ,&
& 7.831556e-01 ,7.850791e-01 ,7.869478e-01 ,7.887597e-01 ,7.905131e-01 ,&
& 7.922062e-01 ,7.938372e-01 ,7.954044e-01 ,7.969059e-01 ,7.983399e-01 ,&
& 7.997047e-01 ,8.009985e-01 ,8.022195e-01 ,8.033658e-01 ,8.044357e-01 ,&
& 8.054275e-01 ,8.063392e-01 ,8.071692e-01 ,8.079157e-01 ,8.085768e-01 ,&
& 8.091507e-01 /)
asyice3(:, 29) = (/ &
! band 29
& 8.850026e-01 ,9.005489e-01 ,9.069242e-01 ,9.121799e-01 ,9.168987e-01 ,&
& 9.212259e-01 ,9.252176e-01 ,9.289028e-01 ,9.323000e-01 ,9.354235e-01 ,&
& 9.382858e-01 ,9.408985e-01 ,9.432734e-01 ,9.454218e-01 ,9.473557e-01 ,&
& 9.490871e-01 ,9.506282e-01 ,9.519917e-01 ,9.531904e-01 ,9.542374e-01 ,&
& 9.551461e-01 ,9.559298e-01 ,9.566023e-01 ,9.571775e-01 ,9.576692e-01 ,&
& 9.580916e-01 ,9.584589e-01 ,9.587853e-01 ,9.590851e-01 ,9.593729e-01 ,&
& 9.596632e-01 ,9.599705e-01 ,9.603096e-01 ,9.606954e-01 ,9.611427e-01 ,&
& 9.616667e-01 ,9.622826e-01 ,9.630060e-01 ,9.638524e-01 ,9.648379e-01 ,&
& 9.659788e-01 ,9.672916e-01 ,9.687933e-01 ,9.705014e-01 ,9.724337e-01 ,&
& 9.746084e-01 /)
! fdelta: unitless
fdlice3(:, 16) = (/ &
! band 16
& 4.959277e-02 ,4.685292e-02 ,4.426104e-02 ,4.181231e-02 ,3.950191e-02 ,&
& 3.732500e-02 ,3.527675e-02 ,3.335235e-02 ,3.154697e-02 ,2.985578e-02 ,&
& 2.827395e-02 ,2.679666e-02 ,2.541909e-02 ,2.413640e-02 ,2.294378e-02 ,&
& 2.183639e-02 ,2.080940e-02 ,1.985801e-02 ,1.897736e-02 ,1.816265e-02 ,&
& 1.740905e-02 ,1.671172e-02 ,1.606585e-02 ,1.546661e-02 ,1.490917e-02 ,&
& 1.438870e-02 ,1.390038e-02 ,1.343939e-02 ,1.300089e-02 ,1.258006e-02 ,&
& 1.217208e-02 ,1.177212e-02 ,1.137536e-02 ,1.097696e-02 ,1.057210e-02 ,&
& 1.015596e-02 ,9.723704e-03 ,9.270516e-03 ,8.791565e-03 ,8.282026e-03 ,&
& 7.737072e-03 ,7.151879e-03 ,6.521619e-03 ,5.841467e-03 ,5.106597e-03 ,&
& 4.312183e-03 /)
fdlice3(:, 17) = (/ &
! band 17
& 5.071224e-02 ,5.000217e-02 ,4.933872e-02 ,4.871992e-02 ,4.814380e-02 ,&
& 4.760839e-02 ,4.711170e-02 ,4.665177e-02 ,4.622662e-02 ,4.583426e-02 ,&
& 4.547274e-02 ,4.514007e-02 ,4.483428e-02 ,4.455340e-02 ,4.429544e-02 ,&
& 4.405844e-02 ,4.384041e-02 ,4.363939e-02 ,4.345340e-02 ,4.328047e-02 ,&
& 4.311861e-02 ,4.296586e-02 ,4.282024e-02 ,4.267977e-02 ,4.254248e-02 ,&
& 4.240640e-02 ,4.226955e-02 ,4.212995e-02 ,4.198564e-02 ,4.183462e-02 ,&
& 4.167494e-02 ,4.150462e-02 ,4.132167e-02 ,4.112413e-02 ,4.091003e-02 ,&
& 4.067737e-02 ,4.042420e-02 ,4.014854e-02 ,3.984840e-02 ,3.952183e-02 ,&
& 3.916683e-02 ,3.878144e-02 ,3.836368e-02 ,3.791158e-02 ,3.742316e-02 ,&
& 3.689645e-02 /)
fdlice3(:, 18) = (/ &
! band 18
& 1.062938e-01 ,1.065234e-01 ,1.067822e-01 ,1.070682e-01 ,1.073793e-01 ,&
& 1.077137e-01 ,1.080693e-01 ,1.084442e-01 ,1.088364e-01 ,1.092439e-01 ,&
& 1.096647e-01 ,1.100970e-01 ,1.105387e-01 ,1.109878e-01 ,1.114423e-01 ,&
& 1.119004e-01 ,1.123599e-01 ,1.128190e-01 ,1.132757e-01 ,1.137279e-01 ,&
& 1.141738e-01 ,1.146113e-01 ,1.150385e-01 ,1.154534e-01 ,1.158540e-01 ,&
& 1.162383e-01 ,1.166045e-01 ,1.169504e-01 ,1.172741e-01 ,1.175738e-01 ,&
& 1.178472e-01 ,1.180926e-01 ,1.183080e-01 ,1.184913e-01 ,1.186405e-01 ,&
& 1.187538e-01 ,1.188291e-01 ,1.188645e-01 ,1.188580e-01 ,1.188076e-01 ,&
& 1.187113e-01 ,1.185672e-01 ,1.183733e-01 ,1.181277e-01 ,1.178282e-01 ,&
& 1.174731e-01 /)
fdlice3(:, 19) = (/ &
! band 19
& 1.076195e-01 ,1.065195e-01 ,1.054696e-01 ,1.044673e-01 ,1.035099e-01 ,&
& 1.025951e-01 ,1.017203e-01 ,1.008831e-01 ,1.000808e-01 ,9.931116e-02 ,&
& 9.857151e-02 ,9.785939e-02 ,9.717230e-02 ,9.650774e-02 ,9.586322e-02 ,&
& 9.523623e-02 ,9.462427e-02 ,9.402484e-02 ,9.343544e-02 ,9.285358e-02 ,&
& 9.227675e-02 ,9.170245e-02 ,9.112818e-02 ,9.055144e-02 ,8.996974e-02 ,&
& 8.938056e-02 ,8.878142e-02 ,8.816981e-02 ,8.754323e-02 ,8.689919e-02 ,&
& 8.623517e-02 ,8.554869e-02 ,8.483724e-02 ,8.409832e-02 ,8.332943e-02 ,&
& 8.252807e-02 ,8.169175e-02 ,8.081795e-02 ,7.990419e-02 ,7.894796e-02 ,&
& 7.794676e-02 ,7.689809e-02 ,7.579945e-02 ,7.464834e-02 ,7.344227e-02 ,&
& 7.217872e-02 /)
fdlice3(:, 20) = (/ &
! band 20
& 1.119014e-01 ,1.122706e-01 ,1.126690e-01 ,1.130947e-01 ,1.135456e-01 ,&
& 1.140199e-01 ,1.145154e-01 ,1.150302e-01 ,1.155623e-01 ,1.161096e-01 ,&
& 1.166703e-01 ,1.172422e-01 ,1.178233e-01 ,1.184118e-01 ,1.190055e-01 ,&
& 1.196025e-01 ,1.202008e-01 ,1.207983e-01 ,1.213931e-01 ,1.219832e-01 ,&
& 1.225665e-01 ,1.231411e-01 ,1.237050e-01 ,1.242561e-01 ,1.247926e-01 ,&
& 1.253122e-01 ,1.258132e-01 ,1.262934e-01 ,1.267509e-01 ,1.271836e-01 ,&
& 1.275896e-01 ,1.279669e-01 ,1.283134e-01 ,1.286272e-01 ,1.289063e-01 ,&
& 1.291486e-01 ,1.293522e-01 ,1.295150e-01 ,1.296351e-01 ,1.297104e-01 ,&
& 1.297390e-01 ,1.297189e-01 ,1.296480e-01 ,1.295244e-01 ,1.293460e-01 ,&
& 1.291109e-01 /)
fdlice3(:, 21) = (/ &
! band 21
& 1.133298e-01 ,1.136777e-01 ,1.140556e-01 ,1.144615e-01 ,1.148934e-01 ,&
& 1.153492e-01 ,1.158269e-01 ,1.163243e-01 ,1.168396e-01 ,1.173706e-01 ,&
& 1.179152e-01 ,1.184715e-01 ,1.190374e-01 ,1.196108e-01 ,1.201897e-01 ,&
& 1.207720e-01 ,1.213558e-01 ,1.219389e-01 ,1.225194e-01 ,1.230951e-01 ,&
& 1.236640e-01 ,1.242241e-01 ,1.247733e-01 ,1.253096e-01 ,1.258309e-01 ,&
& 1.263352e-01 ,1.268205e-01 ,1.272847e-01 ,1.277257e-01 ,1.281415e-01 ,&
& 1.285300e-01 ,1.288893e-01 ,1.292173e-01 ,1.295118e-01 ,1.297710e-01 ,&
& 1.299927e-01 ,1.301748e-01 ,1.303154e-01 ,1.304124e-01 ,1.304637e-01 ,&
& 1.304673e-01 ,1.304212e-01 ,1.303233e-01 ,1.301715e-01 ,1.299638e-01 ,&
& 1.296983e-01 /)
fdlice3(:, 22) = (/ &
! band 22
& 1.145360e-01 ,1.153256e-01 ,1.161453e-01 ,1.169929e-01 ,1.178666e-01 ,&
& 1.187641e-01 ,1.196835e-01 ,1.206227e-01 ,1.215796e-01 ,1.225522e-01 ,&
& 1.235383e-01 ,1.245361e-01 ,1.255433e-01 ,1.265579e-01 ,1.275779e-01 ,&
& 1.286011e-01 ,1.296257e-01 ,1.306494e-01 ,1.316703e-01 ,1.326862e-01 ,&
& 1.336951e-01 ,1.346950e-01 ,1.356838e-01 ,1.366594e-01 ,1.376198e-01 ,&
& 1.385629e-01 ,1.394866e-01 ,1.403889e-01 ,1.412678e-01 ,1.421212e-01 ,&
& 1.429469e-01 ,1.437430e-01 ,1.445074e-01 ,1.452381e-01 ,1.459329e-01 ,&
& 1.465899e-01 ,1.472069e-01 ,1.477819e-01 ,1.483128e-01 ,1.487976e-01 ,&
& 1.492343e-01 ,1.496207e-01 ,1.499548e-01 ,1.502346e-01 ,1.504579e-01 ,&
& 1.506227e-01 /)
fdlice3(:, 23) = (/ &
! band 23
& 1.153263e-01 ,1.161445e-01 ,1.169932e-01 ,1.178703e-01 ,1.187738e-01 ,&
& 1.197016e-01 ,1.206516e-01 ,1.216217e-01 ,1.226099e-01 ,1.236141e-01 ,&
& 1.246322e-01 ,1.256621e-01 ,1.267017e-01 ,1.277491e-01 ,1.288020e-01 ,&
& 1.298584e-01 ,1.309163e-01 ,1.319736e-01 ,1.330281e-01 ,1.340778e-01 ,&
& 1.351207e-01 ,1.361546e-01 ,1.371775e-01 ,1.381873e-01 ,1.391820e-01 ,&
& 1.401593e-01 ,1.411174e-01 ,1.420540e-01 ,1.429671e-01 ,1.438547e-01 ,&
& 1.447146e-01 ,1.455449e-01 ,1.463433e-01 ,1.471078e-01 ,1.478364e-01 ,&
& 1.485270e-01 ,1.491774e-01 ,1.497857e-01 ,1.503497e-01 ,1.508674e-01 ,&
& 1.513367e-01 ,1.517554e-01 ,1.521216e-01 ,1.524332e-01 ,1.526880e-01 ,&
& 1.528840e-01 /)
fdlice3(:, 24) = (/ &
! band 24
& 1.160842e-01 ,1.169118e-01 ,1.177697e-01 ,1.186556e-01 ,1.195676e-01 ,&
& 1.205036e-01 ,1.214616e-01 ,1.224394e-01 ,1.234349e-01 ,1.244463e-01 ,&
& 1.254712e-01 ,1.265078e-01 ,1.275539e-01 ,1.286075e-01 ,1.296664e-01 ,&
& 1.307287e-01 ,1.317923e-01 ,1.328550e-01 ,1.339149e-01 ,1.349699e-01 ,&
& 1.360179e-01 ,1.370567e-01 ,1.380845e-01 ,1.390991e-01 ,1.400984e-01 ,&
& 1.410803e-01 ,1.420429e-01 ,1.429840e-01 ,1.439016e-01 ,1.447936e-01 ,&
& 1.456579e-01 ,1.464925e-01 ,1.472953e-01 ,1.480642e-01 ,1.487972e-01 ,&
& 1.494923e-01 ,1.501472e-01 ,1.507601e-01 ,1.513287e-01 ,1.518511e-01 ,&
& 1.523252e-01 ,1.527489e-01 ,1.531201e-01 ,1.534368e-01 ,1.536969e-01 ,&
& 1.538984e-01 /)
fdlice3(:, 25) = (/ &
! band 25
& 1.168725e-01 ,1.177088e-01 ,1.185747e-01 ,1.194680e-01 ,1.203867e-01 ,&
& 1.213288e-01 ,1.222923e-01 ,1.232750e-01 ,1.242750e-01 ,1.252903e-01 ,&
& 1.263187e-01 ,1.273583e-01 ,1.284069e-01 ,1.294626e-01 ,1.305233e-01 ,&
& 1.315870e-01 ,1.326517e-01 ,1.337152e-01 ,1.347756e-01 ,1.358308e-01 ,&
& 1.368788e-01 ,1.379175e-01 ,1.389449e-01 ,1.399590e-01 ,1.409577e-01 ,&
& 1.419389e-01 ,1.429007e-01 ,1.438410e-01 ,1.447577e-01 ,1.456488e-01 ,&
& 1.465123e-01 ,1.473461e-01 ,1.481483e-01 ,1.489166e-01 ,1.496492e-01 ,&
& 1.503439e-01 ,1.509988e-01 ,1.516118e-01 ,1.521808e-01 ,1.527038e-01 ,&
& 1.531788e-01 ,1.536037e-01 ,1.539764e-01 ,1.542951e-01 ,1.545575e-01 ,&
& 1.547617e-01 /)
fdlice3(:, 26) = (/ &
!band 26
& 1.180509e-01 ,1.189025e-01 ,1.197820e-01 ,1.206875e-01 ,1.216171e-01 ,&
& 1.225687e-01 ,1.235404e-01 ,1.245303e-01 ,1.255363e-01 ,1.265564e-01 ,&
& 1.275888e-01 ,1.286313e-01 ,1.296821e-01 ,1.307392e-01 ,1.318006e-01 ,&
& 1.328643e-01 ,1.339284e-01 ,1.349908e-01 ,1.360497e-01 ,1.371029e-01 ,&
& 1.381486e-01 ,1.391848e-01 ,1.402095e-01 ,1.412208e-01 ,1.422165e-01 ,&
& 1.431949e-01 ,1.441539e-01 ,1.450915e-01 ,1.460058e-01 ,1.468947e-01 ,&
& 1.477564e-01 ,1.485888e-01 ,1.493900e-01 ,1.501580e-01 ,1.508907e-01 ,&
& 1.515864e-01 ,1.522428e-01 ,1.528582e-01 ,1.534305e-01 ,1.539578e-01 ,&
& 1.544380e-01 ,1.548692e-01 ,1.552494e-01 ,1.555767e-01 ,1.558490e-01 ,&
& 1.560645e-01 /)
fdlice3(:, 27) = (/ &
! band 27
& 1.200480e-01 ,1.209267e-01 ,1.218304e-01 ,1.227575e-01 ,1.237059e-01 ,&
& 1.246739e-01 ,1.256595e-01 ,1.266610e-01 ,1.276765e-01 ,1.287041e-01 ,&
& 1.297420e-01 ,1.307883e-01 ,1.318412e-01 ,1.328988e-01 ,1.339593e-01 ,&
& 1.350207e-01 ,1.360813e-01 ,1.371393e-01 ,1.381926e-01 ,1.392396e-01 ,&
& 1.402783e-01 ,1.413069e-01 ,1.423235e-01 ,1.433263e-01 ,1.443134e-01 ,&
& 1.452830e-01 ,1.462332e-01 ,1.471622e-01 ,1.480681e-01 ,1.489490e-01 ,&
& 1.498032e-01 ,1.506286e-01 ,1.514236e-01 ,1.521863e-01 ,1.529147e-01 ,&
& 1.536070e-01 ,1.542614e-01 ,1.548761e-01 ,1.554491e-01 ,1.559787e-01 ,&
& 1.564629e-01 ,1.568999e-01 ,1.572879e-01 ,1.576249e-01 ,1.579093e-01 ,&
& 1.581390e-01 /)
fdlice3(:, 28) = (/ &
! band 28
& 1.247813e-01 ,1.256496e-01 ,1.265417e-01 ,1.274560e-01 ,1.283905e-01 ,&
& 1.293436e-01 ,1.303135e-01 ,1.312983e-01 ,1.322964e-01 ,1.333060e-01 ,&
& 1.343252e-01 ,1.353523e-01 ,1.363855e-01 ,1.374231e-01 ,1.384632e-01 ,&
& 1.395042e-01 ,1.405441e-01 ,1.415813e-01 ,1.426140e-01 ,1.436404e-01 ,&
& 1.446587e-01 ,1.456672e-01 ,1.466640e-01 ,1.476475e-01 ,1.486157e-01 ,&
& 1.495671e-01 ,1.504997e-01 ,1.514117e-01 ,1.523016e-01 ,1.531673e-01 ,&
& 1.540073e-01 ,1.548197e-01 ,1.556026e-01 ,1.563545e-01 ,1.570734e-01 ,&
& 1.577576e-01 ,1.584054e-01 ,1.590149e-01 ,1.595843e-01 ,1.601120e-01 ,&
& 1.605962e-01 ,1.610349e-01 ,1.614266e-01 ,1.617693e-01 ,1.620614e-01 ,&
& 1.623011e-01 /)
fdlice3(:, 29) = (/ &
! band 29
& 1.006055e-01 ,9.549582e-02 ,9.063960e-02 ,8.602900e-02 ,8.165612e-02 ,&
& 7.751308e-02 ,7.359199e-02 ,6.988496e-02 ,6.638412e-02 ,6.308156e-02 ,&
& 5.996942e-02 ,5.703979e-02 ,5.428481e-02 ,5.169657e-02 ,4.926719e-02 ,&
& 4.698880e-02 ,4.485349e-02 ,4.285339e-02 ,4.098061e-02 ,3.922727e-02 ,&
& 3.758547e-02 ,3.604733e-02 ,3.460497e-02 ,3.325051e-02 ,3.197604e-02 ,&
& 3.077369e-02 ,2.963558e-02 ,2.855381e-02 ,2.752050e-02 ,2.652776e-02 ,&
& 2.556772e-02 ,2.463247e-02 ,2.371415e-02 ,2.280485e-02 ,2.189670e-02 ,&
& 2.098180e-02 ,2.005228e-02 ,1.910024e-02 ,1.811781e-02 ,1.709709e-02 ,&
& 1.603020e-02 ,1.490925e-02 ,1.372635e-02 ,1.247363e-02 ,1.114319e-02 ,&
& 9.727157e-03 /)
end subroutine swcldpr
end module rrtmg_sw_init_f
module rrtmg_sw_spcvmc_f 1,5
! ------- Modules -------
use parrrsw_f, only : nbndsw, ngptsw, mxmol, jpband, mxlay
use rrsw_tbl_f, only : tblint, bpade, od_lo, exp_tbl
use rrsw_vsn_f, only : hvrspc, hnamspc
use rrsw_wvn_f, only : ngc, ngs, ngb
use rrtmg_sw_taumol_f, only: taumol_sw
implicit none
contains
! ---------------------------------------------------------------------------
subroutine spcvmc_sw & 2,10
(cc,tncol, ncol, nlayers, istart, iend, icpr, idelm, iout, &
pavel, tavel, pz, tz, tbound, palbd, palbp, &
pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
ptaua, pasya, pomga, prmu0, coldry, adjflux, &
laytrop, layswtch, laylow, jp, jt, jt1, &
co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir, &
zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt, &
ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen)
! ---------------------------------------------------------------------------
!
! Purpose: Contains spectral loop to compute the shortwave radiative fluxes,
! using the two-stream method of H. Barker and McICA, the Monte-Carlo
! Independent Column Approximation, for the representation of
! sub-grid cloud variability (i.e. cloud overlap).
!
! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
!
! Method:
! Adapted from two-stream model of H. Barker;
! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
!
! Modifications:
!
! Original: H. Barker
! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003
! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003
! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003
! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004
! Revision: Code modified so that delta scaling is not done in cloudy profiles
! if routine cldprop is used; delta scaling can be applied by swithcing
! code below if cldprop is not used to get cloud properties.
! AER, Jan 2005
! Revision: Modified to use McICA: MJIacono, AER, Nov 2005
! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006
! Revision: Use exponential lookup table for transmittance: MJIacono, AER,
! Aug 2007
!
! ------------------------------------------------------------------
! ------- Declarations ------
! ------- Input -------
integer , intent(in) :: tncol, ncol,cc
integer , intent(in) :: nlayers
integer , intent(in) :: istart
integer , intent(in) :: iend
integer , intent(in) :: icpr
integer , intent(in) :: idelm ! delta-m scaling flag
! [0 = direct and diffuse fluxes are unscaled]
! [1 = direct and diffuse fluxes are scaled]
integer , intent(in) :: iout
integer , intent(in) :: laytrop(:)
integer , intent(in) :: layswtch(:)
integer , intent(in) :: laylow(:)
integer , intent(in) :: indfor(:,:)
integer , intent(in) :: indself(:,:)
integer , intent(in) :: jp(:,:)
integer , intent(in) :: jt(:,:)
integer , intent(in) :: jt1(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: pavel(:,:) ! layer pressure (hPa, mb)
! Dimensions: (ncol,nlayers)
real , intent(in) :: tavel(:,:) ! layer temperature (K)
! Dimensions: (ncol,nlayers)
real , intent(in) :: pz(:,0:) ! level (interface) pressure (hPa, mb)
! Dimensions: (ncol,0:nlayers)
real , intent(in) :: tz(:,0:) ! level temperatures (hPa, mb)
! Dimensions: (ncol,0:nlayers)
real , intent(in) :: tbound(:) ! surface temperature (K)
! Dimensions: (ncol)
real , intent(in) :: coldry(:,:) ! dry air column density (mol/cm2)
! Dimensions: (ncol,nlayers)
real , intent(in) :: colmol(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: adjflux(:) ! Earth/Sun distance adjustment
! Dimensions: (jpband)
real , intent(in) :: palbd(:,:) ! surface albedo (diffuse)
! Dimensions: (ncol,nbndsw)
real , intent(in) :: palbp(:,:) ! surface albedo (direct)
! Dimensions: (ncol,nbndsw)
real , intent(in) :: prmu0(:) ! cosine of solar zenith angle
! Dimensions: (ncol)
real , intent(in) :: pcldfmc(:,:,:) ! cloud fraction [mcica]
real , intent(in) :: ptaucmc(:,:,:) ! cloud optical depth [mcica]
real , intent(in) :: pasycmc(:,:,:) ! cloud asymmetry parameter [mcica]
real , intent(in) :: pomgcmc(:,:,:) ! cloud single scattering albedo [mcica]
real , intent(in) :: ptaormc(:,:,:) ! cloud optical depth, non-delta scaled [mcica]
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(in) :: ptaua(:,:,:) ! aerosol optical depth
real , intent(in) :: pasya(:,:,:) ! aerosol asymmetry parameter
real , intent(in) :: pomga(:,:,:) ! aerosol single scattering albedo
! Dimensions: (ncol,nlayers,nbndsw)
real , intent(in) :: colh2o(:,:)
real , intent(in) :: colco2(:,:)
real , intent(in) :: colch4(:,:)
real , intent(in) :: co2mult(:,:)
real , intent(in) :: colo3(:,:)
real , intent(in) :: colo2(:,:)
real , intent(in) :: coln2o(:,:)
! Dimensions: (ncol,nlayers)
real , intent(in) :: forfac(:,:)
real , intent(in) :: forfrac(:,:)
real , intent(in) :: selffac(:,:)
real , intent(in) :: selffrac(:,:)
real , intent(in) :: fac00(:,:)
real , intent(in) :: fac01(:,:)
real , intent(in) :: fac10(:,:)
real , intent(in) :: fac11(:,:)
! Dimensions: (ncol,nlayers)
real, intent(inout) gpu_device :: zgco(tncol,ngptsw,nlayers+1), zomco(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: zrdnd(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: zref(tncol,ngptsw,nlayers+1) , zrefo(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: zrefd(tncol,ngptsw,nlayers+1) , zrefdo(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: ztauo(tncol,ngptsw,nlayers)
real, intent(inout) gpu_device :: zdbt(tncol,ngptsw,nlayers+1) ,ztdbt(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: ztra(tncol,ngptsw,nlayers+1) , ztrao(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: ztrad(tncol,ngptsw,nlayers+1) , ztrado(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: zfd(tncol,ngptsw,nlayers+1) , zfu(tncol,ngptsw,nlayers+1)
real gpu_device :: zcd(tncol,ngptsw,nlayers+1) , zcu(tncol,ngptsw,nlayers+1)
real, intent(inout) gpu_device :: ztaur(tncol,nlayers,ngptsw), ztaug(tncol,nlayers,ngptsw)
real, intent(inout) gpu_device :: zsflxzen(tncol,ngptsw)
! ------- Output -------
! All Dimensions: (ncol,nlayers+1)
real , intent(out) :: pbbcd(:,:)
real , intent(out) :: pbbcu(:,:)
real , intent(out) :: pbbfd(:,:)
real , intent(out) :: pbbfu(:,:)
real , intent(out) :: pbbfddir(:,:)
real , intent(out) :: pbbcddir(:,:)
real , intent(out) :: puvcd(:,:)
real , intent(out) :: puvfd(:,:)
real , intent(out) :: puvcddir(:,:)
real , intent(out) :: puvfddir(:,:)
real , intent(out) :: pnicd(:,:)
real , intent(out) :: pnifd(:,:)
real , intent(out) :: pnicddir(:,:)
real , intent(out) :: pnifddir(:,:)
! ------- Local -------
integer :: klev
integer :: ibm, ikl, ikp, ikx
integer :: iw, jb, jg, jl, jk
integer :: itind
real :: tblind, ze1
real :: zclear, zcloud
real :: zincflx, ze2
real :: zdbtmc, zdbtmo, zf, zgw, zreflect
real :: zwf, tauorig, repclc
real :: zdbt_nodel(tncol,ngptsw,nlayers+1)
real :: zdbtc_nodel(tncol,ngptsw,nlayers+1)
real :: ztdbt_nodel(tncol,ngptsw,nlayers+1)
real :: ztdbtc_nodel(tncol,ngptsw,nlayers+1)
! Arrays from rrtmg_sw_vrtqdr routine
integer :: iplon
! ------------------------------------------------------------------
!$acc update host(pomga, ptaua)
!print *, "aerosol values"
!print *, pomga(1, :, :)
!print *, ptaua(1, :, :)
!$acc kernels
pbbcd =0.
pbbcu =0.
pbbfd =0.
pbbfu =0.
pbbcddir =0.
pbbfddir =0.
puvcd =0.
puvfd =0.
puvcddir =0.
puvfddir =0.
pnicd =0.
pnifd =0.
pnicddir =0.
pnifddir =0.
zsflxzen = 0.
! znirr=0.
! znirf=0.
! zparr=0.
! zparf=0.
! zuvrr=0.
! zuvrf=0.
klev = nlayers
!$acc end kernels
#ifndef _ACCEL
# define ncol CHNK
#endif
! Calculate the optical depths for gaseous absorption and Rayleigh scattering
call taumol_sw(ncol,nlayers, &
colh2o , colco2 , colch4 , colo2 , &
colo3 , colmol , &
laytrop , jp , jt , jt1 , &
fac00 , fac01 , fac10 , fac11 , &
selffac , selffrac , indself , forfac , forfrac ,&
indfor , &
zsflxzen , ztaug, ztaur)
repclc = 1.e-12
#ifdef _ACCEL
# define ILOOP_S_CPU
# define ILOOP_E_CPU
# define ILOOP_S_GPU do iplon = 1, ncol
# define ILOOP_E_GPU enddo
# define WLOOP_S_CPU
# define WLOOP_E_CPU
# define WLOOP_S_GPU do iw = 1, 112
# define WLOOP_E_GPU enddo
#else
# define ILOOP_S_GPU
# define ILOOP_E_GPU
# define ILOOP_S_CPU do iplon = 1, ncol
# define ILOOP_E_CPU enddo
# define WLOOP_S_GPU
# define WLOOP_E_GPU
# define WLOOP_S_CPU do iw = 1, 112
# define WLOOP_E_CPU enddo
#endif
!$acc kernels
ILOOP_S_GPU
WLOOP_S_CPU
WLOOP_S_GPU
ILOOP_S_CPU
! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
jb = ngb(iw)
ibm = jb-15
! Clear-sky
! TOA direct beam
ztdbtc_nodel(iplon,iw,1)=1.0 !jm
! Cloudy-sky
! Surface values
ztrao(iplon,iw,klev+1) =0.0
ztrado(iplon,iw,klev+1) =0.0
zrefo(iplon,iw,klev+1) =palbp(iplon,ibm)
zrefdo(iplon,iw,klev+1) =palbd(iplon,ibm)
! Total sky
! TOA direct beam
ztdbt(iplon,iw,1) =1.0
ztdbt_nodel(iplon,iw,1)=1.0
! Surface values
zdbt(iplon,iw,klev+1) =0.0
ztra(iplon,iw,klev+1) =0.0
ztrad(iplon,iw,klev+1) =0.0
zref(iplon,iw,klev+1) =palbp(iplon,ibm)
zrefd(iplon,iw,klev+1) =palbd(iplon,ibm)
enddo
enddo
!$acc end kernels
!$acc kernels loop
ILOOP_S_GPU
!$acc loop private(zf, zwf, ibm, ikl, jb)
WLOOP_S_GPU
!$acc loop seq
do jk=1,klev
ikl=klev+1-jk
WLOOP_S_CPU
jb = ngb(iw)
ibm = jb-15
ILOOP_S_CPU
! Clear-sky optical parameters including aerosols
ztauo(iplon,iw,jk) = ztaur(iplon,ikl,iw) + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm)
#ifndef _ACCEL
! Use exponential lookup table for transmittance, or expansion of
! exponential for low tau
zclear = 1.0 - pcldfmc(iplon,ikl,iw)
zcloud = pcldfmc(iplon,ikl,iw)
ze1 = ztauo(iplon,iw,jk) / prmu0(iplon) ! ztauo corresponds to ztauc at this point in _sw.F version
if (ze1 .le. od_lo) then
zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
else
tblind = ze1 / (bpade + ze1)
itind = tblint * tblind + 0.5
zdbtmc = exp_tbl(itind)
endif
zdbtc_nodel(iplon,iw,jk) = zdbtmc
ztdbtc_nodel(iplon,iw,jk+1) = zdbtc_nodel(iplon,iw,jk) * ztdbtc_nodel(iplon,iw,jk)
tauorig = ztauo(iplon,iw,jk) + ptaormc(iplon,ikl,iw) ! ztauo corresponds to ztauc at this point in _sw.F version
ze1 = tauorig / prmu0(iplon)
if (ze1 .le. od_lo) then
zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1
else
tblind = ze1 / (bpade + ze1)
itind = tblint * tblind + 0.5
zdbtmo = exp_tbl(itind)
endif
zdbt_nodel(iplon,iw,jk) = zclear*zdbtmc + zcloud*zdbtmo
ztdbt_nodel(iplon,iw,jk+1) = zdbt_nodel(iplon,iw,jk) * ztdbt_nodel(iplon,iw,jk)
#endif
zomco(iplon,iw,jk) = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm)
zgco(iplon,iw,jk) = pasya(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) * ptaua(iplon,ikl,ibm) / zomco(iplon,iw,jk)
zomco(iplon,iw,jk) = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk)
zf = zgco(iplon, iw, jk)
zf = zf * zf
zwf = zomco(iplon, iw, jk) * zf
ztauo(iplon, iw, jk) = (1.0 - zwf) * ztauo(iplon, iw, jk)
zomco(iplon, iw, jk) = (zomco(iplon, iw, jk) - zwf) / (1.0 - zwf)
zgco(iplon, iw, jk) = (zgco(iplon, iw, jk) - zf) / (1.0 - zf)
end do
end do
end do
!$acc end kernels
! Clear sky reflectivities
call reftra_sw (ncol, nlayers, &
pcldfmc, zgco, prmu0, ztauo, zomco, &
zrefo, zrefdo, ztrao, ztrado, 1)
!$acc kernels loop
ILOOP_S_GPU
! Combine clear and cloudy reflectivies and optical depths
!$acc loop
WLOOP_S_GPU
!$acc loop seq
do jk=1,klev
WLOOP_S_CPU
ILOOP_S_CPU
! Combine clear and cloudy contributions for total sky
!ikl = klev+1-jk
! Direct beam transmittance
ze1 = (ztauo(iplon,iw,jk)) / prmu0(iplon)
#ifdef _ACCEL
zdbtmc = exp(-ze1)
#else
ze1 = ztauo(iplon,iw,jk) / prmu0(iplon)
if (ze1 .le. od_lo) then
zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
else
tblind = ze1 / (bpade + ze1)
itind = tblint * tblind + 0.5
zdbtmc = exp_tbl(itind)
endif
#endif
zdbt(iplon,iw,jk) = zdbtmc
ztdbt(iplon,iw,jk+1) = zdbt(iplon,iw,jk) *ztdbt(iplon,iw,jk)
end do
end do
end do
!$acc end kernels
! compute the fluxes from the optical depths and reflectivities
! Vertical quadrature for clear-sky fluxes
!$acc kernels
ILOOP_S_GPU
WLOOP_S_GPU
WLOOP_S_CPU
jb = ngb(iw)
ibm = jb-15
ILOOP_S_CPU
! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
zgco(iplon,iw,klev+1) =palbp(iplon,ibm)
zomco(iplon,iw,klev+1) =palbd(iplon,ibm)
end do
end do
!$acc end kernels
call vrtqdr_sw(ncol, klev, &
zrefo , zrefdo , ztrao , ztrado , &
zdbt , zrdnd , zgco, zomco, ztdbt , &
zcd , zcu , ztra)
! perform band integration for clear cases
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
do ikl=1,klev+1
!$acc loop seq
do iw = 1, 112
jb = ngb(iw)
jk=klev+2-ikl
ibm = jb-15
!DIR$ SIMD
ILOOP_S_CPU
zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon)
! Accumulate spectral fluxes over whole spectrum
pbbcu(iplon,ikl) = pbbcu(iplon,ikl) + zincflx*zcu(iplon,iw,jk)
pbbcd(iplon,ikl) = pbbcd(iplon,ikl) + zincflx*zcd(iplon,iw,jk)
pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk)
! Accumulate direct fluxes for UV/visible bands
if (ibm >= 10 .and. ibm <= 13) then
puvcd(iplon,ikl) = puvcd(iplon,ikl) + zincflx*zcd(iplon,iw,jk)
puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk)
! Accumulate direct fluxes for near-IR bands
else if (ibm == 14 .or. ibm <= 9) then
pnicd(iplon,ikl) = pnicd(iplon,ikl) + zincflx*zcd(iplon,iw,jk)
pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk)
endif
enddo
! End loop on jb, spectral band
enddo
! End of longitude loop
enddo
!$acc end kernels
if (cc==2) then
!$acc kernels
ILOOP_S_GPU
WLOOP_S_GPU
do jk=1,klev
ikl=klev+1-jk
WLOOP_S_CPU
jb = ngb(iw)
ibm = jb-15
!DIR$ SIMD
ILOOP_S_CPU
! since the cloudy cases are now computed in a separate partition from the clear cases, we must
! recompute the needed clear sky prerequisites.
ze1 = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon, ikl, ibm)
ze2 = pasya(iplon, ikl, ibm) * pomga(iplon, ikl, ibm) * ptaua(iplon, ikl, ibm) / ze1
ze1 = ze1/ (ztaur(iplon,ikl,iw) + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) )
! compute delta scaled coefficients
zf = ze2*ze2
zwf = ze1*zf
ze1 = (ze1 - zwf) / (1.0 - zwf)
ze2 = (ze2 - zf) / (1.0 - zf)
! direct calculation of delta scaled values
zomco(iplon,iw,jk) = (ztauo(iplon,iw,jk) * ze1 + ptaucmc(iplon,ikl,iw) * pomgcmc(iplon,ikl,iw))
zgco(iplon, iw, jk) = (ptaucmc(iplon,ikl,iw) * pomgcmc(iplon,ikl,iw) * pasycmc(iplon,ikl,iw) ) + &
(ztauo(iplon, iw, jk) * ze1 * ze2)
ztauo(iplon,iw,jk) = ztauo(iplon,iw,jk) + ptaucmc(iplon,ikl,iw)
zgco(iplon,iw,jk) = zgco(iplon, iw, jk) / zomco(iplon, iw, jk)
zomco(iplon,iw,jk) = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk)
end do
end do
end do
!$acc end kernels
! Total sky reflectivities
call reftra_sw (ncol, nlayers, &
pcldfmc, zgco, prmu0, ztauo, zomco, &
zref, zrefd, ztra, ztrad, 0)
klev = nlayers
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
WLOOP_S_GPU
!$acc loop seq
do jk=1,klev
! Combine clear and cloudy contributions for total sky
ikl = klev+1-jk
WLOOP_S_CPU
ILOOP_S_CPU
zclear = 1.0 - pcldfmc(iplon,ikl,iw)
zcloud = pcldfmc(iplon,ikl,iw)
zref(iplon,iw,jk) = zclear*zrefo(iplon,iw,jk) + zcloud*zref(iplon,iw,jk)
zrefd(iplon,iw,jk) = zclear*zrefdo(iplon,iw,jk) + zcloud*zrefd(iplon,iw,jk)
ztra(iplon,iw,jk) = zclear*ztrao(iplon,iw,jk) + zcloud*ztra(iplon,iw,jk)
ztrad(iplon,iw,jk) = zclear*ztrado(iplon,iw,jk) + zcloud*ztrad(iplon,iw,jk)
! Clear + Cloud
ze1 = ztauo(iplon,iw,jk ) / prmu0(iplon)
#ifdef _ACCEL
zdbtmo = exp(-ze1)
#else
if (ze1 .le. od_lo) then
zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1
else
tblind = ze1 / (bpade + ze1)
itind = tblint * tblind + 0.5
zdbtmo = exp_tbl(itind)
endif
#endif
ze1 = (ztauo(iplon,iw,jk) - ptaucmc(iplon,ikl,iw)) / prmu0(iplon)
#ifdef _ACCEL
zdbtmc = exp(-ze1)
#else
if (ze1 .le. od_lo) then
zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1
else
tblind = ze1 / (bpade + ze1)
itind = tblint * tblind + 0.5
zdbtmc = exp_tbl(itind)
endif
#endif
zdbt(iplon,iw,jk) = zclear*zdbtmc + zcloud*zdbtmo
ztdbt(iplon,iw,jk+1) = zdbt(iplon,iw,jk) *ztdbt(iplon,iw,jk)
enddo
end do
end do
!$acc end kernels
!$acc kernels
zrdnd = 0.0
zgco = 0.0
zomco = 0.0
zfd = 0.0
zfu = 0.0
!$acc end kernels
!$acc kernels
ILOOP_S_GPU
WLOOP_S_GPU
! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
WLOOP_S_CPU
jb = ngb(iw)
ibm = jb-15
ILOOP_S_CPU
zgco(iplon,iw,klev+1) =palbp(iplon,ibm)
zomco(iplon,iw,klev+1) =palbd(iplon,ibm)
end do
end do
!$acc end kernels
! Vertical quadrature for cloudy fluxes
call vrtqdr_sw(ncol, klev, &
zref , zrefd , ztra , ztrad , &
zdbt , zrdnd , zgco, zomco , ztdbt , &
zfd , zfu , ztrao)
! Upwelling and downwelling fluxes at levels
! Two-stream calculations go from top to bottom;
! layer indexing is reversed to go bottom to top for output arrays
klev = nlayers
repclc = 1.e-12
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
do ikl=1,klev+1
!$acc loop seq
WLOOP_S_GPU
WLOOP_S_CPU
jb = ngb(iw)
jk=klev+2-ikl
ibm = jb-15
ILOOP_S_CPU
zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon)
! Accumulate spectral fluxes over whole spectrum
pbbfu(iplon,ikl) = pbbfu(iplon,ikl) + zincflx*zfu(iplon,iw,jk)
pbbfd(iplon,ikl) = pbbfd(iplon,ikl) + zincflx*zfd(iplon,iw,jk)
pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk)
! Accumulate direct fluxes for UV/visible bands
if (ibm >= 10 .and. ibm <= 13) then
puvfd(iplon,ikl) = puvfd(iplon,ikl) + zincflx*zfd(iplon,iw,jk)
puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk)
! Accumulate direct fluxes for near-IR bands
else if (ibm == 14 .or. ibm <= 9) then
pnifd(iplon,ikl) = pnifd(iplon,ikl) + zincflx*zfd(iplon,iw,jk)
pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk)
endif
enddo
! End loop on jb, spectral band
enddo
! End of longitude loop
enddo
!$acc end kernels
else ! cc = 1
!$acc kernels
pbbfd = pbbcd
pbbfu = pbbcu
puvfd = puvcd
puvfddir = puvcddir
pnifd = pnicd
pnifddir = pnicddir
!$acc end kernels
end if ! if cc=2, else, endif
!$acc kernels
ILOOP_S_GPU
WLOOP_S_GPU
WLOOP_S_CPU
jb = ngb(iw)
ibm = jb - 15
ILOOP_S_CPU
zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon)
end do
end do
!$acc end kernels
!!$acc end data
# undef ILOOP_S_GPU
# undef ILOOP_E_GPU
# undef ILOOP_S_CPU
# undef ILOOP_E_CPU
# undef WLOOP_S_GPU
# undef WLOOP_E_GPU
# undef WLOOP_S_CPU
# undef WLOOP_E_CPU
#ifndef _ACCEL
# undef ncol
#endif
! !!!!!!!!!!!!!!!!!!!!!
! END CLEAR !!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!
end subroutine spcvmc_sw
! --------------------------------------------------------------------
subroutine reftra_sw(ncol, nlayers, pcldfmc, pgg, prmuzl, ptau, pw, & 4
pref, prefd, ptra, ptrad, ac)
! --------------------------------------------------------------------
! Purpose: computes the reflectivity and transmissivity of a clear or
! cloudy layer using a choice of various approximations.
!
! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
!
! Description:
! explicit arguments :
! --------------------
! inputs
! ------
! lrtchk = .t. for all layers in clear profile
! lrtchk = .t. for cloudy layers in cloud profile
! = .f. for clear layers in cloud profile
! pgg = assymetry factor
! prmuz = cosine solar zenith angle
! ptau = optical thickness
! pw = single scattering albedo
!
! outputs
! -------
! pref : collimated beam reflectivity
! prefd : diffuse beam reflectivity
! ptra : collimated beam transmissivity
! ptrad : diffuse beam transmissivity
!
!
! Method:
! -------
! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
! kmodts = 1 eddington (joseph et al., 1976)
! = 2 pifm (zdunkowski et al., 1980)
! = 3 discrete ordinates (liou, 1973)
!
! ac = 1 -- clear
! ac = 0 -- total (clear and cloudy)
!
! Modifications:
! --------------
! Original: J-JMorcrette, ECMWF, Feb 2003
! Revised for F90 reformatting: MJIacono, AER, Jul 2006
! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
!
! ------------------------------------------------------------------
! ------- Declarations ------
! ------- Input -------
integer , intent(in) :: nlayers
integer , intent(in) :: ncol
real, intent(in) :: pcldfmc(:,:,:) ! Logical flag for reflectivity and
! and transmissivity calculation;
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(in) gpu_device :: pgg(:,:,:) ! asymmetry parameter
real , intent(in) gpu_device :: ptau(:,:,:) ! optical depth
real , intent(in) gpu_device :: pw(:,:,:) ! single scattering albedo
! Dimensions: (ncol,nlayers,ngptsw)
real , intent(in) :: prmuzl(:) ! cosine of solar zenith angle
! Dimensions: (ncol)
integer, intent(in) :: ac
! ------- Output -------
real , intent(out) gpu_device :: pref(:,:,:) ! direct beam reflectivity
real , intent(out) gpu_device :: prefd(:,:,:) ! diffuse beam reflectivity
real , intent(out) gpu_device :: ptra(:,:,:) ! direct beam transmissivity
real , intent(out) gpu_device :: ptrad(:,:,:) ! diffuse beam transmissivity
! Dimensions: (ncol,nlayers,ngptsw)
! ------- Local -------
integer :: jk, jl, kmodts
integer :: itind, iplon, iw
real :: tblind
real :: za, za1, za2
real :: zbeta, zdend, zdenr, zdent
real :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
real :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
real :: zr1, zr2, zr3, zr4, zr5
real :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
real :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
real :: zw, zwcrit, zwo, prmuz
real , parameter :: eps = 1.e-08
! ------------------------------------------------------------------
! Initialize
zsr3=sqrt(3. )
zwcrit=0.9999995
kmodts=2
!$acc kernels loop
do iplon=1,ncol
!$acc loop
do iw=1,112
!$acc loop private(zgamma1, zgamma2, zgamma3, zgamma4)
do jk=1, nlayers
prmuz = prmuzl(iplon)
if ((.not.(pcldfmc(iplon,nlayers+1-jk,iw)) > 1.e-12) .and. ac==0 ) then
pref(iplon,iw,jk) =0.
ptra(iplon,iw,jk) =1.
prefd(iplon,iw,jk) =0.
ptrad(iplon,iw,jk) =1.
else
zto1=ptau(iplon,iw,jk)
zw =pw(iplon,iw,jk)
zg =pgg(iplon,iw,jk)
! General two-stream expressions
zg3= 3. * zg
zgamma1= (8. - zw * (5. + zg3)) * 0.25
zgamma2= 3. *(zw * (1. - zg )) * 0.25
zgamma3= (2. - zg3 * prmuz ) * 0.25
zgamma4= 1. - zgamma3
! Recompute original s.s.a. to test for conservative solution
zwo= zw / (1. - (1. - zw) * (zg / (1. - zg))**2)
if (zwo >= zwcrit) then
! Conservative scattering
za = zgamma1 * prmuz
za1 = za - zgamma3
zgt = zgamma1 * zto1
! Homogeneous reflectance and transmittance,
! collimated beam
ze1 = min ( zto1 / prmuz , 500. )
ze2 = exp(-ze1)
pref(iplon,iw,jk) = (zgt - za1 * (1. - ze2)) / (1. + zgt)
ptra(iplon,iw,jk) = 1. - pref(iplon,iw,jk)
! isotropic incidence
prefd(iplon,iw,jk) = zgt / (1. + zgt)
ptrad(iplon,iw,jk) = 1. - prefd(iplon,iw,jk)
! This is applied for consistency between total (delta-scaled) and direct (unscaled)
! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup
! table returns a transmittance of 1.0.
if (ze2 .eq. 1.0 ) then
pref(iplon,iw,jk) = 0.0
ptra(iplon,iw,jk) = 1.0
prefd(iplon,iw,jk) = 0.0
ptrad(iplon,iw,jk) = 1.0
endif
else
! Non-conservative scattering
za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
zrk = sqrt ( zgamma1**2 - zgamma2**2)
zrp = zrk * prmuz
zrp1 = 1. + zrp
zrm1 = 1. - zrp
zrk2 = 2. * zrk
zrpp = 1. - zrp*zrp
zrkg = zrk + zgamma1
zr1 = zrm1 * (za2 + zrk * zgamma3)
zr2 = zrp1 * (za2 - zrk * zgamma3)
zr3 = zrk2 * (zgamma3 - za2 * prmuz )
zr4 = zrpp * zrkg
zr5 = zrpp * (zrk - zgamma1)
zt1 = zrp1 * (za1 + zrk * zgamma4)
zt2 = zrm1 * (za1 - zrk * zgamma4)
zt3 = zrk2 * (zgamma4 + za1 * prmuz )
zt4 = zr4
zt5 = zr5
! mji - reformulated code to avoid potential floating point exceptions
! zbeta = - zr5 / zr4
zbeta = (zgamma1 - zrk) / zrkg
!!
! Homogeneous reflectance and transmittance
ze1 = min ( zrk * zto1, 5. )
ze2 = min ( zto1 / prmuz , 5. )
! Use exponential lookup table for transmittance, or expansion of
! exponential for low tau
if (ze1 .le. od_lo) then
zem1 = 1. - ze1 + 0.5 * ze1 * ze1
zep1 = 1. / zem1
else
zem1 = exp(-ze1)
zep1 = 1. / zem1
endif
if (ze2 .le. od_lo) then
zem2 = 1. - ze2 + 0.5 * ze2 * ze2
zep2 = 1. / zem2
else
zem2 = exp(-ze2)
zep2 = 1. / zem2
endif
zdenr = zr4*zep1 + zr5*zem1
zdent = zt4*zep1 + zt5*zem1
if (zdenr .ge. -eps .and. zdenr .le. eps) then
pref(iplon,iw,jk) = eps
ptra(iplon,iw,jk) = zem2
else
pref(iplon,iw,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
ptra(iplon,iw,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
endif
! diffuse beam
zemm = zem1*zem1
zdend = 1. / ( (1. - zbeta*zemm ) * zrkg)
prefd(iplon,iw,jk) = zgamma2 * (1. - zemm) * zdend
ptrad(iplon,iw,jk) = zrk2*zem1*zdend
endif
endif
end do
end do
end do
!$acc end kernels
end subroutine reftra_sw
! --------------------------------------------------------------------------
subroutine vrtqdr_sw(ncol, klev, & 4
pref, prefd, ptra, ptrad, &
pdbt, prdnd, prup, prupd, ptdbt, &
pfd, pfu, ztdn)
! --------------------------------------------------------------------------
! Purpose: This routine performs the vertical quadrature integration
!
! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
!
! Modifications.
!
! Original: H. Barker
! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
!
!-----------------------------------------------------------------------
! ------- Declarations -------
! Input
integer , intent (in) :: klev ! number of model layers
integer , intent (in) :: ncol
#ifdef _ACCEL
real , intent(in) gpu_device :: pref(:,:,:) ! direct beam reflectivity
real , intent(in) gpu_device :: prefd(:,:,:) ! diffuse beam reflectivity
real , intent(in) gpu_device :: ptra(:,:,:) ! direct beam transmissivity
real , intent(in) gpu_device :: ptrad(:,:,:) ! diffuse beam transmissivity
real , intent(in) gpu_device :: pdbt(:,:,:)
real , intent(in) gpu_device :: ptdbt(:,:,:)
real , intent(out) gpu_device :: prdnd(:,:,:)
real , intent(inout) gpu_device :: prup(:,:,:)
real , intent(inout) gpu_device :: prupd(:,:,:)
real, intent(inout) gpu_device :: ztdn(:,:,:)
! Dimensions: (ncol,nlayers,ngptsw)
! Output
real , intent(out) gpu_device :: pfd(:,:,:) ! downwelling flux (W/m2)
! unadjusted for earth/sun distance or zenith angle
real , intent(inout) gpu_device :: pfu(:,:,:) ! upwelling flux (W/m2)
! unadjusted for earth/sun distance or zenith angle
! Dimensions: (ncol,nlayers,ngptsw)
#else
real , intent(in) :: pref(CHNK,112,klev+1) ! direct beam reflectivity
real , intent(in) :: prefd(CHNK,112,klev+1) ! diffuse beam reflectivity
real , intent(in) :: ptra(CHNK,112,klev+1) ! direct beam transmissivity
real , intent(in) :: ptrad(CHNK,112,klev+1) ! diffuse beam transmissivity
real , intent(in) :: pdbt(CHNK,112,klev+1)
real , intent(in) :: ptdbt(CHNK,112,klev+1)
real , intent(out) :: prdnd(CHNK,112,klev+1)
real , intent(inout) :: prup(CHNK,112,klev+1)
real , intent(inout) :: prupd(CHNK,112,klev+1)
real, intent(inout) :: ztdn(CHNK,112,klev+1)
! Dimensions: (ncol,nlayers,ngptsw)
! Output
real , intent(out) gpu_device :: pfd(CHNK,112,klev+1) ! downwelling flux (W/m2)
! unadjusted for earth/sun distance or zenith angle
real , intent(inout) gpu_device :: pfu(CHNK,112,klev+1) ! upwelling flux (W/m2)
! unadjusted for earth/sun distance or zenith angle
! Dimensions: (ncol,nlayers,ngptsw)
#endif
! Local
integer :: ikp, ikx, jk, iplon, iw
#ifdef _ACCEL
real :: zreflect, zreflectj
# define ILOOP_S_CPU
# define ILOOP_E_CPU
# define ILOOP_S_GPU do iplon = 1, ncol
# define ILOOP_E_GPU enddo
# define WLOOP_S_CPU
# define WLOOP_E_CPU
# define WLOOP_S_GPU do iw = 1, 112
# define WLOOP_E_GPU enddo
#else
! real, dimension(CHNK) :: zreflect, zreflectj
real :: zreflect, zreflectj
# define ncol CHNK
# define ILOOP_S_GPU
# define ILOOP_E_GPU
# define ILOOP_S_CPU do iplon = 1, ncol
# define ILOOP_E_CPU enddo
# define WLOOP_S_GPU
# define WLOOP_E_GPU
# define WLOOP_S_CPU do iw = 1, 112
# define WLOOP_E_CPU enddo
!# define zreflect ZREFLECT(iplon)
!# define zreflectj ZREFLECTJ(iplon)
#endif
! Definitions
!
! pref(jk) direct reflectance
! prefd(jk) diffuse reflectance
! ptra(jk) direct transmittance
! ptrad(jk) diffuse transmittance
!
! pdbt(jk) layer mean direct beam transmittance
! ptdbt(jk) total direct beam transmittance at levels
!
!-----------------------------------------------------------------------------
! Link lowest layer with surface
! this kernel has a lot of dependencies
! CHNK hardcode klev+1
! pref 8 112 52
! prefd 8 112 52
! ptra 8 112 52
! ptrad 8 112 52
! pdbt 8 112 52
! ptdbt 8 112 52
! prdnd 8 112 52
! prup 8 112 52
! prupd 8 112 52
! ztdn 8 112 52
! pfd 8 112 52
! pfu 8 112 52
!DIR$ ASSUME_ALIGNED pref:64,prefd:64,ptra:64,ptrad:64
!DIR$ ASSUME_ALIGNED pdbt:64,ptdbt:64,prdnd:64,prup:64,prupd:64,ztdn:64,pfd:64,pfu:64
#if 0
write(0,*)'pref ',shape( pref) ! direct beam reflectivity
write(0,*)'prefd ',shape( prefd) ! diffuse beam reflectivity
write(0,*)'ptra ',shape( ptra) ! direct beam transmissivity
write(0,*)'ptrad ',shape( ptrad) ! diffuse beam transmissivity
write(0,*)'pdbt ',shape( pdbt)
write(0,*)'ptdbt ',shape( ptdbt)
write(0,*)'prdnd ',shape( prdnd)
write(0,*)'prup ',shape( prup)
write(0,*)'prupd ',shape( prupd)
write(0,*)'ztdn ',shape( ztdn)
write(0,*)'pfd ',shape( pfd) ! downwelling flux (W/m2)
write(0,*)'pfu ',shape( pfu) ! upwelling flux (W/m2)
#endif
!$acc kernels loop
ILOOP_S_GPU
!$acc loop private(zreflect)
WLOOP_S_GPU
WLOOP_S_CPU
!DIR$ VECTOR ALIGNED
ILOOP_S_CPU
zreflect = 1. / (1. - prefd(iplon,iw,klev+1) * prefd(iplon,iw,klev) )
prup(iplon,iw,klev) = pref(iplon,iw,klev) + (ptrad(iplon,iw,klev) * &
((ptra(iplon,iw,klev) - pdbt(iplon,iw,klev) ) * prefd(iplon,iw,klev+1) + &
pdbt(iplon,iw,klev) * pref(iplon,iw,klev+1) )) * zreflect
prupd(iplon,iw,klev) = prefd(iplon,iw,klev) + ptrad(iplon,iw,klev) * ptrad(iplon,iw,klev) * &
prefd(iplon,iw,klev+1) * zreflect
ILOOP_E_CPU
WLOOP_E_GPU
WLOOP_E_CPU
ILOOP_E_GPU
!$acc end kernels
! Pass from bottom to top
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
WLOOP_S_GPU
!$acc loop seq
do jk = 1,klev-1
ikp = klev+1-jk
ikx = ikp-1
WLOOP_S_CPU
!DIR$ VECTOR ALIGNED
ILOOP_S_CPU
zreflectj = 1. / (1. -prupd(iplon,iw,ikp) * prefd(iplon,iw,ikx) )
prup(iplon,iw,ikx) = pref(iplon,iw,ikx) + (ptrad(iplon,iw,ikx) * &
((ptra(iplon,iw,ikx) - pdbt(iplon,iw,ikx) ) * prupd(iplon,iw,ikp) + &
pdbt(iplon,iw,ikx) * prup(iplon,iw,ikp) )) * zreflectj
prupd(iplon,iw,ikx) = prefd(iplon,iw,ikx) + ptrad(iplon,iw,ikx) * ptrad(iplon,iw,ikx) * &
prupd(iplon,iw,ikp) * zreflectj
ILOOP_E_CPU
WLOOP_E_CPU
end do
WLOOP_E_GPU
ILOOP_E_GPU
!$acc end kernels
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
WLOOP_S_GPU
WLOOP_S_CPU
! Upper boundary conditions
!DIR$ VECTOR ALIGNED
ILOOP_S_CPU
ztdn(iplon, iw, 1) = 1.
prdnd(iplon,iw,1) = 0.
ztdn(iplon, iw, 2) = ptra(iplon,iw,1)
prdnd(iplon,iw,2) = prefd(iplon,iw,1)
ILOOP_E_CPU
WLOOP_E_GPU
WLOOP_E_CPU
ILOOP_E_GPU
!$acc end kernels
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
WLOOP_S_GPU
! Pass from top to bottom
!$acc loop seq
do jk = 2,klev
ikp = jk+1
WLOOP_S_CPU
!DIR$ VECTOR ALIGNED
ILOOP_S_CPU
zreflect = 1. / (1. - prefd(iplon,iw,jk) * prdnd(iplon,iw,jk) )
ztdn(iplon, iw, ikp) = ptdbt(iplon,iw,jk) * ptra(iplon,iw,jk) + &
(ptrad(iplon,iw,jk) * ((ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) ) + &
ptdbt(iplon,iw,jk) * pref(iplon,iw,jk) * prdnd(iplon,iw,jk) )) * zreflect
prdnd(iplon,iw,ikp) = prefd(iplon,iw,jk) + ptrad(iplon,iw,jk) * ptrad(iplon,iw,jk) * &
prdnd(iplon,iw,jk) * zreflect
ILOOP_E_CPU
WLOOP_E_CPU
end do
WLOOP_E_GPU
ILOOP_E_GPU
!$acc end kernels
! Up and down-welling fluxes at levels
!$acc kernels loop
ILOOP_S_GPU
!$acc loop
WLOOP_S_GPU
!$acc loop
do jk = 1,klev+1
WLOOP_S_CPU
!DIR$ VECTOR ALIGNED
ILOOP_S_CPU
zreflect = 1. / (1. - prdnd(iplon,iw,jk) * prupd(iplon,iw,jk) )
pfu(iplon,iw,jk) = (ptdbt(iplon,iw,jk) * prup(iplon,iw,jk) + &
(ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) ) * prupd(iplon,iw,jk) ) * zreflect
pfd(iplon,iw,jk) = ptdbt(iplon,iw,jk) + (ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) + &
ptdbt(iplon,iw,jk) * prup(iplon,iw,jk) * prdnd(iplon,iw,jk) ) * zreflect
ILOOP_E_CPU
WLOOP_E_CPU
end do
WLOOP_E_GPU
ILOOP_E_GPU
!$acc end kernels
end subroutine vrtqdr_sw
end module rrtmg_sw_spcvmc_f
# undef ILOOP_S_GPU
# undef ILOOP_E_GPU
# undef ILOOP_S_CPU
# undef ILOOP_E_CPU
# undef WLOOP_S_GPU
# undef WLOOP_E_GPU
# undef WLOOP_S_CPU
# undef WLOOP_E_CPU
# undef zreflect
# undef zreflectj
# undef ncol
module rrtmg_sw_rad_f 1,5
!
! ****************************************************************************
! * *
! * RRTMG_SW *
! * *
! * *
! * *
! * a rapid radiative transfer model *
! * for the solar spectral region *
! * for application to general circulation models *
! * *
! * *
! * Atmospheric and Environmental Research, Inc. *
! * 131 Hartwell Avenue *
! * Lexington, MA 02421 *
! * *
! * *
! * Eli J. Mlawer *
! * Jennifer S. Delamere *
! * Michael J. Iacono *
! * Shepard A. Clough *
! * David M. Berthiaume *
! * *
! * *
! * *
! * *
! * *
! * email: miacono@aer.com *
! * email: emlawer@aer.com *
! * email: jdelamer@aer.com *
! * *
! * The authors wish to acknowledge the contributions of the *
! * following people: Steven J. Taubman, Patrick D. Brown, *
! * Ronald E. Farren, Luke Chen, Robert Bergstrom. *
! * *
! ****************************************************************************
! --------- Modules ---------
use rrsw_vsn_f
use mcica_subcol_gen_sw_f, only: mcica_sw
use rrtmg_sw_cldprmc_f, only: cldprmc_sw
use rrtmg_sw_setcoef_f, only: setcoef_sw
use rrtmg_sw_spcvmc_f, only: spcvmc_sw
implicit none
public :: rrtmg_sw, earth_sun
INTEGER, PARAMETER :: debug_level_swf=100
contains
subroutine rrtmg_sw & 2,22
(rpart ,ncol ,nlay ,icld ,iaer , &
play ,plev ,tlay ,tlev ,tsfc , &
h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
asdir ,asdif ,aldir ,aldif , &
coszen ,adjes ,dyofyr ,scon , &
inflgsw ,iceflgsw,liqflgsw,cld , &
tauc ,ssac ,asmc ,fsfc , &
ciwp ,clwp ,cswp ,rei ,rel ,res , &
tauaer ,ssaaer ,asmaer ,ecaer , &
swuflx ,swdflx ,swhr ,swuflxc ,swdflxc,swhrc , &
! --------- Add the following four compenants for ssib shortwave down radiation ---!
! ------------------- by Zhenxin 2011-06-20 --------------------------------!
sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
! ---------------------- End, Zhenxin 2011-06-20 --------------------------------!
swdkdir, swdkdif & ! jararias, 2013/08/10
)
use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
jpband, jpb1, jpb2, rrsw_scon
use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
use rrsw_con_f, only : heatfac, oneminus, pi, grav, avogad
use rrsw_wvn_f, only : wavenum1, wavenum2
use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
extice2, ssaice2, asyice2, &
extice3, ssaice3, asyice3, fdlice3, &
abari, bbari, cbari, dbari, ebari, fbari
use rrsw_wvn_f, only : wavenum2, ngb
use rrsw_ref_f, only : preflog, tref
#ifdef _ACCEL
use cudafor
#endif
! ------- Declarations
integer , intent(in) :: rpart ! The number of columns in each partition
integer , intent(in) :: ncol ! Number of horizontal columns
integer , intent(in) :: nlay ! Number of model layers
integer , intent(inout) :: icld ! Cloud overlap method
! 0: Clear only
! 1: Random
! 2: Maximum/random
! 3: Maximum
integer , intent(in) :: iaer ! Aerosol option flag
real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
! Dimensions: (ncol,nlay)
real , intent(in) :: plev(:,:) ! Interface pressures (hPa, mb)
! Dimensions: (ncol,nlay+1)
real , intent(in) :: tlay(:,:) ! Layer temperatures (K)
! Dimensions: (ncol,nlay)
real , intent(in) :: tlev(:,:) ! Interface temperatures (K)
! Dimensions: (ncol,nlay+1)
real , intent(in) :: tsfc(:) ! Surface temperature (K)
! Dimensions: (ncol)
real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: asdir(:) ! UV/vis surface albedo direct rad
! Dimensions: (ncol)
real , intent(in) :: aldir(:) ! Near-IR surface albedo direct rad
! Dimensions: (ncol)
real , intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad
! Dimensions: (ncol)
real , intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad
! Dimensions: (ncol)
integer , intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
! distance if adjflx not provided)
real , intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
real , intent(in) :: coszen(:) ! Cosine of solar zenith angle
! Dimensions: (ncol)
real , intent(in) :: scon ! Solar constant (W/m2)
integer , intent(in) :: inflgsw ! Flag for cloud optical properties
integer , intent(in) :: iceflgsw ! Flag for ice particle specification
integer , intent(in) :: liqflgsw ! Flag for liquid droplet specification
real , intent(in) :: cld(:,:) ! Cloud fraction
! Dimensions: (ncol,nlay)
real , intent(in) :: tauc(:,:,:) ! In-cloud optical depth
! Dimensions: (ncol,nlay,nbndlw)
real , intent(in) :: ssac(:,:,:) ! In-cloud single scattering albedo
! Dimensions: (ncol,nlay,nbndlw)
real , intent(in) :: asmc(:,:,:) ! In-cloud asymmetry parameter
! Dimensions: (ncol,nlay,nbndlw)
real , intent(in) :: fsfc(:,:,:) ! In-cloud forward scattering fraction
! Dimensions: (ncol,nlay,nbndlw)
real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2)
! Dimensions: (ncol, nlay)
real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2)
! Dimensions: (ncol, nlay)
real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2)
! Dimensions: (ncol, nlay)
real , intent(in) :: rei(:,:) ! Cloud ice effective radius (microns)
! Dimensions: (ncol, nlay)
! specific definition of rei depends on setting of iceflglw:
! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
! r_ec must be >= 10.0 microns
! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
! r_ec range is limited to 13.0 to 130.0 microns
! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
! r_k range is limited to 5.0 to 131.0 microns
! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
! dge range is limited to 5.0 to 140.0 microns
! [dge = 1.0315 * r_ec]
real , intent(in) :: rel(:,:) ! Cloud water drop effective radius (microns)
! Dimensions: (ncol,nlay)
real , intent(in) :: res(:,:) ! Cloud snow effective radius (microns)
! Dimensions: (ncol,nlay)
real , intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only)
! Dimensions: (ncol,nlay,naerec)
! (non-delta scaled)
! ----- Output -----
real , intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d)
! Dimensions: (ncol,nlay)
real , intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d)
! Dimensions: (ncol,nlay)
real, intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: swdkdir(:,:) ! Total shortwave downward direct flux (W/m2)
! Dimensions: (ncol,nlay+1) jararias, 2013/08/10
real, intent(out) :: swdkdif(:,:) ! Total shortwave downward diffuse flux (W/m2)
! Dimensions: (ncol,nlay+1) jararias, 2013/08/10
integer :: npart, pncol, ns
CHARACTER(LEN=256) :: message
! mji - time
real :: t1, t2
#ifdef _ACCEL
type(cudadeviceprop) :: prop
real :: gmem
integer :: err
integer :: munits
#endif
if (rpart > 0) then
pncol = rpart
else
#ifdef _ACCEL
err = cudaGetDeviceProperties( prop, 0)
gmem = prop%totalGlobalMem / (1024.0 * 1024.0)
! print *, "Total GPU global memory is ", gmem , "MB"
! dmb 2013
! Here
! The optimal partition size is determined by the following conditions
! 1. Powers of 2 are the most efficient.
! 2. The second to largest power of 2 that can fit on
! the GPU is most efficient.
! 3. Having a small remainder for the final partiion is inefficient.
if (gmem > 5000) then
pncol = 4096
else if (gmem > 3000) then
pncol = 2048
else if (gmem > 1000) then
pncol = 1024
else
pncol = 512
end if
! the smallest allowed partition size is 32
do err = 1, 6
if (pncol > ncol .and. pncol>32) then
pncol = pncol/2
end if
end do
! if we have a very large number of columns, account for the
! static ncol memory requirement
if (ncol>29000 .and. pncol>4000) then
pncol = pncol/2
end if
#else
pncol = 2
pncol = 4
!jm pncol = CHNK redundant, since this is passed in
#endif
end if
WRITE(message,*)'RRTMG_SWF: Number of columns is ',ncol
call wrf_debug( debug_level_swf, message)
WRITE(message,*)'RRTMG_SWF: Number of columns per partition is ',pncol
call wrf_debug( debug_level_swf, message)
ns = ceiling( real(ncol) / real(pncol) )
WRITE(message,*)'RRTMG_SWF: Number of partitions is ',ns
call wrf_debug( debug_level_swf, message)
call cpu_time(t1)
call rrtmg_sw_sub &
(pncol ,ncol ,nlay ,icld ,iaer , &
play ,plev ,tlay ,tlev ,tsfc , &
h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
asdir ,asdif ,aldir ,aldif , &
coszen ,adjes ,dyofyr ,scon , &
inflgsw ,iceflgsw,liqflgsw,cld , &
tauc ,ssac ,asmc ,fsfc , &
ciwp ,clwp ,cswp ,rei ,rel ,res , &
tauaer ,ssaaer ,asmaer ,ecaer , &
swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
swdkdir , swdkdif & ! jararias, 2013/08/10
)
call cpu_time(t2)
WRITE(message,*)'------------------------------------------------'
call wrf_debug( debug_level_swf, message)
WRITE(message,*)'TOTAL RRTMG_SWF RUN TIME IS ', t2-t1
call wrf_debug( debug_level_swf, message)
WRITE(message,*)'------------------------------------------------'
call wrf_debug( debug_level_swf, message)
end subroutine rrtmg_sw
subroutine rrtmg_sw_sub & 1,46
(ncol ,gncol ,nlay ,icld ,iaer , &
gplay ,gplev ,gtlay ,gtlev ,gtsfc , &
gh2ovmr ,go3vmr ,gco2vmr ,gch4vmr ,gn2ovmr ,go2vmr , &
gasdir ,gasdif ,galdir ,galdif , &
gcoszen ,adjes ,dyofyr ,scon , &
inflgsw ,iceflgsw,liqflgsw,gcld , &
gtauc ,gssac ,gasmc ,gfsfc , &
gciwp ,gclwp ,gcswp ,grei ,grel ,gres , &
gtauaer ,gssaaer ,gasmaer ,gecaer , &
swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
swdkdir , swdkdif & ! jararias, 2013/08/10
)
use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
jpband, jpb1, jpb2, rrsw_scon
use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya
use rrsw_con_f, only : heatfac, oneminus, pi, grav, avogad
use rrsw_wvn_f, only : wavenum1, wavenum2
use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, &
extice2, ssaice2, asyice2, &
extice3, ssaice3, asyice3, fdlice3, &
abari, bbari, cbari, dbari, ebari, fbari
use rrsw_wvn_f, only : wavenum2, ngb, icxa, nspa, nspb
use rrsw_ref_f, only : preflog, tref
use rrsw_kg16_f, kao16 => kao, kbo16 => kbo, selfrefo16 => selfrefo, forrefo16 => forrefo, sfluxrefo16 => sfluxrefo
use rrsw_kg16_f, ka16 => ka, kb16 => kb, selfref16 => selfref, forref16 => forref, sfluxref16 => sfluxref
use rrsw_kg17_f, kao17 => kao, kbo17 => kbo, selfrefo17 => selfrefo, forrefo17 => forrefo, sfluxrefo17 => sfluxrefo
use rrsw_kg17_f, ka17 => ka, kb17 => kb, selfref17 => selfref, forref17 => forref, sfluxref17 => sfluxref
use rrsw_kg18_f, kao18 => kao, kbo18 => kbo, selfrefo18 => selfrefo, forrefo18 => forrefo, sfluxrefo18 => sfluxrefo
use rrsw_kg18_f, ka18 => ka, kb18 => kb, selfref18 => selfref, forref18 => forref, sfluxref18 => sfluxref
use rrsw_kg19_f, kao19 => kao, kbo19 => kbo, selfrefo19 => selfrefo, forrefo19 => forrefo, sfluxrefo19 => sfluxrefo
use rrsw_kg19_f, ka19 => ka, kb19 => kb, selfref19 => selfref, forref19 => forref, sfluxref19 => sfluxref
use rrsw_kg20_f, kao20 => kao, kbo20 => kbo, selfrefo20 => selfrefo, forrefo20 => forrefo, &
sfluxrefo20 => sfluxrefo, absch4o20 => absch4o
use rrsw_kg20_f, ka20 => ka, kb20 => kb, selfref20 => selfref, forref20 => forref, &
sfluxref20 => sfluxref, absch420 => absch4
use rrsw_kg21_f, kao21 => kao, kbo21 => kbo, selfrefo21 => selfrefo, forrefo21 => forrefo, sfluxrefo21 => sfluxrefo
use rrsw_kg21_f, ka21 => ka, kb21 => kb, selfref21 => selfref, forref21 => forref, sfluxref21 => sfluxref
use rrsw_kg22_f, kao22 => kao, kbo22 => kbo, selfrefo22 => selfrefo, forrefo22 => forrefo, sfluxrefo22 => sfluxrefo
use rrsw_kg22_f, ka22 => ka, kb22 => kb, selfref22 => selfref, forref22 => forref, sfluxref22 => sfluxref
use rrsw_kg23_f, kao23 => kao, selfrefo23 => selfrefo, forrefo23 => forrefo, sfluxrefo23 => sfluxrefo, raylo23 => raylo
use rrsw_kg23_f, ka23 => ka, selfref23 => selfref, forref23 => forref, sfluxref23 => sfluxref, rayl23 => rayl
use rrsw_kg24_f, kao24 => kao, kbo24 => kbo, selfrefo24 => selfrefo, forrefo24 => forrefo, sfluxrefo24 => sfluxrefo
use rrsw_kg24_f, abso3ao24 => abso3ao, abso3bo24 => abso3bo, raylao24 => raylao, raylbo24 => raylbo
use rrsw_kg24_f, ka24 => ka, kb24 => kb, selfref24 => selfref, forref24 => forref, sfluxref24 => sfluxref
use rrsw_kg24_f, abso3a24 => abso3a, abso3b24 => abso3b, rayla24 => rayla, raylb24 => raylb
use rrsw_kg25_f, kao25 => kao, sfluxrefo25=>sfluxrefo
use rrsw_kg25_f, abso3ao25 => abso3ao, abso3bo25 => abso3bo, raylo25 => raylo
use rrsw_kg25_f, ka25 => ka, sfluxref25=>sfluxref
use rrsw_kg25_f, abso3a25 => abso3a, abso3b25 => abso3b, rayl25 => rayl
use rrsw_kg26_f, sfluxrefo26 => sfluxrefo
use rrsw_kg26_f, sfluxref26 => sfluxref
use rrsw_kg27_f, kao27 => kao, kbo27 => kbo, sfluxrefo27 => sfluxrefo, rayl27=>rayl
use rrsw_kg27_f, ka27 => ka, kb27 => kb, sfluxref27 => sfluxref, raylo27=>raylo
use rrsw_kg28_f, kao28 => kao, kbo28 => kbo, sfluxrefo28 => sfluxrefo
use rrsw_kg28_f, ka28 => ka, kb28 => kb, sfluxref28 => sfluxref
use rrsw_kg29_f, kao29 => kao, kbo29 => kbo, selfrefo29 => selfrefo, forrefo29 => forrefo, sfluxrefo29 => sfluxrefo
use rrsw_kg29_f, absh2oo29 => absh2oo, absco2o29 => absco2o
use rrsw_kg29_f, ka29 => ka, kb29 => kb, selfref29 => selfref, forref29 => forref, sfluxref29 => sfluxref
use rrsw_kg29_f, absh2o29 => absh2o, absco229 => absco2
! ------- Declarations
integer , intent(in) :: ncol
integer , intent(in) :: gncol ! Number of horizontal columns
integer , intent(in) :: nlay ! Number of model layers
integer , intent(inout) :: icld ! Cloud overlap method
! 0: Clear only
! 1: Random
! 2: Maximum/random
! 3: Maximum
integer , intent(in) :: iaer
integer , intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun
! distance if adjflx not provided)
real , intent(in) :: adjes ! Flux adjustment for Earth/Sun distance
real , intent(in) :: scon ! Solar constant (W/m2)
integer , intent(in) :: inflgsw ! Flag for cloud optical properties
integer , intent(in) :: iceflgsw ! Flag for ice particle specification
integer , intent(in) :: liqflgsw ! Flag for liquid droplet specification
real , intent(in) :: gcld(gncol, nlay) ! Cloud fraction
! Dimensions: (ncol,nlay)
real , intent(in) :: gtauc(gncol,nlay,nbndsw) ! In-cloud optical depth
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: gssac(gncol,nlay,nbndsw) ! In-cloud single scattering albedo
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: gasmc(gncol,nlay,nbndsw) ! In-cloud asymmetry parameter
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: gfsfc(gncol,nlay,nbndsw) ! In-cloud forward scattering fraction
! Dimensions: (ncol,nlay,nbndsw)
real , intent(in) :: gciwp(gncol, nlay) ! In-cloud ice water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: gclwp(gncol, nlay) ! In-cloud liquid water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: gcswp(gncol, nlay) ! In-cloud snow water path (g/m2)
! Dimensions: (ncol,nlay)
real , intent(in) :: grei(gncol, nlay) ! Cloud ice effective radius (microns)
! Dimensions: (ncol,nlay)
real , intent(in) :: grel(gncol, nlay) ! Cloud water drop effective radius (microns)
! Dimensions: (ncol,nlay)
real , intent(in) :: gres(gncol, nlay) ! Cloud snow drop effective radius (microns)
! Dimensions: (ncol,nlay)
real , intent(in) :: gplay(gncol,nlay) ! Layer pressures (hPa, mb)
! Dimensions: (ncol,nlay)
real , intent(in) :: gplev(gncol,nlay+1) ! Interface pressures (hPa, mb)
! Dimensions: (ncol,nlay+1)
real , intent(in) :: gtlay(gncol,nlay) ! Layer temperatures (K)
! Dimensions: (ncol,nlay)
real , intent(in) :: gtlev(gncol,nlay+1) ! Interface temperatures (K)
! Dimensions: (ncol,nlay+1)
real , intent(in) :: gtsfc(gncol) ! Surface temperature (K)
! Dimensions: (ncol)
real , intent(in) :: gh2ovmr(gncol,nlay) ! H2O volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: go3vmr(gncol,nlay) ! O3 volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: gco2vmr(gncol,nlay) ! CO2 volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: gch4vmr(gncol,nlay) ! Methane volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: gn2ovmr(gncol,nlay) ! Nitrous oxide volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: go2vmr(gncol,nlay) ! Oxygen volume mixing ratio
! Dimensions: (ncol,nlay)
real , intent(in) :: gasdir(gncol) ! UV/vis surface albedo direct rad
! Dimensions: (ncol)
real , intent(in) :: galdir(gncol) ! Near-IR surface albedo direct rad
! Dimensions: (ncol)
real , intent(in) :: gasdif(gncol) ! UV/vis surface albedo: diffuse rad
! Dimensions: (ncol)
real , intent(in) :: galdif(gncol) ! Near-IR surface albedo: diffuse rad
! Dimensions: (ncol)
real , intent(in) :: gcoszen(gncol) ! Cosine of solar zenith angle
! Dimensions: (ncol)
real , intent(in) :: gtauaer(gncol,nlay,nbndsw) ! Aerosol optical depth (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: gssaaer(gncol,nlay,nbndsw) ! Aerosol single scattering albedo (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: gasmaer(gncol,nlay,nbndsw) ! Aerosol asymmetry parameter (iaer=10 only)
! Dimensions: (ncol,nlay,nbndsw)
! (non-delta scaled)
real , intent(in) :: gecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only)
! Dimensions: (ncol,nlay,naerec)
! (non-delta scaled)
! integer , intent(in) :: normFlx ! Normalize fluxes flag
! 0 = no normalization
! 1 = normalize fluxes ( / (scon * coszen) )
! ----- Output -----
real , intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d)
! Dimensions: (ncol,nlay)
real , intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2)
! Dimensions: (ncol,nlay+1)
real , intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d)
! Dimensions: (ncol,nlay)
real, intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2)
! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20)
real, intent(out) :: swdkdir(:,:) ! Total shortwave downward direct flux (W/m2)
! Dimensions: (ncol,nlay+1) jararias, 2013/08/10
real, intent(out) :: swdkdif(:,:) ! Total shortwave downward diffuse flux (W/m2)
! Dimensions: (ncol,nlay+1) jararias, 2013/08/10
! ----- Local -----
! Control
integer :: istart ! beginning band of calculation
integer :: iend ! ending band of calculation
integer :: icpr ! cldprop/cldprmc use flag
integer :: iout ! output option flag
integer :: idelm ! delta-m scaling flag
! [0 = direct and diffuse fluxes are unscaled]
! [1 = direct and diffuse fluxes are scaled]
! (total downward fluxes are always delta scaled)
integer :: isccos ! instrumental cosine response flag (inactive)
integer :: iplon ! column loop index
integer :: i ! layer loop index ! jk
integer :: ib ! band loop index ! jsw
integer :: ia, ig ! indices
integer :: k ! layer loop index
integer :: ims ! value for changing mcica permute seed
integer :: imca ! flag for mcica [0=off, 1=on]
real :: zepsec, zepzen ! epsilon
real :: zdpgcp ! flux to heating conversion ratio
#ifndef _ACCEL
# define ncol CHNK
#endif
! Atmosphere
real :: coldry(ncol,nlay+1) ! dry air column amount
real :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2)
real :: cossza(ncol) ! Cosine of solar zenith angle
real :: adjflux(jpband) ! adjustment for current Earth/Sun distance
! default value of 1368.22 Wm-2 at 1 AU
real :: albdir(ncol,nbndsw) ! surface albedo, direct ! zalbp
real :: albdif(ncol,nbndsw) ! surface albedo, diffuse ! zalbd
! real :: rdl(ncol), adl(ncol)
! Atmosphere - setcoef
integer :: laytrop(ncol) ! tropopause layer index
integer :: layswtch(ncol) ! tropopause layer index
integer :: laylow(ncol) ! tropopause layer index
integer :: jp(ncol,nlay+1) !
integer :: jt(ncol,nlay+1) !
integer :: jt1(ncol,nlay+1) !
real :: colh2o(ncol,nlay+1) ! column amount (h2o)
real :: colco2(ncol,nlay+1) ! column amount (co2)
real :: colo3(ncol,nlay+1) ! column amount (o3)
real :: coln2o(ncol,nlay+1) ! column amount (n2o)
real :: colch4(ncol,nlay+1) ! column amount (ch4)
real :: colo2(ncol,nlay+1) ! column amount (o2)
real :: colmol(ncol,nlay+1) ! column amount
real :: co2mult(ncol,nlay+1) ! column amount
integer :: indself(ncol,nlay+1)
integer :: indfor(ncol,nlay+1)
real :: selffac(ncol,nlay+1)
real :: selffrac(ncol,nlay+1)
real :: forfac(ncol,nlay+1)
real :: forfrac(ncol,nlay+1)
real :: & !
fac00(ncol,nlay+1) , fac01(ncol,nlay+1) , &
fac10(ncol,nlay+1) , fac11(ncol,nlay+1)
real :: play(ncol,nlay) ! Layer pressures (hPa, mb)
! Dimensions: (ncol,nlay)
real :: plev(ncol,nlay+1) ! Interface pressures (hPa, mb)
! Dimensions: (ncol,nlay+1)
real :: tlay(ncol,nlay) ! Layer temperatures (K)
! Dimensions: (ncol,nlay)
real :: tlev(ncol,nlay+1) ! Interface temperatures (K)
! Dimensions: (ncol,nlay+1)
real :: tsfc(ncol) ! Surface temperature (K)
! Dimensions: (ncol)
real :: coszen(ncol)
! Atmosphere/clouds - cldprop
integer :: ncbands ! number of cloud spectral bands
real :: cld(ncol,nlay) ! Cloud fraction
real :: tauc(ncol,nlay,nbndsw) ! In-cloud optical depth
real :: ssac(ncol,nlay,nbndsw) ! In-cloud single scattering
real :: asmc(ncol,nlay,nbndsw) ! In-cloud asymmetry parameter
real :: fsfc(ncol,nlay,nbndsw) ! In-cloud forward scattering fraction
real :: ciwp(ncol,nlay) ! In-cloud ice water path (g/m2)
real :: clwp(ncol,nlay) ! In-cloud liquid water path (g/m2)
real :: cswp(ncol,nlay) ! In-cloud snow water path (g/m2)
real :: rei(ncol,nlay) ! Cloud ice effective radius (microns)
real :: rel(ncol,nlay) ! Cloud water drop effective radius (microns)
real :: res(ncol,nlay) ! Cloud snow effective radius (microns)
real :: taucmc(ncol,nlay+1,ngptsw) ! in-cloud optical depth [mcica]
real :: taormc(ncol,nlay+1,ngptsw) ! unscaled in-cloud optical depth [mcica]
real :: ssacmc(ncol,nlay+1,ngptsw) ! in-cloud single scattering albedo [mcica]
real :: asmcmc(ncol,nlay+1,ngptsw) ! in-cloud asymmetry parameter [mcica]
real :: fsfcmc(ncol,nlay+1,ngptsw) ! in-cloud forward scattering fraction [mcica]
real :: cldfmcl(ncol,nlay+1,ngptsw) ! cloud fraction [mcica]
real :: ciwpmcl(ncol,nlay+1,ngptsw) ! in-cloud ice water path [mcica]
real :: clwpmcl(ncol,nlay+1,ngptsw) ! in-cloud liquid water path [mcica]
real :: cswpmcl(ncol,nlay+1,ngptsw) ! in-cloud liquid water path [mcica]
! Atmosphere/clouds/aerosol - spcvrt,spcvmc
real :: ztauc(ncol,nlay+1,nbndsw) ! cloud optical depth
real :: ztaucorig(ncol,nlay+1,nbndsw) ! unscaled cloud optical depth
real :: zasyc(ncol,nlay+1,nbndsw) ! cloud asymmetry parameter
! (first moment of phase function)
real :: zomgc(ncol,nlay+1,nbndsw) ! cloud single scattering albedo
real :: taua(ncol, nlay+1, nbndsw)
real :: asya(ncol, nlay+1, nbndsw)
real :: omga(ncol, nlay+1, nbndsw)
real :: zbbfu(ncol,nlay+2) ! temporary upward shortwave flux (w/m2)
real :: zbbfd(ncol,nlay+2) ! temporary downward shortwave flux (w/m2)
real :: zbbcu(ncol,nlay+2) ! temporary clear sky upward shortwave flux (w/m2)
real :: zbbcd(ncol,nlay+2) ! temporary clear sky downward shortwave flux (w/m2)
real :: zbbfddir(ncol,nlay+2) ! temporary downward direct shortwave flux (w/m2)
real :: zbbcddir(ncol,nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2)
real :: zuvfd(ncol,nlay+2) ! temporary UV downward shortwave flux (w/m2)
real :: zuvcd(ncol,nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2)
real :: zuvfddir(ncol,nlay+2) ! temporary UV downward direct shortwave flux (w/m2)
real :: zuvcddir(ncol,nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2)
real :: znifd(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2)
real :: znicd(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2)
real :: znifddir(ncol,nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2)
real :: znicddir(ncol,nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2)
! Optional output fields
real :: swnflx(ncol,nlay+2) ! Total sky shortwave net flux (W/m2)
real :: swnflxc(ncol,nlay+2) ! Clear sky shortwave net flux (W/m2)
real :: dirdflux(ncol,nlay+2) ! Direct downward shortwave surface flux
real :: difdflux(ncol,nlay+2) ! Diffuse downward shortwave surface flux
real :: uvdflx(ncol,nlay+2) ! Total sky downward shortwave flux, UV/vis
real :: nidflx(ncol,nlay+2) ! Total sky downward shortwave flux, near-IR
real :: dirdnuv(ncol,nlay+2) ! Direct downward shortwave flux, UV/vis
real :: difdnuv(ncol,nlay+2) ! Diffuse downward shortwave flux, UV/vis
real :: dirdnir(ncol,nlay+2) ! Direct downward shortwave flux, near-IR
real :: difdnir(ncol,nlay+2) ! Diffuse downward shortwave flux, near-IR
real gpu_device :: zgco(ncol,ngptsw,nlay+1) , zomco(ncol,ngptsw,nlay+1)
real gpu_device :: zrdnd(ncol,ngptsw,nlay+1)
real gpu_device :: zref(ncol,ngptsw,nlay+1) , zrefo(ncol,ngptsw,nlay+1)
real gpu_device :: zrefd(ncol,ngptsw,nlay+1) , zrefdo(ncol,ngptsw,nlay+1)
real gpu_device :: ztauo(ncol,ngptsw,nlay)
real gpu_device :: zdbt(ncol,ngptsw,nlay+1) , ztdbt(ncol,ngptsw,nlay+1)
real gpu_device :: ztra(ncol,ngptsw,nlay+1) , ztrao(ncol,ngptsw,nlay+1)
real gpu_device :: ztrad(ncol,ngptsw,nlay+1) , ztrado(ncol,ngptsw,nlay+1)
real gpu_device :: zfd(ncol,ngptsw,nlay+1) , zfu(ncol,ngptsw,nlay+1)
real gpu_device :: zsflxzen(ncol,ngptsw)
real gpu_device :: ztaur(ncol,nlay,ngptsw) , ztaug(ncol,nlay,ngptsw)
#ifndef _ACCEL
# undef ncol
#endif
integer :: npartc, npart, npartb, cldflag(gncol), profic(gncol), profi(gncol)
real , parameter :: amd = 28.9660 ! Effective molecular weight of dry air (g/mol)
real , parameter :: amw = 18.0160 ! Molecular weight of water vapor (g/mol)
! Set molecular weight ratios (for converting mmr to vmr)
! e.g. h2ovmr = h2ommr * amdw)
real , parameter :: amdw = 1.607793 ! Molecular weight of dry air / water vapor
real , parameter :: amdc = 0.658114 ! Molecular weight of dry air / carbon dioxide
real , parameter :: amdo = 0.603428 ! Molecular weight of dry air / ozone
real , parameter :: amdm = 1.805423 ! Molecular weight of dry air / methane
real , parameter :: amdn = 0.658090 ! Molecular weight of dry air / nitrous oxide
real , parameter :: amdo2 = 0.905140 ! Molecular weight of dry air / oxygen
real , parameter :: sbc = 5.67e-08 ! Stefan-Boltzmann constant (W/m2K4)
integer ii,jj,kk,iw
integer :: isp, l, ix, n, imol ! Loop indices
real :: amm, summol !
real :: adjflx ! flux adjustment for Earth/Sun distance
integer :: prt
integer :: piplon
integer :: ipart, cols, cole, colr, ncolc, ncolb
integer :: irng, cc, ncolst
! Initializations
zepsec = 1.e-06
zepzen = 1.e-10
oneminus = 1.0 - zepsec
pi = 2. * asin(1. )
irng = 0
istart = jpb1
iend = jpb2
iout = 0
icpr = 1
ims = 2
adjflx = adjes
if (dyofyr .gt. 0) then
adjflx = earth_sun(dyofyr)
endif
do ib = jpb1, jpb2
adjflux(ib) = adjflx * scon / rrsw_scon
end do
if (icld.lt.0.or.icld.gt.3) icld = 2
! determine cloud profile
cldflag=0
do iplon = 1, gncol
if (any(gcld(iplon,:) > 0)) cldflag(iplon)=1
end do
! build profile separation
cols = 0
cole = 0
do iplon = 1, gncol
if (cldflag(iplon)==1) then
cole=cole+1
profi(cole) = iplon
else
cols=cols+1
profic(cols) = iplon
end if
end do
!$acc data copyout(swuflxc, swdflxc, swuflx, swdflx, swnflxc, swnflx, swhrc, swhr) &
!$acc create(laytrop, layswtch, laylow, jp, jt, jt1, &
!$acc co2mult, colch4, colco2, colh2o, colmol, coln2o, &
!$acc colo2, colo3, fac00, fac01, fac10, fac11, &
!$acc selffac, selffrac, indself, forfac, forfrac, indfor, &
!$acc zbbfu, zbbfd, zbbcu, zbbcd,zbbfddir, zbbcddir, zuvfd, zuvcd, zuvfddir, &
!$acc zuvcddir, znifd, znicd, znifddir,znicddir, &
!$acc cldfmcl, ciwpmcl, clwpmcl, cswpmcl, &
!$acc taormc, taucmc, ssacmc, asmcmc, fsfcmc) &
!$acc deviceptr(zref,zrefo,zrefd,zrefdo,&
!$acc ztauo,ztdbt,&
!$acc ztra,ztrao,ztrad,ztrado,&
!$acc zfd,zfu,zdbt,zgco,&
!$acc zomco,zrdnd,ztaug, ztaur,zsflxzen)&
!$acc create(ciwp, clwp, cswp, cld, tauc, ssac, asmc, fsfc, rei, rel, res) &
!$acc create(play, tlay, plev, tlev, tsfc, cldflag, coszen) &
!$acc create(coldry, wkl) &
!$acc create(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) &
!$acc create(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) &
!$acc create(taua, asya, omga,gtauaer,gssaaer,gasmaer) &
!$acc copyin(wavenum2, ngb) &
!$acc copyin(tref, preflog, albdif, albdir, cossza)&
!$acc copyin(icxa, adjflux, nspa, nspb)&
!$acc copyin(kao16,kbo16,selfrefo16,forrefo16,sfluxrefo16)&
!$acc copyin(ka16,kb16,selfref16,forref16,sfluxref16)&
!$acc copyin(kao17,kbo17,selfrefo17,forrefo17,sfluxrefo17)&
!$acc copyin(ka17,kb17,selfref17,forref17,sfluxref17)&
!$acc copyin(kao18,kbo18,selfrefo18,forrefo18,sfluxrefo18)&
!$acc copyin(ka18,kb18,selfref18,forref18,sfluxref18)&
!$acc copyin(kao19,kbo19,selfrefo19,forrefo19,sfluxrefo19)&
!$acc copyin(ka19,kb19,selfref19,forref19,sfluxref19)&
!$acc copyin(kao20,kbo20,selfrefo20,forrefo20,sfluxrefo20,absch4o20)&
!$acc copyin(ka20,kb20,selfref20,forref20,sfluxref20,absch420)&
!$acc copyin(kao21,kbo21,selfrefo21,forrefo21,sfluxrefo21)&
!$acc copyin(ka21,kb21,selfref21,forref21,sfluxref21)&
!$acc copyin(kao22,kbo22,selfrefo22,forrefo22,sfluxrefo22)&
!$acc copyin(ka22,kb22,selfref22,forref22,sfluxref22)&
!$acc copyin(kao23,selfrefo23,forrefo23,sfluxrefo23,raylo23)&
!$acc copyin(ka23,selfref23,forref23,sfluxref23,rayl23)&
!$acc copyin(kao24,kbo24,selfrefo24,forrefo24,sfluxrefo24,abso3ao24,abso3bo24,raylao24,raylbo24)&
!$acc copyin(ka24,kb24,selfref24,forref24,sfluxref24,abso3a24,abso3b24,rayla24,raylb24)&
!$acc copyin(kao25,sfluxrefo25,abso3ao25,abso3bo25,raylo25)&
!$acc copyin(ka25,sfluxref25,abso3a25,abso3b25,rayl25)&
!$acc copyin(sfluxrefo26)&
!$acc copyin(sfluxref26)&
!$acc copyin(kao27,kbo27,sfluxrefo27, raylo27)&
!$acc copyin(ka27,kb27,sfluxref27, rayl27)&
!$acc copyin(kao28,kbo28,sfluxrefo28)&
!$acc copyin(ka28,kb28,sfluxref28,gtauc, gssac, gasmc, gfsfc)&
!$acc copyin(kao29,kbo29,selfrefo29,forrefo29,sfluxrefo29,absh2oo29,absco2o29)&
!$acc copyin(ka29,kb29,selfref29,forref29,sfluxref29,absh2o29,absco229)&
!$acc copyin(gh2ovmr, gco2vmr, go3vmr, gn2ovmr, gch4vmr, go2vmr)&
!$acc copyin(gcld, gciwp, gclwp, gcswp, grei, grel, gres, gplay, gplev, gtlay, gtlev, gtsfc)&
!$acc copyin(gasdir, galdir, gasdif, galdif,profi,profic,gcoszen)&
!$acc copyout(sibvisdir,sibvisdif,sibnirdir,sibnirdif,swdkdir,swdkdif)
!$acc update device(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) &
!$acc device(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) &
!$acc device(preflog)
ncolc = cols
ncolb = cole
npartc = ceiling( real(ncolc) / real(ncol) )
npartb = ceiling( real(ncolb) / real(ncol) )
!$acc kernels
cldfmcl = 0.0
ciwpmcl = 0.0
clwpmcl = 0.0
cswpmcl = 0.0
!$acc end kernels
idelm = 1
!$acc kernels
taua = 0.0
asya = 0.0
omga = 1.0
!$acc end kernels
if (iaer==10) then
!$acc update device(gtauaer,gssaaer,gasmaer)
end if
! PARTITION LOOP ----------------------------------------------------------------------------
do cc = 1, 2
if (cc==1) then
npart = npartc
ncolst = ncolc
else
npart = npartb
ncolst = ncolb
end if
do ipart = 0,npart-1
!jm call unsetdebug
!jm if (ipart.eq.IDEBUG-1) then
!jm write(0,*)'setting setdebug ipart = ',ipart+1,' npart ',npart
!jm call setdebug
!jm endif
cols = ipart * ncol + 1
cole = (ipart + 1) * ncol
if (cole>ncolst) cole=ncolst
colr = cole - cols + 1
!$acc kernels
taormc = 0.0
taucmc = 0.0
ssacmc = 1.0
asmcmc = 0.0
fsfcmc = 0.0
!$acc end kernels
! Clear cases
if (cc==1) then
!$acc kernels loop private(piplon)
do iplon = 1, colr
piplon = profic(iplon + cols - 1)
do ib=1,8
albdir(iplon,ib) = galdir(piplon)
albdif(iplon,ib) = galdif(piplon)
enddo
albdir(iplon,nbndsw) = galdir(piplon)
albdif(iplon,nbndsw) = galdif(piplon)
! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
do ib=10,13
albdir(iplon,ib) = gasdir(piplon)
albdif(iplon,ib) = gasdif(piplon)
enddo
! Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average
albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2.
albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2.
end do
!$acc end kernels
!$acc kernels
do iplon = 1, colr
piplon = profic(iplon + cols - 1)
play(iplon,:) = gplay(piplon, 1:nlay)
plev(iplon,:) = gplev(piplon, 1:nlay+1)
tlay(iplon,:) = gtlay(piplon, 1:nlay)
tlev(iplon,:) = gtlev(piplon, 1:nlay+1)
tsfc(iplon) = gtsfc(piplon)
end do
!$acc end kernels
if (iaer==10) then
!$acc kernels
do iw=1,nbndsw
do kk=1,nlay
do iplon = 1, colr
piplon = profic(iplon + cols - 1)
taua(iplon, kk, iw) = gtauaer(piplon, kk, iw)
asya(iplon, kk, iw) = gasmaer(piplon, kk, iw)
omga(iplon, kk, iw) = gssaaer(piplon, kk, iw)
end do
end do
end do
!$acc end kernels
end if
!$acc kernels
do iplon = 1, colr
piplon = profic(iplon + cols - 1)
wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay)
wkl(iplon,2,:) = gco2vmr(piplon,1:nlay)
wkl(iplon,3,:) = go3vmr(piplon,1:nlay)
wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay)
wkl(iplon,5,:) = 0.0
wkl(iplon,6,:) = gch4vmr(piplon,1:nlay)
wkl(iplon,7,:) = go2vmr(piplon,1:nlay)
coszen(iplon) = gcoszen(piplon)
end do
!$acc end kernels
!************** cloudy cases ***************
else
!$acc kernels loop private(piplon)
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
do ib=1,8
albdir(iplon,ib) = galdir(piplon)
albdif(iplon,ib) = galdif(piplon)
enddo
albdir(iplon,nbndsw) = galdir(piplon)
albdif(iplon,nbndsw) = galdif(piplon)
! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
do ib=10,13
albdir(iplon,ib) = gasdir(piplon)
albdif(iplon,ib) = gasdif(piplon)
enddo
! Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average
albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2.
albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2.
end do
!$acc end kernels
!$acc kernels
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
play(iplon,:) = gplay(piplon, 1:nlay)
plev(iplon,:) = gplev(piplon, 1:nlay+1)
tlay(iplon,:) = gtlay(piplon, 1:nlay)
tlev(iplon,:) = gtlev(piplon, 1:nlay+1)
tsfc(iplon) = gtsfc(piplon)
cld(iplon,:) = gcld(piplon, 1:nlay)
ciwp(iplon,:) = gciwp(piplon, 1:nlay)
clwp(iplon,:) = gclwp(piplon, 1:nlay)
cswp(iplon,:) = gcswp(piplon, 1:nlay)
rei(iplon,:) = grei(piplon, 1:nlay)
rel(iplon,:) = grel(piplon, 1:nlay)
res(iplon,:) = gres(piplon, 1:nlay)
end do
!$acc end kernels
if (iaer==10) then
!$acc kernels
do iw=1,nbndsw
do kk=1,nlay
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
taua(iplon, kk, iw) = gtauaer(piplon, kk, iw)
asya(iplon, kk, iw) = gasmaer(piplon, kk, iw)
omga(iplon, kk, iw) = gssaaer(piplon, kk, iw)
end do
end do
end do
!$acc end kernels
end if
! Copy the direct cloud optical properties over to the temp arrays
! and then onto the GPU
! We are on the CPU here
!$acc kernels
do iw=1,nbndsw
do kk=1,nlay
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
tauc(iplon, kk, iw) = gtauc(piplon, kk, iw)
ssac(iplon, kk, iw) = gssac(piplon, kk, iw)
asmc(iplon, kk, iw) = gasmc(piplon, kk, iw)
fsfc(iplon, kk, iw) = gfsfc(piplon, kk, iw)
end do
end do
end do
!$acc end kernels
!$acc kernels
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay)
wkl(iplon,2,:) = gco2vmr(piplon,1:nlay)
wkl(iplon,3,:) = go3vmr(piplon,1:nlay)
wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay)
wkl(iplon,5,:) = 0.0
wkl(iplon,6,:) = gch4vmr(piplon,1:nlay)
wkl(iplon,7,:) = go2vmr(piplon,1:nlay)
coszen(iplon) = gcoszen(piplon)
end do
!$acc end kernels
end if ! if-else-endif cc=1 (clear and cloudy cases)
!$acc kernels
cossza = max(zepzen,coszen)
!$acc end kernels
!$acc kernels
do iplon = 1,colr
do l = 1,nlay
coldry(iplon, l) = (plev(iplon, l)-plev(iplon, l+1)) * 1.e3 * avogad / &
(1.e2 * grav * ((1. - wkl(iplon, 1,l)) * amd + wkl(iplon, 1,l) * amw) * &
(1. + wkl(iplon, 1,l)))
end do
end do
!$acc end kernels
!$acc kernels
do iplon = 1,colr
do l = 1,nlay
do imol = 1, nmol
wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l)
end do
end do
end do
!$acc end kernels
#ifndef _ACCEL
! Use Tom Henderson's technique to pad out and vector remainder
! with valid data so that we can have a static loop range over
! columns without having to test for short vectors.
IF ( colr < CHNK ) THEN
DO jj = 1,ngptsw
DO kk = 1,nlay+1
DO ii = colr+1, CHNK
taormc(ii,kk,jj) = taormc(colr,kk,jj)
taucmc(ii,kk,jj) = taucmc(colr,kk,jj)
ssacmc(ii,kk,jj) = ssacmc(colr,kk,jj)
asmcmc(ii,kk,jj) = asmcmc(colr,kk,jj)
fsfcmc(ii,kk,jj) = fsfcmc(colr,kk,jj)
ENDDO
ENDDO
ENDDO
DO ib = 1,13
DO ii = colr+1, CHNK
albdir(ii,ib) = albdir(colr,ib)
albdif(ii,ib) = albdif(colr,ib)
ENDDO
ENDDO
DO kk = 1,nlay+1
DO ii = colr+1, CHNK
plev(ii,kk) = plev(colr,kk)
tlev(ii,kk) = tlev(colr,kk)
coldry(ii,kk) = coldry(colr,kk)
ENDDO
ENDDO
DO kk = 1,nlay
DO ii = colr+1, CHNK
play(ii,kk) = play(colr,kk)
tlay(ii,kk) = tlay(colr,kk)
cld(ii,kk) = cld(colr,kk)
ciwp(ii,kk) = ciwp(colr,kk)
clwp(ii,kk) = clwp(colr,kk)
cswp(ii,kk) = cswp(colr,kk)
rei(ii,kk) = rei(colr,kk)
rel(ii,kk) = rel(colr,kk)
res(ii,kk) = res(colr,kk)
ENDDO
ENDDO
DO ii = colr+1, CHNK
tsfc(ii) = tsfc(colr)
ENDDO
IF ( iaer==10 ) THEN
DO jj = 1,nbndsw
DO kk = 1,nlay+1
DO ii = colr+1, CHNK
taua(ii,kk,jj) = taua(colr,kk,jj)
asya(ii,kk,jj) = asya(colr,kk,jj)
omga(ii,kk,jj) = omga(colr,kk,jj)
ENDDO
ENDDO
ENDDO
ENDIF
DO jj = 1,nbndsw
DO kk = 1,nlay
DO ii = colr+1, CHNK
tauc(ii,kk,jj) = tauc(colr,kk,jj)
ssac(ii,kk,jj) = ssac(colr,kk,jj)
asmc(ii,kk,jj) = asmc(colr,kk,jj)
fsfc(ii,kk,jj) = fsfc(colr,kk,jj)
ENDDO
ENDDO
ENDDO
DO kk = 1,nlay
DO jj = 1,mxmol
DO ii = colr+1, CHNK
wkl(ii,jj,kk) = wkl(colr,jj,kk)
ENDDO
ENDDO
ENDDO
DO ii = colr+1, CHNK
coszen(ii) = coszen(colr)
ENDDO
ENDIF
#endif
#ifndef _ACCEL
# define colr CHNK
#endif
if (cc==2) then ! call mcica for cloudy cases
call mcica_sw(colr, nlay, 112, icld, irng, play, &
cld, ciwp, clwp, cswp, tauc, ssac, asmc, fsfc, &
cldfmcl, ciwpmcl, clwpmcl, cswpmcl, &
taucmc, ssacmc, asmcmc, fsfcmc, 1 )
end if
if (cc==2) then ! call cldprmc for cloudy cases
call cldprmc_sw(colr, nlay, inflgsw, iceflgsw, liqflgsw, &
cldfmcl, ciwpmcl, clwpmcl, cswpmcl, rei, rel, res, &
taormc, taucmc, ssacmc, asmcmc, fsfcmc)
end if
call setcoef_sw(colr, nlay, play , tlay , plev , tlev , tsfc , &
coldry , wkl , &
laytrop, layswtch, laylow, jp , jt , jt1 , &
co2mult , colch4 , colco2 , colh2o , colmol , coln2o , &
colo2 , colo3 , fac00 , fac01 , fac10 , fac11 , &
selffac , selffrac , indself , forfac , forfrac , indfor )
call spcvmc_sw(cc, ncol, colr, nlay, istart, iend, icpr, idelm, iout, &
play, tlay, plev, tlev, &
tsfc, albdif, albdir, &
cldfmcl, taucmc, asmcmc, ssacmc, taormc, &
taua, asya, omga, cossza, coldry, adjflux, &
laytrop, layswtch, laylow, jp, jt, jt1, &
co2mult, colch4, colco2, colh2o, colmol, &
coln2o, colo2, colo3, &
fac00, fac01, fac10, fac11, &
selffac, selffrac, indself, forfac, forfrac, indfor, &
zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, &
zuvcd, znifd, znicd, &
zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir,&
zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt,&
ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen)
#ifndef _ACCEL
# undef colr
#endif
! Transfer up and down, clear and total sky fluxes to output arrays.
! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
if (cc==1) then ! clear
!$acc kernels loop independent
do iplon = 1, colr
piplon = profic(iplon + cols - 1)
do i = 1, nlay+1
swuflxc(piplon,i) = zbbcu(iplon,i)
swdflxc(piplon,i) = zbbcd(iplon,i)
swuflx(piplon,i) = zbbfu(iplon,i)
swdflx(piplon,i) = zbbfd(iplon,i)
! All-sky downwward direct and diffuse fluxes
swdkdir(piplon,i) = zbbfddir(iplon,i)
swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i)
! UV/visible downward direct/diffuse fluxes
sibvisdir(piplon,i) = zuvfddir(iplon,i)
sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i)
! Near-IR downward direct/diffuse fluxes
sibnirdir(piplon,i) = znifddir(iplon,i)
sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i)
enddo
! Total and clear sky net fluxes
do i = 1, nlay+1
swnflxc(iplon,i) = swdflxc(piplon,i) - swuflxc(piplon,i)
swnflx(iplon,i) = swdflx(piplon,i) - swuflx(piplon,i)
enddo
! Total and clear sky heating rates
do i = 1, nlay
zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1))
swhrc(piplon,i) = (swnflxc(iplon,i+1) - swnflxc(iplon,i) ) * zdpgcp
swhr(piplon,i) = (swnflx(iplon,i+1) - swnflx(iplon,i) ) * zdpgcp
enddo
swhrc(piplon,nlay) = 0.
swhr(piplon,nlay) = 0.
! End longitude loop
enddo
!$acc end kernels
else ! cc = 2, cloudy
!$acc kernels loop independent
do iplon = 1, colr
piplon = profi(iplon + cols - 1)
do i = 1, nlay+1
swuflxc(piplon,i) = zbbcu(iplon,i)
swdflxc(piplon,i) = zbbcd(iplon,i)
swuflx(piplon,i) = zbbfu(iplon,i)
swdflx(piplon,i) = zbbfd(iplon,i)
! All-sky downwward direct and diffuse fluxes
swdkdir(piplon,i) = zbbfddir(iplon,i)
swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i)
! UV/visible downward direct/diffuse fluxes
sibvisdir(piplon,i) = zuvfddir(iplon,i)
sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i)
! Near-IR downward direct/diffuse fluxes
sibnirdir(piplon,i) = znifddir(iplon,i)
sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i)
enddo
! Total and clear sky net fluxes
do i = 1, nlay+1
swnflxc(iplon,i) = swdflxc(piplon,i) - swuflxc(piplon,i)
swnflx(iplon,i) = swdflx(piplon,i) - swuflx(piplon,i)
enddo
! Total and clear sky heating rates
do i = 1, nlay
zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1))
swhrc(piplon,i) = (swnflxc(iplon,i+1) - swnflxc(iplon,i) ) * zdpgcp
swhr(piplon,i) = (swnflx(iplon,i+1) - swnflx(iplon,i) ) * zdpgcp
enddo
swhrc(piplon,nlay) = 0.
swhr(piplon,nlay) = 0.
! End longitude loop
enddo
!$acc end kernels
end if ! if-else-endif clear-cloudy
! End partition loops
end do
end do
!$acc end data
end subroutine rrtmg_sw_sub
!*************************************************************************
real function earth_sun(idn) 2,8
!*************************************************************************
!
! Purpose: Function to calculate the correction factor of Earth's orbit
! for current day of the year
! idn : Day of the year
! earth_sun : square of the ratio of mean to actual Earth-Sun distance
! ------- Modules -------
use rrsw_con_f, only : pi
integer , intent(in) :: idn
real :: gamma
gamma = 2. *pi*(idn-1)/365.
! Use Iqbal's equation 1.2.1
earth_sun = 1.000110 + .034221 * cos(gamma) + .001289 * sin(gamma) + &
.000719 * cos(2. *gamma) + .000077 * sin(2. *gamma)
end function earth_sun
end module rrtmg_sw_rad_f
!------------------------------------------------------------------
MODULE module_ra_rrtmg_swf 2
use module_model_constants, only : cp
USE module_wrf_error
! USE module_dm
use parrrsw_f, only : nbndsw, ngptsw, naerec
use rrtmg_sw_init_f, only: rrtmg_sw_ini
use rrtmg_sw_rad_f, only: rrtmg_sw
! use mcica_subcol_gen_sw, only: mcica_subcol_sw
use module_ra_rrtmg_lwf, only : inirad, o3data, relcalc, reicalc, retab
! mcica_random_numbers, randomNumberSequence, &
! new_RandomNumberSequence, getRandomReal
CONTAINS
!------------------------------------------------------------------
SUBROUTINE RRTMG_SWRAD_FAST( & 1,20
rthratensw, &
swupt, swuptc, swdnt, swdntc, &
swupb, swupbc, swdnb, swdnbc, &
! swupflx, swupflxc, swdnflx, swdnflxc, &
swcf, gsw, &
xtime, gmt, xlat, xlong, &
radt, degrad, declin, &
coszr, julday, solcon, &
albedo, t3d, t8w, tsk, &
p3d, p8w, pi3d, rho3d, &
dz8w, cldfra3d, lradius, iradius, &
is_cammgmp_used, r, g, &
re_cloud,re_ice,re_snow, &
has_reqc,has_reqi,has_reqs, &
icloud, warm_rain, &
f_ice_phy, f_rain_phy, &
xland, xice, snow, &
qv3d, qc3d, qr3d, &
qi3d, qs3d, qg3d, &
o3input, o33d, &
aer_opt, aerod, no_src, &
alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011)
alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011)
swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011)
swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011)
sf_surface_physics, & !Zhenxin
f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
gaer300,gaer400,gaer600,gaer999, & ! czhao
waer300,waer400,waer600,waer999, & ! czhao
aer_ra_feedback, &
!jdfcz progn,prescribe, &
progn, &
qndrop3d,f_qndrop, & !czhao
ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte, &
swupflx, swupflxc, swdnflx, swdnflxc, &
tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11
swddir, swddni, swddif, & ! jararias 2013/08
xcoszen,julian & ! jararias 2013/08
)
!------------------------------------------------------------------
IMPLICIT NONE
!------------------------------------------------------------------
LOGICAL, INTENT(IN ) :: warm_rain
LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
!
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
ims,ime, jms,jme, kms,kme, &
its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN ) :: ICLOUD
!
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
INTENT(IN ) :: dz8w, &
t3d, &
t8w, &
p3d, &
p8w, &
pi3d, &
rho3d
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
INTENT(INOUT) :: RTHRATENSW
REAL, DIMENSION( ims:ime, jms:jme ) , &
INTENT(INOUT) :: GSW, &
SWCF, &
COSZR
INTEGER, INTENT(IN ) :: JULDAY
REAL, INTENT(IN ) :: RADT,DEGRAD, &
XTIME,DECLIN,SOLCON,GMT
REAL, DIMENSION( ims:ime, jms:jme ) , &
INTENT(IN ) :: XLAT, &
XLONG, &
XLAND, &
XICE, &
SNOW, &
TSK, &
ALBEDO
!
!!! ------------------- Zhenxin (2011-06/20) ------------------
REAL, DIMENSION( ims:ime, jms:jme ) , &
OPTIONAL , &
INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw
ALSWVISDIF, &
ALSWNIRDIR, &
ALSWNIRDIF
REAL, DIMENSION( ims:ime, jms:jme ) , &
OPTIONAL , &
INTENT(OUT) :: SWVISDIR, &
SWVISDIF, &
SWNIRDIR, &
SWNIRDIF ! ssib sw dir and diff rad
INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para
! ----------------------- end Zhenxin --------------------------
!
! ------------------------ jararias 2013/08/10 -----------------
real, dimension(ims:ime,jms:jme), intent(out) :: &
swddir, & ! All-sky broadband surface direct horiz irradiance
swddni, & ! All-sky broadband surface direct normal irradiance
swddif ! All-sky broadband surface diffuse irradiance
real, optional, intent(in) :: &
julian ! julian day (1-366)
real, dimension(ims:ime,jms:jme), optional, intent(in) :: &
xcoszen ! cosine of the solar zenith angle
real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw
! ------------------------ jararias end snippet -----------------
REAL, INTENT(IN ) :: R,G
!
! Optional
!
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
OPTIONAL , &
INTENT(IN ) :: &
CLDFRA3D, &
LRADIUS, &
IRADIUS, &
QV3D, &
QC3D, &
QR3D, &
QI3D, &
QS3D, &
QG3D, &
QNDROP3D
!..Added by G. Thompson to couple cloud physics effective radii.
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
RE_CLOUD, &
RE_ICE, &
RE_SNOW
INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
real pi,third,relconst,lwpmin,rhoh2o
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
OPTIONAL , &
INTENT(IN ) :: &
F_ICE_PHY, &
F_RAIN_PHY
LOGICAL, OPTIONAL, INTENT(IN) :: &
F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
! Optional
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao
gaer300,gaer400,gaer600,gaer999, & ! czhao
waer300,waer400,waer600,waer999 ! czhao
INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
INTEGER, INTENT(IN ), OPTIONAL :: progn
! Ozone
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
OPTIONAL , &
INTENT(IN ) :: O33D
INTEGER, OPTIONAL, INTENT(IN ) :: o3input
! EC aerosol: no_src = naerec = 6
INTEGER, INTENT(IN ) :: no_src
REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , &
OPTIONAL , &
INTENT(IN ) :: aerod
INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
!wavelength corresponding to wavenum1 and wavenum2 (cm-1)
real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
real wavemid(nbndsw) ! Mid wavelength (um) of interval
real, parameter :: thresh=1.e-9
real ang,slope
character(len=200) :: msg
! Top of atmosphere and surface shortwave fluxes (W m-2)
REAL, DIMENSION( ims:ime, jms:jme ), &
OPTIONAL, INTENT(INOUT) :: &
SWUPT,SWUPTC,SWDNT,SWDNTC, &
SWUPB,SWUPBC,SWDNB,SWDNBC
! Layer shortwave fluxes (including extra layer above model top)
! Vertical ordering is from bottom to top (W m-2)
REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
OPTIONAL, INTENT(OUT) :: &
SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC
! LOCAL VARS
REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
Tw1D
REAL, DIMENSION( kts:kte ) :: TTEN1D, &
CLDFRA1D, &
DZ1D, &
P1D, &
T1D, &
QV1D, &
QC1D, &
QR1D, &
QI1D, &
QS1D, &
QG1D, &
O31D, &
qndrop1d
! Added local arrays for RRTMG
integer :: ncol, &
nlay, &
icld, &
iaer, &
inflgsw, &
iceflgsw, &
liqflgsw
! Dimension with extra layer from model top to TOA
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: plev, &
tlev
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: play, &
tlay, &
h2ovmr, &
o3vmr, &
co2vmr, &
o2vmr, &
ch4vmr, &
n2ovmr
real, dimension( kts:kte+1 ) :: o3mmr
! Surface albedo (for UV/visible and near-IR spectral regions,
! and for direct and diffuse radiation)
real, dimension( (jte-jts+1)*(ite-its+1) ) :: asdir, &
asdif, &
aldir, &
aldif
! Dimension with extra layer from model top to TOA,
! though no clouds are allowed in extra layer
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: clwpth, &
ciwpth, &
cswpth, &
rel, &
rei, &
res, &
cldfrac
! cldfrac, &
! relqmcl, &
! reicmcl, &
! resnmcl
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw ) :: taucld, &
ssacld, &
asmcld, &
fsfcld
! real, dimension( ngptsw, (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: cldfmcl, &
! clwpmcl, &
! ciwpmcl, &
! cswpmcl, &
! taucmcl, &
! ssacmcl, &
! asmcmcl, &
! fsfcmcl
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw ) :: tauaer, &
ssaaer, &
asmaer
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, naerec ) :: ecaer
! Output arrays contain extra layer from model top to TOA
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: swuflx, &
swdflx, &
swuflxc, &
swdflxc, &
sibvisdir, & ! Zhenxin 2011-06-20
sibvisdif, &
sibnirdir, &
sibnirdif ! Zhenxin 2011-06-20
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10
swdkdif ! jararias, 2013/08/10
real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: swhr, &
swhrc
real, dimension ( (jte-jts+1)*(ite-its+1) ) :: tsfc, &
ps, &
coszen
real :: ro, &
dz, &
adjes, &
scon, &
snow_mass_factor
integer :: dyofyr
integer:: idx_rei
real:: corr
! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
! carbon dioxide (379 ppmv)
real :: co2
data co2 / 379.e-6 /
! methane (1774 ppbv)
real :: ch4
data ch4 / 1774.e-9 /
! nitrous oxide (319 ppbv)
real :: n2o
data n2o / 319.e-9 /
! Set oxygen volume mixing ratio (for o2mmr=0.23143)
real :: o2
data o2 / 0.209488 /
integer :: iplon, irng, permuteseed
integer :: nb
! For old lw cloud property specification
! Cloud and precipitation absorption coefficients
! real :: abcw,abice,abrn,absn
! data abcw /0.144/
! data abice /0.0735/
! data abrn /0.330e-3/
! data absn /2.34e-3/
! Molecular weights and ratios for converting mmr to vmr units
! real :: amd ! Effective molecular weight of dry air (g/mol)
! real :: amw ! Molecular weight of water vapor (g/mol)
! real :: amo ! Molecular weight of ozone (g/mol)
! real :: amo2 ! Molecular weight of oxygen (g/mol)
! Atomic weights for conversion from mass to volume mixing ratios
! data amd / 28.9660 /
! data amw / 18.0160 /
! data amo / 47.9998 /
! data amo2 / 31.9999 /
real :: amdw ! Molecular weight of dry air / water vapor
real :: amdo ! Molecular weight of dry air / ozone
real :: amdo2 ! Molecular weight of dry air / oxygen
data amdw / 1.607793 /
data amdo / 0.603461 /
data amdo2 / 0.905190 /
!!
real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
cliqwp, & ! in-cloud cloud liquid water path
csnowp, & ! in-cloud snow water path
reliq, & ! effective drop radius (microns)
reice ! ice effective drop size (microns)
real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1):: recloud1d, &
reice1d, &
resnow1d
real :: gliqwp, gicewp, gsnowp, gravmks
!
! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
REAL :: FP
! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
real :: coszrs ! Cosine of solar zenith angle for present latitude
logical :: dorrsw ! Flag to allow shortwave calculation
real, dimension ((jte-jts+1)*(ite-its+1)) :: landfrac, landm, snowh, icefrac
integer :: pcols, pver
integer :: icol
integer :: rpart
REAL :: XT24, TLOCTM, HRANG, XXLAT
INTEGER :: i,j,K, na
LOGICAL :: predicate
REAL :: da, eot ! jararias, 14/08/2013
integer :: icnt
! mji - write
! REAL, DIMENSION( ims:ime, jms:jme ) :: SWDB, SWUT
!------------------------------------------------------------------
#if ( WRF_CHEM == 1 )
IF ( aer_ra_feedback == 1) then
IF ( .NOT. &
( PRESENT(tauaer300) .AND. &
PRESENT(tauaer400) .AND. &
PRESENT(tauaer600) .AND. &
PRESENT(tauaer999) .AND. &
PRESENT(gaer300) .AND. &
PRESENT(gaer400) .AND. &
PRESENT(gaer600) .AND. &
PRESENT(gaer999) .AND. &
PRESENT(waer300) .AND. &
PRESENT(waer400) .AND. &
PRESENT(waer600) .AND. &
PRESENT(waer999) ) ) THEN
CALL wrf_error_fatal &
('Warning: missing fields required for aerosol radiation' )
ENDIF
ENDIF
#endif
! Initial value of number of columns per partition;
! Use 2 for CPU; for GPU set to 0 here to allow selection
! of appropriate value in rrtmg_sw
#ifdef _ACCEL
rpart = 0
#else
rpart = CHNK
#endif
!-----CALCULATE SHORT WAVE RADIATION
!
! All fields are ordered vertically from bottom to top
! Pressures are in mb
! jararias, 14/08/2013
if (present(xcoszen)) then
call wrf_debug(100,'coszen from radiation driver')
end if
! Number of columns to process
ncol = (jte-jts+1)*(ite-its+1)
icnt = 0
! latitude loop
j_loop: do j = jts,jte
! longitude loop
i_loop: do i = its,ite
!
icol = i-its+1 + (j-jts)*(ite-its+1)
! Do shortwave by default, deactivate below if sun below horizon
dorrsw = .true.
! Cosine solar zenith angle for current time step
!
! xt24 is the fractional part of simulation days plus half of radt expressed in
! units of minutes
! julian is in days
! radt is in minutes
! jararias, 14/08/2013
if (present(xcoszen)) then
coszr(i,j)=xcoszen(i,j)
coszrs=xcoszen(i,j)
else
! da=6.2831853071795862*(julian-1)/365.
! eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
! -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
xt24 = mod(xtime+radt*0.5,1440.)+eot
tloctm = gmt + xt24/60. + xlong(i,j)/15.
hrang = 15. * (tloctm-12.) * degrad
xxlat = xlat(i,j) * degrad
coszrs = sin(xxlat) * sin(declin) &
+ cos(xxlat) * cos(declin) * cos(hrang)
coszr(i,j) = coszrs
end if
! mji - count daytime points to not process fully nighttime scenes
if (coszrs .gt. 0.0) icnt = icnt + 1
! Set flag to prevent shortwave calculation when sun below horizon
! mji - must set up input everywhere to run model at all grid points on
! GPU when any daytime points present
! if (coszrs.le.0.0) dorrsw = .false.
! Perform shortwave calculation if sun above horizon
if (dorrsw) then
do k=kts,kte+1
Pw1D(K) = p8w(I,K,J)/100.
Tw1D(K) = t8w(I,K,J)
enddo
DO K=kts,kte
QV1D(K)=0.
QC1D(K)=0.
QR1D(K)=0.
QI1D(K)=0.
QS1D(K)=0.
CLDFRA1D(k)=0.
QNDROP1D(k)=0.
ENDDO
DO K=kts,kte
QV1D(K)=QV3D(I,K,J)
QV1D(K)=max(0.,QV1D(K))
ENDDO
IF (PRESENT(O33D)) THEN
DO K=kts,kte
O31D(K)=O33D(I,K,J)
ENDDO
ELSE
DO K=kts,kte
O31D(K)=0.0
ENDDO
ENDIF
DO K=kts,kte
TTEN1D(K)=0.
T1D(K)=t3d(I,K,J)
P1D(K)=p3d(I,K,J)/100.
DZ1D(K)=dz8w(I,K,J)
ENDDO
! moist variables
IF (ICLOUD .ne. 0) THEN
IF ( PRESENT( CLDFRA3D ) ) THEN
DO K=kts,kte
CLDFRA1D(k)=CLDFRA3D(I,K,J)
ENDDO
ENDIF
IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
IF ( F_QC) THEN
DO K=kts,kte
QC1D(K)=QC3D(I,K,J)
QC1D(K)=max(0.,QC1D(K))
ENDDO
ENDIF
ENDIF
IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
IF ( F_QR) THEN
DO K=kts,kte
QR1D(K)=QR3D(I,K,J)
QR1D(K)=max(0.,QR1D(K))
ENDDO
ENDIF
ENDIF
IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
IF (F_QNDROP) THEN
DO K=kts,kte
qndrop1d(K)=qndrop3d(I,K,J)
ENDDO
ENDIF
ENDIF
! This logic is tortured because cannot test F_QI unless
! it is present, and order of evaluation of expressions
! is not specified in Fortran
IF ( PRESENT ( F_QI ) ) THEN
predicate = F_QI
ELSE
predicate = .FALSE.
ENDIF
! For MP option 3
IF (.NOT. predicate .and. .not. warm_rain) THEN
DO K=kts,kte
IF (T1D(K) .lt. 273.15) THEN
QI1D(K)=QC1D(K)
QS1D(K)=QR1D(K)
QC1D(K)=0.
QR1D(K)=0.
ENDIF
ENDDO
ENDIF
IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
IF (F_QI) THEN
DO K=kts,kte
QI1D(K)=QI3D(I,K,J)
QI1D(K)=max(0.,QI1D(K))
ENDDO
ENDIF
ENDIF
IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
IF (F_QS) THEN
DO K=kts,kte
QS1D(K)=QS3D(I,K,J)
QS1D(K)=max(0.,QS1D(K))
ENDDO
ENDIF
ENDIF
IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
IF (F_QG) THEN
DO K=kts,kte
QG1D(K)=QG3D(I,K,J)
QG1D(K)=max(0.,QG1D(K))
ENDDO
ENDIF
ENDIF
! mji - For MP option 5
IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
DO K=kts,kte
qi1d(k) = 0.1*qs3d(i,k,j)
qs1d(k) = 0.9*qs3d(i,k,j)
qc1d(k) = qc3d(i,k,j)
qi1d(k) = max(0.,qi1d(k))
qc1d(k) = max(0.,qc1d(k))
ENDDO
ENDIF
ENDIF
ENDIF
! EMISS0=EMISS(I,J)
! GLW0=0.
! OLR0=0.
! TSFC=TSK(I,J)
DO K=kts,kte
QV1D(K)=AMAX1(QV1D(K),1.E-12)
ENDDO
! Set up input for shortwave
! ncol = 1
! Add extra layer from top of model to top of atmosphere
nlay = (kte - kts + 1) + 1
! Select cloud liquid and ice optics parameterization options
! For passing in cloud optical properties directly:
! icld = 2
! inflgsw = 0
! iceflgsw = 0
! liqflgsw = 0
! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
icld = 2
inflgsw = 2
iceflgsw = 3
liqflgsw = 1
!Mukul change the flags here with reference to the new effective cloud/ice/snow radius
IF (ICLOUD .ne. 0) THEN
IF ( has_reqc .ne. 0) THEN
inflgsw = 3
DO K=kts,kte
recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
& .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
recloud1D(icol,K) = 10.5
elseif (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
& .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
recloud1D(icol,K) = 7.5
endif
ENDDO
ELSE
DO K=kts,kte
recloud1D(icol,K) = 5.0
ENDDO
ENDIF
IF ( has_reqi .ne. 0) THEN
inflgsw = 4
iceflgsw = 4
DO K=kts,kte
reice1D(icol,K) = MAX(5., re_ice(I,K,J)*1.E6)
if (reice1D(icol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
idx_rei = int(t3d(i,k,j)-179.)
idx_rei = min(max(idx_rei,1),75)
corr = t3d(i,k,j) - int(t3d(i,k,j))
reice1D(icol,K) = retab(idx_rei)*(1.-corr) + &
& retab(idx_rei+1)*corr
reice1D(icol,K) = MAX(reice1D(icol,K), 5.0)
endif
ENDDO
ELSE
DO K=kts,kte
reice1D(icol,K) = 10.0
ENDDO
ENDIF
IF ( has_reqs .ne. 0) THEN
inflgsw = 5
iceflgsw = 5
DO K=kts,kte
resnow1D(icol,K) = MAX(10., re_snow(I,K,J)*1.E6)
ENDDO
ELSE
DO K=kts,kte
resnow1D(icol,K) = 10.
ENDDO
ENDIF
! special case for P3 microphysics
! put ice into snow category for optics, then set ice to zero
IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
inflgsw = 5
iceflgsw = 5
DO K=kts,kte
resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
QS1D(K)=QI3D(I,K,J)
QI1D(K)=0.
reice1D(ncol,K)=10.
END DO
END IF
ENDIF
! Set cosine of solar zenith angle
coszen(icol) = coszrs
! Set solar constant
scon = solcon
! For Earth/Sun distance adjustment in RRTMG
! dyofyr = julday
! adjes = 0.0
! For WRF, solar constant is already provided with eccentricity adjustment,
! so do not do this in RRTMG
dyofyr = 0
adjes = 1.0
! Layer indexing goes bottom to top here for all fields.
! Water vapor and ozone are converted from mmr to vmr.
! Pressures are in units of mb here.
plev(icol,1) = pw1d(1)
tlev(icol,1) = tw1d(1)
tsfc(icol) = tsk(i,j)
do k = kts, kte
play(icol,k) = p1d(k)
plev(icol,k+1) = pw1d(k+1)
pdel(icol,k) = plev(icol,k) - plev(icol,k+1)
tlay(icol,k) = t1d(k)
tlev(icol,k+1) = tw1d(k+1)
h2ovmr(icol,k) = qv1d(k) * amdw
co2vmr(icol,k) = co2
o2vmr(icol,k) = o2
ch4vmr(icol,k) = ch4
n2ovmr(icol,k) = n2o
enddo
! Define profile values for extra layer from model top to top of atmosphere.
! The top layer temperature for all gridpoints is set to the top layer-1
! temperature plus a constant (0 K) that represents an isothermal layer
! above ptop. Top layer interface temperatures are linearly interpolated
! from the layer temperatures.
play(icol,kte+1) = 0.5 * plev(icol,kte+1)
tlay(icol,kte+1) = tlev(icol,kte+1) + 0.0
plev(icol,kte+2) = 1.0e-5
tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0
tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0
h2ovmr(icol,kte+1) = h2ovmr(icol,kte)
co2vmr(icol,kte+1) = co2vmr(icol,kte)
o2vmr(icol,kte+1) = o2vmr(icol,kte)
ch4vmr(icol,kte+1) = ch4vmr(icol,kte)
n2ovmr(icol,kte+1) = n2ovmr(icol,kte)
! Get ozone profile including amount in extra layer above model top
! call inirad (o3mmr,plev,kts,kte)
call inirad (o3mmr,plev(icol,:),kts,kte)
if(present(o33d)) then
do k = kts, kte+1
o3vmr(icol,k) = o3mmr(k) * amdo
IF ( PRESENT( O33D ) ) THEN
if(o3input .eq. 2)then
if(k.le.kte)then
o3vmr(icol,k) = o31d(k)
else
! apply shifted climatology profile above model top
o3vmr(icol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
if(o3vmr(icol,k) .le. 0.)o3vmr(icol,k) = o3mmr(k)*amdo
endif
endif
ENDIF
enddo
else
do k = kts, kte+1
o3vmr(icol,k) = o3mmr(k) * amdo
enddo
endif
! Set surface albedo for direct and diffuse radiation in UV/visible and
! near-IR spectral regions
! -------------- Zhenxin 2011-06-20 ----------- !
! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- !
! asdir(icol) = albedo(i,j)
! asdif(icol) = albedo(i,j)
! aldir(icol) = albedo(i,j)
! aldif(icol) = albedo(i,j)
! ------- End of Comments ------ !
! ------- 2. New Addition ------ !
IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN
asdir(icol) = ALSWVISDIR(I,J)
asdif(icol) = ALSWVISDIF(I,J)
aldir(icol) = ALSWNIRDIR(I,J)
aldif(icol) = ALSWNIRDIF(I,J)
ELSE
asdir(icol) = albedo(i,j)
asdif(icol) = albedo(i,j)
aldir(icol) = albedo(i,j)
aldif(icol) = albedo(i,j)
ENDIF
! ---------- End of Addition ------!
! ---------- End of fds_Zhenxin 2011-06-20 --------------!
! Define cloud optical properties for radiation (inflgsw = 0)
! This option is not currently active
! Cloud and precipitation paths in g/m2
! qi=0 if no ice phase
! qs=0 if no ice phase
if (inflgsw .eq. 0) then
! Set cloud fraction and cloud optical properties here; not yet active
do k = kts, kte
cldfrac(icol,k) = cldfra1d(k)
do nb = 1, nbndsw
taucld(icol,k,nb) = 0.0
ssacld(icol,k,nb) = 1.0
asmcld(icol,k,nb) = 0.0
fsfcld(icol,k,nb) = 0.0
enddo
enddo
! Zero out cloud physical property arrays; not used when passing optical properties
! into radiation
do k = kts, kte
clwpth(icol,k) = 0.0
ciwpth(icol,k) = 0.0
rel(icol,k) = 10.0
rei(icol,k) = 10.
enddo
endif
! Define cloud physical properties for radiation (inflgsw = 1 or 2)
! Cloud fraction
! Set cloud arrays if passing cloud physical properties into radiation
if (inflgsw .gt. 0) then
do k = kts, kte
cldfrac(icol,k) = cldfra1d(k)
enddo
! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
pcols = ncol
pver = kte - kts + 1
gravmks = g
landfrac(icol) = 2.-XLAND(I,J)
landm(icol) = landfrac(icol)
snowh(icol) = 0.001*SNOW(I,J)
icefrac(icol) = XICE(I,J)
! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
! pdel is in mb here; convert back to Pa (*100.)
! Water paths are in units of g/m2
! snow added as ice cloud (JD 091022)
do k = kts, kte
gicewp = (qi1d(k)+qs1d(k)) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
gliqwp = qc1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path.
cliqwp(icol,k) = gliqwp / max(0.01,cldfrac(icol,k)) ! In-cloud liquid water path.
end do
! Mukul
!..The ice water path is already sum of cloud ice and snow, but when we have explicit
!.. ice effective radius, overwrite the ice path with only the cloud ice variable,
!.. leaving out the snow for its own effect.
if(iceflgsw.ge.4)then
do k = kts, kte
gicewp = qi1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path.
end do
end if
!..Here the snow path is adjusted if (radiation) effective radius of snow is
!.. larger than what we currently have in the lookup tables. Since mass goes
!.. rather close to diameter squared, adjust the mixing ratio of snow used
!.. to compute its water path in combination with the max diameter. Not a
!.. perfect fix, but certainly better than using all snow mass when diameter is
!.. far larger than table currently contains and crystal sizes much larger than
!.. about 140 microns have lesser impact than those much smaller sizes.
if(iceflgsw.eq.5)then
do k = kts, kte
snow_mass_factor = 1.0
if (resnow1d(icol,k) .gt. 130.)then
snow_mass_factor = (130.0/resnow1d(icol,k))*(130.0/resnow1d(icol,k))
resnow1d(icol,k) = 130.0
endif
gsnowp = qs1d(k) * snow_mass_factor * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
csnowp(icol,k) = gsnowp / max(0.01,cldfrac(icol,k))
end do
end if
!link the aerosol feedback to cloud -czhao
if( PRESENT( progn ) ) then
if (progn == 1) then
!jdfcz if(prescribe==0) then
pi = 4.*atan(1.0)
third=1./3.
rhoh2o=1.e3
relconst=3/(4.*pi*rhoh2o)
! minimun liquid water path to calculate rel
! corresponds to optical depth of 1.e-3 for radius 4 microns.
lwpmin=3.e-5
do k = kts, kte
reliq(icol,k) = 10.
if( PRESENT( F_QNDROP ) ) then
if( F_QNDROP ) then
if ( qc1d(k)*pdel(icol,k).gt.lwpmin.and. &
qndrop1d(k).gt.1000. ) then
reliq(icol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
! apply scaling from Martin et al., JAS 51, 1830.
reliq(icol,k)=1.1*reliq(icol,k)
reliq(icol,k)=reliq(icol,k)*1.e6 ! convert from m to microns
reliq(icol,k)=max(reliq(icol,k),4.)
reliq(icol,k)=min(reliq(icol,k),20.)
end if
end if
end if
end do
!jdfcz else ! prescribe
! following Kiehl
! call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
!jdfcz endif
else ! progn (progn=1)
call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
endif
else !progn (PRESENT)
call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
endif
! following Kristjansson and Mitchell
call reicalc(icol, pcols, pver, tlay, reice)
!..If we already have effective radius of cloud and ice, then just overwrite what
!.. was computed in the relcalc and reicalc subroutines above.
if (inflgsw .ge. 3) then
do k = kts, kte
reliq(icol,k) = recloud1d(icol,k)
end do
endif
if (iceflgsw .ge. 4) then
do k = kts, kte
reice(icol,k) = reice1d(icol,k)
end do
endif
! Limit upper bound of reice for Fu ice parameterization and convert
! from effective radius to generalized effective size (*1.0315; Fu, 1996)
if (iceflgsw .eq. 3) then
do k = kts, kte
reice(icol,k) = reice(icol,k) * 1.0315
reice(icol,k) = min(140.0,reice(icol,k))
end do
endif
!if CAMMGMP is used, use output from CAMMGMP
!PMA
if(is_CAMMGMP_used) then
do k = kts, kte
if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
reice(icol,k) = iradius(i,k,j)
else
reice(icol,k) = 25.
end if
reice(icol,k) = max(5., min(140.0,reice(icol,k)))
if ( qc1d(k) .gt. 1.e-20) then
reliq(icol,k) = lradius(i,k,j)
else
reliq(icol,k) = 10.
end if
reliq(icol,k) = max(2.5, min(60.0,reliq(icol,k)))
enddo
endif
! Set cloud physical property arrays
do k = kts, kte
clwpth(icol,k) = cliqwp(icol,k)
ciwpth(icol,k) = cicewp(icol,k)
rel(icol,k) = reliq(icol,k)
rei(icol,k) = reice(icol,k)
enddo
!Mukul
if (inflgsw .eq. 5) then
do k = kts, kte
cswpth(icol,k) = csnowp(icol,k)
res(icol,k) = resnow1d(icol,k)
end do
else
do k = kts, kte
cswpth(icol,k) = 0.0
res(icol,k) = 10.0
end do
endif
! Zero out cloud optical properties here, calculated in radiation
do k = kts, kte
do nb = 1, nbndsw
taucld(icol,k,nb) = 0.0
ssacld(icol,k,nb) = 1.0
asmcld(icol,k,nb) = 0.0
fsfcld(icol,k,nb) = 0.0
enddo
enddo
endif
! No clouds are allowed in the extra layer from model top to TOA
clwpth(icol,kte+1) = 0.
ciwpth(icol,kte+1) = 0.
cswpth(icol,kte+1) = 0.
rel(icol,kte+1) = 10.
rei(icol,kte+1) = 10.
res(icol,kte+1) = 10.
cldfrac(icol,kte+1) = 0.
do nb = 1, nbndsw
taucld(icol,kte+1,nb) = 0.
ssacld(icol,kte+1,nb) = 1.
asmcld(icol,kte+1,nb) = 0.
fsfcld(icol,kte+1,nb) = 0.
enddo
! mji - mcica sub-column generator called inside rrtmg_sw for gpu
! iplon = 1
! irng = 0
! permuteseed = 1
! Sub-column generator for McICA
! call mcica_subcol_sw(iplon, icol, nlay, icld, permuteseed, irng, play, &
! cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
! cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
! taucmcl, ssacmcl, asmcmcl, fsfcmcl)
!--------------------------------------------------------------------------
! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
!--------------------------------------------------------------------------
! by layer for each RRTMG shortwave band
! No aerosols in top layer above model top (kte+1).
!cz do nb = 1, nbndsw
!cz do k = kts, kte+1
!cz tauaer(icol,k,nb) = 0.
!cz ssaaer(icol,k,nb) = 1.
!cz asmaer(icol,k,nb) = 0.
!cz enddo
!cz enddo
! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
!
do nb = 1, nbndsw
do k = kts,kte+1
tauaer(icol,k,nb) = 0.
ssaaer(icol,k,nb) = 1.
asmaer(icol,k,nb) = 0.
end do
end do
if ( associated (tauaer3d_sw) ) then
! ---- jararias 11/2012
do nb=1,nbndsw
do k=kts,kte
tauaer(icol,k,nb)=tauaer3d_sw(i,k,j,nb)
ssaaer(icol,k,nb)=ssaaer3d_sw(i,k,j,nb)
asmaer(icol,k,nb)=asyaer3d_sw(i,k,j,nb)
end do
end do
end if
#if ( WRF_CHEM == 1 )
IF ( AER_RA_FEEDBACK == 1) then
do nb = 1, nbndsw
wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um
do k = kts,kte !wig
! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
! tauaer - use angstrom exponent
if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
tauaer(icol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
!tauaer(icol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang
!jm TODO need to fix these so they are not writing to stderr, stdout 20141218
if (i==30.and.j==49.and.k==2.and.nb==12) then
write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
endif
! ssa - linear interpolation; extrapolation
slope=(waer600(i,k,j)-waer400(i,k,j))/.2
ssaaer(icol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
if(ssaaer(icol,k,nb).lt.0.4) ssaaer(icol,k,nb)=0.4
if(ssaaer(icol,k,nb).ge.1.0) ssaaer(icol,k,nb)=1.0
! g - linear interpolation;extrapolation
slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
asmaer(icol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
if(asmaer(icol,k,nb).lt.0.5) asmaer(icol,k,nb)=0.5
if(asmaer(icol,k,nb).ge.1.0) asmaer(icol,k,nb)=1.0
endif
end do ! k
end do ! nb
!wig beg
do nb = 1, nbndsw
slope = 0. !use slope as a sum holder
do k = kts,kte
slope = slope + tauaer(icol,k,nb)
end do
if( slope < 0. ) then
write(msg,'("ERROR: Negative total optical depth of ",f8.2,&
& " at point i,j,nb=",3i5)') slope,i,j,nb
call wrf_error_fatal(msg)
else if( slope > 6. ) then
call wrf_message("-------------------------")
write(msg,'("WARNING: Large total sw optical depth of ",f8.2,&
& " at point i,j,nb=",3i5)') slope,i,j,nb
call wrf_message(msg)
call wrf_message("Diagnostics 1: k, tauaer300, tauaer400,&
& tauaer600, tauaer999, tauaer")
do k=kts,kte
write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
tauaer600(i,k,j), tauaer999(i,k,j),tauaer(icol,k,nb)
call wrf_message(msg)
!czhao set an up-limit here to avoid segmentation fault
!from extreme AOD
tauaer(icol,k,nb)=tauaer(icol,k,nb)*6.0/slope
end do
call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600,&
& gaer999")
do k=kts,kte
write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
gaer600(i,k,j), gaer999(i,k,j)
call wrf_message(msg)
end do
call wrf_message("Diagnostics 3: k, waer300, waer400, waer600,&
& waer999")
do k=kts,kte
write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
waer600(i,k,j), waer999(i,k,j)
call wrf_message(msg)
end do
call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
do k=kts-1,kte
write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
call wrf_message(msg)
end do
call wrf_message("-------------------------")
endif
enddo ! nb
endif ! aer_ra_feedback
#endif
! Zero array for input of aerosol optical thickness for use with
! ECMWF aerosol types (not used)
iaer = 0
do na = 1, naerec
do k = kts, kte+1
ecaer(icol,k,na) = 0.
enddo
enddo
IF ( PRESENT( aerod ) ) THEN
if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 .or. aer_opt .eq. 3 ) then
iaer = 10
do na = 1, naerec
do k = kts, kte+1
ecaer(icol,k,na) = 0.
enddo
enddo
else if ( aer_opt .eq. 1 ) then
iaer = 6
do na = 1, naerec
do k = kts, kte
ecaer(icol,k,na) = aerod(i,k,j,na)
enddo
! assuming 0 or same value at the top?
! ecaer(icol,kte+1,na) = ecaer(icol,kte,na)
ecaer(icol,kte+1,na) = 0.
enddo
endif
ENDIF
!
! End of dorrsw check
endif
! End of grid loops
enddo i_loop
enddo j_loop
! Call RRTMG shortwave radiation model
! Perform shortwave calculation if sun above horizon in any part of grid
! Do not perform shortwave calculations if all of grid is in darkness
if (icnt .eq. 0) dorrsw = .false.
if (dorrsw) then
call rrtmg_sw &
(rpart ,ncol ,nlay ,icld ,iaer , &
play ,plev ,tlay ,tlev ,tsfc , &
h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
asdir ,asdif ,aldir ,aldif , &
coszen ,adjes ,dyofyr ,scon , &
inflgsw ,iceflgsw,liqflgsw,cldfrac , &
taucld ,ssacld ,asmcld ,fsfcld , &
ciwpth ,clwpth ,cswpth ,rei ,rel ,res, &
tauaer ,ssaaer ,asmaer ,ecaer , &
swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, &
! ----- Zhenxin added for ssib coupiling 2011-06-20 --------!
sibvisdir, sibvisdif, sibnirdir, sibnirdif, &
! -------------------- End of addition by Zhenxin 2011-06-20 ------!
swdkdir, swdkdif & ! jararias, 2012/08/10
)
endif
! Output net absorbed shortwave surface flux and shortwave cloud forcing
! at the top of atmosphere (W/m2)
! latitude loop
j_loop2: do j = jts,jte
! longitude loop
i_loop2: do i = its,ite
! Use calculated output only if in daylight, otherwise output is zero
dorrsw = .true.
if (coszr(i,j).le.0.0) dorrsw = .false.
! Complete shortwave calculation if sun above horizon
if (dorrsw) then
if (present(xcoszen)) then
coszr(i,j)=xcoszen(i,j)
coszrs=xcoszen(i,j)
else
call wrf_error_fatal('xcoszen must be passed into RRTMG_SWRAD_FAST')
endif
icol = i-its+1 + (j-jts)*(ite-its+1)
gsw(i,j) = swdflx(icol,1) - swuflx(icol,1)
swcf(i,j) = (swdflx(icol,kte+2) - swuflx(icol,kte+2)) - (swdflxc(icol,kte+2) - swuflxc(icol,kte+2))
! mji - write
! swut(i,j) = swuflx(icol,kte+2)
! swdb(i,j) = swdflx(icol,1)
!
if (present(swupt)) then
! Output up and down toa fluxes for total and clear sky
swupt(i,j) = swuflx(icol,kte+2)
swuptc(i,j) = swuflxc(icol,kte+2)
swdnt(i,j) = swdflx(icol,kte+2)
swdntc(i,j) = swdflxc(icol,kte+2)
! Output up and down surface fluxes for total and clear sky
swupb(i,j) = swuflx(icol,1)
swupbc(i,j) = swuflxc(icol,1)
swdnb(i,j) = swdflx(icol,1)
! Added by Zhenxin for 4 compenants of swdown radiation
swvisdir(i,j) = sibvisdir(icol,1)
swvisdif(i,j) = sibvisdif(icol,1)
swnirdir(i,j) = sibnirdir(icol,1)
swnirdif(i,j) = sibnirdif(icol,1)
! Ended, Zhenxin (2011/06/20)
swdnbc(i,j) = swdflxc(icol,1)
endif
swddir(i,j) = swdkdir(icol,1) ! jararias 2013/08/10
swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10
swddif(i,j) = swdkdif(icol,1) ! jararias 2013/08/10
! Output up and down layer fluxes for total and clear sky.
! Vertical ordering is from bottom to top in units of W m-2.
if ( present (swupflx) ) then
do k=kts,kte+2
swupflx(i,k,j) = swuflx(icol,k)
swupflxc(i,k,j) = swuflxc(icol,k)
swdnflx(i,k,j) = swdflx(icol,k)
swdnflxc(i,k,j) = swdflxc(icol,k)
enddo
endif
! Output heating rate tendency; convert heating rate from K/d to K/s
! Heating rate arrays are ordered vertically from bottom to top here.
do k=kts,kte
tten1d(k) = swhr(icol,k)/86400.
rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
enddo
else
if (present(swupt)) then
! Output up and down toa fluxes for total and clear sky
swupt(i,j) = 0.
swuptc(i,j) = 0.
swdnt(i,j) = 0.
swdntc(i,j) = 0.
! Output up and down surface fluxes for total and clear sky
swupb(i,j) = 0.
swupbc(i,j) = 0.
swdnb(i,j) = 0.
swdnbc(i,j) = 0.
swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20)
swvisdif(i,j) = 0.
swnirdir(i,j) = 0.
swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20)
endif
swddir(i,j) = 0. ! jararias 2013/08/10
swddni(i,j) = 0. ! jararias 2013/08/10
swddif(i,j) = 0. ! jararias 2013/08/10
endif
end do i_loop2
end do j_loop2
! mji - write
! do j=jts,jte
! write(62,995) (swut(i,j),i=its,ite)
! enddo
! do j=jts,jte
! write(62,995) (swdb(i,j),i=its,ite)
! enddo
! 995 format(1p6e12.5)
!-------------------------------------------------------------------
END SUBROUTINE RRTMG_SWRAD_FAST
!====================================================================
SUBROUTINE rrtmg_swinit_fast( & 1,2
allowed_to_read , &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte )
!--------------------------------------------------------------------
IMPLICIT NONE
!--------------------------------------------------------------------
LOGICAL , INTENT(IN) :: allowed_to_read
INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte
! Read in absorption coefficients and other data
IF ( allowed_to_read ) THEN
CALL rrtmg_swlookuptable
ENDIF
! Perform g-point reduction and other initializations
! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
call rrtmg_sw_ini(cp)
END SUBROUTINE rrtmg_swinit_fast
! **************************************************************************
SUBROUTINE rrtmg_swlookuptable 2,34
! **************************************************************************
IMPLICIT NONE
! Local
INTEGER :: i
LOGICAL :: opened
LOGICAL , EXTERNAL :: wrf_dm_on_monitor
CHARACTER*80 errmess
INTEGER rrtmg_unit
IF ( wrf_dm_on_monitor() ) THEN
DO i = 10,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
rrtmg_unit = i
GOTO 2010
ENDIF
ENDDO
rrtmg_unit = -1
2010 CONTINUE
ENDIF
CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
IF ( rrtmg_unit < 0 ) THEN
CALL wrf_error_fatal ( 'module_ra_rrtmg_swf: rrtm_swlookuptable: Can not '// &
'find unused fortran unit to read in lookup table.' )
ENDIF
IF ( wrf_dm_on_monitor() ) THEN
OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA', &
FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
ENDIF
call sw_kgb16(rrtmg_unit)
call sw_kgb17(rrtmg_unit)
call sw_kgb18(rrtmg_unit)
call sw_kgb19(rrtmg_unit)
call sw_kgb20(rrtmg_unit)
call sw_kgb21(rrtmg_unit)
call sw_kgb22(rrtmg_unit)
call sw_kgb23(rrtmg_unit)
call sw_kgb24(rrtmg_unit)
call sw_kgb25(rrtmg_unit)
call sw_kgb26(rrtmg_unit)
call sw_kgb27(rrtmg_unit)
call sw_kgb28(rrtmg_unit)
call sw_kgb29(rrtmg_unit)
IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
RETURN
9009 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error opening '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
END SUBROUTINE rrtmg_swlookuptable
! **************************************************************************
! RRTMG Shortwave Radiative Transfer Model
! Atmospheric and Environmental Research, Inc., Cambridge, MA
!
! Original by J.Delamere, Atmospheric & Environmental Research.
! Reformatted for F90: JJMorcrette, ECMWF
! Revision for GCMs: Michael J. Iacono, AER, July 2002
! Further F90 reformatting: Michael J. Iacono, AER, June 2006
!
! This file contains 14 READ statements that include the
! absorption coefficients and other data for each of the 14 shortwave
! spectral bands used in RRTMG_SW. Here, the data are defined for 16
! g-points, or sub-intervals, per band. These data are combined and
! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce
! the total number of g-points from 224 to 112 for use in the GCM.
! **************************************************************************
! **************************************************************************
subroutine sw_kgb16(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat1, layreffr
! use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat1, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat1)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb16
! **************************************************************************
subroutine sw_kgb17(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb17
! **************************************************************************
subroutine sw_kgb18(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb18
! **************************************************************************
subroutine sw_kgb19(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb19
! **************************************************************************
subroutine sw_kgb20(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absch4o, rayl, layreffr
! use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
! absch4o, rayl
! use rrtmg_sw_taumol, only : layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
! Array absch4o contains the absorption coefficients for methane.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(absch4o)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb20
! **************************************************************************
subroutine sw_kgb21(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb21
! **************************************************************************
subroutine sw_kgb22(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb22
! **************************************************************************
subroutine sw_kgb23(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, &
raylo, givfac, layreffr
! use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo
! use rrtmg_sw_taumol, only : givfac, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array raylo contains the Rayleigh extinction coefficient at all v for this band
! Array givfac is the average Giver et al. correction factor for this band.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
DM_BCAST_MACRO(raylo)
DM_BCAST_REAL(givfac)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb23
! **************************************************************************
subroutine sw_kgb24(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
! use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
! raylao, raylbo, abso3ao, abso3bo
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at
! all v for this band for the upper and lower atmosphere.
! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
! all v for this band for the upper and lower atmosphere.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
forrefo, sfluxrefo
DM_BCAST_MACRO(raylao)
DM_BCAST_MACRO(raylbo)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(abso3ao)
DM_BCAST_MACRO(abso3bo)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb24
! **************************************************************************
subroutine sw_kgb25(rrtmg_unit) 2,8
! **************************************************************************
use rrsw_kg25_f, only : kao, sfluxrefo, &
raylo, abso3ao, abso3bo, layreffr
! use rrsw_kg25_f, only : kao, sfluxrefo, raylo, abso3ao, abso3bo
! use rrtmg_sw_taumol, only : layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at
! all v for this band for the upper and lower atmosphere.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
DM_BCAST_MACRO(raylo)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(abso3ao)
DM_BCAST_MACRO(abso3bo)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb25
! **************************************************************************
subroutine sw_kgb26(rrtmg_unit) 2,6
! **************************************************************************
use rrsw_kg26_f, only : sfluxrefo, raylo
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array raylo contains the Rayleigh extinction coefficient at all v for this band.
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
raylo, sfluxrefo
DM_BCAST_MACRO(raylo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb26
! **************************************************************************
subroutine sw_kgb27(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, &
scalekur, layreffr
! use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo
! use rrtmg_sw_taumol, only : scalekur, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! The values in array sfluxrefo were obtained using the "low resolution"
! version of the Kurucz solar source function. For unknown reasons,
! the total irradiance in this band differs from the corresponding
! total in the "high-resolution" version of the Kurucz function.
! Therefore, these values are scaled by the factor SCALEKUR.
! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
raylo, scalekur, layreffr, kao, kbo, sfluxrefo
DM_BCAST_MACRO(raylo)
DM_BCAST_REAL(scalekur)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb27
! **************************************************************************
subroutine sw_kgb28(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg28_f, only : kao, kbo, sfluxrefo, &
rayl, strrat, layreffr
! use rrsw_kg28_f, only : kao, kbo, sfluxrefo, rayl
! use rrtmg_sw_taumol, only : strrat, layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, strrat, layreffr, kao, kbo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_REAL(strrat)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb28
! **************************************************************************
subroutine sw_kgb29(rrtmg_unit) 2,10
! **************************************************************************
use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
absh2oo, absco2o, rayl, layreffr
! use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
! absh2oo, absco2o, rayl
! use rrtmg_sw_taumol, only : layreffr
implicit none
save
! Input
integer, intent(in) :: rrtmg_unit
! Local
character*80 errmess
logical, external :: wrf_dm_on_monitor
! Array sfluxrefo contains the Kurucz solar source function for this band.
! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
! Array absh2oo contains the water vapor absorption coefficient for this band.
! Array absco2o contains the carbon dioxide absorption coefficient for this band.
! The array KAO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels> ~100mb, temperatures, and binary
! species parameters (see taumol.f for definition). The first
! index in the array, JS, runs from 1 to 9, and corresponds to
! different values of the binary species parameter. For instance,
! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8,
! JS = 3 corresponds to the parameter value 2/8, etc. The second index
! in the array, JT, which runs from 1 to 5, corresponds to different
! temperatures. More specifically, JT = 3 means that the data are for
! the reference temperature TREF for this pressure level, JT = 2 refers
! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
! to the JPth reference pressure level (see taumol.f for these levels
! in mb). The fourth index, IG, goes from 1 to 16, and indicates
! which g-interval the absorption coefficients are for.
! The array KBO contains absorption coefs at the 16 chosen g-values
! for a range of pressure levels < ~100mb and temperatures. The first
! index in the array, JT, which runs from 1 to 5, corresponds to
! different temperatures. More specifically, JT = 3 means that the
! data are for the reference temperature TREF for this pressure
! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
! The second index, JP, runs from 13 to 59 and refers to the JPth
! reference pressure level (see taumol.f for the value of these
! pressure levels in mb). The third index, IG, goes from 1 to 16,
! and tells us which g-interval the absorption coefficients are for.
! The array FORREFO contains the coefficient of the water vapor
! foreign-continuum (including the energy term). The first
! index refers to reference temperature (296,260,224,260) and
! pressure (970,475,219,3 mbar) levels. The second index
! runs over the g-channel (1 to 16).
! The array SELFREFO contains the coefficient of the water vapor
! self-continuum (including the energy term). The first index
! refers to temperature in 7.2 degree increments. For instance,
! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
! etc. The second index runs over the g-channel (1 to 16).
#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
DM_BCAST_REAL(rayl)
DM_BCAST_INTEGER(layreffr)
DM_BCAST_MACRO(absh2oo)
DM_BCAST_MACRO(absco2o)
DM_BCAST_MACRO(kao)
DM_BCAST_MACRO(kbo)
DM_BCAST_MACRO(selfrefo)
DM_BCAST_MACRO(forrefo)
DM_BCAST_MACRO(sfluxrefo)
RETURN
9010 CONTINUE
WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// &
'RRTMG_SW_DATA on unit ',rrtmg_unit
CALL wrf_error_fatal(errmess)
end subroutine sw_kgb29
!------------------------------------------------------------------
END MODULE module_ra_rrtmg_swf