PageRenderTime 49ms CodeModel.GetById 14ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/phys/module_ra_cam_support.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 3862 lines | 2179 code | 312 blank | 1371 comment | 68 complexity | 9fa69a80800b610363beb0ee62307edd MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

  1. MODULE module_ra_cam_support
  2. use module_cam_support, only: endrun
  3. implicit none
  4. integer, parameter :: r8 = 8
  5. real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90
  6. integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer
  7. integer :: ixcldliq
  8. integer :: ixcldice
  9. ! integer :: levsiz ! size of level dimension on dataset
  10. integer, parameter :: nbands = 2 ! Number of spectral bands
  11. integer, parameter :: naer_all = 12 + 1
  12. integer, parameter :: naer = 10 + 1
  13. integer, parameter :: bnd_nbr_LW=7
  14. integer, parameter :: ndstsz = 4 ! number of dust size bins
  15. integer :: idxSUL
  16. integer :: idxSSLT
  17. integer :: idxDUSTfirst
  18. integer :: idxCARBONfirst
  19. integer :: idxOCPHO
  20. integer :: idxBCPHO
  21. integer :: idxOCPHI
  22. integer :: idxBCPHI
  23. integer :: idxBG
  24. integer :: idxVOLC
  25. integer :: mxaerl ! Maximum level of background aerosol
  26. ! indices to sections of array that represent
  27. ! groups of aerosols
  28. integer, parameter :: &
  29. numDUST = 4, &
  30. numCARBON = 4
  31. ! portion of each species group to use in computation
  32. ! of relative radiative forcing.
  33. real(r8) :: sulscl_rf = 0._r8 !
  34. real(r8) :: carscl_rf = 0._r8
  35. real(r8) :: ssltscl_rf = 0._r8
  36. real(r8) :: dustscl_rf = 0._r8
  37. real(r8) :: bgscl_rf = 0._r8
  38. real(r8) :: volcscl_rf = 0._r8
  39. ! "background" aerosol species mmr.
  40. real(r8) :: tauback = 0._r8
  41. ! portion of each species group to use in computation
  42. ! of aerosol forcing in driving the climate
  43. real(r8) :: sulscl = 1._r8
  44. real(r8) :: carscl = 1._r8
  45. real(r8) :: ssltscl = 1._r8
  46. real(r8) :: dustscl = 1._r8
  47. real(r8) :: volcscl = 1._r8
  48. !From volcrad.F90 module
  49. integer, parameter :: idx_LW_0500_0650=3
  50. integer, parameter :: idx_LW_0650_0800=4
  51. integer, parameter :: idx_LW_0800_1000=5
  52. integer, parameter :: idx_LW_1000_1200=6
  53. integer, parameter :: idx_LW_1200_2000=7
  54. ! First two values represent the overlap of volcanics with the non-window
  55. ! (0-800, 1200-2200 cm^-1) and window (800-1200 cm^-1) regions.| Coefficients
  56. ! were derived using crm_volc_minimize.pro with spectral flux optimization
  57. ! on first iteration, total heating rate on subsequent iterations (2-9).
  58. ! Five profiles for HLS, HLW, MLS, MLW, and TRO conditions were given equal
  59. ! weight. RMS heating rate errors for a visible stratospheric optical
  60. ! depth of 1.0 are 0.02948 K/day.
  61. !
  62. real(r8) :: abs_cff_mss_aer(bnd_nbr_LW) = &
  63. (/ 70.257384, 285.282943, &
  64. 1.0273851e+02, 6.3073303e+01, 1.2039569e+02, &
  65. 3.6343643e+02, 2.7138528e+02 /)
  66. !From radae.F90 module
  67. real(r8), parameter:: min_tp_h2o = 160.0 ! min T_p for pre-calculated abs/emis
  68. real(r8), parameter:: max_tp_h2o = 349.999999 ! max T_p for pre-calculated abs/emis
  69. real(r8), parameter:: dtp_h2o = 21.111111111111 ! difference in adjacent elements of tp_h2o
  70. real(r8), parameter:: min_te_h2o = -120.0 ! min T_e-T_p for pre-calculated abs/emis
  71. real(r8), parameter:: max_te_h2o = 79.999999 ! max T_e-T_p for pre-calculated abs/emis
  72. real(r8), parameter:: dte_h2o = 10.0 ! difference in adjacent elements of te_h2o
  73. real(r8), parameter:: min_rh_h2o = 0.0 ! min RH for pre-calculated abs/emis
  74. real(r8), parameter:: max_rh_h2o = 1.19999999 ! max RH for pre-calculated abs/emis
  75. real(r8), parameter:: drh_h2o = 0.2 ! difference in adjacent elements of RH
  76. real(r8), parameter:: min_lu_h2o = -8.0 ! min log_10(U) for pre-calculated abs/emis
  77. real(r8), parameter:: min_u_h2o = 1.0e-8 ! min pressure-weighted path-length
  78. real(r8), parameter:: max_lu_h2o = 3.9999999 ! max log_10(U) for pre-calculated abs/emis
  79. real(r8), parameter:: dlu_h2o = 0.5 ! difference in adjacent elements of lu_h2o
  80. real(r8), parameter:: min_lp_h2o = -3.0 ! min log_10(P) for pre-calculated abs/emis
  81. real(r8), parameter:: min_p_h2o = 1.0e-3 ! min log_10(P) for pre-calculated abs/emis
  82. real(r8), parameter:: max_lp_h2o = -0.0000001 ! max log_10(P) for pre-calculated abs/emis
  83. real(r8), parameter:: dlp_h2o = 0.3333333333333 ! difference in adjacent elements of lp_h2o
  84. integer, parameter :: n_u = 25 ! Number of U in abs/emis tables
  85. integer, parameter :: n_p = 10 ! Number of P in abs/emis tables
  86. integer, parameter :: n_tp = 10 ! Number of T_p in abs/emis tables
  87. integer, parameter :: n_te = 21 ! Number of T_e in abs/emis tables
  88. integer, parameter :: n_rh = 7 ! Number of RH in abs/emis tables
  89. real(r8):: c16,c17,c26,c27,c28,c29,c30,c31
  90. real(r8):: fwcoef ! Farwing correction constant
  91. real(r8):: fwc1,fwc2 ! Farwing correction constants
  92. real(r8):: fc1 ! Farwing correction constant
  93. real(r8):: amco2 ! Molecular weight of co2 (g/mol)
  94. real(r8):: amd ! Molecular weight of dry air (g/mol)
  95. real(r8):: p0 ! Standard pressure (dynes/cm**2)
  96. ! These are now allocatable. JM 20090612
  97. real(r8), allocatable, dimension(:,:,:,:,:) :: ah2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (non-window)
  98. real(r8), allocatable, dimension(:,:,:,:,:) :: eh2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! emissivity (non-window)
  99. real(r8), allocatable, dimension(:,:,:,:,:) :: ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (window, for adjacent layers)
  100. real(r8), allocatable, dimension(:,:,:,:,:) :: cn_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for absorptivity (window)
  101. real(r8), allocatable, dimension(:,:,:,:,:) :: cn_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for emissivity (window)
  102. real(r8), allocatable, dimension(:,:,:,:,:) :: ln_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for absorptivity (window)
  103. real(r8), allocatable, dimension(:,:,:,:,:) :: ln_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for emissivity (window)
  104. !
  105. ! Constant coefficients for water vapor overlap with trace gases.
  106. ! Reference: Ramanathan, V. and P.Downey, 1986: A Nonisothermal
  107. ! Emissivity and Absorptivity Formulation for Water Vapor
  108. ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
  109. !
  110. real(r8):: coefh(2,4) = reshape( &
  111. (/ (/5.46557e+01,-7.30387e-02/), &
  112. (/1.09311e+02,-1.46077e-01/), &
  113. (/5.11479e+01,-6.82615e-02/), &
  114. (/1.02296e+02,-1.36523e-01/) /), (/2,4/) )
  115. !
  116. real(r8):: coefj(3,2) = reshape( &
  117. (/ (/2.82096e-02,2.47836e-04,1.16904e-06/), &
  118. (/9.27379e-02,8.04454e-04,6.88844e-06/) /), (/3,2/) )
  119. !
  120. real(r8):: coefk(3,2) = reshape( &
  121. (/ (/2.48852e-01,2.09667e-03,2.60377e-06/) , &
  122. (/1.03594e+00,6.58620e-03,4.04456e-06/) /), (/3,2/) )
  123. integer, parameter :: ntemp = 192 ! Number of temperatures in H2O sat. table for Tp
  124. real(r8) :: estblh2o(0:ntemp) ! saturation vapor pressure for H2O for Tp rang
  125. integer, parameter :: o_fa = 6 ! Degree+1 of poly of T_e for absorptivity as U->inf.
  126. integer, parameter :: o_fe = 6 ! Degree+1 of poly of T_e for emissivity as U->inf.
  127. !-----------------------------------------------------------------------------
  128. ! Data for f in C/H/E fit -- value of A and E as U->infinity
  129. ! New C/LT/E fit (Hitran 2K, CKD 2.4) -- no change
  130. ! These values are determined by integrals of Planck functions or
  131. ! derivatives of Planck functions only.
  132. !-----------------------------------------------------------------------------
  133. !
  134. ! fa/fe coefficients for 2 bands (0-800 & 1200-2200, 800-1200 cm^-1)
  135. !
  136. ! Coefficients of polynomial for f_a in T_e
  137. !
  138. real(r8), parameter:: fat(o_fa,nbands) = reshape( (/ &
  139. (/-1.06665373E-01, 2.90617375E-02, -2.70642049E-04, & ! 0-800&1200-2200 cm^-1
  140. 1.07595511E-06, -1.97419681E-09, 1.37763374E-12/), & ! 0-800&1200-2200 cm^-1
  141. (/ 1.10666537E+00, -2.90617375E-02, 2.70642049E-04, & ! 800-1200 cm^-1
  142. -1.07595511E-06, 1.97419681E-09, -1.37763374E-12/) /) & ! 800-1200 cm^-1
  143. , (/o_fa,nbands/) )
  144. !
  145. ! Coefficients of polynomial for f_e in T_e
  146. !
  147. real(r8), parameter:: fet(o_fe,nbands) = reshape( (/ &
  148. (/3.46148163E-01, 1.51240299E-02, -1.21846479E-04, & ! 0-800&1200-2200 cm^-1
  149. 4.04970123E-07, -6.15368936E-10, 3.52415071E-13/), & ! 0-800&1200-2200 cm^-1
  150. (/6.53851837E-01, -1.51240299E-02, 1.21846479E-04, & ! 800-1200 cm^-1
  151. -4.04970123E-07, 6.15368936E-10, -3.52415071E-13/) /) & ! 800-1200 cm^-1
  152. , (/o_fa,nbands/) )
  153. real(r8) :: gravit ! Acceleration of gravity (cgs)
  154. real(r8) :: rga ! 1./gravit
  155. real(r8) :: gravmks ! Acceleration of gravity (mks)
  156. real(r8) :: cpair ! Specific heat of dry air
  157. real(r8) :: epsilo ! Ratio of mol. wght of H2O to dry air
  158. real(r8) :: epsqs ! Ratio of mol. wght of H2O to dry air
  159. real(r8) :: sslp ! Standard sea-level pressure
  160. real(r8) :: stebol ! Stefan-Boltzmann's constant
  161. real(r8) :: rgsslp ! 0.5/(gravit*sslp)
  162. real(r8) :: dpfo3 ! Voigt correction factor for O3
  163. real(r8) :: dpfco2 ! Voigt correction factor for CO2
  164. real(r8) :: dayspy ! Number of days per 1 year
  165. real(r8) :: pie ! 3.14.....
  166. real(r8) :: mwdry ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
  167. real(r8) :: scon ! solar constant (not used in WRF)
  168. real(r8) :: co2mmr
  169. real(r8) :: mwco2 ! molecular weight of carbon dioxide
  170. real(r8) :: mwh2o ! molecular weight water vapor (shr_const_mwwv)
  171. real(r8) :: mwch4 ! molecular weight ch4
  172. real(r8) :: mwn2o ! molecular weight n2o
  173. real(r8) :: mwf11 ! molecular weight cfc11
  174. real(r8) :: mwf12 ! molecular weight cfc12
  175. real(r8) :: cappa ! R/Cp
  176. real(r8) :: rair ! Gas constant for dry air (J/K/kg)
  177. real(r8) :: tmelt ! freezing T of fresh water ~ K
  178. real(r8) :: r_universal ! Universal gas constant ~ J/K/kmole
  179. real(r8) :: latvap ! latent heat of evaporation ~ J/kg
  180. real(r8) :: latice ! latent heat of fusion ~ J/kg
  181. real(r8) :: zvir ! R_V/R_D - 1.
  182. integer plenest ! length of saturation vapor pressure table
  183. parameter (plenest=250)
  184. !
  185. ! Table of saturation vapor pressure values es from tmin degrees
  186. ! to tmax+1 degrees k in one degree increments. ttrice defines the
  187. ! transition region where es is a combination of ice & water values
  188. !
  189. real(r8) estbl(plenest) ! table values of saturation vapor pressure
  190. real(r8) tmin ! min temperature (K) for table
  191. real(r8) tmax ! max temperature (K) for table
  192. real(r8) pcf(6) ! polynomial coeffs -> es transition water to ice
  193. !real(r8), allocatable :: pin(:) ! ozone pressure level (levsiz)
  194. !real(r8), allocatable :: ozmix(:,:,:) ! mixing ratio
  195. !real(r8), allocatable, target :: abstot_3d(:,:,:,:) ! Non-adjacent layer absorptivites
  196. !real(r8), allocatable, target :: absnxt_3d(:,:,:,:) ! Nearest layer absorptivities
  197. !real(r8), allocatable, target :: emstot_3d(:,:,:) ! Total emissivity
  198. !From aer_optics.F90 module
  199. integer, parameter :: idxVIS = 8 ! index to visible band
  200. integer, parameter :: nrh = 1000 ! number of relative humidity values for look-up-table
  201. integer, parameter :: nspint = 19 ! number of spectral intervals
  202. ! These are now allocatable, JM 20090612
  203. real(r8), allocatable, dimension(:,:) :: ksul ! (nrh, nspint) ! sulfate specific extinction ( m^2 g-1 )
  204. real(r8), allocatable, dimension(:,:) :: wsul ! (nrh, nspint) ! sulfate single scattering albedo
  205. real(r8), allocatable, dimension(:,:) :: gsul ! (nrh, nspint) ! sulfate asymmetry parameter
  206. real(r8), allocatable, dimension(:,:) :: ksslt ! (nrh, nspint) ! sea-salt specific extinction ( m^2 g-1 )
  207. real(r8), allocatable, dimension(:,:) :: wsslt ! (nrh, nspint) ! sea-salt single scattering albedo
  208. real(r8), allocatable, dimension(:,:) :: gsslt ! (nrh, nspint) ! sea-salt asymmetry parameter
  209. real(r8), allocatable, dimension(:,:) :: kcphil ! (nrh, nspint) ! hydrophilic carbon specific extinction ( m^2 g-1 )
  210. real(r8), allocatable, dimension(:,:) :: wcphil ! (nrh, nspint) ! hydrophilic carbon single scattering albedo
  211. real(r8), allocatable, dimension(:,:) :: gcphil ! (nrh, nspint) ! hydrophilic carbon asymmetry parameter
  212. real(r8) :: kbg(nspint) ! background specific extinction ( m^2 g-1 )
  213. real(r8) :: wbg(nspint) ! background single scattering albedo
  214. real(r8) :: gbg(nspint) ! background asymmetry parameter
  215. real(r8) :: kcphob(nspint) ! hydrophobic carbon specific extinction ( m^2 g-1 )
  216. real(r8) :: wcphob(nspint) ! hydrophobic carbon single scattering albedo
  217. real(r8) :: gcphob(nspint) ! hydrophobic carbon asymmetry parameter
  218. real(r8) :: kcb(nspint) ! black carbon specific extinction ( m^2 g-1 )
  219. real(r8) :: wcb(nspint) ! black carbon single scattering albedo
  220. real(r8) :: gcb(nspint) ! black carbon asymmetry parameter
  221. real(r8) :: kvolc(nspint) ! volcanic specific extinction ( m^2 g-1)
  222. real(r8) :: wvolc(nspint) ! volcanic single scattering albedo
  223. real(r8) :: gvolc(nspint) ! volcanic asymmetry parameter
  224. real(r8) :: kdst(ndstsz, nspint) ! dust specific extinction ( m^2 g-1 )
  225. real(r8) :: wdst(ndstsz, nspint) ! dust single scattering albedo
  226. real(r8) :: gdst(ndstsz, nspint) ! dust asymmetry parameter
  227. !
  228. !From comozp.F90 module
  229. real(r8) cplos ! constant for ozone path length integral
  230. real(r8) cplol ! constant for ozone path length integral
  231. !From ghg_surfvals.F90 module
  232. real(r8) :: co2vmr = 3.550e-4 ! co2 volume mixing ratio
  233. real(r8) :: n2ovmr = 0.311e-6 ! n2o volume mixing ratio
  234. real(r8) :: ch4vmr = 1.714e-6 ! ch4 volume mixing ratio
  235. real(r8) :: f11vmr = 0.280e-9 ! cfc11 volume mixing ratio
  236. real(r8) :: f12vmr = 0.503e-9 ! cfc12 volume mixing ratio
  237. integer, parameter :: cyr = 233 ! number of years of co2 data
  238. integer :: yrdata(cyr) = &
  239. (/ 1869, 1870, 1871, 1872, 1873, 1874, 1875, &
  240. 1876, 1877, 1878, 1879, 1880, 1881, 1882, &
  241. 1883, 1884, 1885, 1886, 1887, 1888, 1889, &
  242. 1890, 1891, 1892, 1893, 1894, 1895, 1896, &
  243. 1897, 1898, 1899, 1900, 1901, 1902, 1903, &
  244. 1904, 1905, 1906, 1907, 1908, 1909, 1910, &
  245. 1911, 1912, 1913, 1914, 1915, 1916, 1917, &
  246. 1918, 1919, 1920, 1921, 1922, 1923, 1924, &
  247. 1925, 1926, 1927, 1928, 1929, 1930, 1931, &
  248. 1932, 1933, 1934, 1935, 1936, 1937, 1938, &
  249. 1939, 1940, 1941, 1942, 1943, 1944, 1945, &
  250. 1946, 1947, 1948, 1949, 1950, 1951, 1952, &
  251. 1953, 1954, 1955, 1956, 1957, 1958, 1959, &
  252. 1960, 1961, 1962, 1963, 1964, 1965, 1966, &
  253. 1967, 1968, 1969, 1970, 1971, 1972, 1973, &
  254. 1974, 1975, 1976, 1977, 1978, 1979, 1980, &
  255. 1981, 1982, 1983, 1984, 1985, 1986, 1987, &
  256. 1988, 1989, 1990, 1991, 1992, 1993, 1994, &
  257. 1995, 1996, 1997, 1998, 1999, 2000, 2001, &
  258. 2002, 2003, 2004, 2005, 2006, 2007, 2008, &
  259. 2009, 2010, 2011, 2012, 2013, 2014, 2015, &
  260. 2016, 2017, 2018, 2019, 2020, 2021, 2022, &
  261. 2023, 2024, 2025, 2026, 2027, 2028, 2029, &
  262. 2030, 2031, 2032, 2033, 2034, 2035, 2036, &
  263. 2037, 2038, 2039, 2040, 2041, 2042, 2043, &
  264. 2044, 2045, 2046, 2047, 2048, 2049, 2050, &
  265. 2051, 2052, 2053, 2054, 2055, 2056, 2057, &
  266. 2058, 2059, 2060, 2061, 2062, 2063, 2064, &
  267. 2065, 2066, 2067, 2068, 2069, 2070, 2071, &
  268. 2072, 2073, 2074, 2075, 2076, 2077, 2078, &
  269. 2079, 2080, 2081, 2082, 2083, 2084, 2085, &
  270. 2086, 2087, 2088, 2089, 2090, 2091, 2092, &
  271. 2093, 2094, 2095, 2096, 2097, 2098, 2099, &
  272. 2100, 2101 /)
  273. ! A2 future scenario
  274. real(r8) :: co2(cyr) = &
  275. (/ 289.263, 289.263, 289.416, 289.577, 289.745, 289.919, 290.102, &
  276. 290.293, 290.491, 290.696, 290.909, 291.129, 291.355, 291.587, 291.824, &
  277. 292.066, 292.313, 292.563, 292.815, 293.071, 293.328, 293.586, 293.843, &
  278. 294.098, 294.35, 294.598, 294.842, 295.082, 295.32, 295.558, 295.797, &
  279. 296.038, 296.284, 296.535, 296.794, 297.062, 297.338, 297.62, 297.91, &
  280. 298.204, 298.504, 298.806, 299.111, 299.419, 299.729, 300.04, 300.352, &
  281. 300.666, 300.98, 301.294, 301.608, 301.923, 302.237, 302.551, 302.863, &
  282. 303.172, 303.478, 303.779, 304.075, 304.366, 304.651, 304.93, 305.206, &
  283. 305.478, 305.746, 306.013, 306.28, 306.546, 306.815, 307.087, 307.365, &
  284. 307.65, 307.943, 308.246, 308.56, 308.887, 309.228, 309.584, 309.956, &
  285. 310.344, 310.749, 311.172, 311.614, 312.077, 312.561, 313.068, 313.599, &
  286. 314.154, 314.737, 315.347, 315.984, 316.646, 317.328, 318.026, 318.742, &
  287. 319.489, 320.282, 321.133, 322.045, 323.021, 324.06, 325.155, 326.299, &
  288. 327.484, 328.698, 329.933, 331.194, 332.499, 333.854, 335.254, 336.69, &
  289. 338.15, 339.628, 341.125, 342.65, 344.206, 345.797, 347.397, 348.98, &
  290. 350.551, 352.1, 354.3637, 355.7772, 357.1601, 358.5306, 359.9046, &
  291. 361.4157, 363.0445, 364.7761, 366.6064, 368.5322, 370.534, 372.5798, &
  292. 374.6564, 376.7656, 378.9087, 381.0864, 383.2994, 385.548, 387.8326, &
  293. 390.1536, 392.523, 394.9625, 397.4806, 400.075, 402.7444, 405.4875, &
  294. 408.3035, 411.1918, 414.1518, 417.1831, 420.2806, 423.4355, 426.6442, &
  295. 429.9076, 433.2261, 436.6002, 440.0303, 443.5168, 447.06, 450.6603, &
  296. 454.3059, 457.9756, 461.6612, 465.3649, 469.0886, 472.8335, 476.6008, &
  297. 480.3916, 484.2069, 488.0473, 491.9184, 495.8295, 499.7849, 503.7843, &
  298. 507.8278, 511.9155, 516.0476, 520.2243, 524.4459, 528.7127, 533.0213, &
  299. 537.3655, 541.7429, 546.1544, 550.6005, 555.0819, 559.5991, 564.1525, &
  300. 568.7429, 573.3701, 578.0399, 582.7611, 587.5379, 592.3701, 597.2572, &
  301. 602.1997, 607.1975, 612.2507, 617.3596, 622.524, 627.7528, 633.0616, &
  302. 638.457, 643.9384, 649.505, 655.1568, 660.8936, 666.7153, 672.6219, &
  303. 678.6133, 684.6945, 690.8745, 697.1569, 703.5416, 710.0284, 716.6172, &
  304. 723.308, 730.1008, 736.9958, 743.993, 751.0975, 758.3183, 765.6594, &
  305. 773.1207, 780.702, 788.4033, 796.2249, 804.1667, 812.2289, 820.4118, &
  306. 828.6444, 828.6444 /)
  307. integer :: ntoplw ! top level to solve for longwave cooling (WRF sets this to 1 for model top below 10 mb)
  308. logical :: masterproc = .true.
  309. logical :: ozncyc ! true => cycle ozone dataset
  310. ! logical :: dosw ! True => shortwave calculation this timestep
  311. ! logical :: dolw ! True => longwave calculation this timestep
  312. logical :: indirect ! True => include indirect radiative effects of sulfate aerosols
  313. ! logical :: doabsems ! True => abs/emiss calculation this timestep
  314. logical :: radforce = .false. ! True => calculate aerosol shortwave forcing
  315. logical :: trace_gas=.false. ! set true for chemistry
  316. logical :: strat_volcanic = .false. ! True => volcanic aerosol mass available
  317. real(r8) retab(95)
  318. !
  319. ! Tabulated values of re(T) in the temperature interval
  320. ! 180 K -- 274 K; hexagonal columns assumed:
  321. !
  322. data retab / &
  323. 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
  324. 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
  325. 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
  326. 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
  327. 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
  328. 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
  329. 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
  330. 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
  331. 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
  332. 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
  333. 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
  334. 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
  335. 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
  336. 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
  337. 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
  338. 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
  339. !
  340. save retab
  341. contains
  342. subroutine sortarray(n, ain, indxa)
  343. !-----------------------------------------------
  344. !
  345. ! Purpose:
  346. ! Sort an array
  347. ! Alogrithm:
  348. ! Based on Shell's sorting method.
  349. !
  350. ! Author: T. Craig
  351. !-----------------------------------------------
  352. ! use shr_kind_mod, only: r8 => shr_kind_r8
  353. implicit none
  354. !
  355. ! Arguments
  356. !
  357. integer , intent(in) :: n ! total number of elements
  358. integer , intent(inout) :: indxa(n) ! array of integers
  359. real(r8), intent(inout) :: ain(n) ! array to sort
  360. !
  361. ! local variables
  362. !
  363. integer :: i, j ! Loop indices
  364. integer :: ni ! Starting increment
  365. integer :: itmp ! Temporary index
  366. real(r8):: atmp ! Temporary value to swap
  367. ni = 1
  368. do while(.TRUE.)
  369. ni = 3*ni + 1
  370. if (ni <= n) cycle
  371. exit
  372. end do
  373. do while(.TRUE.)
  374. ni = ni/3
  375. do i = ni + 1, n
  376. atmp = ain(i)
  377. itmp = indxa(i)
  378. j = i
  379. do while(.TRUE.)
  380. if (ain(j-ni) <= atmp) exit
  381. ain(j) = ain(j-ni)
  382. indxa(j) = indxa(j-ni)
  383. j = j - ni
  384. if (j > ni) cycle
  385. exit
  386. end do
  387. ain(j) = atmp
  388. indxa(j) = itmp
  389. end do
  390. if (ni > 1) cycle
  391. exit
  392. end do
  393. return
  394. end subroutine sortarray
  395. subroutine trcab(lchnk ,ncol ,pcols, pverp, &
  396. k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
  397. un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
  398. uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
  399. bch4 ,to3co2 ,pnm ,dw ,pnew , &
  400. s2c ,uptype ,dplh2o ,abplnk1 ,tco2 , &
  401. th2o ,to3 ,abstrc , &
  402. aer_trn_ttl)
  403. !-----------------------------------------------------------------------
  404. !
  405. ! Purpose:
  406. ! Calculate absorptivity for non nearest layers for CH4, N2O, CFC11 and
  407. ! CFC12.
  408. !
  409. ! Method:
  410. ! See CCM3 description for equations.
  411. !
  412. ! Author: J. Kiehl
  413. !
  414. !-----------------------------------------------------------------------
  415. ! use shr_kind_mod, only: r8 => shr_kind_r8
  416. ! use ppgrid
  417. ! use volcrad
  418. implicit none
  419. !------------------------------Arguments--------------------------------
  420. !
  421. ! Input arguments
  422. !
  423. integer, intent(in) :: lchnk ! chunk identifier
  424. integer, intent(in) :: ncol ! number of atmospheric columns
  425. integer, intent(in) :: pcols, pverp
  426. integer, intent(in) :: k1,k2 ! level indices
  427. !
  428. real(r8), intent(in) :: to3co2(pcols) ! pressure weighted temperature
  429. real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressures
  430. real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
  431. real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
  432. real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
  433. !
  434. real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
  435. real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
  436. real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
  437. real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
  438. real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
  439. !
  440. real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
  441. real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
  442. real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
  443. real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
  444. real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
  445. !
  446. real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
  447. real(r8), intent(in) :: dw(pcols) ! h2o path length
  448. real(r8), intent(in) :: pnew(pcols) ! pressure
  449. real(r8), intent(in) :: s2c(pcols,pverp) ! continuum path length
  450. real(r8), intent(in) :: uptype(pcols,pverp) ! p-type h2o path length
  451. !
  452. real(r8), intent(in) :: dplh2o(pcols) ! p squared h2o path length
  453. real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! Planck factor
  454. real(r8), intent(in) :: tco2(pcols) ! co2 transmission factor
  455. real(r8), intent(in) :: th2o(pcols) ! h2o transmission factor
  456. real(r8), intent(in) :: to3(pcols) ! o3 transmission factor
  457. real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
  458. !
  459. ! Output Arguments
  460. !
  461. real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
  462. !
  463. !--------------------------Local Variables------------------------------
  464. !
  465. integer i,l ! loop counters
  466. real(r8) sqti(pcols) ! square root of mean temp
  467. real(r8) du1 ! cfc11 path length
  468. real(r8) du2 ! cfc12 path length
  469. real(r8) acfc1 ! cfc11 absorptivity 798 cm-1
  470. real(r8) acfc2 ! cfc11 absorptivity 846 cm-1
  471. !
  472. real(r8) acfc3 ! cfc11 absorptivity 933 cm-1
  473. real(r8) acfc4 ! cfc11 absorptivity 1085 cm-1
  474. real(r8) acfc5 ! cfc12 absorptivity 889 cm-1
  475. real(r8) acfc6 ! cfc12 absorptivity 923 cm-1
  476. real(r8) acfc7 ! cfc12 absorptivity 1102 cm-1
  477. !
  478. real(r8) acfc8 ! cfc12 absorptivity 1161 cm-1
  479. real(r8) du01 ! n2o path length
  480. real(r8) dbeta01 ! n2o pressure factor
  481. real(r8) dbeta11 ! "
  482. real(r8) an2o1 ! absorptivity of 1285 cm-1 n2o band
  483. !
  484. real(r8) du02 ! n2o path length
  485. real(r8) dbeta02 ! n2o pressure factor
  486. real(r8) an2o2 ! absorptivity of 589 cm-1 n2o band
  487. real(r8) du03 ! n2o path length
  488. real(r8) dbeta03 ! n2o pressure factor
  489. !
  490. real(r8) an2o3 ! absorptivity of 1168 cm-1 n2o band
  491. real(r8) duch4 ! ch4 path length
  492. real(r8) dbetac ! ch4 pressure factor
  493. real(r8) ach4 ! absorptivity of 1306 cm-1 ch4 band
  494. real(r8) du11 ! co2 path length
  495. !
  496. real(r8) du12 ! "
  497. real(r8) du13 ! "
  498. real(r8) dbetc1 ! co2 pressure factor
  499. real(r8) dbetc2 ! co2 pressure factor
  500. real(r8) aco21 ! absorptivity of 1064 cm-1 band
  501. !
  502. real(r8) du21 ! co2 path length
  503. real(r8) du22 ! "
  504. real(r8) du23 ! "
  505. real(r8) aco22 ! absorptivity of 961 cm-1 band
  506. real(r8) tt(pcols) ! temp. factor for h2o overlap factor
  507. !
  508. real(r8) psi1 ! "
  509. real(r8) phi1 ! "
  510. real(r8) p1 ! h2o overlap factor
  511. real(r8) w1 ! "
  512. real(r8) ds2c(pcols) ! continuum path length
  513. !
  514. real(r8) duptyp(pcols) ! p-type path length
  515. real(r8) tw(pcols,6) ! h2o transmission factor
  516. real(r8) g1(6) ! "
  517. real(r8) g2(6) ! "
  518. real(r8) g3(6) ! "
  519. !
  520. real(r8) g4(6) ! "
  521. real(r8) ab(6) ! h2o temp. factor
  522. real(r8) bb(6) ! "
  523. real(r8) abp(6) ! "
  524. real(r8) bbp(6) ! "
  525. !
  526. real(r8) tcfc3 ! transmission for cfc11 band
  527. real(r8) tcfc4 ! transmission for cfc11 band
  528. real(r8) tcfc6 ! transmission for cfc12 band
  529. real(r8) tcfc7 ! transmission for cfc12 band
  530. real(r8) tcfc8 ! transmission for cfc12 band
  531. !
  532. real(r8) tlw ! h2o transmission
  533. real(r8) tch4 ! ch4 transmission
  534. !
  535. !--------------------------Data Statements------------------------------
  536. !
  537. data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
  538. data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
  539. data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
  540. data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
  541. data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
  542. data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
  543. data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
  544. data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
  545. !
  546. !--------------------------Statement Functions--------------------------
  547. !
  548. real(r8) func, u, b
  549. func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
  550. !
  551. !------------------------------------------------------------------------
  552. !
  553. do i = 1,ncol
  554. sqti(i) = sqrt(to3co2(i))
  555. !
  556. ! h2o transmission
  557. !
  558. tt(i) = abs(to3co2(i) - 250.0)
  559. ds2c(i) = abs(s2c(i,k1) - s2c(i,k2))
  560. duptyp(i) = abs(uptype(i,k1) - uptype(i,k2))
  561. end do
  562. !
  563. do l = 1,6
  564. do i = 1,ncol
  565. psi1 = exp(abp(l)*tt(i) + bbp(l)*tt(i)*tt(i))
  566. phi1 = exp(ab(l)*tt(i) + bb(l)*tt(i)*tt(i))
  567. p1 = pnew(i)*(psi1/phi1)/sslp
  568. w1 = dw(i)*phi1
  569. tw(i,l) = exp(-g1(l)*p1*(sqrt(1.0 + g2(l)*(w1/p1)) - 1.0) - &
  570. g3(l)*ds2c(i)-g4(l)*duptyp(i))
  571. end do
  572. end do
  573. !
  574. do i=1,ncol
  575. tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
  576. 0.3*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000))
  577. tw(i,2)=tw(i,2)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
  578. tw(i,3)=tw(i,3)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
  579. tw(i,4)=tw(i,4)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
  580. tw(i,5)=tw(i,5)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
  581. tw(i,6)=tw(i,6)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
  582. end do ! end loop over lon
  583. do i = 1,ncol
  584. du1 = abs(ucfc11(i,k1) - ucfc11(i,k2))
  585. du2 = abs(ucfc12(i,k1) - ucfc12(i,k2))
  586. !
  587. ! cfc transmissions
  588. !
  589. tcfc3 = exp(-175.005*du1)
  590. tcfc4 = exp(-1202.18*du1)
  591. tcfc6 = exp(-5786.73*du2)
  592. tcfc7 = exp(-2873.51*du2)
  593. tcfc8 = exp(-2085.59*du2)
  594. !
  595. ! Absorptivity for CFC11 bands
  596. !
  597. acfc1 = 50.0*(1.0 - exp(-54.09*du1))*tw(i,1)*abplnk1(7,i,k2)
  598. acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*abplnk1(8,i,k2)
  599. acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*abplnk1(9,i,k2)
  600. acfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*abplnk1(10,i,k2)
  601. !
  602. ! Absorptivity for CFC12 bands
  603. !
  604. acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*abplnk1(11,i,k2)
  605. acfc6 = 50.0*(1.0 - tcfc6)* tw(i,4) * abplnk1(12,i,k2)
  606. acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5) * tcfc4*abplnk1(13,i,k2)
  607. acfc8 = 70.0*(1.0 - tcfc8)* tw(i,6) * abplnk1(14,i,k2)
  608. !
  609. ! Emissivity for CH4 band 1306 cm-1
  610. !
  611. tlw = exp(-1.0*sqrt(dplh2o(i)))
  612. tlw=tlw*aer_trn_ttl(i,k1,k2,idx_LW_1200_2000)
  613. duch4 = abs(uch4(i,k1) - uch4(i,k2))
  614. dbetac = abs(bch4(i,k1) - bch4(i,k2))/duch4
  615. ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac))*tlw*abplnk1(3,i,k2)
  616. tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
  617. !
  618. ! Absorptivity for N2O bands
  619. !
  620. du01 = abs(un2o0(i,k1) - un2o0(i,k2))
  621. du11 = abs(un2o1(i,k1) - un2o1(i,k2))
  622. dbeta01 = abs(bn2o0(i,k1) - bn2o0(i,k2))/du01
  623. dbeta11 = abs(bn2o1(i,k1) - bn2o1(i,k2))/du11
  624. !
  625. ! 1285 cm-1 band
  626. !
  627. an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
  628. + func(du11,dbeta11))*tlw*tch4*abplnk1(4,i,k2)
  629. du02 = 0.100090*du01
  630. du12 = 0.0992746*du11
  631. dbeta02 = 0.964282*dbeta01
  632. !
  633. ! 589 cm-1 band
  634. !
  635. an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) + &
  636. func(du12,dbeta02))*th2o(i)*tco2(i)*abplnk1(5,i,k2)
  637. du03 = 0.0333767*du01
  638. dbeta03 = 0.982143*dbeta01
  639. !
  640. ! 1168 cm-1 band
  641. !
  642. an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03))* &
  643. tw(i,6)*tcfc8*abplnk1(6,i,k2)
  644. !
  645. ! Emissivity for 1064 cm-1 band of CO2
  646. !
  647. du11 = abs(uco211(i,k1) - uco211(i,k2))
  648. du12 = abs(uco212(i,k1) - uco212(i,k2))
  649. du13 = abs(uco213(i,k1) - uco213(i,k2))
  650. dbetc1 = 2.97558*abs(pnm(i,k1) + pnm(i,k2))/(2.0*sslp*sqti(i))
  651. dbetc2 = 2.0*dbetc1
  652. aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
  653. + func(du12,dbetc2) + func(du13,dbetc2)) &
  654. *to3(i)*tw(i,5)*tcfc4*tcfc7*abplnk1(2,i,k2)
  655. !
  656. ! Emissivity for 961 cm-1 band
  657. !
  658. du21 = abs(uco221(i,k1) - uco221(i,k2))
  659. du22 = abs(uco222(i,k1) - uco222(i,k2))
  660. du23 = abs(uco223(i,k1) - uco223(i,k2))
  661. aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
  662. + func(du22,dbetc1) + func(du23,dbetc2)) &
  663. *tw(i,4)*tcfc3*tcfc6*abplnk1(1,i,k2)
  664. !
  665. ! total trace gas absorptivity
  666. !
  667. abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
  668. acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
  669. aco21 + aco22
  670. end do
  671. !
  672. return
  673. !
  674. end subroutine trcab
  675. subroutine trcabn(lchnk ,ncol ,pcols, pverp, &
  676. k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
  677. un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
  678. uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
  679. winpl ,pinpl ,tco2 ,th2o ,to3 , &
  680. uptype ,dw ,s2c ,up2 ,pnew , &
  681. abstrc ,uinpl , &
  682. aer_trn_ngh)
  683. !-----------------------------------------------------------------------
  684. !
  685. ! Purpose:
  686. ! Calculate nearest layer absorptivity due to CH4, N2O, CFC11 and CFC12
  687. !
  688. ! Method:
  689. ! Equations in CCM3 description
  690. !
  691. ! Author: J. Kiehl
  692. !
  693. !-----------------------------------------------------------------------
  694. !
  695. ! use shr_kind_mod, only: r8 => shr_kind_r8
  696. ! use ppgrid
  697. ! use volcrad
  698. implicit none
  699. !------------------------------Arguments--------------------------------
  700. !
  701. ! Input arguments
  702. !
  703. integer, intent(in) :: lchnk ! chunk identifier
  704. integer, intent(in) :: ncol ! number of atmospheric columns
  705. integer, intent(in) :: pcols, pverp
  706. integer, intent(in) :: k2 ! level index
  707. integer, intent(in) :: kn ! level index
  708. !
  709. real(r8), intent(in) :: tbar(pcols,4) ! pressure weighted temperature
  710. real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
  711. real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
  712. real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
  713. real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
  714. !
  715. real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
  716. real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
  717. real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
  718. real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
  719. real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
  720. !
  721. real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
  722. real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
  723. real(r8), intent(in) :: bplnk(14,pcols,4) ! weighted Planck fnc. for absorptivity
  724. real(r8), intent(in) :: winpl(pcols,4) ! fractional path length
  725. real(r8), intent(in) :: pinpl(pcols,4) ! pressure factor for subdivided layer
  726. !
  727. real(r8), intent(in) :: tco2(pcols) ! co2 transmission
  728. real(r8), intent(in) :: th2o(pcols) ! h2o transmission
  729. real(r8), intent(in) :: to3(pcols) ! o3 transmission
  730. real(r8), intent(in) :: dw(pcols) ! h2o path length
  731. real(r8), intent(in) :: pnew(pcols) ! pressure factor
  732. !
  733. real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum factor
  734. real(r8), intent(in) :: uptype(pcols,pverp) ! p-type path length
  735. real(r8), intent(in) :: up2(pcols) ! p squared path length
  736. real(r8), intent(in) :: uinpl(pcols,4) ! Nearest layer subdivision factor
  737. real(r8), intent(in) :: aer_trn_ngh(pcols,bnd_nbr_LW)
  738. ! [fraction] Total transmission between
  739. ! nearest neighbor sub-levels
  740. !
  741. ! Output Arguments
  742. !
  743. real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
  744. !
  745. !--------------------------Local Variables------------------------------
  746. !
  747. integer i,l ! loop counters
  748. !
  749. real(r8) sqti(pcols) ! square root of mean temp
  750. real(r8) rsqti(pcols) ! reciprocal of sqti
  751. real(r8) du1 ! cfc11 path length
  752. real(r8) du2 ! cfc12 path length
  753. real(r8) acfc1 ! absorptivity of cfc11 798 cm-1 band
  754. !
  755. real(r8) acfc2 ! absorptivity of cfc11 846 cm-1 band
  756. real(r8) acfc3 ! absorptivity of cfc11 933 cm-1 band
  757. real(r8) acfc4 ! absorptivity of cfc11 1085 cm-1 band
  758. real(r8) acfc5 ! absorptivity of cfc11 889 cm-1 band
  759. real(r8) acfc6 ! absorptivity of cfc11 923 cm-1 band
  760. !
  761. real(r8) acfc7 ! absorptivity of cfc11 1102 cm-1 band
  762. real(r8) acfc8 ! absorptivity of cfc11 1161 cm-1 band
  763. real(r8) du01 ! n2o path length
  764. real(r8) dbeta01 ! n2o pressure factors
  765. real(r8) dbeta11 ! "
  766. !
  767. real(r8) an2o1 ! absorptivity of the 1285 cm-1 n2o band
  768. real(r8) du02 ! n2o path length
  769. real(r8) dbeta02 ! n2o pressure factor
  770. real(r8) an2o2 ! absorptivity of the 589 cm-1 n2o band
  771. real(r8) du03 ! n2o path length
  772. !
  773. real(r8) dbeta03 ! n2o pressure factor
  774. real(r8) an2o3 ! absorptivity of the 1168 cm-1 n2o band
  775. real(r8) duch4 ! ch4 path length
  776. real(r8) dbetac ! ch4 pressure factor
  777. real(r8) ach4 ! absorptivity of the 1306 cm-1 ch4 band
  778. !
  779. real(r8) du11 ! co2 path length
  780. real(r8) du12 ! "
  781. real(r8) du13 ! "
  782. real(r8) dbetc1 ! co2 pressure factor
  783. real(r8) dbetc2 ! co2 pressure factor
  784. !
  785. real(r8) aco21 ! absorptivity of the 1064 cm-1 co2 band
  786. real(r8) du21 ! co2 path length
  787. real(r8) du22 ! "
  788. real(r8) du23 ! "
  789. real(r8) aco22 ! absorptivity of the 961 cm-1 co2 band
  790. !
  791. real(r8) tt(pcols) ! temp. factor for h2o overlap
  792. real(r8) psi1 ! "
  793. real(r8) phi1 ! "
  794. real(r8) p1 ! factor for h2o overlap
  795. real(r8) w1 ! "
  796. !
  797. real(r8) ds2c(pcols) ! continuum path length
  798. real(r8) duptyp(pcols) ! p-type path length
  799. real(r8) tw(pcols,6) ! h2o transmission overlap
  800. real(r8) g1(6) ! h2o overlap factor
  801. real(r8) g2(6) ! "
  802. !
  803. real(r8) g3(6) ! "
  804. real(r8) g4(6) ! "
  805. real(r8) ab(6) ! h2o temp. factor
  806. real(r8) bb(6) ! "
  807. real(r8) abp(6) ! "
  808. !
  809. real(r8) bbp(6) ! "
  810. real(r8) tcfc3 ! transmission of cfc11 band
  811. real(r8) tcfc4 ! transmission of cfc11 band
  812. real(r8) tcfc6 ! transmission of cfc12 band
  813. real(r8) tcfc7 ! "
  814. !
  815. real(r8) tcfc8 ! "
  816. real(r8) tlw ! h2o transmission
  817. real(r8) tch4 ! ch4 transmission
  818. !
  819. !--------------------------Data Statements------------------------------
  820. !
  821. data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
  822. data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
  823. data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
  824. data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
  825. data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
  826. data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
  827. data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
  828. data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
  829. !
  830. !--------------------------Statement Functions--------------------------
  831. !
  832. real(r8) func, u, b
  833. func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
  834. !
  835. !------------------------------------------------------------------
  836. !
  837. do i = 1,ncol
  838. sqti(i) = sqrt(tbar(i,kn))
  839. rsqti(i) = 1. / sqti(i)
  840. !
  841. ! h2o transmission
  842. !
  843. tt(i) = abs(tbar(i,kn) - 250.0)
  844. ds2c(i) = abs(s2c(i,k2+1) - s2c(i,k2))*uinpl(i,kn)
  845. duptyp(i) = abs(uptype(i,k2+1) - uptype(i,k2))*uinpl(i,kn)
  846. end do
  847. !
  848. do l = 1,6
  849. do i = 1,ncol
  850. psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
  851. phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
  852. p1 = pnew(i) * (psi1/phi1) / sslp
  853. w1 = dw(i) * winpl(i,kn) * phi1
  854. tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
  855. - g3(l)*ds2c(i)-g4(l)*duptyp(i))
  856. end do
  857. end do
  858. !
  859. do i=1,ncol
  860. tw(i,1)=tw(i,1)*(0.7*aer_trn_ngh(i,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
  861. 0.3*aer_trn_ngh(i,idx_LW_0800_1000))
  862. tw(i,2)=tw(i,2)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
  863. tw(i,3)=tw(i,3)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
  864. tw(i,4)=tw(i,4)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
  865. tw(i,5)=tw(i,5)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
  866. tw(i,6)=tw(i,6)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
  867. end do ! end loop over lon
  868. do i = 1,ncol
  869. !
  870. du1 = abs(ucfc11(i,k2+1) - ucfc11(i,k2)) * winpl(i,kn)
  871. du2 = abs(ucfc12(i,k2+1) - ucfc12(i,k2)) * winpl(i,kn)
  872. !
  873. ! cfc transmissions
  874. !
  875. tcfc3 = exp(-175.005*du1)
  876. tcfc4 = exp(-1202.18*du1)
  877. tcfc6 = exp(-5786.73*du2)
  878. tcfc7 = exp(-2873.51*du2)
  879. tcfc8 = exp(-2085.59*du2)
  880. !
  881. ! Absorptivity for CFC11 bands
  882. !
  883. acfc1 = 50.0*(1.0 - exp(-54.09*du1)) * tw(i,1)*bplnk(7,i,kn)
  884. acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*bplnk(8,i,kn)
  885. acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6 * bplnk(9,i,kn)
  886. acfc4 = 100.0*(1.0 - tcfc4)* tw(i,5) * bplnk(10,i,kn)
  887. !
  888. ! Absorptivity for CFC12 bands
  889. !
  890. acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*bplnk(11,i,kn)
  891. acfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*bplnk(12,i,kn)
  892. acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5)*tcfc4 *bplnk(13,i,kn)
  893. acfc8 = 70.0*(1.0 - tcfc8)*tw(i,6)*bplnk(14,i,kn)
  894. !
  895. ! Absorptivity for CH4 band 1306 cm-1
  896. !
  897. tlw = exp(-1.0*sqrt(up2(i)))
  898. tlw=tlw*aer_trn_ngh(i,idx_LW_1200_2000)
  899. duch4 = abs(uch4(i,k2+1) - uch4(i,k2)) * winpl(i,kn)
  900. dbetac = 2.94449 * pinpl(i,kn) * rsqti(i) / sslp
  901. ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac)) * tlw * bplnk(3,i,kn)
  902. tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
  903. !
  904. ! Absorptivity for N2O bands
  905. !
  906. du01 = abs(un2o0(i,k2+1) - un2o0(i,k2)) * winpl(i,kn)
  907. du11 = abs(un2o1(i,k2+1) - un2o1(i,k2)) * winpl(i,kn)
  908. dbeta01 = 19.399 * pinpl(i,kn) * rsqti(i) / sslp
  909. dbeta11 = dbeta01
  910. !
  911. ! 1285 cm-1 band
  912. !
  913. an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
  914. + func(du11,dbeta11)) * tlw * tch4 * bplnk(4,i,kn)
  915. du02 = 0.100090*du01
  916. du12 = 0.0992746*du11
  917. dbeta02 = 0.964282*dbeta01
  918. !
  919. ! 589 cm-1 band
  920. !
  921. an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) &
  922. + func(du12,dbeta02)) * tco2(i) * th2o(i) * bplnk(5,i,kn)
  923. du03 = 0.0333767*du01
  924. dbeta03 = 0.982143*dbeta01
  925. !
  926. ! 1168 cm-1 band
  927. !
  928. an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03)) * &
  929. tw(i,6) * tcfc8 * bplnk(6,i,kn)
  930. !
  931. ! Absorptivity for 1064 cm-1 band of CO2
  932. !
  933. du11 = abs(uco211(i,k2+1) - uco211(i,k2)) * winpl(i,kn)
  934. du12 = abs(uco212(i,k2+1) - uco212(i,k2)) * winpl(i,kn)
  935. du13 = abs(uco213(i,k2+1) - uco213(i,k2)) * winpl(i,kn)
  936. dbetc1 = 2.97558 * pinpl(i,kn) * rsqti(i) / sslp
  937. dbetc2 = 2.0 * dbetc1
  938. aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
  939. + func(du12,dbetc2) + func(du13,dbetc2)) &
  940. * to3(i) * tw(i,5) * tcfc4 * tcfc7 * bplnk(2,i,kn)
  941. !
  942. ! Absorptivity for 961 cm-1 band of co2
  943. !
  944. du21 = abs(uco221(i,k2+1) - uco221(i,k2)) * winpl(i,kn)
  945. du22 = abs(uco222(i,k2+1) - uco222(i,k2)) * winpl(i,kn)
  946. du23 = abs(uco223(i,k2+1) - uco223(i,k2)) * winpl(i,kn)
  947. aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
  948. + func(du22,dbetc1) + func(du23,dbetc2)) &
  949. * tw(i,4) * tcfc3 * tcfc6 * bplnk(1,i,kn)
  950. !
  951. ! total trace gas absorptivity
  952. !
  953. abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
  954. acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
  955. aco21 + aco22
  956. end do
  957. !
  958. return
  959. !
  960. end subroutine trcabn
  961. subroutine trcems(lchnk ,ncol ,pcols, pverp, &
  962. k ,co2t ,pnm ,ucfc11 ,ucfc12 , &
  963. un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
  964. bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
  965. uco222 ,uco223 ,uptype ,w ,s2c , &
  966. up2 ,emplnk ,th2o ,tco2 ,to3 , &
  967. emstrc , &
  968. aer_trn_ttl)
  969. !-----------------------------------------------------------------------
  970. !
  971. ! Purpose:
  972. ! Calculate emissivity for CH4, N2O, CFC11 and CFC12 bands.
  973. !
  974. ! Method:
  975. ! See CCM3 Description for equations.
  976. !
  977. ! Author: J. Kiehl
  978. !
  979. !-----------------------------------------------------------------------
  980. ! use shr_kind_mod, only: r8 => shr_kind_r8
  981. ! use ppgrid
  982. ! use volcrad
  983. implicit none
  984. !
  985. !------------------------------Arguments--------------------------------
  986. !
  987. ! Input arguments
  988. !
  989. integer, intent(in) :: lchnk ! chunk identifier
  990. integer, intent(in) :: ncol ! number of atmospheric columns
  991. integer, intent(in) :: pcols, pverp
  992. real(r8), intent(in) :: co2t(pcols,pverp) ! pressure weighted temperature
  993. real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressure
  994. real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
  995. real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
  996. real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
  997. !
  998. real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
  999. real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
  1000. real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
  1001. real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
  1002. real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
  1003. !
  1004. real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
  1005. real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
  1006. real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
  1007. real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
  1008. real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
  1009. !
  1010. real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
  1011. real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
  1012. real(r8), intent(in) :: emplnk(14,pcols) ! emissivity Planck factor
  1013. real(r8), intent(in) :: th2o(pcols) ! water vapor overlap factor
  1014. real(r8), intent(in) :: tco2(pcols) ! co2 overlap factor
  1015. !
  1016. real(r8), intent(in) :: to3(pcols) ! o3 overlap factor
  1017. real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum path length
  1018. real(r8), intent(in) :: w(pcols,pverp) ! h2o path length
  1019. real(r8), intent(in) :: up2(pcols) ! pressure squared h2o path length
  1020. !
  1021. integer, intent(in) :: k ! level index
  1022. real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
  1023. !
  1024. ! Output Arguments
  1025. !
  1026. real(r8), intent(out) :: emstrc(pcols,pverp) ! total trace gas emissivity
  1027. !
  1028. !--------------------------Local Variables------------------------------
  1029. !
  1030. integer i,l ! loop counters
  1031. !
  1032. real(r8) sqti(pcols) ! square root of mean temp
  1033. real(r8) ecfc1 ! emissivity of cfc11 798 cm-1 band
  1034. real(r8) ecfc2 ! " " " 846 cm-1 band
  1035. real(r8) ecfc3 ! " " " 933 cm-1 band
  1036. real(r8) ecfc4 ! " " " 1085 cm-1 band
  1037. !
  1038. real(r8) ecfc5 ! " " cfc12 889 cm-1 band
  1039. real(r8) ecfc6 ! " " " 923 cm-1 band
  1040. real(r8) ecfc7 ! " " " 1102 cm-1 band
  1041. real(r8) ecfc8 ! " " " 1161 cm-1 band
  1042. real(r8) u01 ! n2o path leng

Large files files are truncated, but you can click here to view the full file