/wrfv2_fire/phys/module_ra_cam_support.F
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
- MODULE module_ra_cam_support
- use module_cam_support, only: endrun
- implicit none
- integer, parameter :: r8 = 8
- real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90
- integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer
- integer :: ixcldliq
- integer :: ixcldice
- ! integer :: levsiz ! size of level dimension on dataset
- integer, parameter :: nbands = 2 ! Number of spectral bands
- integer, parameter :: naer_all = 12 + 1
- integer, parameter :: naer = 10 + 1
- integer, parameter :: bnd_nbr_LW=7
- integer, parameter :: ndstsz = 4 ! number of dust size bins
- integer :: idxSUL
- integer :: idxSSLT
- integer :: idxDUSTfirst
- integer :: idxCARBONfirst
- integer :: idxOCPHO
- integer :: idxBCPHO
- integer :: idxOCPHI
- integer :: idxBCPHI
- integer :: idxBG
- integer :: idxVOLC
- integer :: mxaerl ! Maximum level of background aerosol
- ! indices to sections of array that represent
- ! groups of aerosols
- integer, parameter :: &
- numDUST = 4, &
- numCARBON = 4
- ! portion of each species group to use in computation
- ! of relative radiative forcing.
- real(r8) :: sulscl_rf = 0._r8 !
- real(r8) :: carscl_rf = 0._r8
- real(r8) :: ssltscl_rf = 0._r8
- real(r8) :: dustscl_rf = 0._r8
- real(r8) :: bgscl_rf = 0._r8
- real(r8) :: volcscl_rf = 0._r8
- ! "background" aerosol species mmr.
- real(r8) :: tauback = 0._r8
- ! portion of each species group to use in computation
- ! of aerosol forcing in driving the climate
- real(r8) :: sulscl = 1._r8
- real(r8) :: carscl = 1._r8
- real(r8) :: ssltscl = 1._r8
- real(r8) :: dustscl = 1._r8
- real(r8) :: volcscl = 1._r8
- !From volcrad.F90 module
- integer, parameter :: idx_LW_0500_0650=3
- integer, parameter :: idx_LW_0650_0800=4
- integer, parameter :: idx_LW_0800_1000=5
- integer, parameter :: idx_LW_1000_1200=6
- integer, parameter :: idx_LW_1200_2000=7
- ! First two values represent the overlap of volcanics with the non-window
- ! (0-800, 1200-2200 cm^-1) and window (800-1200 cm^-1) regions.| Coefficients
- ! were derived using crm_volc_minimize.pro with spectral flux optimization
- ! on first iteration, total heating rate on subsequent iterations (2-9).
- ! Five profiles for HLS, HLW, MLS, MLW, and TRO conditions were given equal
- ! weight. RMS heating rate errors for a visible stratospheric optical
- ! depth of 1.0 are 0.02948 K/day.
- !
- real(r8) :: abs_cff_mss_aer(bnd_nbr_LW) = &
- (/ 70.257384, 285.282943, &
- 1.0273851e+02, 6.3073303e+01, 1.2039569e+02, &
- 3.6343643e+02, 2.7138528e+02 /)
- !From radae.F90 module
- real(r8), parameter:: min_tp_h2o = 160.0 ! min T_p for pre-calculated abs/emis
- real(r8), parameter:: max_tp_h2o = 349.999999 ! max T_p for pre-calculated abs/emis
- real(r8), parameter:: dtp_h2o = 21.111111111111 ! difference in adjacent elements of tp_h2o
- real(r8), parameter:: min_te_h2o = -120.0 ! min T_e-T_p for pre-calculated abs/emis
- real(r8), parameter:: max_te_h2o = 79.999999 ! max T_e-T_p for pre-calculated abs/emis
- real(r8), parameter:: dte_h2o = 10.0 ! difference in adjacent elements of te_h2o
- real(r8), parameter:: min_rh_h2o = 0.0 ! min RH for pre-calculated abs/emis
- real(r8), parameter:: max_rh_h2o = 1.19999999 ! max RH for pre-calculated abs/emis
- real(r8), parameter:: drh_h2o = 0.2 ! difference in adjacent elements of RH
- real(r8), parameter:: min_lu_h2o = -8.0 ! min log_10(U) for pre-calculated abs/emis
- real(r8), parameter:: min_u_h2o = 1.0e-8 ! min pressure-weighted path-length
- real(r8), parameter:: max_lu_h2o = 3.9999999 ! max log_10(U) for pre-calculated abs/emis
- real(r8), parameter:: dlu_h2o = 0.5 ! difference in adjacent elements of lu_h2o
- real(r8), parameter:: min_lp_h2o = -3.0 ! min log_10(P) for pre-calculated abs/emis
- real(r8), parameter:: min_p_h2o = 1.0e-3 ! min log_10(P) for pre-calculated abs/emis
- real(r8), parameter:: max_lp_h2o = -0.0000001 ! max log_10(P) for pre-calculated abs/emis
- real(r8), parameter:: dlp_h2o = 0.3333333333333 ! difference in adjacent elements of lp_h2o
- integer, parameter :: n_u = 25 ! Number of U in abs/emis tables
- integer, parameter :: n_p = 10 ! Number of P in abs/emis tables
- integer, parameter :: n_tp = 10 ! Number of T_p in abs/emis tables
- integer, parameter :: n_te = 21 ! Number of T_e in abs/emis tables
- integer, parameter :: n_rh = 7 ! Number of RH in abs/emis tables
- real(r8):: c16,c17,c26,c27,c28,c29,c30,c31
- real(r8):: fwcoef ! Farwing correction constant
- real(r8):: fwc1,fwc2 ! Farwing correction constants
- real(r8):: fc1 ! Farwing correction constant
- real(r8):: amco2 ! Molecular weight of co2 (g/mol)
- real(r8):: amd ! Molecular weight of dry air (g/mol)
- real(r8):: p0 ! Standard pressure (dynes/cm**2)
- ! These are now allocatable. JM 20090612
- real(r8), allocatable, dimension(:,:,:,:,:) :: ah2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (non-window)
- real(r8), allocatable, dimension(:,:,:,:,:) :: eh2onw ! (n_p, n_tp, n_u, n_te, n_rh) ! emissivity (non-window)
- real(r8), allocatable, dimension(:,:,:,:,:) :: ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (window, for adjacent layers)
- real(r8), allocatable, dimension(:,:,:,:,:) :: cn_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for absorptivity (window)
- real(r8), allocatable, dimension(:,:,:,:,:) :: cn_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for emissivity (window)
- real(r8), allocatable, dimension(:,:,:,:,:) :: ln_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for absorptivity (window)
- real(r8), allocatable, dimension(:,:,:,:,:) :: ln_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for emissivity (window)
- !
- ! Constant coefficients for water vapor overlap with trace gases.
- ! Reference: Ramanathan, V. and P.Downey, 1986: A Nonisothermal
- ! Emissivity and Absorptivity Formulation for Water Vapor
- ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
- !
- real(r8):: coefh(2,4) = reshape( &
- (/ (/5.46557e+01,-7.30387e-02/), &
- (/1.09311e+02,-1.46077e-01/), &
- (/5.11479e+01,-6.82615e-02/), &
- (/1.02296e+02,-1.36523e-01/) /), (/2,4/) )
- !
- real(r8):: coefj(3,2) = reshape( &
- (/ (/2.82096e-02,2.47836e-04,1.16904e-06/), &
- (/9.27379e-02,8.04454e-04,6.88844e-06/) /), (/3,2/) )
- !
- real(r8):: coefk(3,2) = reshape( &
- (/ (/2.48852e-01,2.09667e-03,2.60377e-06/) , &
- (/1.03594e+00,6.58620e-03,4.04456e-06/) /), (/3,2/) )
- integer, parameter :: ntemp = 192 ! Number of temperatures in H2O sat. table for Tp
- real(r8) :: estblh2o(0:ntemp) ! saturation vapor pressure for H2O for Tp rang
- integer, parameter :: o_fa = 6 ! Degree+1 of poly of T_e for absorptivity as U->inf.
- integer, parameter :: o_fe = 6 ! Degree+1 of poly of T_e for emissivity as U->inf.
- !-----------------------------------------------------------------------------
- ! Data for f in C/H/E fit -- value of A and E as U->infinity
- ! New C/LT/E fit (Hitran 2K, CKD 2.4) -- no change
- ! These values are determined by integrals of Planck functions or
- ! derivatives of Planck functions only.
- !-----------------------------------------------------------------------------
- !
- ! fa/fe coefficients for 2 bands (0-800 & 1200-2200, 800-1200 cm^-1)
- !
- ! Coefficients of polynomial for f_a in T_e
- !
- real(r8), parameter:: fat(o_fa,nbands) = reshape( (/ &
- (/-1.06665373E-01, 2.90617375E-02, -2.70642049E-04, & ! 0-800&1200-2200 cm^-1
- 1.07595511E-06, -1.97419681E-09, 1.37763374E-12/), & ! 0-800&1200-2200 cm^-1
- (/ 1.10666537E+00, -2.90617375E-02, 2.70642049E-04, & ! 800-1200 cm^-1
- -1.07595511E-06, 1.97419681E-09, -1.37763374E-12/) /) & ! 800-1200 cm^-1
- , (/o_fa,nbands/) )
- !
- ! Coefficients of polynomial for f_e in T_e
- !
- real(r8), parameter:: fet(o_fe,nbands) = reshape( (/ &
- (/3.46148163E-01, 1.51240299E-02, -1.21846479E-04, & ! 0-800&1200-2200 cm^-1
- 4.04970123E-07, -6.15368936E-10, 3.52415071E-13/), & ! 0-800&1200-2200 cm^-1
- (/6.53851837E-01, -1.51240299E-02, 1.21846479E-04, & ! 800-1200 cm^-1
- -4.04970123E-07, 6.15368936E-10, -3.52415071E-13/) /) & ! 800-1200 cm^-1
- , (/o_fa,nbands/) )
- real(r8) :: gravit ! Acceleration of gravity (cgs)
- real(r8) :: rga ! 1./gravit
- real(r8) :: gravmks ! Acceleration of gravity (mks)
- real(r8) :: cpair ! Specific heat of dry air
- real(r8) :: epsilo ! Ratio of mol. wght of H2O to dry air
- real(r8) :: epsqs ! Ratio of mol. wght of H2O to dry air
- real(r8) :: sslp ! Standard sea-level pressure
- real(r8) :: stebol ! Stefan-Boltzmann's constant
- real(r8) :: rgsslp ! 0.5/(gravit*sslp)
- real(r8) :: dpfo3 ! Voigt correction factor for O3
- real(r8) :: dpfco2 ! Voigt correction factor for CO2
- real(r8) :: dayspy ! Number of days per 1 year
- real(r8) :: pie ! 3.14.....
- real(r8) :: mwdry ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
- real(r8) :: scon ! solar constant (not used in WRF)
- real(r8) :: co2mmr
- real(r8) :: mwco2 ! molecular weight of carbon dioxide
- real(r8) :: mwh2o ! molecular weight water vapor (shr_const_mwwv)
- real(r8) :: mwch4 ! molecular weight ch4
- real(r8) :: mwn2o ! molecular weight n2o
- real(r8) :: mwf11 ! molecular weight cfc11
- real(r8) :: mwf12 ! molecular weight cfc12
- real(r8) :: cappa ! R/Cp
- real(r8) :: rair ! Gas constant for dry air (J/K/kg)
- real(r8) :: tmelt ! freezing T of fresh water ~ K
- real(r8) :: r_universal ! Universal gas constant ~ J/K/kmole
- real(r8) :: latvap ! latent heat of evaporation ~ J/kg
- real(r8) :: latice ! latent heat of fusion ~ J/kg
- real(r8) :: zvir ! R_V/R_D - 1.
- integer plenest ! length of saturation vapor pressure table
- parameter (plenest=250)
- !
- ! Table of saturation vapor pressure values es from tmin degrees
- ! to tmax+1 degrees k in one degree increments. ttrice defines the
- ! transition region where es is a combination of ice & water values
- !
- real(r8) estbl(plenest) ! table values of saturation vapor pressure
- real(r8) tmin ! min temperature (K) for table
- real(r8) tmax ! max temperature (K) for table
- real(r8) pcf(6) ! polynomial coeffs -> es transition water to ice
- !real(r8), allocatable :: pin(:) ! ozone pressure level (levsiz)
- !real(r8), allocatable :: ozmix(:,:,:) ! mixing ratio
- !real(r8), allocatable, target :: abstot_3d(:,:,:,:) ! Non-adjacent layer absorptivites
- !real(r8), allocatable, target :: absnxt_3d(:,:,:,:) ! Nearest layer absorptivities
- !real(r8), allocatable, target :: emstot_3d(:,:,:) ! Total emissivity
- !From aer_optics.F90 module
- integer, parameter :: idxVIS = 8 ! index to visible band
- integer, parameter :: nrh = 1000 ! number of relative humidity values for look-up-table
- integer, parameter :: nspint = 19 ! number of spectral intervals
- ! These are now allocatable, JM 20090612
- real(r8), allocatable, dimension(:,:) :: ksul ! (nrh, nspint) ! sulfate specific extinction ( m^2 g-1 )
- real(r8), allocatable, dimension(:,:) :: wsul ! (nrh, nspint) ! sulfate single scattering albedo
- real(r8), allocatable, dimension(:,:) :: gsul ! (nrh, nspint) ! sulfate asymmetry parameter
- real(r8), allocatable, dimension(:,:) :: ksslt ! (nrh, nspint) ! sea-salt specific extinction ( m^2 g-1 )
- real(r8), allocatable, dimension(:,:) :: wsslt ! (nrh, nspint) ! sea-salt single scattering albedo
- real(r8), allocatable, dimension(:,:) :: gsslt ! (nrh, nspint) ! sea-salt asymmetry parameter
- real(r8), allocatable, dimension(:,:) :: kcphil ! (nrh, nspint) ! hydrophilic carbon specific extinction ( m^2 g-1 )
- real(r8), allocatable, dimension(:,:) :: wcphil ! (nrh, nspint) ! hydrophilic carbon single scattering albedo
- real(r8), allocatable, dimension(:,:) :: gcphil ! (nrh, nspint) ! hydrophilic carbon asymmetry parameter
- real(r8) :: kbg(nspint) ! background specific extinction ( m^2 g-1 )
- real(r8) :: wbg(nspint) ! background single scattering albedo
- real(r8) :: gbg(nspint) ! background asymmetry parameter
- real(r8) :: kcphob(nspint) ! hydrophobic carbon specific extinction ( m^2 g-1 )
- real(r8) :: wcphob(nspint) ! hydrophobic carbon single scattering albedo
- real(r8) :: gcphob(nspint) ! hydrophobic carbon asymmetry parameter
- real(r8) :: kcb(nspint) ! black carbon specific extinction ( m^2 g-1 )
- real(r8) :: wcb(nspint) ! black carbon single scattering albedo
- real(r8) :: gcb(nspint) ! black carbon asymmetry parameter
- real(r8) :: kvolc(nspint) ! volcanic specific extinction ( m^2 g-1)
- real(r8) :: wvolc(nspint) ! volcanic single scattering albedo
- real(r8) :: gvolc(nspint) ! volcanic asymmetry parameter
- real(r8) :: kdst(ndstsz, nspint) ! dust specific extinction ( m^2 g-1 )
- real(r8) :: wdst(ndstsz, nspint) ! dust single scattering albedo
- real(r8) :: gdst(ndstsz, nspint) ! dust asymmetry parameter
- !
- !From comozp.F90 module
- real(r8) cplos ! constant for ozone path length integral
- real(r8) cplol ! constant for ozone path length integral
- !From ghg_surfvals.F90 module
- real(r8) :: co2vmr = 3.550e-4 ! co2 volume mixing ratio
- real(r8) :: n2ovmr = 0.311e-6 ! n2o volume mixing ratio
- real(r8) :: ch4vmr = 1.714e-6 ! ch4 volume mixing ratio
- real(r8) :: f11vmr = 0.280e-9 ! cfc11 volume mixing ratio
- real(r8) :: f12vmr = 0.503e-9 ! cfc12 volume mixing ratio
- integer, parameter :: cyr = 233 ! number of years of co2 data
- integer :: yrdata(cyr) = &
- (/ 1869, 1870, 1871, 1872, 1873, 1874, 1875, &
- 1876, 1877, 1878, 1879, 1880, 1881, 1882, &
- 1883, 1884, 1885, 1886, 1887, 1888, 1889, &
- 1890, 1891, 1892, 1893, 1894, 1895, 1896, &
- 1897, 1898, 1899, 1900, 1901, 1902, 1903, &
- 1904, 1905, 1906, 1907, 1908, 1909, 1910, &
- 1911, 1912, 1913, 1914, 1915, 1916, 1917, &
- 1918, 1919, 1920, 1921, 1922, 1923, 1924, &
- 1925, 1926, 1927, 1928, 1929, 1930, 1931, &
- 1932, 1933, 1934, 1935, 1936, 1937, 1938, &
- 1939, 1940, 1941, 1942, 1943, 1944, 1945, &
- 1946, 1947, 1948, 1949, 1950, 1951, 1952, &
- 1953, 1954, 1955, 1956, 1957, 1958, 1959, &
- 1960, 1961, 1962, 1963, 1964, 1965, 1966, &
- 1967, 1968, 1969, 1970, 1971, 1972, 1973, &
- 1974, 1975, 1976, 1977, 1978, 1979, 1980, &
- 1981, 1982, 1983, 1984, 1985, 1986, 1987, &
- 1988, 1989, 1990, 1991, 1992, 1993, 1994, &
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, &
- 2002, 2003, 2004, 2005, 2006, 2007, 2008, &
- 2009, 2010, 2011, 2012, 2013, 2014, 2015, &
- 2016, 2017, 2018, 2019, 2020, 2021, 2022, &
- 2023, 2024, 2025, 2026, 2027, 2028, 2029, &
- 2030, 2031, 2032, 2033, 2034, 2035, 2036, &
- 2037, 2038, 2039, 2040, 2041, 2042, 2043, &
- 2044, 2045, 2046, 2047, 2048, 2049, 2050, &
- 2051, 2052, 2053, 2054, 2055, 2056, 2057, &
- 2058, 2059, 2060, 2061, 2062, 2063, 2064, &
- 2065, 2066, 2067, 2068, 2069, 2070, 2071, &
- 2072, 2073, 2074, 2075, 2076, 2077, 2078, &
- 2079, 2080, 2081, 2082, 2083, 2084, 2085, &
- 2086, 2087, 2088, 2089, 2090, 2091, 2092, &
- 2093, 2094, 2095, 2096, 2097, 2098, 2099, &
- 2100, 2101 /)
- ! A2 future scenario
- real(r8) :: co2(cyr) = &
- (/ 289.263, 289.263, 289.416, 289.577, 289.745, 289.919, 290.102, &
- 290.293, 290.491, 290.696, 290.909, 291.129, 291.355, 291.587, 291.824, &
- 292.066, 292.313, 292.563, 292.815, 293.071, 293.328, 293.586, 293.843, &
- 294.098, 294.35, 294.598, 294.842, 295.082, 295.32, 295.558, 295.797, &
- 296.038, 296.284, 296.535, 296.794, 297.062, 297.338, 297.62, 297.91, &
- 298.204, 298.504, 298.806, 299.111, 299.419, 299.729, 300.04, 300.352, &
- 300.666, 300.98, 301.294, 301.608, 301.923, 302.237, 302.551, 302.863, &
- 303.172, 303.478, 303.779, 304.075, 304.366, 304.651, 304.93, 305.206, &
- 305.478, 305.746, 306.013, 306.28, 306.546, 306.815, 307.087, 307.365, &
- 307.65, 307.943, 308.246, 308.56, 308.887, 309.228, 309.584, 309.956, &
- 310.344, 310.749, 311.172, 311.614, 312.077, 312.561, 313.068, 313.599, &
- 314.154, 314.737, 315.347, 315.984, 316.646, 317.328, 318.026, 318.742, &
- 319.489, 320.282, 321.133, 322.045, 323.021, 324.06, 325.155, 326.299, &
- 327.484, 328.698, 329.933, 331.194, 332.499, 333.854, 335.254, 336.69, &
- 338.15, 339.628, 341.125, 342.65, 344.206, 345.797, 347.397, 348.98, &
- 350.551, 352.1, 354.3637, 355.7772, 357.1601, 358.5306, 359.9046, &
- 361.4157, 363.0445, 364.7761, 366.6064, 368.5322, 370.534, 372.5798, &
- 374.6564, 376.7656, 378.9087, 381.0864, 383.2994, 385.548, 387.8326, &
- 390.1536, 392.523, 394.9625, 397.4806, 400.075, 402.7444, 405.4875, &
- 408.3035, 411.1918, 414.1518, 417.1831, 420.2806, 423.4355, 426.6442, &
- 429.9076, 433.2261, 436.6002, 440.0303, 443.5168, 447.06, 450.6603, &
- 454.3059, 457.9756, 461.6612, 465.3649, 469.0886, 472.8335, 476.6008, &
- 480.3916, 484.2069, 488.0473, 491.9184, 495.8295, 499.7849, 503.7843, &
- 507.8278, 511.9155, 516.0476, 520.2243, 524.4459, 528.7127, 533.0213, &
- 537.3655, 541.7429, 546.1544, 550.6005, 555.0819, 559.5991, 564.1525, &
- 568.7429, 573.3701, 578.0399, 582.7611, 587.5379, 592.3701, 597.2572, &
- 602.1997, 607.1975, 612.2507, 617.3596, 622.524, 627.7528, 633.0616, &
- 638.457, 643.9384, 649.505, 655.1568, 660.8936, 666.7153, 672.6219, &
- 678.6133, 684.6945, 690.8745, 697.1569, 703.5416, 710.0284, 716.6172, &
- 723.308, 730.1008, 736.9958, 743.993, 751.0975, 758.3183, 765.6594, &
- 773.1207, 780.702, 788.4033, 796.2249, 804.1667, 812.2289, 820.4118, &
- 828.6444, 828.6444 /)
- integer :: ntoplw ! top level to solve for longwave cooling (WRF sets this to 1 for model top below 10 mb)
- logical :: masterproc = .true.
- logical :: ozncyc ! true => cycle ozone dataset
- ! logical :: dosw ! True => shortwave calculation this timestep
- ! logical :: dolw ! True => longwave calculation this timestep
- logical :: indirect ! True => include indirect radiative effects of sulfate aerosols
- ! logical :: doabsems ! True => abs/emiss calculation this timestep
- logical :: radforce = .false. ! True => calculate aerosol shortwave forcing
- logical :: trace_gas=.false. ! set true for chemistry
- logical :: strat_volcanic = .false. ! True => volcanic aerosol mass available
- real(r8) retab(95)
- !
- ! Tabulated values of re(T) in the temperature interval
- ! 180 K -- 274 K; hexagonal columns assumed:
- !
- data retab / &
- 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
- 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
- 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
- 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
- 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
- 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
- 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
- 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
- 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
- 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
- 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
- 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
- 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
- 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
- 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
- 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
- !
- save retab
- contains
- subroutine sortarray(n, ain, indxa)
- !-----------------------------------------------
- !
- ! Purpose:
- ! Sort an array
- ! Alogrithm:
- ! Based on Shell's sorting method.
- !
- ! Author: T. Craig
- !-----------------------------------------------
- ! use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
- !
- ! Arguments
- !
- integer , intent(in) :: n ! total number of elements
- integer , intent(inout) :: indxa(n) ! array of integers
- real(r8), intent(inout) :: ain(n) ! array to sort
- !
- ! local variables
- !
- integer :: i, j ! Loop indices
- integer :: ni ! Starting increment
- integer :: itmp ! Temporary index
- real(r8):: atmp ! Temporary value to swap
-
- ni = 1
- do while(.TRUE.)
- ni = 3*ni + 1
- if (ni <= n) cycle
- exit
- end do
-
- do while(.TRUE.)
- ni = ni/3
- do i = ni + 1, n
- atmp = ain(i)
- itmp = indxa(i)
- j = i
- do while(.TRUE.)
- if (ain(j-ni) <= atmp) exit
- ain(j) = ain(j-ni)
- indxa(j) = indxa(j-ni)
- j = j - ni
- if (j > ni) cycle
- exit
- end do
- ain(j) = atmp
- indxa(j) = itmp
- end do
- if (ni > 1) cycle
- exit
- end do
- return
-
- end subroutine sortarray
- subroutine trcab(lchnk ,ncol ,pcols, pverp, &
- k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
- un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
- uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
- bch4 ,to3co2 ,pnm ,dw ,pnew , &
- s2c ,uptype ,dplh2o ,abplnk1 ,tco2 , &
- th2o ,to3 ,abstrc , &
- aer_trn_ttl)
- !-----------------------------------------------------------------------
- !
- ! Purpose:
- ! Calculate absorptivity for non nearest layers for CH4, N2O, CFC11 and
- ! CFC12.
- !
- ! Method:
- ! See CCM3 description for equations.
- !
- ! Author: J. Kiehl
- !
- !-----------------------------------------------------------------------
- ! use shr_kind_mod, only: r8 => shr_kind_r8
- ! use ppgrid
- ! use volcrad
- implicit none
- !------------------------------Arguments--------------------------------
- !
- ! Input arguments
- !
- integer, intent(in) :: lchnk ! chunk identifier
- integer, intent(in) :: ncol ! number of atmospheric columns
- integer, intent(in) :: pcols, pverp
- integer, intent(in) :: k1,k2 ! level indices
- !
- real(r8), intent(in) :: to3co2(pcols) ! pressure weighted temperature
- real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressures
- real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
- real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
- real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
- !
- real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
- real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
- real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
- !
- real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
- real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
- !
- real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
- real(r8), intent(in) :: dw(pcols) ! h2o path length
- real(r8), intent(in) :: pnew(pcols) ! pressure
- real(r8), intent(in) :: s2c(pcols,pverp) ! continuum path length
- real(r8), intent(in) :: uptype(pcols,pverp) ! p-type h2o path length
- !
- real(r8), intent(in) :: dplh2o(pcols) ! p squared h2o path length
- real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! Planck factor
- real(r8), intent(in) :: tco2(pcols) ! co2 transmission factor
- real(r8), intent(in) :: th2o(pcols) ! h2o transmission factor
- real(r8), intent(in) :: to3(pcols) ! o3 transmission factor
- real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
- !
- ! Output Arguments
- !
- real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
- !
- !--------------------------Local Variables------------------------------
- !
- integer i,l ! loop counters
- real(r8) sqti(pcols) ! square root of mean temp
- real(r8) du1 ! cfc11 path length
- real(r8) du2 ! cfc12 path length
- real(r8) acfc1 ! cfc11 absorptivity 798 cm-1
- real(r8) acfc2 ! cfc11 absorptivity 846 cm-1
- !
- real(r8) acfc3 ! cfc11 absorptivity 933 cm-1
- real(r8) acfc4 ! cfc11 absorptivity 1085 cm-1
- real(r8) acfc5 ! cfc12 absorptivity 889 cm-1
- real(r8) acfc6 ! cfc12 absorptivity 923 cm-1
- real(r8) acfc7 ! cfc12 absorptivity 1102 cm-1
- !
- real(r8) acfc8 ! cfc12 absorptivity 1161 cm-1
- real(r8) du01 ! n2o path length
- real(r8) dbeta01 ! n2o pressure factor
- real(r8) dbeta11 ! "
- real(r8) an2o1 ! absorptivity of 1285 cm-1 n2o band
- !
- real(r8) du02 ! n2o path length
- real(r8) dbeta02 ! n2o pressure factor
- real(r8) an2o2 ! absorptivity of 589 cm-1 n2o band
- real(r8) du03 ! n2o path length
- real(r8) dbeta03 ! n2o pressure factor
- !
- real(r8) an2o3 ! absorptivity of 1168 cm-1 n2o band
- real(r8) duch4 ! ch4 path length
- real(r8) dbetac ! ch4 pressure factor
- real(r8) ach4 ! absorptivity of 1306 cm-1 ch4 band
- real(r8) du11 ! co2 path length
- !
- real(r8) du12 ! "
- real(r8) du13 ! "
- real(r8) dbetc1 ! co2 pressure factor
- real(r8) dbetc2 ! co2 pressure factor
- real(r8) aco21 ! absorptivity of 1064 cm-1 band
- !
- real(r8) du21 ! co2 path length
- real(r8) du22 ! "
- real(r8) du23 ! "
- real(r8) aco22 ! absorptivity of 961 cm-1 band
- real(r8) tt(pcols) ! temp. factor for h2o overlap factor
- !
- real(r8) psi1 ! "
- real(r8) phi1 ! "
- real(r8) p1 ! h2o overlap factor
- real(r8) w1 ! "
- real(r8) ds2c(pcols) ! continuum path length
- !
- real(r8) duptyp(pcols) ! p-type path length
- real(r8) tw(pcols,6) ! h2o transmission factor
- real(r8) g1(6) ! "
- real(r8) g2(6) ! "
- real(r8) g3(6) ! "
- !
- real(r8) g4(6) ! "
- real(r8) ab(6) ! h2o temp. factor
- real(r8) bb(6) ! "
- real(r8) abp(6) ! "
- real(r8) bbp(6) ! "
- !
- real(r8) tcfc3 ! transmission for cfc11 band
- real(r8) tcfc4 ! transmission for cfc11 band
- real(r8) tcfc6 ! transmission for cfc12 band
- real(r8) tcfc7 ! transmission for cfc12 band
- real(r8) tcfc8 ! transmission for cfc12 band
- !
- real(r8) tlw ! h2o transmission
- real(r8) tch4 ! ch4 transmission
- !
- !--------------------------Data Statements------------------------------
- !
- data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
- data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
- data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
- data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
- data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
- data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
- data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
- data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
- !
- !--------------------------Statement Functions--------------------------
- !
- real(r8) func, u, b
- func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
- !
- !------------------------------------------------------------------------
- !
- do i = 1,ncol
- sqti(i) = sqrt(to3co2(i))
- !
- ! h2o transmission
- !
- tt(i) = abs(to3co2(i) - 250.0)
- ds2c(i) = abs(s2c(i,k1) - s2c(i,k2))
- duptyp(i) = abs(uptype(i,k1) - uptype(i,k2))
- end do
- !
- do l = 1,6
- do i = 1,ncol
- psi1 = exp(abp(l)*tt(i) + bbp(l)*tt(i)*tt(i))
- phi1 = exp(ab(l)*tt(i) + bb(l)*tt(i)*tt(i))
- p1 = pnew(i)*(psi1/phi1)/sslp
- w1 = dw(i)*phi1
- tw(i,l) = exp(-g1(l)*p1*(sqrt(1.0 + g2(l)*(w1/p1)) - 1.0) - &
- g3(l)*ds2c(i)-g4(l)*duptyp(i))
- end do
- end do
- !
- do i=1,ncol
- tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
- 0.3*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000))
- tw(i,2)=tw(i,2)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
- tw(i,3)=tw(i,3)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
- tw(i,4)=tw(i,4)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
- tw(i,5)=tw(i,5)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
- tw(i,6)=tw(i,6)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
- end do ! end loop over lon
- do i = 1,ncol
- du1 = abs(ucfc11(i,k1) - ucfc11(i,k2))
- du2 = abs(ucfc12(i,k1) - ucfc12(i,k2))
- !
- ! cfc transmissions
- !
- tcfc3 = exp(-175.005*du1)
- tcfc4 = exp(-1202.18*du1)
- tcfc6 = exp(-5786.73*du2)
- tcfc7 = exp(-2873.51*du2)
- tcfc8 = exp(-2085.59*du2)
- !
- ! Absorptivity for CFC11 bands
- !
- acfc1 = 50.0*(1.0 - exp(-54.09*du1))*tw(i,1)*abplnk1(7,i,k2)
- acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*abplnk1(8,i,k2)
- acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*abplnk1(9,i,k2)
- acfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*abplnk1(10,i,k2)
- !
- ! Absorptivity for CFC12 bands
- !
- acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*abplnk1(11,i,k2)
- acfc6 = 50.0*(1.0 - tcfc6)* tw(i,4) * abplnk1(12,i,k2)
- acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5) * tcfc4*abplnk1(13,i,k2)
- acfc8 = 70.0*(1.0 - tcfc8)* tw(i,6) * abplnk1(14,i,k2)
- !
- ! Emissivity for CH4 band 1306 cm-1
- !
- tlw = exp(-1.0*sqrt(dplh2o(i)))
- tlw=tlw*aer_trn_ttl(i,k1,k2,idx_LW_1200_2000)
- duch4 = abs(uch4(i,k1) - uch4(i,k2))
- dbetac = abs(bch4(i,k1) - bch4(i,k2))/duch4
- ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac))*tlw*abplnk1(3,i,k2)
- tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
- !
- ! Absorptivity for N2O bands
- !
- du01 = abs(un2o0(i,k1) - un2o0(i,k2))
- du11 = abs(un2o1(i,k1) - un2o1(i,k2))
- dbeta01 = abs(bn2o0(i,k1) - bn2o0(i,k2))/du01
- dbeta11 = abs(bn2o1(i,k1) - bn2o1(i,k2))/du11
- !
- ! 1285 cm-1 band
- !
- an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
- + func(du11,dbeta11))*tlw*tch4*abplnk1(4,i,k2)
- du02 = 0.100090*du01
- du12 = 0.0992746*du11
- dbeta02 = 0.964282*dbeta01
- !
- ! 589 cm-1 band
- !
- an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) + &
- func(du12,dbeta02))*th2o(i)*tco2(i)*abplnk1(5,i,k2)
- du03 = 0.0333767*du01
- dbeta03 = 0.982143*dbeta01
- !
- ! 1168 cm-1 band
- !
- an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03))* &
- tw(i,6)*tcfc8*abplnk1(6,i,k2)
- !
- ! Emissivity for 1064 cm-1 band of CO2
- !
- du11 = abs(uco211(i,k1) - uco211(i,k2))
- du12 = abs(uco212(i,k1) - uco212(i,k2))
- du13 = abs(uco213(i,k1) - uco213(i,k2))
- dbetc1 = 2.97558*abs(pnm(i,k1) + pnm(i,k2))/(2.0*sslp*sqti(i))
- dbetc2 = 2.0*dbetc1
- aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
- + func(du12,dbetc2) + func(du13,dbetc2)) &
- *to3(i)*tw(i,5)*tcfc4*tcfc7*abplnk1(2,i,k2)
- !
- ! Emissivity for 961 cm-1 band
- !
- du21 = abs(uco221(i,k1) - uco221(i,k2))
- du22 = abs(uco222(i,k1) - uco222(i,k2))
- du23 = abs(uco223(i,k1) - uco223(i,k2))
- aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
- + func(du22,dbetc1) + func(du23,dbetc2)) &
- *tw(i,4)*tcfc3*tcfc6*abplnk1(1,i,k2)
- !
- ! total trace gas absorptivity
- !
- abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
- acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
- aco21 + aco22
- end do
- !
- return
- !
- end subroutine trcab
- subroutine trcabn(lchnk ,ncol ,pcols, pverp, &
- k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
- un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
- uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
- winpl ,pinpl ,tco2 ,th2o ,to3 , &
- uptype ,dw ,s2c ,up2 ,pnew , &
- abstrc ,uinpl , &
- aer_trn_ngh)
- !-----------------------------------------------------------------------
- !
- ! Purpose:
- ! Calculate nearest layer absorptivity due to CH4, N2O, CFC11 and CFC12
- !
- ! Method:
- ! Equations in CCM3 description
- !
- ! Author: J. Kiehl
- !
- !-----------------------------------------------------------------------
- !
- ! use shr_kind_mod, only: r8 => shr_kind_r8
- ! use ppgrid
- ! use volcrad
- implicit none
-
- !------------------------------Arguments--------------------------------
- !
- ! Input arguments
- !
- integer, intent(in) :: lchnk ! chunk identifier
- integer, intent(in) :: ncol ! number of atmospheric columns
- integer, intent(in) :: pcols, pverp
- integer, intent(in) :: k2 ! level index
- integer, intent(in) :: kn ! level index
- !
- real(r8), intent(in) :: tbar(pcols,4) ! pressure weighted temperature
- real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
- real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
- real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
- real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
- !
- real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
- real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
- !
- real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: bplnk(14,pcols,4) ! weighted Planck fnc. for absorptivity
- real(r8), intent(in) :: winpl(pcols,4) ! fractional path length
- real(r8), intent(in) :: pinpl(pcols,4) ! pressure factor for subdivided layer
- !
- real(r8), intent(in) :: tco2(pcols) ! co2 transmission
- real(r8), intent(in) :: th2o(pcols) ! h2o transmission
- real(r8), intent(in) :: to3(pcols) ! o3 transmission
- real(r8), intent(in) :: dw(pcols) ! h2o path length
- real(r8), intent(in) :: pnew(pcols) ! pressure factor
- !
- real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum factor
- real(r8), intent(in) :: uptype(pcols,pverp) ! p-type path length
- real(r8), intent(in) :: up2(pcols) ! p squared path length
- real(r8), intent(in) :: uinpl(pcols,4) ! Nearest layer subdivision factor
- real(r8), intent(in) :: aer_trn_ngh(pcols,bnd_nbr_LW)
- ! [fraction] Total transmission between
- ! nearest neighbor sub-levels
- !
- ! Output Arguments
- !
- real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
- !
- !--------------------------Local Variables------------------------------
- !
- integer i,l ! loop counters
- !
- real(r8) sqti(pcols) ! square root of mean temp
- real(r8) rsqti(pcols) ! reciprocal of sqti
- real(r8) du1 ! cfc11 path length
- real(r8) du2 ! cfc12 path length
- real(r8) acfc1 ! absorptivity of cfc11 798 cm-1 band
- !
- real(r8) acfc2 ! absorptivity of cfc11 846 cm-1 band
- real(r8) acfc3 ! absorptivity of cfc11 933 cm-1 band
- real(r8) acfc4 ! absorptivity of cfc11 1085 cm-1 band
- real(r8) acfc5 ! absorptivity of cfc11 889 cm-1 band
- real(r8) acfc6 ! absorptivity of cfc11 923 cm-1 band
- !
- real(r8) acfc7 ! absorptivity of cfc11 1102 cm-1 band
- real(r8) acfc8 ! absorptivity of cfc11 1161 cm-1 band
- real(r8) du01 ! n2o path length
- real(r8) dbeta01 ! n2o pressure factors
- real(r8) dbeta11 ! "
- !
- real(r8) an2o1 ! absorptivity of the 1285 cm-1 n2o band
- real(r8) du02 ! n2o path length
- real(r8) dbeta02 ! n2o pressure factor
- real(r8) an2o2 ! absorptivity of the 589 cm-1 n2o band
- real(r8) du03 ! n2o path length
- !
- real(r8) dbeta03 ! n2o pressure factor
- real(r8) an2o3 ! absorptivity of the 1168 cm-1 n2o band
- real(r8) duch4 ! ch4 path length
- real(r8) dbetac ! ch4 pressure factor
- real(r8) ach4 ! absorptivity of the 1306 cm-1 ch4 band
- !
- real(r8) du11 ! co2 path length
- real(r8) du12 ! "
- real(r8) du13 ! "
- real(r8) dbetc1 ! co2 pressure factor
- real(r8) dbetc2 ! co2 pressure factor
- !
- real(r8) aco21 ! absorptivity of the 1064 cm-1 co2 band
- real(r8) du21 ! co2 path length
- real(r8) du22 ! "
- real(r8) du23 ! "
- real(r8) aco22 ! absorptivity of the 961 cm-1 co2 band
- !
- real(r8) tt(pcols) ! temp. factor for h2o overlap
- real(r8) psi1 ! "
- real(r8) phi1 ! "
- real(r8) p1 ! factor for h2o overlap
- real(r8) w1 ! "
- !
- real(r8) ds2c(pcols) ! continuum path length
- real(r8) duptyp(pcols) ! p-type path length
- real(r8) tw(pcols,6) ! h2o transmission overlap
- real(r8) g1(6) ! h2o overlap factor
- real(r8) g2(6) ! "
- !
- real(r8) g3(6) ! "
- real(r8) g4(6) ! "
- real(r8) ab(6) ! h2o temp. factor
- real(r8) bb(6) ! "
- real(r8) abp(6) ! "
- !
- real(r8) bbp(6) ! "
- real(r8) tcfc3 ! transmission of cfc11 band
- real(r8) tcfc4 ! transmission of cfc11 band
- real(r8) tcfc6 ! transmission of cfc12 band
- real(r8) tcfc7 ! "
- !
- real(r8) tcfc8 ! "
- real(r8) tlw ! h2o transmission
- real(r8) tch4 ! ch4 transmission
- !
- !--------------------------Data Statements------------------------------
- !
- data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
- data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
- data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
- data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
- data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
- data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
- data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
- data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
- !
- !--------------------------Statement Functions--------------------------
- !
- real(r8) func, u, b
- func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
- !
- !------------------------------------------------------------------
- !
- do i = 1,ncol
- sqti(i) = sqrt(tbar(i,kn))
- rsqti(i) = 1. / sqti(i)
- !
- ! h2o transmission
- !
- tt(i) = abs(tbar(i,kn) - 250.0)
- ds2c(i) = abs(s2c(i,k2+1) - s2c(i,k2))*uinpl(i,kn)
- duptyp(i) = abs(uptype(i,k2+1) - uptype(i,k2))*uinpl(i,kn)
- end do
- !
- do l = 1,6
- do i = 1,ncol
- psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
- phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
- p1 = pnew(i) * (psi1/phi1) / sslp
- w1 = dw(i) * winpl(i,kn) * phi1
- tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
- - g3(l)*ds2c(i)-g4(l)*duptyp(i))
- end do
- end do
- !
- do i=1,ncol
- tw(i,1)=tw(i,1)*(0.7*aer_trn_ngh(i,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
- 0.3*aer_trn_ngh(i,idx_LW_0800_1000))
- tw(i,2)=tw(i,2)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
- tw(i,3)=tw(i,3)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
- tw(i,4)=tw(i,4)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
- tw(i,5)=tw(i,5)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
- tw(i,6)=tw(i,6)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
- end do ! end loop over lon
- do i = 1,ncol
- !
- du1 = abs(ucfc11(i,k2+1) - ucfc11(i,k2)) * winpl(i,kn)
- du2 = abs(ucfc12(i,k2+1) - ucfc12(i,k2)) * winpl(i,kn)
- !
- ! cfc transmissions
- !
- tcfc3 = exp(-175.005*du1)
- tcfc4 = exp(-1202.18*du1)
- tcfc6 = exp(-5786.73*du2)
- tcfc7 = exp(-2873.51*du2)
- tcfc8 = exp(-2085.59*du2)
- !
- ! Absorptivity for CFC11 bands
- !
- acfc1 = 50.0*(1.0 - exp(-54.09*du1)) * tw(i,1)*bplnk(7,i,kn)
- acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*bplnk(8,i,kn)
- acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6 * bplnk(9,i,kn)
- acfc4 = 100.0*(1.0 - tcfc4)* tw(i,5) * bplnk(10,i,kn)
- !
- ! Absorptivity for CFC12 bands
- !
- acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*bplnk(11,i,kn)
- acfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*bplnk(12,i,kn)
- acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5)*tcfc4 *bplnk(13,i,kn)
- acfc8 = 70.0*(1.0 - tcfc8)*tw(i,6)*bplnk(14,i,kn)
- !
- ! Absorptivity for CH4 band 1306 cm-1
- !
- tlw = exp(-1.0*sqrt(up2(i)))
- tlw=tlw*aer_trn_ngh(i,idx_LW_1200_2000)
- duch4 = abs(uch4(i,k2+1) - uch4(i,k2)) * winpl(i,kn)
- dbetac = 2.94449 * pinpl(i,kn) * rsqti(i) / sslp
- ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac)) * tlw * bplnk(3,i,kn)
- tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
- !
- ! Absorptivity for N2O bands
- !
- du01 = abs(un2o0(i,k2+1) - un2o0(i,k2)) * winpl(i,kn)
- du11 = abs(un2o1(i,k2+1) - un2o1(i,k2)) * winpl(i,kn)
- dbeta01 = 19.399 * pinpl(i,kn) * rsqti(i) / sslp
- dbeta11 = dbeta01
- !
- ! 1285 cm-1 band
- !
- an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
- + func(du11,dbeta11)) * tlw * tch4 * bplnk(4,i,kn)
- du02 = 0.100090*du01
- du12 = 0.0992746*du11
- dbeta02 = 0.964282*dbeta01
- !
- ! 589 cm-1 band
- !
- an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) &
- + func(du12,dbeta02)) * tco2(i) * th2o(i) * bplnk(5,i,kn)
- du03 = 0.0333767*du01
- dbeta03 = 0.982143*dbeta01
- !
- ! 1168 cm-1 band
- !
- an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03)) * &
- tw(i,6) * tcfc8 * bplnk(6,i,kn)
- !
- ! Absorptivity for 1064 cm-1 band of CO2
- !
- du11 = abs(uco211(i,k2+1) - uco211(i,k2)) * winpl(i,kn)
- du12 = abs(uco212(i,k2+1) - uco212(i,k2)) * winpl(i,kn)
- du13 = abs(uco213(i,k2+1) - uco213(i,k2)) * winpl(i,kn)
- dbetc1 = 2.97558 * pinpl(i,kn) * rsqti(i) / sslp
- dbetc2 = 2.0 * dbetc1
- aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
- + func(du12,dbetc2) + func(du13,dbetc2)) &
- * to3(i) * tw(i,5) * tcfc4 * tcfc7 * bplnk(2,i,kn)
- !
- ! Absorptivity for 961 cm-1 band of co2
- !
- du21 = abs(uco221(i,k2+1) - uco221(i,k2)) * winpl(i,kn)
- du22 = abs(uco222(i,k2+1) - uco222(i,k2)) * winpl(i,kn)
- du23 = abs(uco223(i,k2+1) - uco223(i,k2)) * winpl(i,kn)
- aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
- + func(du22,dbetc1) + func(du23,dbetc2)) &
- * tw(i,4) * tcfc3 * tcfc6 * bplnk(1,i,kn)
- !
- ! total trace gas absorptivity
- !
- abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
- acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
- aco21 + aco22
- end do
- !
- return
- !
- end subroutine trcabn
- subroutine trcems(lchnk ,ncol ,pcols, pverp, &
- k ,co2t ,pnm ,ucfc11 ,ucfc12 , &
- un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
- bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
- uco222 ,uco223 ,uptype ,w ,s2c , &
- up2 ,emplnk ,th2o ,tco2 ,to3 , &
- emstrc , &
- aer_trn_ttl)
- !-----------------------------------------------------------------------
- !
- ! Purpose:
- ! Calculate emissivity for CH4, N2O, CFC11 and CFC12 bands.
- !
- ! Method:
- ! See CCM3 Description for equations.
- !
- ! Author: J. Kiehl
- !
- !-----------------------------------------------------------------------
- ! use shr_kind_mod, only: r8 => shr_kind_r8
- ! use ppgrid
- ! use volcrad
- implicit none
- !
- !------------------------------Arguments--------------------------------
- !
- ! Input arguments
- !
- integer, intent(in) :: lchnk ! chunk identifier
- integer, intent(in) :: ncol ! number of atmospheric columns
- integer, intent(in) :: pcols, pverp
- real(r8), intent(in) :: co2t(pcols,pverp) ! pressure weighted temperature
- real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressure
- real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
- real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
- real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
- !
- real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
- real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
- real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
- real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
- !
- real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
- real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
- real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
- !
- real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
- real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
- real(r8), intent(in) :: emplnk(14,pcols) ! emissivity Planck factor
- real(r8), intent(in) :: th2o(pcols) ! water vapor overlap factor
- real(r8), intent(in) :: tco2(pcols) ! co2 overlap factor
- !
- real(r8), intent(in) :: to3(pcols) ! o3 overlap factor
- real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum path length
- real(r8), intent(in) :: w(pcols,pverp) ! h2o path length
- real(r8), intent(in) :: up2(pcols) ! pressure squared h2o path length
- !
- integer, intent(in) :: k ! level index
- real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
- !
- ! Output Arguments
- !
- real(r8), intent(out) :: emstrc(pcols,pverp) ! total trace gas emissivity
- !
- !--------------------------Local Variables------------------------------
- !
- integer i,l ! loop counters
- !
- real(r8) sqti(pcols) ! square root of mean temp
- real(r8) ecfc1 ! emissivity of cfc11 798 cm-1 band
- real(r8) ecfc2 ! " " " 846 cm-1 band
- real(r8) ecfc3 ! " " " 933 cm-1 band
- real(r8) ecfc4 ! " " " 1085 cm-1 band
- !
- real(r8) ecfc5 ! " " cfc12 889 cm-1 band
- real(r8) ecfc6 ! " " " 923 cm-1 band
- real(r8) ecfc7 ! " " " 1102 cm-1 band
- real(r8) ecfc8 ! " " " 1161 cm-1 band
- real(r8) u01 ! n2o path leng…
Large files files are truncated, but you can click here to view the full file