module_ra_cam.F
References to this file elsewhere.
1 MODULE module_ra_cam
2 integer, parameter :: r8 = 8
3 real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90
4 integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer
5
6 integer :: ixcldliq
7 integer :: ixcldice
8 ! integer :: levsiz ! size of level dimension on dataset
9 integer, parameter :: nbands = 2 ! Number of spectral bands
10 integer, parameter :: naer_all = 12 + 1
11 integer, parameter :: naer = 10 + 1
12 integer, parameter :: bnd_nbr_LW=7
13 integer, parameter :: ndstsz = 4 ! number of dust size bins
14 integer :: idxSUL
15 integer :: idxSSLT
16 integer :: idxDUSTfirst
17 integer :: idxCARBONfirst
18 integer :: idxOCPHO
19 integer :: idxBCPHO
20 integer :: idxOCPHI
21 integer :: idxBCPHI
22 integer :: idxBG
23 integer :: idxVOLC
24
25 integer :: mxaerl ! Maximum level of background aerosol
26
27 ! indices to sections of array that represent
28 ! groups of aerosols
29
30 integer, parameter :: &
31 numDUST = 4, &
32 numCARBON = 4
33
34 ! portion of each species group to use in computation
35 ! of relative radiative forcing.
36
37 real(r8) :: sulscl_rf = 0._r8 !
38 real(r8) :: carscl_rf = 0._r8
39 real(r8) :: ssltscl_rf = 0._r8
40 real(r8) :: dustscl_rf = 0._r8
41 real(r8) :: bgscl_rf = 0._r8
42 real(r8) :: volcscl_rf = 0._r8
43
44 ! "background" aerosol species mmr.
45 real(r8) :: tauback = 0._r8
46
47 ! portion of each species group to use in computation
48 ! of aerosol forcing in driving the climate
49 real(r8) :: sulscl = 1._r8
50 real(r8) :: carscl = 1._r8
51 real(r8) :: ssltscl = 1._r8
52 real(r8) :: dustscl = 1._r8
53 real(r8) :: volcscl = 1._r8
54
55 !From volcrad.F90 module
56 integer, parameter :: idx_LW_0500_0650=3
57 integer, parameter :: idx_LW_0650_0800=4
58 integer, parameter :: idx_LW_0800_1000=5
59 integer, parameter :: idx_LW_1000_1200=6
60 integer, parameter :: idx_LW_1200_2000=7
61
62 ! First two values represent the overlap of volcanics with the non-window
63 ! (0-800, 1200-2200 cm^-1) and window (800-1200 cm^-1) regions.| Coefficients
64 ! were derived using crm_volc_minimize.pro with spectral flux optimization
65 ! on first iteration, total heating rate on subsequent iterations (2-9).
66 ! Five profiles for HLS, HLW, MLS, MLW, and TRO conditions were given equal
67 ! weight. RMS heating rate errors for a visible stratospheric optical
68 ! depth of 1.0 are 0.02948 K/day.
69 !
70 real(r8) :: abs_cff_mss_aer(bnd_nbr_LW) = &
71 (/ 70.257384, 285.282943, &
72 1.0273851e+02, 6.3073303e+01, 1.2039569e+02, &
73 3.6343643e+02, 2.7138528e+02 /)
74
75 !From radae.F90 module
76 real(r8), parameter:: min_tp_h2o = 160.0 ! min T_p for pre-calculated abs/emis
77 real(r8), parameter:: max_tp_h2o = 349.999999 ! max T_p for pre-calculated abs/emis
78 real(r8), parameter:: dtp_h2o = 21.111111111111 ! difference in adjacent elements of tp_h2o
79 real(r8), parameter:: min_te_h2o = -120.0 ! min T_e-T_p for pre-calculated abs/emis
80 real(r8), parameter:: max_te_h2o = 79.999999 ! max T_e-T_p for pre-calculated abs/emis
81 real(r8), parameter:: dte_h2o = 10.0 ! difference in adjacent elements of te_h2o
82 real(r8), parameter:: min_rh_h2o = 0.0 ! min RH for pre-calculated abs/emis
83 real(r8), parameter:: max_rh_h2o = 1.19999999 ! max RH for pre-calculated abs/emis
84 real(r8), parameter:: drh_h2o = 0.2 ! difference in adjacent elements of RH
85 real(r8), parameter:: min_lu_h2o = -8.0 ! min log_10(U) for pre-calculated abs/emis
86 real(r8), parameter:: min_u_h2o = 1.0e-8 ! min pressure-weighted path-length
87 real(r8), parameter:: max_lu_h2o = 3.9999999 ! max log_10(U) for pre-calculated abs/emis
88 real(r8), parameter:: dlu_h2o = 0.5 ! difference in adjacent elements of lu_h2o
89 real(r8), parameter:: min_lp_h2o = -3.0 ! min log_10(P) for pre-calculated abs/emis
90 real(r8), parameter:: min_p_h2o = 1.0e-3 ! min log_10(P) for pre-calculated abs/emis
91 real(r8), parameter:: max_lp_h2o = -0.0000001 ! max log_10(P) for pre-calculated abs/emis
92 real(r8), parameter:: dlp_h2o = 0.3333333333333 ! difference in adjacent elements of lp_h2o
93 integer, parameter :: n_u = 25 ! Number of U in abs/emis tables
94 integer, parameter :: n_p = 10 ! Number of P in abs/emis tables
95 integer, parameter :: n_tp = 10 ! Number of T_p in abs/emis tables
96 integer, parameter :: n_te = 21 ! Number of T_e in abs/emis tables
97 integer, parameter :: n_rh = 7 ! Number of RH in abs/emis tables
98 real(r8):: c16,c17,c26,c27,c28,c29,c30,c31
99 real(r8):: fwcoef ! Farwing correction constant
100 real(r8):: fwc1,fwc2 ! Farwing correction constants
101 real(r8):: fc1 ! Farwing correction constant
102 real(r8):: amco2 ! Molecular weight of co2 (g/mol)
103 real(r8):: amd ! Molecular weight of dry air (g/mol)
104 real(r8):: p0 ! Standard pressure (dynes/cm**2)
105
106 real(r8):: ah2onw(n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (non-window)
107 real(r8):: eh2onw(n_p, n_tp, n_u, n_te, n_rh) ! emissivity (non-window)
108 real(r8):: ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! absorptivity (window, for adjacent layers)
109 real(r8):: cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for absorptivity (window)
110 real(r8):: cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) ! continuum transmission for emissivity (window)
111 real(r8):: ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for absorptivity (window)
112 real(r8):: ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) ! line-only transmission for emissivity (window)
113
114 !
115 ! Constant coefficients for water vapor overlap with trace gases.
116 ! Reference: Ramanathan, V. and P.Downey, 1986: A Nonisothermal
117 ! Emissivity and Absorptivity Formulation for Water Vapor
118 ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
119 !
120 #ifndef G95
121 real(r8):: coefh(2,4) = reshape( &
122 (/ (/5.46557e+01,-7.30387e-02/), &
123 (/1.09311e+02,-1.46077e-01/), &
124 (/5.11479e+01,-6.82615e-02/), &
125 (/1.02296e+02,-1.36523e-01/) /), (/2,4/) )
126 !
127 real(r8):: coefj(3,2) = reshape( &
128 (/ (/2.82096e-02,2.47836e-04,1.16904e-06/), &
129 (/9.27379e-02,8.04454e-04,6.88844e-06/) /), (/3,2/) )
130 !
131 real(r8):: coefk(3,2) = reshape( &
132 (/ (/2.48852e-01,2.09667e-03,2.60377e-06/) , &
133 (/1.03594e+00,6.58620e-03,4.04456e-06/) /), (/3,2/) )
134 #else
135 ! this use of reshape does not work in g95, as of 20061212 jm
136 real(r8):: coefh(2,4)
137 real(r8):: coefj(3,2)
138 real(r8):: coefk(3,2)
139 #endif
140
141 integer, parameter :: ntemp = 192 ! Number of temperatures in H2O sat. table for Tp
142 real(r8) :: estblh2o(0:ntemp) ! saturation vapor pressure for H2O for Tp rang
143 integer, parameter :: o_fa = 6 ! Degree+1 of poly of T_e for absorptivity as U->inf.
144 integer, parameter :: o_fe = 6 ! Degree+1 of poly of T_e for emissivity as U->inf.
145
146 !-----------------------------------------------------------------------------
147 ! Data for f in C/H/E fit -- value of A and E as U->infinity
148 ! New C/LT/E fit (Hitran 2K, CKD 2.4) -- no change
149 ! These values are determined by integrals of Planck functions or
150 ! derivatives of Planck functions only.
151 !-----------------------------------------------------------------------------
152 !
153 ! fa/fe coefficients for 2 bands (0-800 & 1200-2200, 800-1200 cm^-1)
154 !
155 ! Coefficients of polynomial for f_a in T_e
156 !
157 #ifndef G95
158 real(r8), parameter:: fat(o_fa,nbands) = reshape( (/ &
159 (/-1.06665373E-01, 2.90617375E-02, -2.70642049E-04, & ! 0-800&1200-2200 cm^-1
160 1.07595511E-06, -1.97419681E-09, 1.37763374E-12/), & ! 0-800&1200-2200 cm^-1
161 (/ 1.10666537E+00, -2.90617375E-02, 2.70642049E-04, & ! 800-1200 cm^-1
162 -1.07595511E-06, 1.97419681E-09, -1.37763374E-12/) /) & ! 800-1200 cm^-1
163 , (/o_fa,nbands/) )
164 !
165 ! Coefficients of polynomial for f_e in T_e
166 !
167 real(r8), parameter:: fet(o_fe,nbands) = reshape( (/ &
168 (/3.46148163E-01, 1.51240299E-02, -1.21846479E-04, & ! 0-800&1200-2200 cm^-1
169 4.04970123E-07, -6.15368936E-10, 3.52415071E-13/), & ! 0-800&1200-2200 cm^-1
170 (/6.53851837E-01, -1.51240299E-02, 1.21846479E-04, & ! 800-1200 cm^-1
171 -4.04970123E-07, 6.15368936E-10, -3.52415071E-13/) /) & ! 800-1200 cm^-1
172 , (/o_fa,nbands/) )
173 #else
174 ! this use of reshape does not work in g95, as of 20061212 jm
175 real(r8):: fat(o_fa,nbands)
176 real(r8):: fet(o_fe,nbands)
177 #endif
178
179
180 real(r8) :: gravit ! Acceleration of gravity (cgs)
181 real(r8) :: rga ! 1./gravit
182 real(r8) :: gravmks ! Acceleration of gravity (mks)
183 real(r8) :: cpair ! Specific heat of dry air
184 real(r8) :: epsilo ! Ratio of mol. wght of H2O to dry air
185 real(r8) :: epsqs ! Ratio of mol. wght of H2O to dry air
186 real(r8) :: sslp ! Standard sea-level pressure
187 real(r8) :: stebol ! Stefan-Boltzmann's constant
188 real(r8) :: rgsslp ! 0.5/(gravit*sslp)
189 real(r8) :: dpfo3 ! Voigt correction factor for O3
190 real(r8) :: dpfco2 ! Voigt correction factor for CO2
191 real(r8) :: dayspy ! Number of days per 1 year
192 real(r8) :: pie ! 3.14.....
193 real(r8) :: mwdry ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
194 real(r8) :: scon ! solar constant (not used in WRF)
195 real(r8) :: co2mmr
196 real(r8) :: mwco2 ! molecular weight of carbon dioxide
197 real(r8) :: mwh2o ! molecular weight water vapor (shr_const_mwwv)
198 real(r8) :: mwch4 ! molecular weight ch4
199 real(r8) :: mwn2o ! molecular weight n2o
200 real(r8) :: mwf11 ! molecular weight cfc11
201 real(r8) :: mwf12 ! molecular weight cfc12
202 real(r8) :: cappa ! R/Cp
203 real(r8) :: rair ! Gas constant for dry air (J/K/kg)
204 real(r8) :: tmelt ! freezing T of fresh water ~ K
205 real(r8) :: r_universal ! Universal gas constant ~ J/K/kmole
206 real(r8) :: latvap ! latent heat of evaporation ~ J/kg
207 real(r8) :: latice ! latent heat of fusion ~ J/kg
208 real(r8) :: zvir ! R_V/R_D - 1.
209 integer plenest ! length of saturation vapor pressure table
210 parameter (plenest=250)
211 !
212 ! Table of saturation vapor pressure values es from tmin degrees
213 ! to tmax+1 degrees k in one degree increments. ttrice defines the
214 ! transition region where es is a combination of ice & water values
215 !
216 real(r8) estbl(plenest) ! table values of saturation vapor pressure
217 real(r8) tmin ! min temperature (K) for table
218 real(r8) tmax ! max temperature (K) for table
219 real(r8) pcf(6) ! polynomial coeffs -> es transition water to ice
220 !real(r8), allocatable :: pin(:) ! ozone pressure level (levsiz)
221 !real(r8), allocatable :: ozmix(:,:,:) ! mixing ratio
222 !real(r8), allocatable, target :: abstot_3d(:,:,:,:) ! Non-adjacent layer absorptivites
223 !real(r8), allocatable, target :: absnxt_3d(:,:,:,:) ! Nearest layer absorptivities
224 !real(r8), allocatable, target :: emstot_3d(:,:,:) ! Total emissivity
225
226 !From aer_optics.F90 module
227 integer, parameter :: idxVIS = 8 ! index to visible band
228 integer, parameter :: nrh = 1000 ! number of relative humidity values for look-up-table
229 integer, parameter :: nspint = 19 ! number of spectral intervals
230 real(r8) :: ksul(nrh, nspint) ! sulfate specific extinction ( m^2 g-1 )
231 real(r8) :: wsul(nrh, nspint) ! sulfate single scattering albedo
232 real(r8) :: gsul(nrh, nspint) ! sulfate asymmetry parameter
233 real(r8) :: kbg(nspint) ! background specific extinction ( m^2 g-1 )
234 real(r8) :: wbg(nspint) ! background single scattering albedo
235 real(r8) :: gbg(nspint) ! background asymmetry parameter
236 real(r8) :: ksslt(nrh, nspint) ! sea-salt specific extinction ( m^2 g-1 )
237 real(r8) :: wsslt(nrh, nspint) ! sea-salt single scattering albedo
238 real(r8) :: gsslt(nrh, nspint) ! sea-salt asymmetry parameter
239 real(r8) :: kcphil(nrh, nspint) ! hydrophilic carbon specific extinction ( m^2 g-1 )
240 real(r8) :: wcphil(nrh, nspint) ! hydrophilic carbon single scattering albedo
241 real(r8) :: gcphil(nrh, nspint) ! hydrophilic carbon asymmetry parameter
242 real(r8) :: kcphob(nspint) ! hydrophobic carbon specific extinction ( m^2 g-1 )
243 real(r8) :: wcphob(nspint) ! hydrophobic carbon single scattering albedo
244 real(r8) :: gcphob(nspint) ! hydrophobic carbon asymmetry parameter
245 real(r8) :: kcb(nspint) ! black carbon specific extinction ( m^2 g-1 )
246 real(r8) :: wcb(nspint) ! black carbon single scattering albedo
247 real(r8) :: gcb(nspint) ! black carbon asymmetry parameter
248 real(r8) :: kvolc(nspint) ! volcanic specific extinction ( m^2 g-1)
249 real(r8) :: wvolc(nspint) ! volcanic single scattering albedo
250 real(r8) :: gvolc(nspint) ! volcanic asymmetry parameter
251 real(r8) :: kdst(ndstsz, nspint) ! dust specific extinction ( m^2 g-1 )
252 real(r8) :: wdst(ndstsz, nspint) ! dust single scattering albedo
253 real(r8) :: gdst(ndstsz, nspint) ! dust asymmetry parameter
254 !
255 !From comozp.F90 module
256 real(r8) cplos ! constant for ozone path length integral
257 real(r8) cplol ! constant for ozone path length integral
258
259 !From ghg_surfvals.F90 module
260 real(r8) :: co2vmr = 3.550e-4 ! co2 volume mixing ratio
261 real(r8) :: n2ovmr = 0.311e-6 ! n2o volume mixing ratio
262 real(r8) :: ch4vmr = 1.714e-6 ! ch4 volume mixing ratio
263 real(r8) :: f11vmr = 0.280e-9 ! cfc11 volume mixing ratio
264 real(r8) :: f12vmr = 0.503e-9 ! cfc12 volume mixing ratio
265
266
267 integer :: ntoplw ! top level to solve for longwave cooling (WRF sets this to 1 for model top below 10 mb)
268
269 logical :: masterproc = .true.
270 logical :: ozncyc ! true => cycle ozone dataset
271 logical :: dosw ! True => shortwave calculation this timestep
272 logical :: dolw ! True => longwave calculation this timestep
273 logical :: indirect ! True => include indirect radiative effects of sulfate aerosols
274 ! logical :: doabsems ! True => abs/emiss calculation this timestep
275 logical :: radforce = .false. ! True => calculate aerosol shortwave forcing
276 logical :: trace_gas=.false. ! set true for chemistry
277 logical :: strat_volcanic = .false. ! True => volcanic aerosol mass available
278
279
280 CONTAINS
281
282 subroutine camrad(RTHRATENLW,RTHRATENSW, &
283 SWUPT,SWUPTC,SWDNT,SWDNTC, &
284 LWUPT,LWUPTC,LWDNT,LWDNTC, &
285 SWUPB,SWUPBC,SWDNB,SWDNBC, &
286 LWUPB,LWUPBC,LWDNB,LWDNBC, &
287 swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr, &
288 GSW,GLW,XLAT,XLONG, &
289 ALBEDO,t_phy,TSK,EMISS, &
290 QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, &
291 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
292 f_ice_phy,f_rain_phy, &
293 p_phy,p8w,z,pi_phy,rho_phy,dz8w, &
294 CLDFRA,XLAND,XICE,SNOW, &
295 ozmixm,pin0,levsiz,num_months, &
296 m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0, &
297 cam_abs_dim1, cam_abs_dim2, &
298 paerlev,naer_c, &
299 GMT,JULDAY,JULIAN,DT,XTIME,DECLIN,SOLCON, &
300 RADT,DEGRAD,n_cldadv, &
301 abstot_3d, absnxt_3d, emstot_3d, &
302 doabsems, &
303 ids,ide, jds,jde, kds,kde, &
304 ims,ime, jms,jme, kms,kme, &
305 its,ite, jts,jte, kts,kte )
306
307 USE module_wrf_error
308
309 !------------------------------------------------------------------
310 IMPLICIT NONE
311 !------------------------------------------------------------------
312
313 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
314 ims,ime, jms,jme, kms,kme, &
315 its,ite, jts,jte, kts,kte
316 LOGICAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
317 LOGICAL, INTENT(INout) :: doabsems
318
319 INTEGER, INTENT(IN ) :: n_cldadv
320 INTEGER, INTENT(IN ) :: JULDAY
321 REAL, INTENT(IN ) :: JULIAN
322 REAL, INTENT(IN ) :: DT
323 INTEGER, INTENT(IN ) :: levsiz, num_months
324 INTEGER, INTENT(IN ) :: paerlev, naer_c
325 INTEGER, INTENT(IN ) :: cam_abs_dim1, cam_abs_dim2
326
327
328 REAL, INTENT(IN ) :: RADT,DEGRAD, &
329 XTIME,DECLIN,SOLCON,GMT
330 !
331 !
332 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
333 INTENT(IN ) :: P_PHY, &
334 P8W, &
335 Z, &
336 pi_PHY, &
337 rho_PHY, &
338 dz8w, &
339 T_PHY, &
340 QV3D, &
341 QC3D, &
342 QR3D, &
343 QI3D, &
344 QS3D, &
345 QG3D, &
346 CLDFRA
347
348 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
349 INTENT(INOUT) :: RTHRATENLW, &
350 RTHRATENSW
351 !
352 REAL, DIMENSION( ims:ime, jms:jme ), &
353 INTENT(IN ) :: XLAT, &
354 XLONG, &
355 XLAND, &
356 XICE, &
357 SNOW, &
358 EMISS, &
359 TSK, &
360 ALBEDO
361
362 REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
363 INTENT(IN ) :: OZMIXM
364
365 REAL, DIMENSION(levsiz), INTENT(IN ) :: PIN0
366
367 REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN ) :: m_psp,m_psn
368 REAL, DIMENSION(paerlev), intent(in) :: m_hybi0
369 REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
370 INTENT(IN ) :: aerosolcp, aerosolcn
371
372 !
373 REAL, DIMENSION( ims:ime, jms:jme ), &
374 INTENT(INOUT) :: GSW, GLW
375
376 ! saving arrays for doabsems reduction of radiation calcs
377
378 REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ), &
379 INTENT(INOUT) :: abstot_3d
380 REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1 , jms:jme ), &
381 INTENT(INOUT) :: absnxt_3d
382 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
383 INTENT(INOUT) :: emstot_3d
384
385
386 ! Added outputs of total and clearsky fluxes etc
387 ! Note that k=1 refers to the half level below the model lowest level (Sfc)
388 ! k=kme refers to the half level above the model highest level (TOA)
389 !
390 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
391 ! INTENT(INOUT) :: swup, &
392 ! swupclear, &
393 ! swdn, &
394 ! swdnclear, &
395 ! lwup, &
396 ! lwupclear, &
397 ! lwdn, &
398 ! lwdnclear
399
400 REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
401 SWUPT,SWUPTC,SWDNT,SWDNTC, &
402 LWUPT,LWUPTC,LWDNT,LWDNTC, &
403 SWUPB,SWUPBC,SWDNB,SWDNBC, &
404 LWUPB,LWUPBC,LWDNB,LWDNBC
405
406 REAL, DIMENSION( ims:ime, jms:jme ), &
407 INTENT(INOUT) :: swcf, &
408 lwcf, &
409 olr, &
410 coszr
411 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
412 INTENT(OUT ) :: cemiss, & ! cloud emissivity for isccp
413 taucldc, & ! cloud water optical depth for isccp
414 taucldi ! cloud ice optical depth for isccp
415 !
416 !
417 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
418 INTENT(IN ) :: &
419 F_ICE_PHY, &
420 F_RAIN_PHY
421
422
423 ! LOCAL VARIABLES
424
425 INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp
426 INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n
427 integer :: begchunk, endchunk
428
429 REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24
430
431 real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups
432 real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps
433 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t
434 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) :: pint, lnpint
435 real(r8), DIMENSION( its:ite , kts:kte+1 ) :: phyd
436 real(r8), DIMENSION( its:ite , kts:kte ) :: phydmid
437 real(r8), DIMENSION( its:ite ) :: fp
438 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q
439 ! real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm ! reference pressures at midpoints
440 ! real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi ! reference pressures at interfaces
441 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cicewp ! in-cloud cloud ice water path
442 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cliqwp ! in-cloud cloud liquid water path
443 real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxcl ! cloud water optical depth
444 real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxci ! cloud ice optical depth
445 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: emis ! cloud emissivity
446 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rel ! effective drop radius (microns)
447 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rei ! ice effective drop size (microns)
448 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn ! Maximum values of pressure for each
449 integer , dimension( 1:ite-its+1 ) :: nmxrgn ! Number of maximally overlapped regions
450
451 real(r8), dimension( 1:ite-its+1 ) :: fsns ! Surface absorbed solar flux
452 real(r8), dimension( 1:ite-its+1 ) :: fsnt ! Net column abs solar flux at model top
453 real(r8), dimension( 1:ite-its+1 ) :: flns ! Srf longwave cooling (up-down) flux
454 real(r8), dimension( 1:ite-its+1 ) :: flnt ! Net outgoing lw flux at model top
455 ! Added outputs of total and clearsky fluxes etc
456 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsup ! Upward total sky solar
457 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsupc ! Upward clear sky solar
458 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdn ! Downward total sky solar
459 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdnc ! Downward clear sky solar
460 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flup ! Upward total sky longwave
461 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flupc ! Upward clear sky longwave
462 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldn ! Downward total sky longwave
463 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldnc ! Downward clear sky longwave
464 real(r8), dimension( 1:ite-its+1 ) :: swcftoa ! Top of the atmosphere solar cloud forcing
465 real(r8), dimension( 1:ite-its+1 ) :: lwcftoa ! Top of the atmosphere longwave cloud forcing
466 real(r8), dimension( 1:ite-its+1 ) :: olrtoa ! Top of the atmosphere outgoing longwave
467 !
468 real(r8), dimension( 1:ite-its+1 ) :: sols ! Downward solar rad onto surface (sw direct)
469 real(r8), dimension( 1:ite-its+1 ) :: soll ! Downward solar rad onto surface (lw direct)
470 real(r8), dimension( 1:ite-its+1 ) :: solsd ! Downward solar rad onto surface (sw diffuse)
471 real(r8), dimension( 1:ite-its+1 ) :: solld ! Downward solar rad onto surface (lw diffuse)
472 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrs ! Solar heating rate
473 real(r8), dimension( 1:ite-its+1 ) :: fsds ! Flux Shortwave Downwelling Surface
474 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrl ! Longwave cooling rate
475 real(r8), dimension( 1:ite-its+1 ) :: flwds ! Surface down longwave flux
476 real(r8), dimension( 1:ite-its+1, levsiz, num_months ) :: ozmixmj ! monthly ozone mixing ratio
477 real(r8), dimension( 1:ite-its+1, levsiz ) :: ozmix ! ozone mixing ratio (time interpolated)
478 real(r8), dimension(levsiz) :: pin ! ozone pressure level
479 real(r8), dimension(1:ite-its+1) :: m_psjp,m_psjn ! MATCH surface pressure
480 real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljp ! monthly aerosol concentrations
481 real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljn ! monthly aerosol concentrations
482 real(r8), dimension(paerlev) :: m_hybi
483 real(r8), dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
484 real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity
485 real(r8), dimension(its:ite,kts:kte,4) :: absnxt ! Total nearest layer absorptivity
486 real(r8), dimension(its:ite,kts:kte+1) :: emstot ! Total emissivity
487 CHARACTER(LEN=256) :: msgstr
488
489 #if !defined(MAC_KLUDGE) && !defined(G95)
490 lchnk = 1
491 begchunk = ims
492 endchunk = ime
493 ncol = ite - its + 1
494 pcols= ite - its + 1
495 pver = kte - kts + 1
496 pverp= pver + 1
497 pverr = kte - kts + 1
498 pverrp= pverr + 1
499 ! number of advected constituents and non-advected constituents (including water vapor)
500 ppcnst = n_cldadv
501 ! number of non-advected constituents
502 pnats = 0
503 pcnst = ppcnst-pnats
504
505 ! check the # species defined for the input climatology and naer
506
507 ! if(naer_c.ne.naer) then
508 ! WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer
509 if(naer_c.ne.naer_all) then
510 WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all
511 CALL wrf_error_fatal ( wrf_err_message )
512 endif
513 !
514 !===================================================
515 ! Radiation computations
516 !===================================================
517
518 do k=1,levsiz
519 pin(k)=pin0(k)
520 enddo
521
522 do k=1,paerlev
523 m_hybi(k)=m_hybi0(k)
524 enddo
525
526 ! check for uninitialized arrays
527 if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems)then
528 CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart')
529 doabsems = .true.
530 endif
531
532 do j =jts,jte
533
534 !
535 ! Cosine solar zenith angle for current time step
536 !
537
538 ! call zenith (calday, clat, clon, coszrs, ncol)
539
540 do i = its,ite
541 ii = i - its + 1
542 ! XT24 is the fractional part of simulation days plus half of RADT expressed in
543 ! units of minutes
544 ! JULIAN is in days
545 ! RADT is in minutes
546 XT24=MOD(XTIME+RADT*0.5,1440.)
547 TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
548 HRANG=15.*(TLOCTM-12.)*DEGRAD
549 XXLAT=XLAT(I,J)*DEGRAD
550 clat(ii)=xxlat
551 coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
552 enddo
553
554 ! moist variables
555
556 do k = kts,kte
557 kk = kte - k + kts
558 do i = its,ite
559 ii = i - its + 1
560 q(ii,kk,1) = max(1.e-10,qv3d(i,k,j))
561 IF ( F_QI .and. F_QC .and. F_QS ) THEN
562 q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j))
563 q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)+qs3d(i,k,j))
564 ELSE IF ( F_QC .and. F_QR ) THEN
565 ! Warm rain or simple ice
566 q(ii,kk,ixcldliq) = 0.
567 q(ii,kk,ixcldice) = 0.
568 if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j))
569 if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j))
570 ELSE IF ( F_QC .and. F_QS ) THEN
571 ! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
572 q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)*f_ice_phy(i,k,j))
573 q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j)))
574 ELSE
575 q(ii,kk,ixcldliq) = 0.
576 q(ii,kk,ixcldice) = 0.
577 ENDIF
578 cld(ii,kk) = CLDFRA(I,K,J)
579 enddo
580 enddo
581
582 do i = its,ite
583 ii = i - its + 1
584 landfrac(ii) = 2.-XLAND(I,J)
585 landm(ii) = landfrac(ii)
586 snowh(ii) = 0.001*SNOW(I,J)
587 icefrac(ii) = XICE(I,J)
588 enddo
589
590 do m=1,num_months
591 do k=1,levsiz
592 do i = its,ite
593 ii = i - its + 1
594 ozmixmj(ii,k,m) = ozmixm(i,k,j,m)
595 enddo
596 enddo
597 enddo
598
599 do i = its,ite
600 ii = i - its + 1
601 m_psjp(ii) = m_psp(i,j)
602 m_psjn(ii) = m_psn(i,j)
603 enddo
604
605 do n=1,naer_c
606 do k=1,paerlev
607 do i = its,ite
608 ii = i - its + 1
609 aerosoljp(ii,k,n) = aerosolcp(i,k,j,n)
610 aerosoljn(ii,k,n) = aerosolcn(i,k,j,n)
611 enddo
612 enddo
613 enddo
614
615 !
616 ! Complete radiation calculations
617 !
618 do i = its,ite
619 ii = i - its + 1
620 lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4
621 enddo
622
623 ! first guess
624 do k = kts,kte+1
625 do i = its,ite
626 if(k.eq.kts)then
627 phyd(i,k)=p8w(i,kts,j)
628 else
629 phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)
630 endif
631 enddo
632 enddo
633
634 ! correction factor FP to match p8w(I,kts,J)-p8w(I,kte+1,J)
635 do i = its,ite
636 fp(i)=(p8w(I,kts,J)-p8w(I,kte+1,J))/(PHYD(i,KTS)-PHYD(i,KTE+1))
637 enddo
638
639 ! final pass
640 do k = kts+1,kte+1
641 do i = its,ite
642 phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)*fp(i)
643 phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k))
644 enddo
645 enddo
646
647 do k = kts,kte+1
648 kk = kte - k + kts + 1
649 do i = its,ite
650 ii = i - its + 1
651 pint(ii,kk) = phyd(i,k)
652 if(k.eq.kts)ps(ii)=pint(ii,kk)
653 lnpint(ii,kk) = log(pint(ii,kk))
654 enddo
655 enddo
656
657 if(.not.doabsems)then
658 ! do kk = kts,kte+1
659 do kk = 1,cam_abs_dim2
660 do kk1 = kts,kte+1
661 do i = its,ite
662 abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j)
663 enddo
664 enddo
665 enddo
666 ! do kk = 1,4
667 do kk = 1,cam_abs_dim1
668 do kk1 = kts,kte
669 do i = its,ite
670 absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j)
671 enddo
672 enddo
673 enddo
674 do kk = kts,kte+1
675 do i = its,ite
676 emstot(i,kk) = emstot_3d(i,kk,j)
677 enddo
678 enddo
679 endif
680
681 do k = kts,kte
682 kk = kte - k + kts
683 do i = its,ite
684 ii = i - its + 1
685 pmid(ii,kk) = phydmid(i,k)
686 lnpmid(ii,kk) = log(pmid(ii,kk))
687 lnpint(ii,kk) = log(pint(ii,kk))
688 pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk)
689 t(ii,kk) = t_phy(i,k,j)
690 zm(ii,kk) = z(i,k,j)
691 enddo
692 enddo
693
694
695 ! Compute cloud water/ice paths and optical properties for input to radiation
696
697 call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, &
698 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh)
699
700 do i = its,ite
701 ii = i - its + 1
702 ! use same albedo for direct and diffuse
703 ! change this when separate values are provided
704 asdir(ii) = albedo(i,j)
705 asdif(ii) = albedo(i,j)
706 aldir(ii) = albedo(i,j)
707 aldif(ii) = albedo(i,j)
708 enddo
709
710 ! WRF allocate space here (not needed if oznini is called)
711 ! allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90
712
713 call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid, &
714 pint, lnpmid, lnpint, pdel, t, q, &
715 cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif, &
716 aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
717 pin, ozmixmj, ozmix, levsiz, num_months, &
718 m_psjp,m_psjn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, &
719 doabsems, abstot, absnxt, emstot, &
720 fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, &
721 fsns, fsnt ,flns ,flnt , &
722 qrs, qrl, flwds, rel, rei, &
723 sols, soll, solsd, solld, &
724 landfrac, zm, fsds)
725
726 do k = kts,kte
727 kk = kte - k + kts
728 do i = its,ite
729 ii = i - its + 1
730 RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
731 RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j))
732 cemiss(i,k,j) = emis(ii,kk)
733 taucldc(i,k,j) = tauxcl(ii,kk)
734 taucldi(i,k,j) = tauxci(ii,kk)
735 enddo
736 enddo
737
738 if(doabsems)then
739 ! do kk = kts,kte+1
740 do kk = 1,cam_abs_dim2
741 do kk1 = kts,kte+1
742 do i = its,ite
743 abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk)
744 enddo
745 enddo
746 enddo
747 ! do kk = 1,4
748 do kk = 1,cam_abs_dim1
749 do kk1 = kts,kte
750 do i = its,ite
751 absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk)
752 enddo
753 enddo
754 enddo
755 do kk = kts,kte+1
756 do i = its,ite
757 emstot_3d(i,kk,j) = emstot(i,kk)
758 enddo
759 enddo
760 endif
761
762 IF(PRESENT(SWUPT))THEN
763 ! Added shortwave and longwave upward/downward total and clear sky fluxes
764 do k = kts,kte+1
765 kk = kte +1 - k + kts
766 do i = its,ite
767 ii = i - its + 1
768 ! swup(i,k,j) = fsup(ii,kk)
769 ! swupclear(i,k,j) = fsupc(ii,kk)
770 ! swdn(i,k,j) = fsdn(ii,kk)
771 ! swdnclear(i,k,j) = fsdnc(ii,kk)
772 ! lwup(i,k,j) = flup(ii,kk)
773 ! lwupclear(i,k,j) = flupc(ii,kk)
774 ! lwdn(i,k,j) = fldn(ii,kk)
775 ! lwdnclear(i,k,j) = fldnc(ii,kk)
776 if(k.eq.kte+1)then
777 swupt(i,j) = fsup(ii,kk)
778 swuptc(i,j) = fsupc(ii,kk)
779 swdnt(i,j) = fsdn(ii,kk)
780 swdntc(i,j) = fsdnc(ii,kk)
781 lwupt(i,j) = fsup(ii,kk)
782 lwuptc(i,j) = fsupc(ii,kk)
783 lwdnt(i,j) = fsdn(ii,kk)
784 lwdntc(i,j) = fsdnc(ii,kk)
785 endif
786 if(k.eq.kts)then
787 swupb(i,j) = fsup(ii,kk)
788 swupbc(i,j) = fsupc(ii,kk)
789 swdnb(i,j) = fsdn(ii,kk)
790 swdnbc(i,j) = fsdnc(ii,kk)
791 lwupb(i,j) = fsup(ii,kk)
792 lwupbc(i,j) = fsupc(ii,kk)
793 lwdnb(i,j) = fsdn(ii,kk)
794 lwdnbc(i,j) = fsdnc(ii,kk)
795 endif
796 ! if(i.eq.30.and.j.eq.30) then
797 ! print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk)
798 ! print 1234, 'long ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk)
799 ! 1234 format (a6,4i4,4f10.3)
800 ! endif
801 enddo
802 enddo
803 ENDIF
804
805 do i = its,ite
806 ii = i - its + 1
807 GLW(I,J) = flwds(ii)
808 GSW(I,J) = fsns(ii)
809 ! Added shortwave and longwave cloud forcing at TOA
810 swcf(i,j) = swcftoa(ii)
811 lwcf(i,j) = lwcftoa(ii)
812 olr(i,j) = olrtoa(ii)
813 coszr(i,j) = coszrs(ii)
814 enddo
815
816 enddo ! j-loop
817
818 #endif
819
820 end subroutine camrad
821 !====================================================================
822 SUBROUTINE camradinit( &
823 R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, &
824 ozmixm,pin,levsiz,XLAT,num_months, &
825 m_psp,m_psn,m_hybi,aerosolcp,aerosolcn, &
826 paerlev,naer_c, &
827 ids, ide, jds, jde, kds, kde, &
828 ims, ime, jms, jme, kms, kme, &
829 its, ite, jts, jte, kts, kte )
830
831 USE module_wrf_error
832 USE module_configure
833
834 !--------------------------------------------------------------------
835 IMPLICIT NONE
836 !--------------------------------------------------------------------
837 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
838 ims, ime, jms, jme, kms, kme, &
839 its, ite, jts, jte, kts, kte
840 REAL, intent(in) :: pptop
841 REAL, INTENT(IN) :: R_D,R_V,CP,G,STBOLT,EP_2
842
843 REAL, DIMENSION( kms:kme ) :: shalf
844
845 INTEGER, INTENT(IN ) :: levsiz, num_months
846 INTEGER, INTENT(IN ) :: paerlev, naer_c
847
848 REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT
849
850 REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
851 INTENT(INOUT ) :: OZMIXM
852
853 REAL, DIMENSION(levsiz), INTENT(INOUT ) :: PIN
854 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT ) :: m_psp,m_psn
855 REAL, DIMENSION(paerlev), INTENT(INOUT ) :: m_hybi
856 REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
857 INTENT(INOUT) :: aerosolcp,aerosolcn
858
859 REAL(r8) :: pstd
860 REAL(r8) :: rh2o, cpair
861
862 #if !defined(MAC_KLUDGE) && !defined(G95)
863 ozncyc = .true.
864 dosw = .true.
865 dolw = .true.
866 indirect = .true.
867 ixcldliq = 2
868 ixcldice = 3
869 #if (NMM_CORE != 1)
870 ! aerosol array is not in the NMM Registry
871 ! since CAM radiation not available to NMM (yet)
872 ! so this is blocked out to enable CAM compilation with NMM
873 idxSUL = P_SUL
874 idxSSLT = P_SSLT
875 idxDUSTfirst = P_DUST1
876 idxOCPHO = P_OCPHO
877 idxCARBONfirst = P_OCPHO
878 idxBCPHO = P_BCPHO
879 idxOCPHI = P_OCPHI
880 idxBCPHI = P_BCPHI
881 idxBG = P_BG
882 idxVOLC = P_VOLC
883 #endif
884
885 pstd = 101325.0
886 ! from physconst module
887 mwdry = 28.966 ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
888 mwco2 = 44. ! molecular weight co2
889 mwh2o = 18.016 ! molecular weight water vapor (shr_const_mwwv)
890 mwch4 = 16. ! molecular weight ch4
891 mwn2o = 44. ! molecular weight n2o
892 mwf11 = 136. ! molecular weight cfc11
893 mwf12 = 120. ! molecular weight cfc12
894 cappa = R_D/CP
895 rair = R_D
896 tmelt = 273.16 ! freezing T of fresh water ~ K
897 r_universal = 6.02214e26 * STBOLT ! Universal gas constant ~ J/K/kmole
898 latvap = 2.501e6 ! latent heat of evaporation ~ J/kg
899 latice = 3.336e5 ! latent heat of fusion ~ J/kg
900 zvir = R_V/R_D - 1.
901 rh2o = R_V
902 cpair = CP
903 !
904 epsqs = EP_2
905
906 CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 )
907 CALL esinti(epsqs ,latvap ,latice ,rh2o ,cpair ,tmelt )
908 CALL oznini(ozmixm,pin,levsiz,num_months,XLAT, &
909 ids, ide, jds, jde, kds, kde, &
910 ims, ime, jms, jme, kms, kme, &
911 its, ite, jts, jte, kts, kte)
912 CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, &
913 ids, ide, jds, jde, kds, kde, &
914 ims, ime, jms, jme, kms, kme, &
915 its, ite, jts, jte, kts, kte)
916
917 #endif
918
919 END SUBROUTINE camradinit
920
921 #if !defined(MAC_KLUDGE) && !defined(G95)
922 subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, &
923 ids, ide, jds, jde, kds, kde, &
924 ims, ime, jms, jme, kms, kme, &
925 its, ite, jts, jte, kts, kte)
926 !
927 ! This subroutine assumes uniform distribution of ozone concentration.
928 ! It should be replaced by monthly climatology that varies latitudinally and vertically
929 !
930
931 IMPLICIT NONE
932
933 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
934 ims,ime, jms,jme, kms,kme, &
935 its,ite, jts,jte, kts,kte
936
937 INTEGER, INTENT(IN ) :: levsiz, num_months
938
939 REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT
940
941 REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
942 INTENT(OUT ) :: OZMIXM
943
944 REAL, DIMENSION(levsiz), INTENT(OUT ) :: PIN
945
946 ! Local
947 INTEGER, PARAMETER :: latsiz = 64
948 INTEGER, PARAMETER :: lonsiz = 1
949 INTEGER :: i, j, k, itf, jtf, ktf, m, pin_unit, lat_unit, oz_unit
950 REAL :: interp_pt
951 CHARACTER*256 :: message
952
953 REAL, DIMENSION( lonsiz, levsiz, latsiz, num_months ) :: &
954 OZMIXIN
955
956 REAL, DIMENSION(latsiz) :: lat_ozone
957
958 jtf=min0(jte,jde-1)
959 ktf=min0(kte,kde-1)
960 itf=min0(ite,ide-1)
961
962
963 !-- read in ozone pressure data
964
965 WRITE(message,*)'num_months = ',num_months
966 CALL wrf_debug(50,message)
967
968 pin_unit = 27
969 OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD')
970 do k = 1,levsiz
971 READ (pin_unit,*)pin(k)
972 end do
973 close(27)
974
975 do k=1,levsiz
976 pin(k) = pin(k)*100.
977 end do
978
979 !-- read in ozone lat data
980
981 lat_unit = 28
982 OPEN(lat_unit, FILE='ozone_lat.formatted',FORM='FORMATTED',STATUS='OLD')
983 do j = 1,latsiz
984 READ (lat_unit,*)lat_ozone(j)
985 end do
986 close(28)
987
988
989 !-- read in ozone data
990
991 oz_unit = 29
992 OPEN(oz_unit, FILE='ozone.formatted',FORM='FORMATTED',STATUS='OLD')
993
994 do m=2,num_months
995 do j=1,latsiz ! latsiz=64
996 do k=1,levsiz ! levsiz=59
997 do i=1,lonsiz ! lonsiz=1
998 READ (oz_unit,*)ozmixin(i,k,j,m)
999 enddo
1000 enddo
1001 enddo
1002 enddo
1003 close(29)
1004
1005
1006 !-- latitudinally interpolate ozone data (and extend longitudinally)
1007 !-- using function lin_interpol2(x, f, y) result(g)
1008 ! Purpose:
1009 ! interpolates f(x) to point y
1010 ! assuming f(x) = f(x0) + a * (x - x0)
1011 ! where a = ( f(x1) - f(x0) ) / (x1 - x0)
1012 ! x0 <= x <= x1
1013 ! assumes x is monotonically increasing
1014 ! real, intent(in), dimension(:) :: x ! grid points
1015 ! real, intent(in), dimension(:) :: f ! grid function values
1016 ! real, intent(in) :: y ! interpolation point
1017 ! real :: g ! interpolated function value
1018 !---------------------------------------------------------------------------
1019
1020 do m=2,num_months
1021 do j=jts,jtf
1022 do k=1,levsiz
1023 do i=its,itf
1024 interp_pt=XLAT(i,j)
1025 ozmixm(i,k,j,m)=lin_interpol2(lat_ozone(:),ozmixin(1,k,:,m),interp_pt)
1026 enddo
1027 enddo
1028 enddo
1029 enddo
1030
1031 ! Old code for fixed ozone
1032
1033 ! pin(1)=70.
1034 ! DO k=2,levsiz
1035 ! pin(k)=pin(k-1)+16.
1036 ! ENDDO
1037
1038 ! DO k=1,levsiz
1039 ! pin(k) = pin(k)*100.
1040 ! end do
1041
1042 ! DO m=1,num_months
1043 ! DO j=jts,jtf
1044 ! DO i=its,itf
1045 ! DO k=1,2
1046 ! ozmixm(i,k,j,m)=1.e-6
1047 ! ENDDO
1048 ! DO k=3,levsiz
1049 ! ozmixm(i,k,j,m)=1.e-7
1050 ! ENDDO
1051 ! ENDDO
1052 ! ENDDO
1053 ! ENDDO
1054
1055 END SUBROUTINE oznini
1056
1057 subroutine aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, &
1058 ids, ide, jds, jde, kds, kde, &
1059 ims, ime, jms, jme, kms, kme, &
1060 its, ite, jts, jte, kts, kte)
1061 !
1062 ! This subroutine assumes a uniform aerosol distribution in both time and space.
1063 ! It should be modified if aerosol data are available from WRF-CHEM or other sources
1064 !
1065 IMPLICIT NONE
1066
1067 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
1068 ims,ime, jms,jme, kms,kme, &
1069 its,ite, jts,jte, kts,kte
1070
1071 INTEGER, INTENT(IN ) :: paerlev,naer_c
1072
1073 REAL, intent(in) :: pptop
1074 REAL, DIMENSION( kms:kme ), intent(in) :: shalf
1075
1076 REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
1077 INTENT(INOUT ) :: aerosolcn , aerosolcp
1078
1079 REAL, DIMENSION(paerlev), INTENT(OUT ) :: m_hybi
1080 REAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT ) :: m_psp,m_psn
1081
1082 REAL :: psurf
1083 real, dimension(29) :: hybi
1084 integer k ! index through vertical levels
1085
1086 INTEGER :: i, j, itf, jtf, ktf,m
1087
1088 data hybi/0, 0.0065700002014637, 0.0138600002974272, 0.023089999333024, &
1089 0.0346900001168251, 0.0491999983787537, 0.0672300010919571, &
1090 0.0894500017166138, 0.116539999842644, 0.149159997701645, &
1091 0.187830001115799, 0.232859998941422, 0.284209996461868, &
1092 0.341369986534119, 0.403340011835098, 0.468600004911423, &
1093 0.535290002822876, 0.601350009441376, 0.66482001543045, &
1094 0.724009990692139, 0.777729988098145, 0.825269997119904, &
1095 0.866419970989227, 0.901350021362305, 0.930540025234222, &
1096 0.954590022563934, 0.974179983139038, 0.990000009536743, 1/
1097
1098 jtf=min0(jte,jde-1)
1099 ktf=min0(kte,kde-1)
1100 itf=min0(ite,ide-1)
1101
1102 do k=1,paerlev
1103 m_hybi(k)=hybi(k)
1104 enddo
1105
1106 !
1107 ! mxaerl = max number of levels (from bottom) for background aerosol
1108 ! Limit background aerosol height to regions below 900 mb
1109 !
1110
1111 psurf = 1.e05
1112 mxaerl = 0
1113 ! do k=pver,1,-1
1114 do k=kms,kme-1
1115 ! if (hypm(k) >= 9.e4) mxaerl = mxaerl + 1
1116 if (shalf(k)*psurf+pptop >= 9.e4) mxaerl = mxaerl + 1
1117 end do
1118 mxaerl = max(mxaerl,1)
1119 ! if (masterproc) then
1120 write(6,*)'AEROSOLS: Background aerosol will be limited to ', &
1121 'bottom ',mxaerl,' model interfaces.'
1122 ! 'bottom ',mxaerl,' model interfaces. Top interface is ', &
1123 ! hypi(pverp-mxaerl),' pascals'
1124 ! end if
1125
1126 DO j=jts,jtf
1127 DO i=its,itf
1128 m_psp(i,j)=psurf
1129 m_psn(i,j)=psurf
1130 ENDDO
1131 ENDDO
1132
1133 DO j=jts,jtf
1134 DO i=its,itf
1135 DO k=1,paerlev
1136 aerosolcp(i,k,j,idxSUL)=1.e-7
1137 aerosolcn(i,k,j,idxSUL)=1.e-7
1138 aerosolcp(i,k,j,idxSSLT)=1.e-22
1139 aerosolcn(i,k,j,idxSSLT)=1.e-22
1140 aerosolcp(i,k,j,idxDUSTfirst)=1.e-7
1141 aerosolcn(i,k,j,idxDUSTfirst)=1.e-7
1142 aerosolcp(i,k,j,idxDUSTfirst+1)=1.e-7
1143 aerosolcn(i,k,j,idxDUSTfirst+1)=1.e-7
1144 aerosolcp(i,k,j,idxDUSTfirst+2)=1.e-7
1145 aerosolcn(i,k,j,idxDUSTfirst+2)=1.e-7
1146 aerosolcp(i,k,j,idxDUSTfirst+3)=1.e-7
1147 aerosolcn(i,k,j,idxDUSTfirst+3)=1.e-7
1148 aerosolcp(i,k,j,idxOCPHO)=1.e-7
1149 aerosolcn(i,k,j,idxOCPHO)=1.e-7
1150 aerosolcp(i,k,j,idxBCPHO)=1.e-9
1151 aerosolcn(i,k,j,idxBCPHO)=1.e-9
1152 aerosolcp(i,k,j,idxOCPHI)=1.e-7
1153 aerosolcn(i,k,j,idxOCPHI)=1.e-7
1154 aerosolcp(i,k,j,idxBCPHI)=1.e-8
1155 aerosolcn(i,k,j,idxBCPHI)=1.e-8
1156 ENDDO
1157 ENDDO
1158 ENDDO
1159
1160 call aer_optics_initialize
1161
1162
1163 END subroutine aerosol_init
1164
1165 subroutine aer_optics_initialize
1166
1167 USE module_wrf_error
1168 USE module_dm
1169
1170 ! use shr_kind_mod, only: r8 => shr_kind_r8
1171 ! use pmgrid ! masterproc is here
1172 ! use ioFileMod, only: getfil
1173
1174 !#if ( defined SPMD )
1175 ! use mpishorthand
1176 !#endif
1177 implicit none
1178
1179 ! include 'netcdf.inc'
1180
1181
1182 integer :: nrh_opac ! number of relative humidity values for OPAC data
1183 integer :: nbnd ! number of spectral bands, should be identical to nspint
1184 real(r8), parameter :: wgt_sscm = 6.0 / 7.0
1185 integer :: krh_opac ! rh index for OPAC rh grid
1186 integer :: krh ! another rh index
1187 integer :: ksz ! dust size bin index
1188 integer :: kbnd ! band index
1189
1190 real(r8) :: rh ! local relative humidity variable
1191
1192 integer, parameter :: irh=8
1193 real(r8) :: rh_opac(irh) ! OPAC relative humidity grid
1194 real(r8) :: ksul_opac(irh,nspint) ! sulfate extinction
1195 real(r8) :: wsul_opac(irh,nspint) ! single scattering albedo
1196 real(r8) :: gsul_opac(irh,nspint) ! asymmetry parameter
1197 real(r8) :: ksslt_opac(irh,nspint) ! sea-salt
1198 real(r8) :: wsslt_opac(irh,nspint)
1199 real(r8) :: gsslt_opac(irh,nspint)
1200 real(r8) :: kssam_opac(irh,nspint) ! sea-salt accumulation mode
1201 real(r8) :: wssam_opac(irh,nspint)
1202 real(r8) :: gssam_opac(irh,nspint)
1203 real(r8) :: ksscm_opac(irh,nspint) ! sea-salt coarse mode
1204 real(r8) :: wsscm_opac(irh,nspint)
1205 real(r8) :: gsscm_opac(irh,nspint)
1206 real(r8) :: kcphil_opac(irh,nspint) ! hydrophilic organic carbon
1207 real(r8) :: wcphil_opac(irh,nspint)
1208 real(r8) :: gcphil_opac(irh,nspint)
1209 real(r8) :: dummy(nspint)
1210
1211 LOGICAL :: opened
1212 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
1213
1214 CHARACTER*80 errmess
1215 INTEGER cam_aer_unit
1216 integer :: i
1217
1218 ! read aerosol optics data
1219
1220 IF ( wrf_dm_on_monitor() ) THEN
1221 DO i = 10,99
1222 INQUIRE ( i , OPENED = opened )
1223 IF ( .NOT. opened ) THEN
1224 cam_aer_unit = i
1225 GOTO 2010
1226 ENDIF
1227 ENDDO
1228 cam_aer_unit = -1
1229 2010 CONTINUE
1230 ENDIF
1231 CALL wrf_dm_bcast_bytes ( cam_aer_unit , IWORDSIZE )
1232 IF ( cam_aer_unit < 0 ) THEN
1233 CALL wrf_error_fatal ( 'module_ra_cam: aer_optics_initialize: Can not find unused fortran unit to read in lookup table.' )
1234 ENDIF
1235
1236 IF ( wrf_dm_on_monitor() ) THEN
1237 OPEN(cam_aer_unit,FILE='CAM_AEROPT_DATA', &
1238 FORM='UNFORMATTED',STATUS='OLD',ERR=9010)
1239 call wrf_debug(50,'reading CAM_AEROPT_DATA')
1240 ENDIF
1241
1242 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 )
1243
1244 IF ( wrf_dm_on_monitor() ) then
1245 READ (cam_aer_unit,ERR=9010) dummy
1246 READ (cam_aer_unit,ERR=9010) rh_opac
1247 READ (cam_aer_unit,ERR=9010) ksul_opac
1248 READ (cam_aer_unit,ERR=9010) wsul_opac
1249 READ (cam_aer_unit,ERR=9010) gsul_opac
1250 READ (cam_aer_unit,ERR=9010) kssam_opac
1251 READ (cam_aer_unit,ERR=9010) wssam_opac
1252 READ (cam_aer_unit,ERR=9010) gssam_opac
1253 READ (cam_aer_unit,ERR=9010) ksscm_opac
1254 READ (cam_aer_unit,ERR=9010) wsscm_opac
1255 READ (cam_aer_unit,ERR=9010) gsscm_opac
1256 READ (cam_aer_unit,ERR=9010) kcphil_opac
1257 READ (cam_aer_unit,ERR=9010) wcphil_opac
1258 READ (cam_aer_unit,ERR=9010) gcphil_opac
1259 READ (cam_aer_unit,ERR=9010) kcb
1260 READ (cam_aer_unit,ERR=9010) wcb
1261 READ (cam_aer_unit,ERR=9010) gcb
1262 READ (cam_aer_unit,ERR=9010) kdst
1263 READ (cam_aer_unit,ERR=9010) wdst
1264 READ (cam_aer_unit,ERR=9010) gdst
1265 READ (cam_aer_unit,ERR=9010) kbg
1266 READ (cam_aer_unit,ERR=9010) wbg
1267 READ (cam_aer_unit,ERR=9010) gbg
1268 READ (cam_aer_unit,ERR=9010) kvolc
1269 READ (cam_aer_unit,ERR=9010) wvolc
1270 READ (cam_aer_unit,ERR=9010) gvolc
1271 endif
1272
1273 DM_BCAST_MACRO(rh_opac)
1274 DM_BCAST_MACRO(ksul_opac)
1275 DM_BCAST_MACRO(wsul_opac)
1276 DM_BCAST_MACRO(gsul_opac)
1277 DM_BCAST_MACRO(kssam_opac)
1278 DM_BCAST_MACRO(wssam_opac)
1279 DM_BCAST_MACRO(gssam_opac)
1280 DM_BCAST_MACRO(ksscm_opac)
1281 DM_BCAST_MACRO(wsscm_opac)
1282 DM_BCAST_MACRO(gsscm_opac)
1283 DM_BCAST_MACRO(kcphil_opac)
1284 DM_BCAST_MACRO(wcphil_opac)
1285 DM_BCAST_MACRO(gcphil_opac)
1286 DM_BCAST_MACRO(kcb)
1287 DM_BCAST_MACRO(wcb)
1288 DM_BCAST_MACRO(gcb)
1289 DM_BCAST_MACRO(kvolc)
1290 DM_BCAST_MACRO(wvolc)
1291 DM_BCAST_MACRO(kdst)
1292 DM_BCAST_MACRO(wdst)
1293 DM_BCAST_MACRO(gdst)
1294 DM_BCAST_MACRO(kbg)
1295 DM_BCAST_MACRO(wbg)
1296 DM_BCAST_MACRO(gbg)
1297
1298 IF ( wrf_dm_on_monitor() ) CLOSE (cam_aer_unit)
1299
1300 ! map OPAC aerosol species onto CAM aerosol species
1301 ! CAM name OPAC name
1302 ! sul or SO4 = suso sulfate soluble
1303 ! sslt or SSLT = 1/7 ssam + 6/7 sscm sea-salt accumulation/coagulation mode
1304 ! cphil or CPHI = waso water soluble (carbon)
1305 ! cphob or CPHO = waso @ rh = 0
1306 ! cb or BCPHI/BCPHO = soot
1307
1308 ksslt_opac(:,:) = (1.0 - wgt_sscm) * kssam_opac(:,:) + wgt_sscm * ksscm_opac(:,:)
1309
1310 wsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) &
1311 + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) ) &
1312 / ksslt_opac(:,:)
1313
1314 gsslt_opac(:,:) = ( (1.0 - wgt_sscm) * kssam_opac(:,:) * wssam_opac(:,:) * gssam_opac(:,:) &
1315 + wgt_sscm * ksscm_opac(:,:) * wsscm_opac(:,:) * gsscm_opac(:,:) ) &
1316 / ( ksslt_opac(:,:) * wsslt_opac(:,:) )
1317
1318 do i=1,nspint
1319 kcphob(i) = kcphil_opac(1,i)
1320 wcphob(i) = wcphil_opac(1,i)
1321 gcphob(i) = gcphil_opac(1,i)
1322 end do
1323
1324 ! interpolate optical properties of hygrospopic aerosol species
1325 ! onto a uniform relative humidity grid
1326
1327 nbnd = nspint
1328
1329 do krh = 1, nrh
1330 rh = 1.0_r8 / nrh * (krh - 1)
1331 do kbnd = 1, nbnd
1332 ksul(krh, kbnd) = exp_interpol( rh_opac, &
1333 ksul_opac(:, kbnd) / ksul_opac(1, kbnd), rh ) * ksul_opac(1, kbnd)
1334 wsul(krh, kbnd) = lin_interpol( rh_opac, &
1335 wsul_opac(:, kbnd) / wsul_opac(1, kbnd), rh ) * wsul_opac(1, kbnd)
1336 gsul(krh, kbnd) = lin_interpol( rh_opac, &
1337 gsul_opac(:, kbnd) / gsul_opac(1, kbnd), rh ) * gsul_opac(1, kbnd)
1338 ksslt(krh, kbnd) = exp_interpol( rh_opac, &
1339 ksslt_opac(:, kbnd) / ksslt_opac(1, kbnd), rh ) * ksslt_opac(1, kbnd)
1340 wsslt(krh, kbnd) = lin_interpol( rh_opac, &
1341 wsslt_opac(:, kbnd) / wsslt_opac(1, kbnd), rh ) * wsslt_opac(1, kbnd)
1342 gsslt(krh, kbnd) = lin_interpol( rh_opac, &
1343 gsslt_opac(:, kbnd) / gsslt_opac(1, kbnd), rh ) * gsslt_opac(1, kbnd)
1344 kcphil(krh, kbnd) = exp_interpol( rh_opac, &
1345 kcphil_opac(:, kbnd) / kcphil_opac(1, kbnd), rh ) * kcphil_opac(1, kbnd)
1346 wcphil(krh, kbnd) = lin_interpol( rh_opac, &
1347 wcphil_opac(:, kbnd) / wcphil_opac(1, kbnd), rh ) * wcphil_opac(1, kbnd)
1348 gcphil(krh, kbnd) = lin_interpol( rh_opac, &
1349 gcphil_opac(:, kbnd) / gcphil_opac(1, kbnd), rh ) * gcphil_opac(1, kbnd)
1350 end do
1351 end do
1352
1353 RETURN
1354 9010 CONTINUE
1355 WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_aer_unit
1356 CALL wrf_error_fatal(errmess)
1357
1358 END subroutine aer_optics_initialize
1359
1360 function exp_interpol(x, f, y) result(g)
1361
1362 ! Purpose:
1363 ! interpolates f(x) to point y
1364 ! assuming f(x) = f(x0) exp a(x - x0)
1365 ! where a = ( ln f(x1) - ln f(x0) ) / (x1 - x0)
1366 ! x0 <= x <= x1
1367 ! assumes x is monotonically increasing
1368
1369 ! Author: D. Fillmore
1370
1371 ! use shr_kind_mod, only: r8 => shr_kind_r8
1372
1373 implicit none
1374
1375 real(r8), intent(in), dimension(:) :: x ! grid points
1376 real(r8), intent(in), dimension(:) :: f ! grid function values
1377 real(r8), intent(in) :: y ! interpolation point
1378 real(r8) :: g ! interpolated function value
1379
1380 integer :: k ! interpolation point index
1381 integer :: n ! length of x
1382 real(r8) :: a
1383
1384 n = size(x)
1385
1386 ! find k such that x(k) < y =< x(k+1)
1387 ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
1388
1389 if (y <= x(1)) then
1390 k = 1
1391 else if (y >= x(n)) then
1392 k = n - 1
1393 else
1394 k = 1
1395 do while (y > x(k+1) .and. k < n)
1396 k = k + 1
1397 end do
1398 end if
1399
1400 ! interpolate
1401 a = ( log( f(k+1) / f(k) ) ) / ( x(k+1) - x(k) )
1402 g = f(k) * exp( a * (y - x(k)) )
1403
1404 end function exp_interpol
1405
1406 function lin_interpol(x, f, y) result(g)
1407
1408 ! Purpose:
1409 ! interpolates f(x) to point y
1410 ! assuming f(x) = f(x0) + a * (x - x0)
1411 ! where a = ( f(x1) - f(x0) ) / (x1 - x0)
1412 ! x0 <= x <= x1
1413 ! assumes x is monotonically increasing
1414
1415 ! Author: D. Fillmore
1416
1417 ! use shr_kind_mod, only: r8 => shr_kind_r8
1418
1419 implicit none
1420
1421 real(r8), intent(in), dimension(:) :: x ! grid points
1422 real(r8), intent(in), dimension(:) :: f ! grid function values
1423 real(r8), intent(in) :: y ! interpolation point
1424 real(r8) :: g ! interpolated function value
1425
1426 integer :: k ! interpolation point index
1427 integer :: n ! length of x
1428 real(r8) :: a
1429
1430 n = size(x)
1431
1432 ! find k such that x(k) < y =< x(k+1)
1433 ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
1434
1435 if (y <= x(1)) then
1436 k = 1
1437 else if (y >= x(n)) then
1438 k = n - 1
1439 else
1440 k = 1
1441 do while (y > x(k+1) .and. k < n)
1442 k = k + 1
1443 end do
1444 end if
1445
1446 ! interpolate
1447 a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) )
1448 g = f(k) + a * (y - x(k))
1449
1450 end function lin_interpol
1451
1452 function lin_interpol2(x, f, y) result(g)
1453
1454 ! Purpose:
1455 ! interpolates f(x) to point y
1456 ! assuming f(x) = f(x0) + a * (x - x0)
1457 ! where a = ( f(x1) - f(x0) ) / (x1 - x0)
1458 ! x0 <= x <= x1
1459 ! assumes x is monotonically increasing
1460
1461 ! Author: D. Fillmore :: J. Done changed from r8 to r4
1462
1463 implicit none
1464
1465 real, intent(in), dimension(:) :: x ! grid points
1466 real, intent(in), dimension(:) :: f ! grid function values
1467 real, intent(in) :: y ! interpolation point
1468 real :: g ! interpolated function value
1469
1470 integer :: k ! interpolation point index
1471 integer :: n ! length of x
1472 real :: a
1473
1474 n = size(x)
1475
1476 ! find k such that x(k) < y =< x(k+1)
1477 ! set k = 1 if y <= x(1) and k = n-1 if y > x(n)
1478
1479 if (y <= x(1)) then
1480 k = 1
1481 else if (y >= x(n)) then
1482 k = n - 1
1483 else
1484 k = 1
1485 do while (y > x(k+1) .and. k < n)
1486 k = k + 1
1487 end do
1488 end if
1489
1490 ! interpolate
1491 a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) )
1492 g = f(k) + a * (y - x(k))
1493
1494 end function lin_interpol2
1495
1496 subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
1497
1498 IMPLICIT NONE
1499
1500 INTEGER, INTENT(IN ) :: levsiz, num_months,pcols
1501
1502 REAL(r8), DIMENSION( pcols, levsiz, num_months ), &
1503 INTENT(IN ) :: ozmixmj
1504
1505 REAL, INTENT(IN ) :: XTIME,GMT
1506 INTEGER, INTENT(IN ) :: JULDAY
1507 REAL, INTENT(IN ) :: JULIAN
1508 REAL, INTENT(IN ) :: DT
1509
1510 REAL(r8), DIMENSION( pcols, levsiz ), &
1511 INTENT(OUT ) :: ozmix
1512 !Local
1513 REAL(r8) :: intJULIAN
1514 integer :: np1,np,nm,m,k,i
1515 integer :: IJUL
1516 integer, dimension(12) :: date_oz
1517 data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
1518 real(r8) :: cdayozp, cdayozm
1519 real(r8) :: fact1, fact2
1520 logical :: finddate
1521 CHARACTER(LEN=256) :: msgstr
1522
1523 ! JULIAN starts from 0.0 at 0Z on 1 Jan.
1524 intJULIAN = JULIAN + 1.0_r8 ! offset by one day
1525 ! jan 1st 00z is julian=1.0 here
1526 IJUL=INT(intJULIAN)
1527 ! Note that following will drift.
1528 ! Need to use actual month/day info to compute julian.
1529 intJULIAN=intJULIAN-FLOAT(IJUL)
1530 IJUL=MOD(IJUL,365)
1531 IF(IJUL.EQ.0)IJUL=365
1532 intJULIAN=intJULIAN+IJUL
1533 np1=1
1534 finddate=.false.
1535 do m=1,num_months
1536 if(date_oz(m).gt.intjulian.and..not.finddate) then
1537 np1=m
1538 finddate=.true.
1539 endif
1540 enddo
1541 cdayozp=date_oz(np1)
1542 if(np1.gt.1) then
1543 cdayozm=date_oz(np1-1)
1544 np=np1
1545 nm=np-1
1546 else
1547 cdayozm=date_oz(12)
1548 np=np1
1549 nm=12
1550 endif
1551 call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, &
1552 fact1, fact2)
1553
1554 !
1555 ! Time interpolation.
1556 !
1557 do k=1,levsiz
1558 do i=1,pcols
1559 ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2
1560 end do
1561 end do
1562
1563 END subroutine oznint
1564
1565 subroutine getfactors (cycflag, np1, cdayminus, cdayplus, cday, &
1566 fact1, fact2)
1567 !---------------------------------------------------------------------------
1568 !
1569 ! Purpose: Determine time interpolation factors (normally for a boundary dataset)
1570 ! for linear interpolation.
1571 !
1572 ! Method: Assume 365 days per year. Output variable fact1 will be the weight to
1573 ! apply to data at calendar time "cdayminus", and fact2 the weight to apply
1574 ! to data at time "cdayplus". Combining these values will produce a result
1575 ! valid at time "cday". Output arguments fact1 and fact2 will be between
1576 ! 0 and 1, and fact1 + fact2 = 1 to roundoff.
1577 !
1578 ! Author: Jim Rosinski
1579 !
1580 !---------------------------------------------------------------------------
1581 implicit none
1582 !
1583 ! Arguments
1584 !
1585 logical, intent(in) :: cycflag ! flag indicates whether dataset is being cycled yearly
1586
1587 integer, intent(in) :: np1 ! index points to forward time slice matching cdayplus
1588
1589 real(r8), intent(in) :: cdayminus ! calendar day of rearward time slice
1590 real(r8), intent(in) :: cdayplus ! calendar day of forward time slice
1591 real(r8), intent(in) :: cday ! calenar day to be interpolated to
1592 real(r8), intent(out) :: fact1 ! time interpolation factor to apply to rearward time slice
1593 real(r8), intent(out) :: fact2 ! time interpolation factor to apply to forward time slice
1594
1595 ! character(len=*), intent(in) :: str ! string to be added to print in case of error (normally the callers name)
1596 !
1597 ! Local workspace
1598 !
1599 real(r8) :: deltat ! time difference (days) between cdayminus and cdayplus
1600 real(r8), parameter :: daysperyear = 365. ! number of days in a year
1601 !
1602 ! Initial sanity checks
1603 !
1604 ! if (np1 == 1 .and. .not. cycflag) then
1605 ! call endrun ('GETFACTORS:'//str//' cycflag false and forward month index = Jan. not allowed')
1606 ! end if
1607
1608 ! if (np1 < 1) then
1609 ! call endrun ('GETFACTORS:'//str//' input arg np1 must be > 0')
1610 ! end if
1611
1612 if (cycflag) then
1613 if ((cday < 1.) .or. (cday > (daysperyear+1.))) then
1614 write(6,*) 'GETFACTORS:', ' bad cday=',cday
1615 ! call endrun ()
1616 end if
1617 else
1618 if (cday < 1.) then
1619 write(6,*) 'GETFACTORS:', ' bad cday=',cday
1620 ! call endrun ()
1621 end if
1622 end if
1623 !
1624 ! Determine time interpolation factors. Account for December-January
1625 ! interpolation if dataset is being cycled yearly.
1626 !
1627 if (cycflag .and. np1 == 1) then ! Dec-Jan interpolation
1628 deltat = cdayplus + daysperyear - cdayminus
1629 if (cday > cdayplus) then ! We are in December
1630 fact1 = (cdayplus + daysperyear - cday)/deltat
1631 fact2 = (cday - cdayminus)/deltat
1632 else ! We are in January
1633 fact1 = (cdayplus - cday)/deltat
1634 fact2 = (cday + daysperyear - cdayminus)/deltat
1635 end if
1636 else
1637 deltat = cdayplus - cdayminus
1638 fact1 = (cdayplus - cday)/deltat
1639 fact2 = (cday - cdayminus)/deltat
1640 end if
1641
1642 if (.not. validfactors (fact1, fact2)) then
1643 write(6,*) 'GETFACTORS: ', ' bad fact1 and/or fact2=', fact1, fact2
1644 ! call endrun ()
1645 end if
1646
1647 return
1648 end subroutine getfactors
1649
1650 logical function validfactors (fact1, fact2)
1651 !---------------------------------------------------------------------------
1652 !
1653 ! Purpose: check sanity of time interpolation factors to within 32-bit roundoff
1654 !
1655 !---------------------------------------------------------------------------
1656 implicit none
1657
1658 real(r8), intent(in) :: fact1, fact2 ! time interpolation factors
1659
1660 validfactors = .true.
1661 if (abs(fact1+fact2-1.) > 1.e-6 .or. &
1662 fact1 > 1.000001 .or. fact1 < -1.e-6 .or. &
1663 fact2 > 1.000001 .or. fact2 < -1.e-6) then
1664
1665 validfactors = .false.
1666 end if
1667
1668 return
1669 end function validfactors
1670
1671 subroutine get_rf_scales(scales)
1672
1673 real(r8), intent(out)::scales(naer_all) ! scale aerosols by this amount
1674
1675 integer i ! loop index
1676
1677 scales(idxBG) = bgscl_rf
1678 scales(idxSUL) = sulscl_rf
1679 scales(idxSSLT) = ssltscl_rf
1680
1681 do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1
1682 scales(i) = carscl_rf
1683 enddo
1684
1685 do i = idxDUSTfirst, idxDUSTfirst+numDUST-1
1686 scales(i) = dustscl_rf
1687 enddo
1688
1689 scales(idxVOLC) = volcscl_rf
1690
1691 end subroutine get_rf_scales
1692
1693 subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
1694 aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale)
1695 !------------------------------------------------------------------
1696 !
1697 ! Input:
1698 ! time at which aerosol mmrs are needed (get_curr_calday())
1699 ! chunk index
1700 ! CAM's vertical grid (pint)
1701 !
1702 ! Output:
1703 ! values for Aerosol Mass Mixing Ratios at specified time
1704 ! on vertical grid specified by CAM (AEROSOLt)
1705 !
1706 ! Method:
1707 ! first determine which indexs of aerosols are the bounding data sets
1708 ! interpolate both onto vertical grid aerm(),aerp().
1709 ! from those two, interpolate in time.
1710 !
1711 !------------------------------------------------------------------
1712
1713 ! use volcanicmass, only: get_volcanic_mass
1714 ! use timeinterp, only: getfactors
1715 !
1716 ! aerosol fields interpolated to current time step
1717 ! on pressure levels of this time step.
1718 ! these should be made read-only for other modules
1719 ! Is allocation done correctly here?
1720 !
1721 integer, intent(in) :: c ! Chunk Id.
1722 integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp
1723 real(r8), intent(in) :: pint(pcols,pverp) ! midpoint pres.
1724 real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount
1725 REAL, INTENT(IN ) :: XTIME,GMT
1726 INTEGER, INTENT(IN ) :: JULDAY
1727 REAL, INTENT(IN ) :: JULIAN
1728 REAL, INTENT(IN ) :: DT
1729 real(r8), intent(in ) :: m_psp(pcols),m_psn(pcols) ! Match surface pressure
1730 real(r8), intent(in ) :: aerosoljp(pcols,paerlev,naer_c)
1731 real(r8), intent(in ) :: aerosoljn(pcols,paerlev,naer_c)
1732 real(r8), intent(in ) :: m_hybi(paerlev)
1733
1734 real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
1735 !
1736 ! Local workspace
1737 !
1738 real(r8) caldayloc ! calendar day of current timestep
1739 real(r8) fact1, fact2 ! time interpolation factors
1740
1741 integer :: nm = 1 ! index to prv month in array. init to 1 and toggle between 1 and 2
1742 integer :: np = 2 ! index to nxt month in array. init to 2 and toggle between 1 and 2
1743 integer :: mo_nxt = bigint ! index to nxt month in file
1744 integer :: mo_prv ! index to previous month
1745
1746 real(r8) :: cdaym = inf ! calendar day of prv month
1747 real(r8) :: cdayp = inf ! calendar day of next month
1748 real(r8) :: Mid(12) ! Days into year for mid month date
1749 data Mid/16.5, 46.0, 75.5, 106.0, 136.5, 167.0, 197.5, 228.5, 259.0, 289.5, 320.0, 350.5 /
1750
1751 integer i, k, j ! spatial indices
1752 integer m ! constituent index
1753 integer lats(pcols),lons(pcols) ! latitude and longitudes of column
1754 integer ncol ! number of columns
1755 INTEGER IJUL
1756 REAL(r8) intJULIAN
1757
1758 real(r8) speciesmin(naer) ! minimal value for each species
1759 !
1760 ! values before current time step "the minus month"
1761 ! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr
1762 ! aerosolp(pcols,pver) is value of next month's aerosol mmr
1763 ! (think minus and plus or values to left and right of point to be interpolated)
1764 !
1765 real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month
1766 !
1767 ! values beyond (or at) current time step "the plus month"
1768 !
1769 real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month
1770 CHARACTER(LEN=256) :: msgstr
1771
1772 ! JULIAN starts from 0.0 at 0Z on 1 Jan.
1773 intJULIAN = JULIAN + 1.0_r8 ! offset by one day
1774 ! jan 1st 00z is julian=1.0 here
1775 IJUL=INT(intJULIAN)
1776 ! Note that following will drift.
1777 ! Need to use actual month/day info to compute julian.
1778 intJULIAN=intJULIAN-FLOAT(IJUL)
1779 IJUL=MOD(IJUL,365)
1780 IF(IJUL.EQ.0)IJUL=365
1781 caldayloc=intJULIAN+IJUL
1782
1783 if (caldayloc < Mid(1)) then
1784 mo_prv = 12
1785 mo_nxt = 1
1786 else if (caldayloc >= Mid(12)) then
1787 mo_prv = 12
1788 mo_nxt = 1
1789 else
1790 do i = 2 , 12
1791 if (caldayloc < Mid(i)) then
1792 mo_prv = i-1
1793 mo_nxt = i
1794 exit
1795 end if
1796 end do
1797 end if
1798 !
1799 ! Set initial calendar day values
1800 !
1801 cdaym = Mid(mo_prv)
1802 cdayp = Mid(mo_nxt)
1803
1804 !
1805 ! Determine time interpolation factors. 1st arg says we are cycling 1 year of data
1806 !
1807 call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, &
1808 fact1, fact2)
1809 !
1810 ! interpolate (prv and nxt month) bounding datasets onto cam vertical grid.
1811 ! compute mass mixing ratios on CAMS's pressure coordinate
1812 ! for both the "minus" and "plus" months
1813 !
1814 ! ncol = get_ncols_p©
1815 ncol = pcols
1816
1817 ! call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c)
1818 ! call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c)
1819
1820 call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c)
1821 call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c)
1822
1823 !
1824 ! Time interpolate.
1825 !
1826 do m=1,naer
1827 do k=1,pver
1828 do i=1,ncol
1829 AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2
1830 end do
1831 end do
1832 end do
1833
1834 ! do i=1,ncol
1835 ! Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2
1836 ! end do
1837 !
1838 ! get background aerosol (tuning) field
1839 !
1840 call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG))
1841
1842 !
1843 ! find volcanic aerosol masses
1844 !
1845 ! if (strat_volcanic) then
1846 ! call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC))
1847 ! else
1848 AEROSOLt(:,:,idxVOLC) = 0._r8
1849 ! endif
1850
1851 !
1852 ! exit if mmr is negative (we have previously set
1853 ! cumulative mass to be a decreasing function.)
1854 !
1855 speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species
1856
1857 do m=1,naer
1858 do k=1,pver
1859 do i=1,ncol
1860 if (AEROSOLt(i, k, m) < speciesmin(m)) then
1861 write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting'
1862 write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m)
1863 ! call endrun ()
1864 end if
1865 end do
1866 end do
1867 end do
1868 !
1869 ! scale any AEROSOLS as required
1870 !
1871 call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale)
1872
1873 return
1874 end subroutine get_aerosol
1875
1876 subroutine vert_interpolate (Match_ps, aerosolc, m_hybi, paerlev, naer_c, pint, n, AEROSOL_mmr, pcols, pver, pverp, ncol, c)
1877 !--------------------------------------------------------------------
1878 ! Input: match surface pressure, cam interface pressure,
1879 ! month index, number of columns, chunk index
1880 !
1881 ! Output: Aerosol mass mixing ratio (AEROSOL_mmr)
1882 !
1883 ! Method:
1884 ! interpolate column mass (cumulative) from match onto
1885 ! cam's vertical grid (pressure coordinate)
1886 ! convert back to mass mixing ratio
1887 !
1888 !--------------------------------------------------------------------
1889
1890 ! use physconst, only: gravit
1891
1892 integer, intent(in) :: paerlev,naer_c,pcols,pver,pverp
1893 real(r8), intent(out) :: AEROSOL_mmr(pcols,pver,naer) ! aerosol mmr from MATCH
1894 real(r8), intent(in) :: Match_ps(pcols) ! surface pressure at a particular month
1895 real(r8), intent(in) :: pint(pcols,pverp) ! interface pressure from CAM
1896 real(r8), intent(in) :: aerosolc(pcols,paerlev,naer_c)
1897 real(r8), intent(in) :: m_hybi(paerlev)
1898
1899 integer, intent(in) :: ncol,c ! chunk index and number of columns
1900 integer, intent(in) :: n ! prv or nxt month index
1901 !
1902 ! Local workspace
1903 !
1904 integer m ! index to aerosol species
1905 integer kupper(pcols) ! last upper bound for interpolation
1906 integer i, k, kk, kkstart, kount ! loop vars for interpolation
1907 integer isv, ksv, msv ! loop indices to save
1908
1909 logical bad ! indicates a bad point found
1910 logical lev_interp_comp ! interpolation completed for a level
1911
1912 real(r8) AEROSOL(pcols,pverp,naer) ! cumulative mass of aerosol in column beneath upper
1913 ! interface of level in column at particular month
1914 real(r8) dpl, dpu ! lower and upper intepolation factors
1915 real(r8) v_coord ! vertical coordinate
1916 real(r8) m_to_mmr ! mass to mass mixing ratio conversion factor
1917 real(r8) AER_diff ! temp var for difference between aerosol masses
1918
1919 ! call t_startf ('vert_interpolate')
1920 !
1921 ! Initialize index array
1922 !
1923 do i=1,ncol
1924 kupper(i) = 1
1925 end do
1926 !
1927 ! assign total mass to topmost level
1928 !
1929
1930 do i=1,ncol
1931 do m=1,naer
1932 AEROSOL(i,1,m) = AEROSOLc(i,1,m)
1933 enddo
1934 enddo
1935 !
1936 ! At every pressure level, interpolate onto that pressure level
1937 !
1938 do k=2,pver
1939 !
1940 ! Top level we need to start looking is the top level for the previous k
1941 ! for all longitude points
1942 !
1943 kkstart = paerlev
1944 do i=1,ncol
1945 kkstart = min0(kkstart,kupper(i))
1946 end do
1947 kount = 0
1948 !
1949 ! Store level indices for interpolation
1950 !
1951 ! for the pressure interpolation should be comparing
1952 ! pint(column,lev) with M_hybi(lev)*M_ps_cam_col(month,column,chunk)
1953 !
1954 lev_interp_comp = .false.
1955 do kk=kkstart,paerlev-1
1956 if(.not.lev_interp_comp) then
1957 do i=1,ncol
1958 v_coord = pint(i,k)
1959 if (M_hybi(kk)*Match_ps(i) .lt. v_coord .and. v_coord .le. M_hybi(kk+1)*Match_ps(i)) then
1960 kupper(i) = kk
1961 kount = kount + 1
1962 end if
1963 end do
1964 !
1965 ! If all indices for this level have been found, do the interpolation and
1966 ! go to the next level
1967 !
1968 ! Interpolate in pressure.
1969 !
1970 if (kount.eq.ncol) then
1971 do i=1,ncol
1972 do m=1,naer
1973 dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i)
1974 dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k)
1975 AEROSOL(i,k,m) = &
1976 (AEROSOLc(i,kupper(i) ,m)*dpl + &
1977 AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu)
1978 enddo
1979 enddo !i
1980 lev_interp_comp = .true.
1981 end if
1982 end if
1983 end do
1984 !
1985 ! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
1986
1987 ! must extrapolate from the bottom or top pressure level for at least some
1988 ! of the longitude points.
1989 !
1990
1991 if(.not.lev_interp_comp) then
1992 do i=1,ncol
1993 do m=1,naer
1994 if (pint(i,k) .lt. M_hybi(1)*Match_ps(i)) then
1995 AEROSOL(i,k,m) = AEROSOLc(i,1,m)
1996 else if (pint(i,k) .gt. M_hybi(paerlev)*Match_ps(i)) then
1997 AEROSOL(i,k,m) = 0.0
1998 else
1999 dpu = pint(i,k) - M_hybi(kupper(i))*Match_ps(i)
2000 dpl = M_hybi(kupper(i)+1)*Match_ps(i) - pint(i,k)
2001 AEROSOL(i,k,m) = &
2002 (AEROSOLc(i,kupper(i) ,m)*dpl + &
2003 AEROSOLc(i,kupper(i)+1,m)*dpu)/(dpl + dpu)
2004 end if
2005 enddo
2006 end do
2007
2008 if (kount.gt.ncol) then
2009 ! call endrun ('VERT_INTERPOLATE: Bad data: non-monotonicity suspected in dependent variable')
2010 end if
2011 end if
2012 end do
2013
2014 ! call t_startf ('vi_checks')
2015 !
2016 ! aerosol mass beneath lowest interface (pverp) must be 0
2017 !
2018 AEROSOL(1:ncol,pverp,:) = 0.
2019 !
2020 ! Set mass in layer to zero whenever it is less than
2021 ! 1.e-40 kg/m^2 in the layer
2022 !
2023 do m = 1, naer
2024 do k = 1, pver
2025 do i = 1, ncol
2026 if (AEROSOL(i,k,m) < 1.e-40_r8) AEROSOL(i,k,m) = 0.
2027 end do
2028 end do
2029 end do
2030 !
2031 ! Set mass in layer to zero whenever it is less than
2032 ! 10^-15 relative to column total mass
2033 ! convert back to mass mixing ratios.
2034 ! exit if mmr is negative
2035 !
2036 do m = 1, naer
2037 do k = 1, pver
2038 do i = 1, ncol
2039 AER_diff = AEROSOL(i,k,m) - AEROSOL(i,k+1,m)
2040 if( abs(AER_diff) < 1e-15*AEROSOL(i,1,m)) then
2041 AER_diff = 0.
2042 end if
2043 m_to_mmr = gravmks / (pint(i,k+1)-pint(i,k))
2044 AEROSOL_mmr(i,k,m)= AER_diff * m_to_mmr
2045 if (AEROSOL_mmr(i,k,m) < 0) then
2046 write(6,*)'vert_interpolate: mmr < 0, m, col, lev, mmr',m, i, k, AEROSOL_mmr(i,k,m)
2047 write(6,*)'vert_interpolate: aerosol(k),(k+1)',AEROSOL(i,k,m),AEROSOL(i,k+1,m)
2048 write(6,*)'vert_interpolate: pint(k+1),(k)',pint(i,k+1),pint(i,k)
2049 write(6,*)'n,c',n,c
2050 ! call endrun()
2051 end if
2052 end do
2053 end do
2054 end do
2055
2056 ! call t_stopf ('vi_checks')
2057 ! call t_stopf ('vert_interpolate')
2058
2059 return
2060 end subroutine vert_interpolate
2061
2062 subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
2063 !--------------------------------------------------------------
2064 ! Compute effect of sulfate on effective liquid water radius
2065 ! Method of Martin et. al.
2066 !--------------------------------------------------------------
2067
2068 ! use constituents, only: ppcnst, cnst_get_ind
2069 ! use history, only: outfld
2070
2071 !#include <comctl.h>
2072
2073 integer, intent(in) :: ncol ! number of atmospheric columns
2074 integer, intent(in) :: lchnk ! chunk identifier
2075 integer, intent(in) :: pcols,pver,ppcnst
2076
2077 real(r8), intent(in) :: landfrac(pcols) ! land fraction
2078 real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
2079 real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
2080 real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
2081 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
2082 real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
2083 real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
2084 !
2085 ! local variables
2086 !
2087 real(r8) locrhoair(pcols,pver) ! dry air density [kg/m^3 ]
2088 real(r8) lwcwat(pcols,pver) ! in-cloud liquid water path [kg/m^3 ]
2089 real(r8) sulfmix(pcols,pver) ! sulfate mass mixing ratio [kg/kg ]
2090 real(r8) so4mass(pcols,pver) ! sulfate mass concentration [g/cm^3 ]
2091 real(r8) Aso4(pcols,pver) ! sulfate # concentration [#/cm^3 ]
2092 real(r8) Ntot(pcols,pver) ! ccn # concentration [#/cm^3 ]
2093 real(r8) relmod(pcols,pver) ! effective radius [microns]
2094
2095 real(r8) wrel(pcols,pver) ! weighted effective radius [microns]
2096 real(r8) wlwc(pcols,pver) ! weighted liq. water content [kg/m^3 ]
2097 real(r8) cldfrq(pcols,pver) ! frequency of occurance of...
2098 ! ! clouds (cld => 0.01) [fraction]
2099 real(r8) locPi ! my piece of the pi
2100 real(r8) Rdryair ! gas constant of dry air [J/deg/kg]
2101 real(r8) rhowat ! density of water [kg/m^3 ]
2102 real(r8) Acoef ! m->A conversion factor; assumes
2103 ! ! Dbar=0.10, sigma=2.0 [g^-1 ]
2104 real(r8) rekappa ! kappa in evaluation of re(lmod)
2105 real(r8) recoef ! temp. coeficient for calc of re(lmod)
2106 real(r8) reexp ! 1.0/3.0
2107 real(r8) Ntotb ! temp var to hold below cloud ccn
2108 ! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)...
2109 real(r8) Cmarn ! Coef for CDNC_marine [cm^-3]
2110 real(r8) Cland ! Coef for CDNC_land [cm^-3]
2111 real(r8) Hmarn ! Scale height for CDNC_marine [m]
2112 real(r8) Hland ! Scale height for CDNC_land [m]
2113 parameter ( Cmarn = 50.0, Cland = 100.0 )
2114 parameter ( Hmarn = 1000.0, Hland = 2000.0 )
2115 real(r8) bgaer ! temp var to hold background CDNC
2116
2117 integer i,k ! loop indices
2118 !
2119 ! Statement functions
2120 !
2121 logical land ! is this a column over land?
2122 land(i) = nint(landfrac(i)).gt.0.5_r8
2123
2124 if (indirect) then
2125
2126 ! call endrun ('AEROSOL_INDIRECT: indirect effect is obsolete')
2127
2128 ! ramping is not yet resolved so sulfmix is 0.
2129 sulfmix(1:ncol,1:pver) = 0._r8
2130
2131 locPi = 3.141592654
2132 Rdryair = 287.04
2133 rhowat = 1000.0
2134 Acoef = 1.2930E14
2135 recoef = 3.0/(4.0*locPi*rhowat)
2136 reexp = 1.0/3.0
2137
2138 ! call cnst_get_ind('CLDLIQ', ixcldliq)
2139 do k=pver,1,-1
2140 do i = 1,ncol
2141 locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) )
2142 lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* &
2143 locrhoair(i,k)
2144 ! NOTE: 0.001 converts kg/m3 -> g/cm3
2145 so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001
2146 Aso4(i,k) = so4mass(i,k)*Acoef
2147
2148 if (Aso4(i,k) <= 280.0) then
2149 Aso4(i,k) = max(36.0_r8,Aso4(i,k))
2150 Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30
2151 rekappa = 0.80
2152 else
2153 Aso4(i,k) = min(1500.0_r8,Aso4(i,k))
2154 Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9
2155 rekappa = 0.67
2156 end if
2157 if (land(i)) then ! Account for local background aerosol;
2158 bgaer = Cland*exp(-(zm(i,k)/Hland))
2159 Ntot(i,k) = max(bgaer,Ntot(i,k))
2160 else
2161 bgaer = Cmarn*exp(-(zm(i,k)/Hmarn))
2162 Ntot(i,k) = max(bgaer,Ntot(i,k))
2163 end if
2164
2165 if (k == pver) then
2166 Ntotb = Ntot(i,k)
2167 else
2168 Ntotb = Ntot(i,k+1)
2169 end if
2170
2171 relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0
2172 relmod(i,k) = max(4.0_r8,relmod(i,k))
2173 relmod(i,k) = min(20.0_r8,relmod(i,k))
2174 if (cld(i,k) >= 0.01) then
2175 cldfrq(i,k) = 1.0
2176 else
2177 cldfrq(i,k) = 0.0
2178 end if
2179 wrel(i,k) = relmod(i,k)*cldfrq(i,k)
2180 wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k)
2181 end do
2182 end do
2183 ! call outfld('MSO4 ',so4mass,pcols,lchnk)
2184 ! call outfld('LWC ',lwcwat ,pcols,lchnk)
2185 ! call outfld('CLDFRQ ',cldfrq ,pcols,lchnk)
2186 ! call outfld('WREL ',wrel ,pcols,lchnk)
2187 ! call outfld('WLWC ',wlwc ,pcols,lchnk)
2188 ! write(6,*)'WARNING: indirect calculation has no effects'
2189 else
2190 do k = 1, pver
2191 do i = 1, ncol
2192 relmod(i,k) = rel(i,k)
2193 end do
2194 end do
2195 endif
2196
2197 ! call outfld('REL ',relmod ,pcols,lchnk)
2198
2199 return
2200 end subroutine aerosol_indirect
2201
2202
2203 subroutine background(lchnk, ncol, pint, pcols, pverr, pverrp, mmr)
2204 !-----------------------------------------------------------------------
2205 !
2206 ! Purpose:
2207 ! Set global mean tropospheric aerosol background (or tuning) field
2208 !
2209 ! Method:
2210 ! Specify aerosol mixing ratio.
2211 ! Aerosol mass mixing ratio
2212 ! is specified so that the column visible aerosol optical depth is a
2213 ! specified global number (tauback). This means that the actual mixing
2214 ! ratio depends on pressure thickness of the lowest three atmospheric
2215 ! layers near the surface.
2216 !
2217 !-----------------------------------------------------------------------
2218 ! use shr_kind_mod, only: r8 => shr_kind_r8
2219 ! use aer_optics, only: kbg,idxVIS
2220 ! use physconst, only: gravit
2221 !-----------------------------------------------------------------------
2222 implicit none
2223 !-----------------------------------------------------------------------
2224 !#include <ptrrgrid.h>
2225 !------------------------------Arguments--------------------------------
2226 !
2227 ! Input arguments
2228 !
2229 integer, intent(in) :: lchnk ! chunk identifier
2230 integer, intent(in) :: ncol ! number of atmospheric columns
2231 integer, intent(in) :: pcols,pverr,pverrp
2232
2233 real(r8), intent(in) :: pint(pcols,pverrp) ! Interface pressure (mks)
2234 !
2235 ! Output arguments
2236 !
2237 real(r8), intent(out) :: mmr(pcols,pverr) ! "background" aerosol mass mixing ratio
2238 !
2239 !---------------------------Local variables-----------------------------
2240 !
2241 integer i ! Longitude index
2242 integer k ! Level index
2243 !
2244 real(r8) mass2mmr ! Factor to convert mass to mass mixing ratio
2245 real(r8) mass ! Mass of "background" aerosol as specified by tauback
2246 !
2247 !-----------------------------------------------------------------------
2248 !
2249 do i=1,ncol
2250 mass2mmr = gravmks / (pint(i,pverrp)-pint(i,pverrp-mxaerl))
2251 do k=1,pverr
2252 !
2253 ! Compute aerosol mass mixing ratio for specified levels (1.e3 factor is
2254 ! for units conversion of the extinction coefficiant from m2/g to m2/kg)
2255 !
2256 if ( k >= pverrp-mxaerl ) then
2257 ! kaervs is not consistent with the values in aer_optics
2258 ! this ?should? be changed.
2259 ! rhfac is also implemented differently
2260 mass = tauback / (1.e3 * kbg(idxVIS))
2261 mmr(i,k) = mass2mmr*mass
2262 else
2263 mmr(i,k) = 0._r8
2264 endif
2265 !
2266 enddo
2267 enddo
2268 !
2269 return
2270 end subroutine background
2271
2272 subroutine scale_aerosols(AEROSOLt, pcols, pver, ncol, lchnk, scale)
2273 !-----------------------------------------------------------------
2274 ! scale each species as determined by scale factors
2275 !-----------------------------------------------------------------
2276 integer, intent(in) :: ncol, lchnk ! number of columns and chunk index
2277 integer, intent(in) :: pcols, pver
2278 real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount
2279 real(r8), intent(inout) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
2280 integer m
2281
2282 do m = 1, naer_all
2283 AEROSOLt(:ncol, :, m) = scale(m)*AEROSOLt(:ncol, :, m)
2284 end do
2285
2286 return
2287 end subroutine scale_aerosols
2288
2289 subroutine get_int_scales(scales)
2290 real(r8), intent(out)::scales(naer_all) ! scale each aerosol by this amount
2291 integer i ! index through species
2292
2293 !initialize
2294 scales = 1.
2295
2296 scales(idxBG) = 1._r8
2297 scales(idxSUL) = sulscl
2298 scales(idxSSLT) = ssltscl
2299
2300 do i = idxCARBONfirst, idxCARBONfirst+numCARBON-1
2301 scales(i) = carscl
2302 enddo
2303
2304 do i = idxDUSTfirst, idxDUSTfirst+numDUST-1
2305 scales(i) = dustscl
2306 enddo
2307
2308 scales(idxVOLC) = volcscl
2309
2310 return
2311 end subroutine get_int_scales
2312
2313 subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp )
2314 !
2315 ! Purpose: Compute strat. aerosol transmissions needed in absorptivity/
2316 ! emissivity calculations
2317 ! aer_trn() is called by radclw() when doabsems is .true.
2318 !
2319 ! use shr_kind_mod, only: r8 => shr_kind_r8
2320 ! use pmgrid
2321 ! use ppgrid
2322 ! use prescribed_aerosols, only: strat_volcanic
2323 implicit none
2324
2325 ! Input arguments
2326 !
2327 ! [kg m-2] Volcanics path above kth interface level
2328 !
2329 integer, intent(in) :: pcols, plev, plevp
2330 real(r8), intent(in) :: aer_mpp(pcols,plevp)
2331
2332 ! Output arguments
2333 !
2334 ! [fraction] Total volcanic transmission between interfaces k1 and k2
2335 !
2336 real(r8), intent(out) :: aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW)
2337
2338 !-------------------------------------------------------------------------
2339 ! Local variables
2340
2341 integer bnd_idx ! LW band index
2342 integer i ! lon index
2343 integer k1 ! lev index
2344 integer k2 ! lev index
2345 real(r8) aer_pth_dlt ! [kg m-2] Volcanics path between interface
2346 ! levels k1 and k2
2347 real(r8) odap_aer_ttl ! [fraction] Total path absorption optical
2348 ! depth
2349
2350 !-------------------------------------------------------------------------
2351
2352 if (strat_volcanic) then
2353 do bnd_idx=1,bnd_nbr_LW
2354 do i=1,pcols
2355 aer_trn_ttl(i,1,1,bnd_idx)=1.0
2356 end do
2357 do k1=2,plevp
2358 do i=1,pcols
2359 aer_trn_ttl(i,k1,k1,bnd_idx)=1.0
2360
2361 aer_pth_dlt = abs(aer_mpp(i,k1) - aer_mpp(i,1))
2362 odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
2363
2364 aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl)
2365 end do
2366 end do
2367
2368 do k1=2,plev
2369 do k2=k1+1,plevp
2370 do i=1,pcols
2371 aer_trn_ttl(i,k1,k2,bnd_idx) = &
2372 aer_trn_ttl(i,1,k2,bnd_idx) / &
2373 aer_trn_ttl(i,1,k1,bnd_idx)
2374 end do
2375 end do
2376 end do
2377
2378 do k1=2,plevp
2379 do k2=1,k1-1
2380 do i=1,pcols
2381 aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx)
2382 end do
2383 end do
2384 end do
2385 end do
2386 else
2387 aer_trn_ttl = 1.0
2388 endif
2389
2390 return
2391 end subroutine aer_trn
2392
2393 subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp)
2394 !------------------------------------------------------
2395 ! Purpose: convert mass per layer to cumulative mass from Top
2396 !------------------------------------------------------
2397 ! use shr_kind_mod, only: r8 => shr_kind_r8
2398 ! use ppgrid
2399 ! use pmgrid
2400 implicit none
2401 !#include <crdcon.h>
2402
2403 ! Parameters
2404 ! Input
2405 integer, intent(in) :: pcols, plev, plevp
2406 real(r8), intent(in):: aer_mass(pcols,plev) ! Rad level aerosol mass mixing ratio
2407 integer, intent(in):: ncol
2408 !
2409 ! Output
2410 real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface
2411 !
2412 ! Local
2413 integer i ! Column index
2414 integer k ! Level index
2415 !------------------------------------------------------
2416 !------------------------------------------------------
2417
2418 aer_mpp(1:ncol,1) = 0._r8
2419 do k=2,plevp
2420 aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1)
2421 enddo
2422 !
2423 return
2424 end subroutine aer_pth
2425
2426 subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, &
2427 lwups ,emis , &
2428 pmid ,pint ,pmln ,piln ,pdel ,t , &
2429 ! qm1 ,cld ,cicewp ,cliqwp ,coszrs, clat, &
2430 qm1 ,cld ,cicewp ,cliqwp ,tauxcl, tauxci, coszrs, clat, &
2431 asdir ,asdif ,aldir ,aldif ,solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
2432 pin, ozmixmj, ozmix, levsiz, num_months, &
2433 m_psp, m_psn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn , &
2434 nmxrgn , &
2435 doabsems, abstot, absnxt, emstot, &
2436 fsup ,fsupc ,fsdn ,fsdnc , &
2437 flup ,flupc ,fldn ,fldnc , &
2438 swcf ,lwcf ,flut , &
2439 fsns ,fsnt ,flns ,flnt , &
2440 qrs ,qrl ,flwds ,rel ,rei , &
2441 sols ,soll ,solsd ,solld , &
2442 landfrac,zm ,fsds )
2443 !-----------------------------------------------------------------------
2444 !
2445 ! Purpose:
2446 ! Driver for radiation computation.
2447 !
2448 ! Method:
2449 ! Radiation uses cgs units, so conversions must be done from
2450 ! model fields to radiation fields.
2451 !
2452 ! Author: CCM1, CMS Contact: J. Truesdale
2453 !
2454 !-----------------------------------------------------------------------
2455 ! use shr_kind_mod, only: r8 => shr_kind_r8
2456 ! use ppgrid
2457 ! use pspect
2458 ! use commap
2459 ! use history, only: outfld
2460 ! use constituents, only: ppcnst, cnst_get_ind
2461 ! use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, &
2462 ! aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC
2463 ! use physics_types, only: physics_state
2464 ! use wv_saturation, only: aqsat
2465 ! use chemistry, only: trace_gas
2466 ! use physconst, only: cpair, epsilo
2467 ! use aer_optics, only: idxVIS
2468 ! use aerosol_intr, only: set_aerosol_from_prognostics
2469
2470
2471 implicit none
2472
2473 !
2474 ! Input arguments
2475 !
2476 integer, intent(in) :: lchnk,j ! chunk identifier
2477 integer, intent(in) :: ncol ! number of atmospheric columns
2478 integer, intent(in) :: levsiz ! number of ozone data levels
2479 integer, intent(in) :: num_months ! 12 months
2480 integer, intent(in) :: paerlev,naer_c ! aerosol vertical level and # species
2481 integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst
2482 logical, intent(in) :: doabsems
2483
2484
2485 integer nspint ! Num of spctrl intervals across solar spectrum
2486 integer naer_groups ! Num of aerosol groups for optical diagnostics
2487 parameter ( nspint = 19 )
2488 parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols
2489
2490
2491 real(r8), intent(in) :: lwups(pcols) ! Longwave up flux at surface
2492 real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
2493 real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
2494 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
2495 real(r8), intent(in) :: pmln(pcols,pver) ! Natural log of pmid
2496 real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
2497 real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
2498 real(r8), intent(in) :: piln(pcols,pverp) ! Natural log of pint
2499 real(r8), intent(in) :: pdel(pcols,pverp) ! Pressure difference across layer
2500 real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
2501 real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
2502 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
2503 real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
2504 real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
2505 real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth
2506 real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth
2507 real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
2508 real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns
2509 real(r8), intent(in) :: asdir(pcols) ! albedo shortwave direct
2510 real(r8), intent(in) :: asdif(pcols) ! albedo shortwave diffuse
2511 real(r8), intent(in) :: aldir(pcols) ! albedo longwave direct
2512 real(r8), intent(in) :: aldif(pcols) ! albedo longwave diffuse
2513 real(r8), intent(in) :: landfrac(pcols) ! land fraction
2514 real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
2515 real(r8), intent(in) :: pin(levsiz) ! Pressure levels of ozone data
2516 real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months) ! monthly ozone mixing ratio
2517 real(r8), intent(inout) :: ozmix(pcols,levsiz) ! Ozone data
2518 real, intent(in) :: solcon ! solar constant with eccentricity factor
2519 REAL, INTENT(IN ) :: XTIME,GMT
2520 INTEGER, INTENT(IN ) :: JULDAY
2521 REAL, INTENT(IN ) :: JULIAN
2522 REAL, INTENT(IN ) :: DT
2523 real(r8), intent(in) :: m_psp(pcols),m_psn(pcols) ! MATCH surface pressure
2524 real(r8), intent(in) :: aerosoljp(pcols,paerlev,naer_c) ! aerosol concentrations
2525 real(r8), intent(in) :: aerosoljn(pcols,paerlev,naer_c) ! aerosol concentrations
2526 real(r8), intent(in) :: m_hybi(paerlev)
2527 ! type(physics_state), intent(in) :: state
2528 real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
2529 ! maximally overlapped region.
2530 ! 0->pmxrgn(i,1) is range of pmid for
2531 ! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
2532 ! 2nd region, etc
2533 integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
2534
2535 real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn
2536 integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn
2537
2538 !
2539 ! Output solar arguments
2540 !
2541 real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
2542 real(r8), intent(out) :: fsnt(pcols) ! Net column abs solar flux at model top
2543 real(r8), intent(out) :: flns(pcols) ! Srf longwave cooling (up-down) flux
2544 real(r8), intent(out) :: flnt(pcols) ! Net outgoing lw flux at model top
2545 real(r8), intent(out) :: sols(pcols) ! Downward solar rad onto surface (sw direct)
2546 real(r8), intent(out) :: soll(pcols) ! Downward solar rad onto surface (lw direct)
2547 real(r8), intent(out) :: solsd(pcols) ! Downward solar rad onto surface (sw diffuse)
2548 real(r8), intent(out) :: solld(pcols) ! Downward solar rad onto surface (lw diffuse)
2549 real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
2550 real(r8), intent(out) :: fsds(pcols) ! Flux Shortwave Downwelling Surface
2551 ! Added outputs of total and clearsky fluxes etc
2552 real(r8), intent(out) :: fsup(pcols,pverp) ! Upward total sky solar
2553 real(r8), intent(out) :: fsupc(pcols,pverp) ! Upward clear sky solar
2554 real(r8), intent(out) :: fsdn(pcols,pverp) ! Downward total sky solar
2555 real(r8), intent(out) :: fsdnc(pcols,pverp) ! Downward clear sky solar
2556 real(r8), intent(out) :: flup(pcols,pverp) ! Upward total sky longwave
2557 real(r8), intent(out) :: flupc(pcols,pverp) ! Upward clear sky longwave
2558 real(r8), intent(out) :: fldn(pcols,pverp) ! Downward total sky longwave
2559 real(r8), intent(out) :: fldnc(pcols,pverp) ! Downward clear sky longwave
2560 real(r8), intent(out) :: swcf(pcols) ! Top of the atmosphere solar cloud forcing
2561 real(r8), intent(out) :: lwcf(pcols) ! Top of the atmosphere longwave cloud forcing
2562 real(r8), intent(out) :: flut(pcols) ! Top of the atmosphere outgoing longwave
2563 !
2564 ! Output longwave arguments
2565 !
2566 real(r8), intent(out) :: qrl(pcols,pver) ! Longwave cooling rate
2567 real(r8), intent(out) :: flwds(pcols) ! Surface down longwave flux
2568
2569 real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
2570 real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
2571 real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
2572
2573
2574 !
2575 !---------------------------Local variables-----------------------------
2576 !
2577 integer i, k ! index
2578
2579 integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array
2580
2581 real(r8) solin(pcols) ! Solar incident flux
2582 ! real(r8) fsds(pcols) ! Flux Shortwave Downwelling Surface
2583 real(r8) fsntoa(pcols) ! Net solar flux at TOA
2584 real(r8) fsntoac(pcols) ! Clear sky net solar flux at TOA
2585 real(r8) fsnirt(pcols) ! Near-IR flux absorbed at toa
2586 real(r8) fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa
2587 real(r8) fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns
2588 real(r8) fsntc(pcols) ! Clear sky total column abs solar flux
2589 real(r8) fsnsc(pcols) ! Clear sky surface abs solar flux
2590 real(r8) fsdsc(pcols) ! Clear sky surface downwelling solar flux
2591 ! real(r8) flut(pcols) ! Upward flux at top of model
2592 ! real(r8) lwcf(pcols) ! longwave cloud forcing
2593 ! real(r8) swcf(pcols) ! shortwave cloud forcing
2594 real(r8) flutc(pcols) ! Upward Clear Sky flux at top of model
2595 real(r8) flntc(pcols) ! Clear sky lw flux at model top
2596 real(r8) flnsc(pcols) ! Clear sky lw flux at srf (up-down)
2597 real(r8) ftem(pcols,pver) ! temporary array for outfld
2598
2599 real(r8) pbr(pcols,pverr) ! Model mid-level pressures (dynes/cm2)
2600 real(r8) pnm(pcols,pverrp) ! Model interface pressures (dynes/cm2)
2601 real(r8) o3vmr(pcols,pverr) ! Ozone volume mixing ratio
2602 real(r8) o3mmr(pcols,pverr) ! Ozone mass mixing ratio
2603 real(r8) eccf ! Earth/sun distance factor
2604 real(r8) n2o(pcols,pver) ! nitrous oxide mass mixing ratio
2605 real(r8) ch4(pcols,pver) ! methane mass mixing ratio
2606 real(r8) cfc11(pcols,pver) ! cfc11 mass mixing ratio
2607 real(r8) cfc12(pcols,pver) ! cfc12 mass mixing ratio
2608 real(r8) rh(pcols,pverr) ! level relative humidity (fraction)
2609 real(r8) lwupcgs(pcols) ! Upward longwave flux in cgs units
2610
2611 real(r8) esat(pcols,pverr) ! saturation vapor pressure
2612 real(r8) qsat(pcols,pverr) ! saturation specific humidity
2613
2614 real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums
2615 real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
2616 real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
2617 real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
2618 real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
2619
2620 real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios
2621 real(r8) scales(naer_all) ! scaling factors for aerosols
2622
2623
2624 !
2625 ! Interpolate ozone volume mixing ratio to model levels
2626 !
2627 ! WRF: added pin, levsiz, ozmix here
2628 call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
2629
2630 call radozn(lchnk ,ncol &
2631 ,pcols, pver &
2632 ,pmid ,pin, levsiz, ozmix, o3vmr )
2633
2634 ! call outfld('O3VMR ',o3vmr ,pcols, lchnk)
2635
2636 !
2637 ! Set chunk dependent radiation input
2638 !
2639 call radinp(lchnk ,ncol ,pcols, pver, pverp, &
2640 pmid ,pint ,o3vmr , pbr ,&
2641 pnm ,eccf ,o3mmr )
2642
2643 !
2644 ! Solar radiation computation
2645 !
2646 if (dosw) then
2647
2648 !
2649 ! calculate heating with aerosols
2650 !
2651 call aqsat(t, pmid, esat, qsat, pcols, &
2652 ncol, pver, 1, pver)
2653
2654 ! calculate relative humidity
2655 ! rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
2656 ! ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
2657 ! ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo)
2658 rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
2659 ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
2660 ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo)
2661
2662 if (radforce) then
2663
2664 pmxrgnrf = pmxrgn
2665 nmxrgnrf = nmxrgn
2666
2667 call get_rf_scales(scales)
2668
2669 call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
2670 aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
2671
2672 ! overwrite with prognostics aerosols
2673
2674 ! no feedback from prognostic aerosols
2675 ! call set_aerosol_from_prognostics (ncol, q, aerosol)
2676
2677 call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
2678
2679 ! call t_startf('radcswmx_rf')
2680 call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
2681 pnm ,pbr ,qm1 ,rh ,o3mmr , &
2682 aerosol ,cld ,cicewp ,cliqwp ,rel , &
2683 ! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
2684 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
2685 asdir ,asdif ,aldir ,aldif ,nmxrgnrf, &
2686 pmxrgnrf,qrs ,fsnt ,fsntc ,fsntoa , &
2687 fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
2688 fsnsc ,fsdsc ,fsds ,sols ,soll , &
2689 solsd ,solld ,frc_day , &
2690 fsup ,fsupc ,fsdn ,fsdnc , &
2691 aertau ,aerssa ,aerasm ,aerfwd )
2692 ! call t_stopf('radcswmx_rf')
2693
2694 !
2695 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
2696 !
2697
2698 do i = 1, ncol
2699 solin(i) = solin(i)*1.e-3
2700 fsnt(i) = fsnt(i) *1.e-3
2701 fsns(i) = fsns(i) *1.e-3
2702 fsntc(i) = fsntc(i)*1.e-3
2703 fsnsc(i) = fsnsc(i)*1.e-3
2704 end do
2705 ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
2706 !
2707 ! Dump shortwave radiation information to history tape buffer (diagnostics)
2708 !
2709 ! call outfld('QRS_RF ',ftem ,pcols,lchnk)
2710 ! call outfld('FSNT_RF ',fsnt ,pcols,lchnk)
2711 ! call outfld('FSNS_RF ',fsns ,pcols,lchnk)
2712 ! call outfld('FSNTC_RF',fsntc ,pcols,lchnk)
2713 ! call outfld('FSNSC_RF',fsnsc ,pcols,lchnk)
2714
2715 endif ! if (radforce)
2716
2717 call get_int_scales(scales)
2718
2719 call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
2720 m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
2721
2722 ! overwrite with prognostics aerosols
2723 ! call set_aerosol_from_prognostics (ncol, q, aerosol)
2724
2725 call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
2726 ! call t_startf('radcswmx')
2727
2728 call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
2729 pnm ,pbr ,qm1 ,rh ,o3mmr , &
2730 aerosol ,cld ,cicewp ,cliqwp ,rel , &
2731 ! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
2732 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
2733 asdir ,asdif ,aldir ,aldif ,nmxrgn , &
2734 pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , &
2735 fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
2736 fsnsc ,fsdsc ,fsds ,sols ,soll , &
2737 solsd ,solld ,frc_day , &
2738 fsup ,fsupc ,fsdn ,fsdnc , &
2739 aertau ,aerssa ,aerasm ,aerfwd )
2740 ! call t_stopf('radcswmx')
2741
2742 ! -- tls ---------------------------------------------------------------2
2743 !
2744 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
2745 !
2746 do i=1,ncol
2747 solin(i) = solin(i)*1.e-3
2748 fsds(i) = fsds(i)*1.e-3
2749 fsnirt(i)= fsnirt(i)*1.e-3
2750 fsnrtc(i)= fsnrtc(i)*1.e-3
2751 fsnirtsq(i)= fsnirtsq(i)*1.e-3
2752 fsnt(i) = fsnt(i) *1.e-3
2753 fsns(i) = fsns(i) *1.e-3
2754 fsntc(i) = fsntc(i)*1.e-3
2755 fsnsc(i) = fsnsc(i)*1.e-3
2756 fsdsc(i) = fsdsc(i)*1.e-3
2757 fsntoa(i)=fsntoa(i)*1.e-3
2758 fsntoac(i)=fsntoac(i)*1.e-3
2759 end do
2760 ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
2761
2762 ! Added upward/downward total and clear sky fluxes
2763 do k = 1, pverp
2764 do i = 1, ncol
2765 fsup(i,k) = fsup(i,k)*1.e-3
2766 fsupc(i,k) = fsupc(i,k)*1.e-3
2767 fsdn(i,k) = fsdn(i,k)*1.e-3
2768 fsdnc(i,k) = fsdnc(i,k)*1.e-3
2769 end do
2770 end do
2771
2772 !
2773 ! Dump shortwave radiation information to history tape buffer (diagnostics)
2774 !
2775
2776 ! call outfld('frc_day ', frc_day, pcols, lchnk)
2777 ! call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk)
2778 ! call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk)
2779 ! call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk)
2780 ! call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk)
2781 ! call outfld('BGOD_v ', aertau(:,idxVIS,5) ,pcols,lchnk)
2782 ! call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk)
2783 ! call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk)
2784 ! call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk)
2785 ! call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk)
2786 ! call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk)
2787 ! call aerosol_diagnostics (lchnk, ncol, pdel, aerosol)
2788
2789 ! call outfld('QRS ',ftem ,pcols,lchnk)
2790 ! call outfld('SOLIN ',solin ,pcols,lchnk)
2791 ! call outfld('FSDS ',fsds ,pcols,lchnk)
2792 ! call outfld('FSNIRTOA',fsnirt,pcols,lchnk)
2793 ! call outfld('FSNRTOAC',fsnrtc,pcols,lchnk)
2794 ! call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk)
2795 ! call outfld('FSNT ',fsnt ,pcols,lchnk)
2796 ! call outfld('FSNS ',fsns ,pcols,lchnk)
2797 ! call outfld('FSNTC ',fsntc ,pcols,lchnk)
2798 ! call outfld('FSNSC ',fsnsc ,pcols,lchnk)
2799 ! call outfld('FSDSC ',fsdsc ,pcols,lchnk)
2800 ! call outfld('FSNTOA ',fsntoa,pcols,lchnk)
2801 ! call outfld('FSNTOAC ',fsntoac,pcols,lchnk)
2802 ! call outfld('SOLS ',sols ,pcols,lchnk)
2803 ! call outfld('SOLL ',soll ,pcols,lchnk)
2804 ! call outfld('SOLSD ',solsd ,pcols,lchnk)
2805 ! call outfld('SOLLD ',solld ,pcols,lchnk)
2806
2807 end if
2808 !
2809 ! Longwave radiation computation
2810 !
2811 if (dolw) then
2812 !
2813 ! Convert upward longwave flux units to CGS
2814 !
2815 do i=1,ncol
2816 ! lwupcgs(i) = lwup(i)*1000.
2817 lwupcgs(i) = lwups(i)
2818 end do
2819 !
2820 ! Do longwave computation. If not implementing greenhouse gas code then
2821 ! first specify trace gas mixing ratios. If greenhouse gas code then:
2822 ! o ixtrcg => indx of advected n2o tracer
2823 ! o ixtrcg+1 => indx of advected ch4 tracer
2824 ! o ixtrcg+2 => indx of advected cfc11 tracer
2825 ! o ixtrcg+3 => indx of advected cfc12 tracer
2826 !
2827 if (trace_gas) then
2828 ! call cnst_get_ind('N2O' , in2o)
2829 ! call cnst_get_ind('CH4' , ich4)
2830 ! call cnst_get_ind('CFC11', if11)
2831 ! call cnst_get_ind('CFC12', if12)
2832 ! call t_startf("radclwmx")
2833 call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
2834 lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
2835 pbr ,pnm ,pmln ,piln , &
2836 qm1(1,1,in2o) ,qm1(1,1,ich4) , &
2837 qm1(1,1,if11) ,qm1(1,1,if12) , &
2838 cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
2839 doabsems, abstot, absnxt, emstot, &
2840 flns ,flnt ,flnsc ,flntc ,flwds , &
2841 flut ,flutc , &
2842 flup ,flupc ,fldn ,fldnc , &
2843 aerosol(:,:,idxVOLC))
2844 ! call t_stopf("radclwmx")
2845 else
2846 call trcmix(lchnk ,ncol ,pcols, pver, &
2847 pmid ,clat, n2o ,ch4 , &
2848 cfc11 ,cfc12 )
2849
2850 ! call t_startf("radclwmx")
2851 call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
2852 lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
2853 pbr ,pnm ,pmln ,piln , &
2854 n2o ,ch4 ,cfc11 ,cfc12 , &
2855 cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
2856 doabsems, abstot, absnxt, emstot, &
2857 flns ,flnt ,flnsc ,flntc ,flwds , &
2858 flut ,flutc , &
2859 flup ,flupc ,fldn ,fldnc , &
2860 aerosol(:,:,idxVOLC))
2861 ! call t_stopf("radclwmx")
2862 endif
2863 !
2864 ! Convert units of longwave fields needed by rest of model from CGS to MKS
2865 !
2866 do i=1,ncol
2867 flnt(i) = flnt(i)*1.e-3
2868 flut(i) = flut(i)*1.e-3
2869 flutc(i) = flutc(i)*1.e-3
2870 flns(i) = flns(i)*1.e-3
2871 flntc(i) = flntc(i)*1.e-3
2872 flnsc(i) = flnsc(i)*1.e-3
2873 flwds(i) = flwds(i)*1.e-3
2874 lwcf(i) = flutc(i) - flut(i)
2875 swcf(i) = fsntoa(i) - fsntoac(i)
2876 end do
2877
2878 ! Added upward/downward total and clear sky fluxes
2879 do k = 1, pverp
2880 do i = 1, ncol
2881 flup(i,k) = flup(i,k)*1.e-3
2882 flupc(i,k) = flupc(i,k)*1.e-3
2883 fldn(i,k) = fldn(i,k)*1.e-3
2884 fldnc(i,k) = fldnc(i,k)*1.e-3
2885 end do
2886 end do
2887 !
2888 ! Dump longwave radiation information to history tape buffer (diagnostics)
2889 !
2890 ! call outfld('QRL ',qrl(:ncol,:)/cpair,ncol,lchnk)
2891 ! call outfld('FLNT ',flnt ,pcols,lchnk)
2892 ! call outfld('FLUT ',flut ,pcols,lchnk)
2893 ! call outfld('FLUTC ',flutc ,pcols,lchnk)
2894 ! call outfld('FLNTC ',flntc ,pcols,lchnk)
2895 ! call outfld('FLNS ',flns ,pcols,lchnk)
2896 ! call outfld('FLNSC ',flnsc ,pcols,lchnk)
2897 ! call outfld('LWCF ',lwcf ,pcols,lchnk)
2898 ! call outfld('SWCF ',swcf ,pcols,lchnk)
2899 !
2900 end if
2901 !
2902 return
2903 end subroutine radctl
2904 subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, &
2905 q, cldn, landfrac, landm,icefrac, &
2906 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh )
2907 !
2908 ! Compute (liquid+ice) water path and cloud water/ice diagnostics
2909 ! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios
2910 !
2911 ! **** mixes interface and physics code temporarily
2912 !-----------------------------------------------------------------------
2913 ! use physics_types, only: physics_state
2914 ! use history, only: outfld
2915 ! use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw
2916
2917 implicit none
2918
2919 ! Arguments
2920 integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst
2921 real(r8), intent(in) :: q(pcols,pver,ppcnst) ! moisture arrays
2922 real(r8), intent(in) :: cldn(pcols,pver) ! new cloud fraction
2923 real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness
2924 real(r8), intent(in) :: t(pcols,pver) ! temperature
2925 real(r8), intent(in) :: pmid(pcols,pver) ! pressure
2926 real(r8), intent(in) :: pint(pcols,pverp) ! pressure
2927 real(r8), intent(in) :: ps(pcols) ! surface pressure
2928 real(r8), intent(in) :: landfrac(pcols) ! Land fraction
2929 real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
2930 real(r8), intent(in) :: landm(pcols) ! Land fraction ramped
2931 real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
2932
2933 !!$ real(r8), intent(out) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
2934 real(r8), intent(out) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
2935 real(r8), intent(out) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
2936 real(r8), intent(out) :: emis (pcols,pver) ! cloud emissivity
2937 real(r8), intent(out) :: rel (pcols,pver) ! effective drop radius (microns)
2938 real(r8), intent(out) :: rei (pcols,pver) ! ice effective drop size (microns)
2939 real(r8), intent(out) :: pmxrgn(pcols,pver+1) ! Maximum values of pressure for each
2940 integer , intent(out) :: nmxrgn(pcols) ! Number of maximally overlapped regions
2941
2942 ! Local variables
2943 real(r8) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
2944 !!$ real(r8) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
2945 !!$ real(r8) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
2946 real(r8) :: effcld(pcols,pver) ! effective cloud=cld*emis
2947 real(r8) :: gicewp(pcols,pver) ! grid-box cloud ice water path
2948 real(r8) :: gliqwp(pcols,pver) ! grid-box cloud liquid water path
2949 real(r8) :: gwp (pcols,pver) ! grid-box cloud (total) water path
2950 real(r8) :: hl (pcols) ! Liquid water scale height
2951 real(r8) :: tgicewp(pcols) ! Vertically integrated ice water path
2952 real(r8) :: tgliqwp(pcols) ! Vertically integrated liquid water path
2953 real(r8) :: tgwp (pcols) ! Vertically integrated (total) cloud water path
2954 real(r8) :: tpw (pcols) ! total precipitable water
2955 real(r8) :: clwpold(pcols,pver) ! Presribed cloud liq. h2o path
2956 real(r8) :: ficemr (pcols,pver) ! Ice fraction from ice and liquid mixing ratios
2957
2958 real(r8) :: rgrav ! inverse gravitational acceleration
2959
2960 integer :: i,k ! loop indexes
2961 integer :: lchnk
2962
2963 !-----------------------------------------------------------------------
2964
2965 ! Compute liquid and ice water paths
2966 tgicewp(:ncol) = 0.
2967 tgliqwp(:ncol) = 0.
2968 do k=1,pver
2969 do i = 1,ncol
2970 gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0 ! Grid box ice water path.
2971 gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0 ! Grid box liquid water path.
2972 !!$ gwp (i,k) = gicewp(i,k) + gliqwp(i,k)
2973 cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
2974 cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
2975 !!$ cwp (i,k) = gwp (i,k) / max(0.01_r8,cldn(i,k))
2976 ficemr(i,k) = q(i,k,ixcldice) / &
2977 max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq)))
2978
2979 tgicewp(i) = tgicewp(i) + gicewp(i,k)
2980 tgliqwp(i) = tgliqwp(i) + gliqwp(i,k)
2981 end do
2982 end do
2983 tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol)
2984 gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver)
2985 cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
2986
2987 ! Compute total preciptable water in column (in mm)
2988 tpw(:ncol) = 0.0
2989 rgrav = 1.0/gravmks
2990 do k=1,pver
2991 do i=1,ncol
2992 tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav
2993 end do
2994 end do
2995
2996 ! Diagnostic liquid water path (old specified form)
2997 ! call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl)
2998
2999 ! Cloud water and ice particle sizes
3000 call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
3001
3002 ! Cloud emissivity.
3003 call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis)
3004
3005 ! Effective cloud cover
3006 do k=1,pver
3007 do i=1,ncol
3008 effcld(i,k) = cldn(i,k)*emis(i,k)
3009 end do
3010 end do
3011
3012 ! Determine parameters for maximum/random overlap
3013 call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn)
3014
3015 ! call outfld('GCLDLWP' ,gwp , pcols,lchnk)
3016 ! call outfld('TGCLDCWP',tgwp , pcols,lchnk)
3017 ! call outfld('TGCLDLWP',tgliqwp, pcols,lchnk)
3018 ! call outfld('TGCLDIWP',tgicewp, pcols,lchnk)
3019 ! call outfld('ICLDLWP' ,cwp , pcols,lchnk)
3020 ! call outfld('SETLWP' ,clwpold, pcols,lchnk)
3021 ! call outfld('EFFCLD' ,effcld , pcols,lchnk)
3022 ! call outfld('LWSH' ,hl , pcols,lchnk)
3023
3024 end subroutine param_cldoptics_calc
3025
3026 subroutine radabs(lchnk ,ncol ,pcols, pver, pverp, &
3027 pbr ,pnm ,co2em ,co2eml ,tplnka , &
3028 s2c ,tcg ,w ,h2otr ,plco2 , &
3029 plh2o ,co2t ,tint ,tlayr ,plol , &
3030 plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
3031 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
3032 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
3033 bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
3034 abstot ,absnxt ,plh2ob ,wb , &
3035 aer_mpp ,aer_trn_ttl)
3036 !-----------------------------------------------------------------------
3037 !
3038 ! Purpose:
3039 ! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12
3040 !
3041 ! Method:
3042 ! h2o .... Uses nonisothermal emissivity method for water vapor from
3043 ! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
3044 ! Emissivity and Absorptivity Formulation for Water Vapor
3045 ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
3046 !
3047 ! Implementation updated by Collins, Hackney, and Edwards (2001)
3048 ! using line-by-line calculations based upon Hitran 1996 and
3049 ! CKD 2.1 for absorptivity and emissivity
3050 !
3051 ! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
3052 ! using line-by-line calculations based upon Hitran 2000 and
3053 ! CKD 2.4 for absorptivity and emissivity
3054 !
3055 ! co2 .... Uses absorptance parameterization of the 15 micro-meter
3056 ! (500 - 800 cm-1) band system of Carbon Dioxide, from
3057 ! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
3058 ! of the Absorptance Due to the 15 micro-meter Band System
3059 ! of Carbon Dioxide Jouranl of Geophysical Research,
3060 ! vol. 96., D5, pp 9013-9019.
3061 ! Parameterizations for the 9.4 and 10.4 mircon bands of CO2
3062 ! are also included.
3063 !
3064 ! o3 .... Uses absorptance parameterization of the 9.6 micro-meter
3065 ! band system of ozone, from Ramanathan, V. and R.Dickinson,
3066 ! 1979: The Role of stratospheric ozone in the zonal and
3067 ! seasonal radiative energy balance of the earth-troposphere
3068 ! system. Journal of the Atmospheric Sciences, Vol. 36,
3069 ! pp 1084-1104
3070 !
3071 ! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
3072 !
3073 ! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
3074 ! bands of nitrous oxide
3075 !
3076 ! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
3077 ! micron bands of CFC11
3078 !
3079 ! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
3080 ! micron bands of CFC12
3081 !
3082 !
3083 ! Computes individual absorptivities for non-adjacent layers, accounting
3084 ! for band overlap, and sums to obtain the total; then, computes the
3085 ! nearest layer contribution.
3086 !
3087 ! Author: W. Collins (H2O absorptivity) and J. Kiehl
3088 !
3089 !-----------------------------------------------------------------------
3090 !------------------------------Arguments--------------------------------
3091 !
3092 ! Input arguments
3093 !
3094 integer, intent(in) :: lchnk ! chunk identifier
3095 integer, intent(in) :: ncol ! number of atmospheric columns
3096 integer, intent(in) :: pcols, pver, pverp
3097
3098 real(r8), intent(in) :: pbr(pcols,pver) ! Prssr at mid-levels (dynes/cm2)
3099 real(r8), intent(in) :: pnm(pcols,pverp) ! Prssr at interfaces (dynes/cm2)
3100 real(r8), intent(in) :: co2em(pcols,pverp) ! Co2 emissivity function
3101 real(r8), intent(in) :: co2eml(pcols,pver) ! Co2 emissivity function
3102 real(r8), intent(in) :: tplnka(pcols,pverp) ! Planck fnctn level temperature
3103 real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
3104 real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
3105 real(r8), intent(in) :: w(pcols,pverp) ! H2o prs wghted path
3106 real(r8), intent(in) :: h2otr(pcols,pverp) ! H2o trnsmssn fnct for o3 overlap
3107 real(r8), intent(in) :: plco2(pcols,pverp) ! Co2 prs wghted path length
3108 real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wfhted path length
3109 real(r8), intent(in) :: co2t(pcols,pverp) ! Tmp and prs wghted path length
3110 real(r8), intent(in) :: tint(pcols,pverp) ! Interface temperatures
3111 real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 level temperatures
3112 real(r8), intent(in) :: plol(pcols,pverp) ! Ozone prs wghted path length
3113 real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path length
3114 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
3115 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
3116 real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
3117 ! Hulst-Curtis-Godson temp. factor
3118 ! for H2O bands
3119 real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
3120 ! Hulst-Curtis-Godson temp. factor
3121 ! for H2O bands
3122
3123 real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level
3124 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
3125
3126
3127 !
3128 ! Trace gas variables
3129 !
3130 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
3131 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
3132 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
3133 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
3134 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
3135 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
3136 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
3137 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
3138 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
3139 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
3140 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
3141 real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
3142 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
3143 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
3144 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
3145 real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! non-nearest layer Planck factor
3146 real(r8), intent(in) :: abplnk2(14,pcols,pverp) ! nearest layer factor
3147 !
3148 ! Output arguments
3149 !
3150 real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity
3151 real(r8), intent(out) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
3152 !
3153 !---------------------------Local variables-----------------------------
3154 !
3155 integer i ! Longitude index
3156 integer k ! Level index
3157 integer k1 ! Level index
3158 integer k2 ! Level index
3159 integer kn ! Nearest level index
3160 integer wvl ! Wavelength index
3161
3162 real(r8) abstrc(pcols) ! total trace gas absorptivity
3163 real(r8) bplnk(14,pcols,4) ! Planck functions for sub-divided layers
3164 real(r8) pnew(pcols) ! Effective pressure for H2O vapor linewidth
3165 real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
3166 ! Hulst-Curtis-Godson correction for
3167 ! each band
3168 real(r8) u(pcols) ! Pressure weighted H2O path length
3169 real(r8) ub(nbands) ! Pressure weighted H2O path length with
3170 ! Hulst-Curtis-Godson correction for
3171 ! each band
3172 real(r8) tbar(pcols,4) ! Mean layer temperature
3173 real(r8) emm(pcols,4) ! Mean co2 emissivity
3174 real(r8) o3emm(pcols,4) ! Mean o3 emissivity
3175 real(r8) o3bndi ! Ozone band parameter
3176 real(r8) temh2o(pcols,4) ! Mean layer temperature equivalent to tbar
3177 real(r8) k21 ! Exponential coefficient used to calculate
3178 ! ! rotation band transmissvty in the 650-800
3179 ! ! cm-1 region (tr1)
3180 real(r8) k22 ! Exponential coefficient used to calculate
3181 ! ! rotation band transmissvty in the 500-650
3182 ! ! cm-1 region (tr2)
3183 real(r8) uc1(pcols) ! H2o continuum pathlength in 500-800 cm-1
3184 real(r8) to3h2o(pcols) ! H2o trnsmsn for overlap with o3
3185 real(r8) pi ! For co2 absorptivity computation
3186 real(r8) sqti(pcols) ! Used to store sqrt of mean temperature
3187 real(r8) et ! Co2 hot band factor
3188 real(r8) et2 ! Co2 hot band factor squared
3189 real(r8) et4 ! Co2 hot band factor to fourth power
3190 real(r8) omet ! Co2 stimulated emission term
3191 real(r8) f1co2 ! Co2 central band factor
3192 real(r8) f2co2(pcols) ! Co2 weak band factor
3193 real(r8) f3co2(pcols) ! Co2 weak band factor
3194 real(r8) t1co2(pcols) ! Overlap factr weak bands on strong band
3195 real(r8) sqwp ! Sqrt of co2 pathlength
3196 real(r8) f1sqwp(pcols) ! Main co2 band factor
3197 real(r8) oneme ! Co2 stimulated emission term
3198 real(r8) alphat ! Part of the co2 stimulated emission term
3199 real(r8) wco2 ! Constants used to define co2 pathlength
3200 real(r8) posqt ! Effective pressure for co2 line width
3201 real(r8) u7(pcols) ! Co2 hot band path length
3202 real(r8) u8 ! Co2 hot band path length
3203 real(r8) u9 ! Co2 hot band path length
3204 real(r8) u13 ! Co2 hot band path length
3205 real(r8) rbeta7(pcols) ! Inverse of co2 hot band line width par
3206 real(r8) rbeta8 ! Inverse of co2 hot band line width par
3207 real(r8) rbeta9 ! Inverse of co2 hot band line width par
3208 real(r8) rbeta13 ! Inverse of co2 hot band line width par
3209 real(r8) tpatha ! For absorptivity computation
3210 real(r8) abso(pcols,4) ! Absorptivity for various gases/bands
3211 real(r8) dtx(pcols) ! Planck temperature minus 250 K
3212 real(r8) dty(pcols) ! Path temperature minus 250 K
3213 real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
3214 real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
3215 real(r8) tr1 ! Eqn(6) in table A2 of R&D for 650-800
3216 real(r8) tr10(pcols) ! Eqn (6) times eq(4) in table A2
3217 ! ! of R&D for 500-650 cm-1 region
3218 real(r8) tr2 ! Eqn(6) in table A2 of R&D for 500-650
3219 real(r8) tr5 ! Eqn(4) in table A2 of R&D for 650-800
3220 real(r8) tr6 ! Eqn(4) in table A2 of R&D for 500-650
3221 real(r8) tr9(pcols) ! Equation (6) times eq(4) in table A2
3222 ! ! of R&D for 650-800 cm-1 region
3223 real(r8) sqrtu(pcols) ! Sqrt of pressure weighted h20 pathlength
3224 real(r8) fwk(pcols) ! Equation(33) in R&D far wing correction
3225 real(r8) fwku(pcols) ! GU term in eqs(1) and (6) in table A2
3226 real(r8) to3co2(pcols) ! P weighted temp in ozone band model
3227 real(r8) dpnm(pcols) ! Pressure difference between two levels
3228 real(r8) pnmsq(pcols,pverp) ! Pressure squared
3229 real(r8) dw(pcols) ! Amount of h2o between two levels
3230 real(r8) uinpl(pcols,4) ! Nearest layer subdivision factor
3231 real(r8) winpl(pcols,4) ! Nearest layer subdivision factor
3232 real(r8) zinpl(pcols,4) ! Nearest layer subdivision factor
3233 real(r8) pinpl(pcols,4) ! Nearest layer subdivision factor
3234 real(r8) dplh2o(pcols) ! Difference in press weighted h2o amount
3235 real(r8) r293 ! 1/293
3236 real(r8) r250 ! 1/250
3237 real(r8) r3205 ! Line width factor for o3 (see R&Di)
3238 real(r8) r300 ! 1/300
3239 real(r8) rsslp ! Reciprocal of sea level pressure
3240 real(r8) r2sslp ! 1/2 of rsslp
3241 real(r8) ds2c ! Y in eq(7) in table A2 of R&D
3242 real(r8) dplos ! Ozone pathlength eq(A2) in R&Di
3243 real(r8) dplol ! Presure weighted ozone pathlength
3244 real(r8) tlocal ! Local interface temperature
3245 real(r8) beta ! Ozone mean line parameter eq(A3) in R&Di
3246 ! (includes Voigt line correction factor)
3247 real(r8) rphat ! Effective pressure for ozone beta
3248 real(r8) tcrfac ! Ozone temperature factor table 1 R&Di
3249 real(r8) tmp1 ! Ozone band factor see eq(A1) in R&Di
3250 real(r8) u1 ! Effective ozone pathlength eq(A2) in R&Di
3251 real(r8) realnu ! 1/beta factor in ozone band model eq(A1)
3252 real(r8) tmp2 ! Ozone band factor see eq(A1) in R&Di
3253 real(r8) u2 ! Effective ozone pathlength eq(A2) in R&Di
3254 real(r8) rsqti ! Reciprocal of sqrt of path temperature
3255 real(r8) tpath ! Path temperature used in co2 band model
3256 real(r8) tmp3 ! Weak band factor see K&B
3257 real(r8) rdpnmsq ! Reciprocal of difference in press^2
3258 real(r8) rdpnm ! Reciprocal of difference in press
3259 real(r8) p1 ! Mean pressure factor
3260 real(r8) p2 ! Mean pressure factor
3261 real(r8) dtym10 ! T - 260 used in eq(9) and (10) table A3a
3262 real(r8) dplco2 ! Co2 path length
3263 real(r8) te ! A_0 T factor in ozone model table 1 of R&Di
3264 real(r8) denom ! Denominator in eq(r8) of table A3a of R&D
3265 real(r8) th2o(pcols) ! transmission due to H2O
3266 real(r8) tco2(pcols) ! transmission due to CO2
3267 real(r8) to3(pcols) ! transmission due to O3
3268 !
3269 ! Transmission terms for various spectral intervals:
3270 !
3271 real(r8) trab2(pcols) ! H2o 500 - 800 cm-1
3272 real(r8) absbnd ! Proportional to co2 band absorptance
3273 real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3
3274 real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3
3275 !
3276 ! Variables for Collins/Hackney/Edwards (C/H/E) &
3277 ! Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization
3278
3279 !
3280 ! Notation:
3281 ! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
3282 ! P = atmospheric pressure
3283 ! P_0 = reference atmospheric pressure
3284 ! W = precipitable water path
3285 ! T_e = emission temperature
3286 ! T_p = path temperature
3287 ! RH = path relative humidity
3288 !
3289 real(r8) fa ! asymptotic value of abs. as U->infinity
3290 real(r8) a_star ! normalized absorptivity for non-window
3291 real(r8) l_star ! interpolated line transmission
3292 real(r8) c_star ! interpolated continuum transmission
3293
3294 real(r8) te1 ! emission temperature
3295 real(r8) te2 ! te^2
3296 real(r8) te3 ! te^3
3297 real(r8) te4 ! te^4
3298 real(r8) te5 ! te^5
3299
3300 real(r8) log_u ! log base 10 of U
3301 real(r8) log_uc ! log base 10 of H2O continuum path
3302 real(r8) log_p ! log base 10 of P
3303 real(r8) t_p ! T_p
3304 real(r8) t_e ! T_e (offset by T_p)
3305
3306 integer iu ! index for log10(U)
3307 integer iu1 ! iu + 1
3308 integer iuc ! index for log10(H2O continuum path)
3309 integer iuc1 ! iuc + 1
3310 integer ip ! index for log10(P)
3311 integer ip1 ! ip + 1
3312 integer itp ! index for T_p
3313 integer itp1 ! itp + 1
3314 integer ite ! index for T_e
3315 integer ite1 ! ite + 1
3316 integer irh ! index for RH
3317 integer irh1 ! irh + 1
3318
3319 real(r8) dvar ! normalized variation in T_p/T_e/P/U
3320 real(r8) uvar ! U * diffusivity factor
3321 real(r8) uscl ! factor for lineary scaling as U->0
3322
3323 real(r8) wu ! weight for U
3324 real(r8) wu1 ! 1 - wu
3325 real(r8) wuc ! weight for H2O continuum path
3326 real(r8) wuc1 ! 1 - wuc
3327 real(r8) wp ! weight for P
3328 real(r8) wp1 ! 1 - wp
3329 real(r8) wtp ! weight for T_p
3330 real(r8) wtp1 ! 1 - wtp
3331 real(r8) wte ! weight for T_e
3332 real(r8) wte1 ! 1 - wte
3333 real(r8) wrh ! weight for RH
3334 real(r8) wrh1 ! 1 - wrh
3335
3336 real(r8) w_0_0_ ! weight for Tp/Te combination
3337 real(r8) w_0_1_ ! weight for Tp/Te combination
3338 real(r8) w_1_0_ ! weight for Tp/Te combination
3339 real(r8) w_1_1_ ! weight for Tp/Te combination
3340
3341 real(r8) w_0_00 ! weight for Tp/Te/RH combination
3342 real(r8) w_0_01 ! weight for Tp/Te/RH combination
3343 real(r8) w_0_10 ! weight for Tp/Te/RH combination
3344 real(r8) w_0_11 ! weight for Tp/Te/RH combination
3345 real(r8) w_1_00 ! weight for Tp/Te/RH combination
3346 real(r8) w_1_01 ! weight for Tp/Te/RH combination
3347 real(r8) w_1_10 ! weight for Tp/Te/RH combination
3348 real(r8) w_1_11 ! weight for Tp/Te/RH combination
3349
3350 real(r8) w00_00 ! weight for P/Tp/Te/RH combination
3351 real(r8) w00_01 ! weight for P/Tp/Te/RH combination
3352 real(r8) w00_10 ! weight for P/Tp/Te/RH combination
3353 real(r8) w00_11 ! weight for P/Tp/Te/RH combination
3354 real(r8) w01_00 ! weight for P/Tp/Te/RH combination
3355 real(r8) w01_01 ! weight for P/Tp/Te/RH combination
3356 real(r8) w01_10 ! weight for P/Tp/Te/RH combination
3357 real(r8) w01_11 ! weight for P/Tp/Te/RH combination
3358 real(r8) w10_00 ! weight for P/Tp/Te/RH combination
3359 real(r8) w10_01 ! weight for P/Tp/Te/RH combination
3360 real(r8) w10_10 ! weight for P/Tp/Te/RH combination
3361 real(r8) w10_11 ! weight for P/Tp/Te/RH combination
3362 real(r8) w11_00 ! weight for P/Tp/Te/RH combination
3363 real(r8) w11_01 ! weight for P/Tp/Te/RH combination
3364 real(r8) w11_10 ! weight for P/Tp/Te/RH combination
3365 real(r8) w11_11 ! weight for P/Tp/Te/RH combination
3366
3367 integer ib ! spectral interval:
3368 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
3369 ! 2 = 800-1200 cm^-1
3370
3371
3372 real(r8) pch2o ! H2O continuum path
3373 real(r8) fch2o ! temp. factor for continuum
3374 real(r8) uch2o ! U corresponding to H2O cont. path (window)
3375
3376 real(r8) fdif ! secant(zenith angle) for diffusivity approx.
3377
3378 real(r8) sslp_mks ! Sea-level pressure in MKS units
3379 real(r8) esx ! saturation vapor pressure returned by vqsatd
3380 real(r8) qsx ! saturation mixing ratio returned by vqsatd
3381 real(r8) pnew_mks ! pnew in MKS units
3382 real(r8) q_path ! effective specific humidity along path
3383 real(r8) rh_path ! effective relative humidity along path
3384 real(r8) omeps ! 1 - epsilo
3385
3386 integer iest ! index in estblh2o
3387
3388 integer bnd_idx ! LW band index
3389 real(r8) aer_pth_dlt ! [kg m-2] STRAER path between interface levels k1 and k2
3390 real(r8) aer_pth_ngh(pcols)
3391 ! [kg m-2] STRAER path between neighboring layers
3392 real(r8) odap_aer_ttl ! [fraction] Total path absorption optical depth
3393 real(r8) aer_trn_ngh(pcols,bnd_nbr_LW)
3394 ! [fraction] Total transmission between
3395 ! nearest neighbor sub-levels
3396 !
3397 !--------------------------Statement function---------------------------
3398 !
3399 real(r8) dbvt,t ! Planck fnctn tmp derivative for o3
3400 !
3401 dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
3402 (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
3403 !
3404 !
3405 !-----------------------------------------------------------------------
3406 !
3407 ! Initialize
3408 !
3409 do k2=1,ntoplw-1
3410 do k1=1,ntoplw-1
3411 abstot(:,k1,k2) = inf ! set unused portions for lf95 restart write
3412 end do
3413 end do
3414 do k2=1,4
3415 do k1=1,ntoplw-1
3416 absnxt(:,k1,k2) = inf ! set unused portions for lf95 restart write
3417 end do
3418 end do
3419
3420 do k=ntoplw,pverp
3421 abstot(:,k,k) = inf ! set unused portions for lf95 restart write
3422 end do
3423
3424 do k=ntoplw,pver
3425 do i=1,ncol
3426 dbvtly(i,k) = dbvt(tlayr(i,k+1))
3427 dbvtit(i,k) = dbvt(tint(i,k))
3428 end do
3429 end do
3430 do i=1,ncol
3431 dbvtit(i,pverp) = dbvt(tint(i,pverp))
3432 end do
3433 !
3434 r293 = 1./293.
3435 r250 = 1./250.
3436 r3205 = 1./.3205
3437 r300 = 1./300.
3438 rsslp = 1./sslp
3439 r2sslp = 1./(2.*sslp)
3440 !
3441 !Constants for computing U corresponding to H2O cont. path
3442 !
3443 fdif = 1.66
3444 sslp_mks = sslp / 10.0
3445 omeps = 1.0 - epsilo
3446 !
3447 ! Non-adjacent layer absorptivity:
3448 !
3449 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
3450 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
3451 ! abso(i,2) 800 - 1200 cm-1 h2o window
3452 !
3453 ! Separation between rotation and vibration-rotation dropped, so
3454 ! only 2 slots needed for H2O absorptivity
3455 !
3456 ! 500-800 cm^-1 H2o continuum/line overlap already included
3457 ! in abso(i,1). This used to be in abso(i,4)
3458 !
3459 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
3460 ! abso(i,4) co2 15 micrometer band system
3461 !
3462 do k=ntoplw,pverp
3463 do i=1,ncol
3464 pnmsq(i,k) = pnm(i,k)**2
3465 dtx(i) = tplnka(i,k) - 250.
3466 end do
3467 end do
3468 !
3469 ! Non-nearest layer level loops
3470 !
3471 do k1=pverp,ntoplw,-1
3472 do k2=pverp,ntoplw,-1
3473 if (k1 == k2) cycle
3474 do i=1,ncol
3475 dplh2o(i) = plh2o(i,k1) - plh2o(i,k2)
3476 u(i) = abs(dplh2o(i))
3477 sqrtu(i) = sqrt(u(i))
3478 ds2c = abs(s2c(i,k1) - s2c(i,k2))
3479 dw(i) = abs(w(i,k1) - w(i,k2))
3480 uc1(i) = (ds2c + 1.7e-3*u(i))*(1. + 2.*ds2c)/(1. + 15.*ds2c)
3481 pch2o = ds2c
3482 pnew(i) = u(i)/dw(i)
3483 pnew_mks = pnew(i) * sslp_mks
3484 !
3485 ! Changed effective path temperature to std. Curtis-Godson form
3486 !
3487 tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i)
3488 t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o)
3489 iest = floor(t_p) - min_tp_h2o
3490 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
3491 (t_p - min_tp_h2o - iest)
3492 qsx = epsilo * esx / (pnew_mks - omeps * esx)
3493 !
3494 ! Compute effective RH along path
3495 !
3496 q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga
3497 !
3498 ! Calculate effective u, pnew for each band using
3499 ! Hulst-Curtis-Godson approximation:
3500 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
3501 ! 2nd edition, Oxford University Press, 1989.
3502 ! Effective H2O path (w)
3503 ! eq. 6.24, p. 228
3504 ! Effective H2O path pressure (pnew = u/w):
3505 ! eq. 6.29, p. 228
3506 !
3507 ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1)
3508 ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2)
3509
3510 pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1)
3511 pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2)
3512
3513 dtx(i) = tplnka(i,k2) - 250.
3514 dty(i) = tpatha - 250.
3515
3516 fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
3517 fwku(i) = fwk(i)*u(i)
3518 !
3519 ! Define variables for C/H/E (now C/LT/E) fit
3520 !
3521 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
3522 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
3523 ! abso(i,2) 800 - 1200 cm-1 h2o window
3524 !
3525 ! Separation between rotation and vibration-rotation dropped, so
3526 ! only 2 slots needed for H2O absorptivity
3527 !
3528 ! Notation:
3529 ! U = integral (P/P_0 dW)
3530 ! P = atmospheric pressure
3531 ! P_0 = reference atmospheric pressure
3532 ! W = precipitable water path
3533 ! T_e = emission temperature
3534 ! T_p = path temperature
3535 ! RH = path relative humidity
3536 !
3537 !
3538 ! Terms for asymptotic value of emissivity
3539 !
3540 te1 = tplnka(i,k2)
3541 te2 = te1 * te1
3542 te3 = te2 * te1
3543 te4 = te3 * te1
3544 te5 = te4 * te1
3545
3546 !
3547 ! Band-independent indices for lines and continuum tables
3548 !
3549 dvar = (t_p - min_tp_h2o) / dtp_h2o
3550 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
3551 itp1 = itp + 1
3552 wtp = dvar - floor(dvar)
3553 wtp1 = 1.0 - wtp
3554
3555 t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o)
3556 dvar = (t_e - min_te_h2o) / dte_h2o
3557 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
3558 ite1 = ite + 1
3559 wte = dvar - floor(dvar)
3560 wte1 = 1.0 - wte
3561
3562 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
3563 dvar = (rh_path - min_rh_h2o) / drh_h2o
3564 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
3565 irh1 = irh + 1
3566 wrh = dvar - floor(dvar)
3567 wrh1 = 1.0 - wrh
3568
3569 w_0_0_ = wtp * wte
3570 w_0_1_ = wtp * wte1
3571 w_1_0_ = wtp1 * wte
3572 w_1_1_ = wtp1 * wte1
3573
3574 w_0_00 = w_0_0_ * wrh
3575 w_0_01 = w_0_0_ * wrh1
3576 w_0_10 = w_0_1_ * wrh
3577 w_0_11 = w_0_1_ * wrh1
3578 w_1_00 = w_1_0_ * wrh
3579 w_1_01 = w_1_0_ * wrh1
3580 w_1_10 = w_1_1_ * wrh
3581 w_1_11 = w_1_1_ * wrh1
3582
3583 !
3584 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
3585 !
3586 ! Assume foreign continuum dominates total H2O continuum in these bands
3587 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
3588 ! Then the effective H2O path is just
3589 ! U_c = integral[ f(P) dW ]
3590 ! where
3591 ! W = water-vapor mass and
3592 ! f(P) = dependence of foreign continuum on pressure
3593 ! = P / sslp
3594 ! Then
3595 ! U_c = U (the same effective H2O path as for lines)
3596 !
3597 !
3598 ! Continuum terms for 800-1200 cm^-1
3599 !
3600 ! Assume self continuum dominates total H2O continuum for this band
3601 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
3602 ! Then the effective H2O self-continuum path is
3603 ! U_c = integral[ h(e,T) dW ] (*eq. 1*)
3604 ! where
3605 ! W = water-vapor mass and
3606 ! e = partial pressure of H2O along path
3607 ! T = temperature along path
3608 ! h(e,T) = dependence of foreign continuum on e,T
3609 ! = e / sslp * f(T)
3610 !
3611 ! Replacing
3612 ! e =~ q * P / epsilo
3613 ! q = mixing ratio of H2O
3614 ! epsilo = 0.622
3615 !
3616 ! and using the definition
3617 ! U = integral [ (P / sslp) dW ]
3618 ! = (P / sslp) W (homogeneous path)
3619 !
3620 ! the effective path length for the self continuum is
3621 ! U_c = (q / epsilo) f(T) U (*eq. 2*)
3622 !
3623 ! Once values of T, U, and q have been calculated for the inhomogeneous
3624 ! path, this sets U_c for the corresponding
3625 ! homogeneous atmosphere. However, this need not equal the
3626 ! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
3627 ! under consideration.
3628 !
3629 ! Solution: hold T and q constant, solve for U' that gives U_c' by
3630 ! inverting eq. (2):
3631 !
3632 ! U' = (U_c * epsilo) / (q * f(T))
3633 !
3634 fch2o = fh2oself(t_p)
3635 uch2o = (pch2o * epsilo) / (q_path * fch2o)
3636
3637 !
3638 ! Band-dependent indices for non-window
3639 !
3640 ib = 1
3641
3642 uvar = ub(ib) * fdif
3643 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
3644 dvar = (log_u - min_lu_h2o) / dlu_h2o
3645 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3646 iu1 = iu + 1
3647 wu = dvar - floor(dvar)
3648 wu1 = 1.0 - wu
3649
3650 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
3651 dvar = (log_p - min_lp_h2o) / dlp_h2o
3652 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
3653 ip1 = ip + 1
3654 wp = dvar - floor(dvar)
3655 wp1 = 1.0 - wp
3656
3657 w00_00 = wp * w_0_00
3658 w00_01 = wp * w_0_01
3659 w00_10 = wp * w_0_10
3660 w00_11 = wp * w_0_11
3661 w01_00 = wp * w_1_00
3662 w01_01 = wp * w_1_01
3663 w01_10 = wp * w_1_10
3664 w01_11 = wp * w_1_11
3665 w10_00 = wp1 * w_0_00
3666 w10_01 = wp1 * w_0_01
3667 w10_10 = wp1 * w_0_10
3668 w10_11 = wp1 * w_0_11
3669 w11_00 = wp1 * w_1_00
3670 w11_01 = wp1 * w_1_01
3671 w11_10 = wp1 * w_1_10
3672 w11_11 = wp1 * w_1_11
3673 !
3674 ! Asymptotic value of absorptivity as U->infinity
3675 !
3676 fa = fat(1,ib) + &
3677 fat(2,ib) * te1 + &
3678 fat(3,ib) * te2 + &
3679 fat(4,ib) * te3 + &
3680 fat(5,ib) * te4 + &
3681 fat(6,ib) * te5
3682
3683 a_star = &
3684 ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3685 ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3686 ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3687 ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3688 ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
3689 ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
3690 ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
3691 ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
3692 ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3693 ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3694 ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3695 ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3696 ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
3697 ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
3698 ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
3699 ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
3700 ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3701 ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3702 ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3703 ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3704 ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
3705 ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
3706 ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
3707 ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
3708 ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3709 ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3710 ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3711 ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3712 ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
3713 ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
3714 ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
3715 ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3716 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
3717 aer_trn_ttl(i,k1,k2,ib)), &
3718 0.0_r8), 1.0_r8)
3719 !
3720 ! Invoke linear limit for scaling wrt u below min_u_h2o
3721 !
3722 if (uvar < min_u_h2o) then
3723 uscl = uvar / min_u_h2o
3724 abso(i,ib) = abso(i,ib) * uscl
3725 endif
3726
3727 !
3728 ! Band-dependent indices for window
3729 !
3730 ib = 2
3731
3732 uvar = ub(ib) * fdif
3733 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
3734 dvar = (log_u - min_lu_h2o) / dlu_h2o
3735 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3736 iu1 = iu + 1
3737 wu = dvar - floor(dvar)
3738 wu1 = 1.0 - wu
3739
3740 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
3741 dvar = (log_p - min_lp_h2o) / dlp_h2o
3742 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
3743 ip1 = ip + 1
3744 wp = dvar - floor(dvar)
3745 wp1 = 1.0 - wp
3746
3747 w00_00 = wp * w_0_00
3748 w00_01 = wp * w_0_01
3749 w00_10 = wp * w_0_10
3750 w00_11 = wp * w_0_11
3751 w01_00 = wp * w_1_00
3752 w01_01 = wp * w_1_01
3753 w01_10 = wp * w_1_10
3754 w01_11 = wp * w_1_11
3755 w10_00 = wp1 * w_0_00
3756 w10_01 = wp1 * w_0_01
3757 w10_10 = wp1 * w_0_10
3758 w10_11 = wp1 * w_0_11
3759 w11_00 = wp1 * w_1_00
3760 w11_01 = wp1 * w_1_01
3761 w11_10 = wp1 * w_1_10
3762 w11_11 = wp1 * w_1_11
3763
3764 log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
3765 dvar = (log_uc - min_lu_h2o) / dlu_h2o
3766 iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3767 iuc1 = iuc + 1
3768 wuc = dvar - floor(dvar)
3769 wuc1 = 1.0 - wuc
3770 !
3771 ! Asymptotic value of absorptivity as U->infinity
3772 !
3773 fa = fat(1,ib) + &
3774 fat(2,ib) * te1 + &
3775 fat(3,ib) * te2 + &
3776 fat(4,ib) * te3 + &
3777 fat(5,ib) * te4 + &
3778 fat(6,ib) * te5
3779
3780 l_star = &
3781 ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3782 ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3783 ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3784 ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3785 ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
3786 ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
3787 ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
3788 ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
3789 ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3790 ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3791 ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3792 ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3793 ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
3794 ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
3795 ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
3796 ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
3797 ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3798 ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3799 ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3800 ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3801 ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
3802 ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
3803 ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
3804 ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
3805 ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3806 ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3807 ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3808 ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3809 ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
3810 ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
3811 ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
3812 ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3813
3814 c_star = &
3815 cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
3816 cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
3817 cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
3818 cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
3819 cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
3820 cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
3821 cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
3822 cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
3823 cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
3824 cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
3825 cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
3826 cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
3827 cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
3828 cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
3829 cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
3830 cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
3831 cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
3832 cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
3833 cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
3834 cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
3835 cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
3836 cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
3837 cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
3838 cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
3839 cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
3840 cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
3841 cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
3842 cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
3843 cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
3844 cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
3845 cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
3846 cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
3847 abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * &
3848 aer_trn_ttl(i,k1,k2,ib)), &
3849 0.0_r8), 1.0_r8)
3850 !
3851 ! Invoke linear limit for scaling wrt u below min_u_h2o
3852 !
3853 if (uvar < min_u_h2o) then
3854 uscl = uvar / min_u_h2o
3855 abso(i,ib) = abso(i,ib) * uscl
3856 endif
3857
3858 end do
3859 !
3860 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
3861 !
3862 do i=1,ncol
3863 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
3864 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
3865 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
3866 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
3867 end do
3868 !
3869 ! 500 - 800 cm-1 h2o rotation band overlap with co2
3870 !
3871 do i=1,ncol
3872 k21 = term7(i,1) + term8(i,1)/ &
3873 (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i))
3874 k22 = term7(i,2) + term8(i,2)/ &
3875 (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i))
3876 tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
3877 tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
3878 tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)
3879 ! ! H2O line+STRAER trn 650--800 cm-1
3880 tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650)
3881 ! ! H2O line+STRAER trn 500--650 cm-1
3882 tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
3883 tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
3884 tr9(i) = tr1*tr5
3885 tr10(i) = tr2*tr6
3886 th2o(i) = tr10(i)
3887 trab2(i) = 0.65*tr9(i) + 0.35*tr10(i)
3888 end do
3889 if (k2 < k1) then
3890 do i=1,ncol
3891 to3h2o(i) = h2otr(i,k1)/h2otr(i,k2)
3892 end do
3893 else
3894 do i=1,ncol
3895 to3h2o(i) = h2otr(i,k2)/h2otr(i,k1)
3896 end do
3897 end if
3898 !
3899 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
3900 !
3901 do i=1,ncol
3902 dpnm(i) = pnm(i,k1) - pnm(i,k2)
3903 to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i)
3904 te = (to3co2(i)*r293)**.7
3905 dplos = plos(i,k1) - plos(i,k2)
3906 dplol = plol(i,k1) - plol(i,k2)
3907 u1 = 18.29*abs(dplos)/te
3908 u2 = .5649*abs(dplos)/te
3909 rphat = dplol/dplos
3910 tlocal = tint(i,k2)
3911 tcrfac = sqrt(tlocal*r250)*te
3912 beta = r3205*(rphat + dpfo3*tcrfac)
3913 realnu = te/beta
3914 tmp1 = u1/sqrt(4. + u1*(1. + realnu))
3915 tmp2 = u2/sqrt(4. + u2*(1. + realnu))
3916 o3bndi = 74.*te*log(1. + tmp1 + tmp2)
3917 abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2)
3918 to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
3919 end do
3920 !
3921 ! abso(i,4) co2 15 micrometer band system
3922 !
3923 do i=1,ncol
3924 sqwp = sqrt(abs(plco2(i,k1) - plco2(i,k2)))
3925 et = exp(-480./to3co2(i))
3926 sqti(i) = sqrt(to3co2(i))
3927 rsqti = 1./sqti(i)
3928 et2 = et*et
3929 et4 = et2*et2
3930 omet = 1. - 1.5*et2
3931 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
3932 f1sqwp(i) = f1co2*sqwp
3933 t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
3934 oneme = 1. - et2
3935 alphat = oneme**3*rsqti
3936 pi = abs(dpnm(i))
3937 wco2 = 2.5221*co2vmr*pi*rga
3938 u7(i) = 4.9411e4*alphat*et2*wco2
3939 u8 = 3.9744e4*alphat*et4*wco2
3940 u9 = 1.0447e5*alphat*et4*et2*wco2
3941 u13 = 2.8388e3*alphat*et4*wco2
3942 tpath = to3co2(i)
3943 tlocal = tint(i,k2)
3944 tcrfac = sqrt(tlocal*r250*tpath*r300)
3945 posqt = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti
3946 rbeta7(i) = 1./(5.3228*posqt)
3947 rbeta8 = 1./(10.6576*posqt)
3948 rbeta9 = rbeta7(i)
3949 rbeta13 = rbeta9
3950 f2co2(i) = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + &
3951 (u8 /sqrt(4. + u8*(1. + rbeta8))) + &
3952 (u9 /sqrt(4. + u9*(1. + rbeta9)))
3953 f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
3954 end do
3955 if (k2 >= k1) then
3956 do i=1,ncol
3957 sqti(i) = sqrt(tlayr(i,k2))
3958 end do
3959 end if
3960 !
3961 do i=1,ncol
3962 tmp1 = log(1. + f1sqwp(i))
3963 tmp2 = log(1. + f2co2(i))
3964 tmp3 = log(1. + f3co2(i))
3965 absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
3966 abso(i,4) = trab2(i)*co2em(i,k2)*absbnd
3967 tco2(i) = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))))
3968 end do
3969 !
3970 ! Calculate absorptivity due to trace gases, abstrc
3971 !
3972 call trcab( lchnk ,ncol ,pcols, pverp, &
3973 k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
3974 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
3975 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
3976 bch4 ,to3co2 ,pnm ,dw ,pnew , &
3977 s2c ,uptype ,u ,abplnk1 ,tco2 , &
3978 th2o ,to3 ,abstrc , &
3979 aer_trn_ttl)
3980 !
3981 ! Sum total absorptivity
3982 !
3983 do i=1,ncol
3984 abstot(i,k1,k2) = abso(i,1) + abso(i,2) + &
3985 abso(i,3) + abso(i,4) + abstrc(i)
3986 end do
3987 end do ! do k2 =
3988 end do ! do k1 =
3989 !
3990 ! Adjacent layer absorptivity:
3991 !
3992 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
3993 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
3994 ! abso(i,2) 800 - 1200 cm-1 h2o window
3995 !
3996 ! Separation between rotation and vibration-rotation dropped, so
3997 ! only 2 slots needed for H2O absorptivity
3998 !
3999 ! 500-800 cm^-1 H2o continuum/line overlap already included
4000 ! in abso(i,1). This used to be in abso(i,4)
4001 !
4002 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
4003 ! abso(i,4) co2 15 micrometer band system
4004 !
4005 ! Nearest layer level loop
4006 !
4007 do k2=pver,ntoplw,-1
4008 do i=1,ncol
4009 tbar(i,1) = 0.5*(tint(i,k2+1) + tlayr(i,k2+1))
4010 emm(i,1) = 0.5*(co2em(i,k2+1) + co2eml(i,k2))
4011 tbar(i,2) = 0.5*(tlayr(i,k2+1) + tint(i,k2))
4012 emm(i,2) = 0.5*(co2em(i,k2) + co2eml(i,k2))
4013 tbar(i,3) = 0.5*(tbar(i,2) + tbar(i,1))
4014 emm(i,3) = emm(i,1)
4015 tbar(i,4) = tbar(i,3)
4016 emm(i,4) = emm(i,2)
4017 o3emm(i,1) = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2))
4018 o3emm(i,2) = 0.5*(dbvtit(i,k2) + dbvtly(i,k2))
4019 o3emm(i,3) = o3emm(i,1)
4020 o3emm(i,4) = o3emm(i,2)
4021 temh2o(i,1) = tbar(i,1)
4022 temh2o(i,2) = tbar(i,2)
4023 temh2o(i,3) = tbar(i,1)
4024 temh2o(i,4) = tbar(i,2)
4025 dpnm(i) = pnm(i,k2+1) - pnm(i,k2)
4026 end do
4027 !
4028 ! Weighted Planck functions for trace gases
4029 !
4030 do wvl = 1,14
4031 do i = 1,ncol
4032 bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2))
4033 bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2))
4034 bplnk(wvl,i,3) = bplnk(wvl,i,1)
4035 bplnk(wvl,i,4) = bplnk(wvl,i,2)
4036 end do
4037 end do
4038
4039 do i=1,ncol
4040 rdpnmsq = 1./(pnmsq(i,k2+1) - pnmsq(i,k2))
4041 rdpnm = 1./dpnm(i)
4042 p1 = .5*(pbr(i,k2) + pnm(i,k2+1))
4043 p2 = .5*(pbr(i,k2) + pnm(i,k2 ))
4044 uinpl(i,1) = (pnmsq(i,k2+1) - p1**2)*rdpnmsq
4045 uinpl(i,2) = -(pnmsq(i,k2 ) - p2**2)*rdpnmsq
4046 uinpl(i,3) = -(pnmsq(i,k2 ) - p1**2)*rdpnmsq
4047 uinpl(i,4) = (pnmsq(i,k2+1) - p2**2)*rdpnmsq
4048 winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm
4049 winpl(i,2) = (.5*(-pnm(i,k2 ) + pbr(i,k2)))*rdpnm
4050 winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2 ))*rdpnm
4051 winpl(i,4) = (.5*(-pnm(i,k2 ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm
4052 tmp1 = 1./(piln(i,k2+1) - piln(i,k2))
4053 tmp2 = piln(i,k2+1) - pmln(i,k2)
4054 tmp3 = piln(i,k2 ) - pmln(i,k2)
4055 zinpl(i,1) = (.5*tmp2 )*tmp1
4056 zinpl(i,2) = ( - .5*tmp3)*tmp1
4057 zinpl(i,3) = (.5*tmp2 - tmp3)*tmp1
4058 zinpl(i,4) = ( tmp2 - .5*tmp3)*tmp1
4059 pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1))
4060 pinpl(i,2) = 0.5*(p2 + pnm(i,k2 ))
4061 pinpl(i,3) = 0.5*(p1 + pnm(i,k2 ))
4062 pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1))
4063 if(strat_volcanic) then
4064 aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1))
4065 endif
4066 end do
4067 do kn=1,4
4068 do i=1,ncol
4069 u(i) = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1))
4070 sqrtu(i) = sqrt(u(i))
4071 dw(i) = abs(w(i,k2) - w(i,k2+1))
4072 pnew(i) = u(i)/(winpl(i,kn)*dw(i))
4073 pnew_mks = pnew(i) * sslp_mks
4074 t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o)
4075 iest = floor(t_p) - min_tp_h2o
4076 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
4077 (t_p - min_tp_h2o - iest)
4078 qsx = epsilo * esx / (pnew_mks - omeps * esx)
4079 q_path = dw(i) / ABS(dpnm(i)) / rga
4080
4081 ds2c = abs(s2c(i,k2) - s2c(i,k2+1))
4082 uc1(i) = uinpl(i,kn)*ds2c
4083 pch2o = uc1(i)
4084 uc1(i) = (uc1(i) + 1.7e-3*u(i))*(1. + 2.*uc1(i))/(1. + 15.*uc1(i))
4085 dtx(i) = temh2o(i,kn) - 250.
4086 dty(i) = tbar(i,kn) - 250.
4087
4088 fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
4089 fwku(i) = fwk(i)*u(i)
4090
4091 if(strat_volcanic) then
4092 aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i)
4093
4094 do bnd_idx=1,bnd_nbr_LW
4095 odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
4096 aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl)
4097 end do
4098 else
4099 aer_trn_ngh(i,:) = 1.0
4100 endif
4101
4102 !
4103 ! Define variables for C/H/E (now C/LT/E) fit
4104 !
4105 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
4106 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
4107 ! abso(i,2) 800 - 1200 cm-1 h2o window
4108 !
4109 ! Separation between rotation and vibration-rotation dropped, so
4110 ! only 2 slots needed for H2O absorptivity
4111 !
4112 ! Notation:
4113 ! U = integral (P/P_0 dW)
4114 ! P = atmospheric pressure
4115 ! P_0 = reference atmospheric pressure
4116 ! W = precipitable water path
4117 ! T_e = emission temperature
4118 ! T_p = path temperature
4119 ! RH = path relative humidity
4120 !
4121 !
4122 ! Terms for asymptotic value of emissivity
4123 !
4124 te1 = temh2o(i,kn)
4125 te2 = te1 * te1
4126 te3 = te2 * te1
4127 te4 = te3 * te1
4128 te5 = te4 * te1
4129
4130 !
4131 ! Indices for lines and continuum tables
4132 ! Note: because we are dealing with the nearest layer,
4133 ! the Hulst-Curtis-Godson corrections
4134 ! for inhomogeneous paths are not applied.
4135 !
4136 uvar = u(i)*fdif
4137 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
4138 dvar = (log_u - min_lu_h2o) / dlu_h2o
4139 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
4140 iu1 = iu + 1
4141 wu = dvar - floor(dvar)
4142 wu1 = 1.0 - wu
4143
4144 log_p = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o)
4145 dvar = (log_p - min_lp_h2o) / dlp_h2o
4146 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
4147 ip1 = ip + 1
4148 wp = dvar - floor(dvar)
4149 wp1 = 1.0 - wp
4150
4151 dvar = (t_p - min_tp_h2o) / dtp_h2o
4152 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
4153 itp1 = itp + 1
4154 wtp = dvar - floor(dvar)
4155 wtp1 = 1.0 - wtp
4156
4157 t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o)
4158 dvar = (t_e - min_te_h2o) / dte_h2o
4159 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
4160 ite1 = ite + 1
4161 wte = dvar - floor(dvar)
4162 wte1 = 1.0 - wte
4163
4164 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
4165 dvar = (rh_path - min_rh_h2o) / drh_h2o
4166 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
4167 irh1 = irh + 1
4168 wrh = dvar - floor(dvar)
4169 wrh1 = 1.0 - wrh
4170
4171 w_0_0_ = wtp * wte
4172 w_0_1_ = wtp * wte1
4173 w_1_0_ = wtp1 * wte
4174 w_1_1_ = wtp1 * wte1
4175
4176 w_0_00 = w_0_0_ * wrh
4177 w_0_01 = w_0_0_ * wrh1
4178 w_0_10 = w_0_1_ * wrh
4179 w_0_11 = w_0_1_ * wrh1
4180 w_1_00 = w_1_0_ * wrh
4181 w_1_01 = w_1_0_ * wrh1
4182 w_1_10 = w_1_1_ * wrh
4183 w_1_11 = w_1_1_ * wrh1
4184
4185 w00_00 = wp * w_0_00
4186 w00_01 = wp * w_0_01
4187 w00_10 = wp * w_0_10
4188 w00_11 = wp * w_0_11
4189 w01_00 = wp * w_1_00
4190 w01_01 = wp * w_1_01
4191 w01_10 = wp * w_1_10
4192 w01_11 = wp * w_1_11
4193 w10_00 = wp1 * w_0_00
4194 w10_01 = wp1 * w_0_01
4195 w10_10 = wp1 * w_0_10
4196 w10_11 = wp1 * w_0_11
4197 w11_00 = wp1 * w_1_00
4198 w11_01 = wp1 * w_1_01
4199 w11_10 = wp1 * w_1_10
4200 w11_11 = wp1 * w_1_11
4201
4202 !
4203 ! Non-window absorptivity
4204 !
4205 ib = 1
4206
4207 fa = fat(1,ib) + &
4208 fat(2,ib) * te1 + &
4209 fat(3,ib) * te2 + &
4210 fat(4,ib) * te3 + &
4211 fat(5,ib) * te4 + &
4212 fat(6,ib) * te5
4213
4214 a_star = &
4215 ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
4216 ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
4217 ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
4218 ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
4219 ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
4220 ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
4221 ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
4222 ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
4223 ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
4224 ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
4225 ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
4226 ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
4227 ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
4228 ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
4229 ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
4230 ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
4231 ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
4232 ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
4233 ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
4234 ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
4235 ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
4236 ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
4237 ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
4238 ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
4239 ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
4240 ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
4241 ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
4242 ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
4243 ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
4244 ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
4245 ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
4246 ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
4247
4248 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
4249 aer_trn_ngh(i,ib)), &
4250 0.0_r8), 1.0_r8)
4251
4252 !
4253 ! Invoke linear limit for scaling wrt u below min_u_h2o
4254 !
4255 if (uvar < min_u_h2o) then
4256 uscl = uvar / min_u_h2o
4257 abso(i,ib) = abso(i,ib) * uscl
4258 endif
4259
4260 !
4261 ! Window absorptivity
4262 !
4263 ib = 2
4264
4265 fa = fat(1,ib) + &
4266 fat(2,ib) * te1 + &
4267 fat(3,ib) * te2 + &
4268 fat(4,ib) * te3 + &
4269 fat(5,ib) * te4 + &
4270 fat(6,ib) * te5
4271
4272 a_star = &
4273 ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
4274 ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
4275 ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
4276 ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
4277 ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
4278 ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
4279 ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
4280 ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
4281 ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
4282 ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
4283 ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
4284 ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
4285 ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
4286 ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
4287 ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
4288 ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
4289 ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
4290 ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
4291 ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
4292 ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
4293 ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
4294 ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
4295 ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
4296 ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
4297 ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
4298 ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
4299 ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
4300 ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
4301 ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
4302 ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
4303 ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
4304 ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
4305
4306 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
4307 aer_trn_ngh(i,ib)), &
4308 0.0_r8), 1.0_r8)
4309
4310 !
4311 ! Invoke linear limit for scaling wrt u below min_u_h2o
4312 !
4313 if (uvar < min_u_h2o) then
4314 uscl = uvar / min_u_h2o
4315 abso(i,ib) = abso(i,ib) * uscl
4316 endif
4317
4318 end do
4319 !
4320 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
4321 !
4322 do i=1,ncol
4323 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
4324 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
4325 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
4326 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
4327 end do
4328 !
4329 ! 500 - 800 cm-1 h2o rotation band overlap with co2
4330 !
4331 do i=1,ncol
4332 dtym10 = dty(i) - 10.
4333 denom = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i)
4334 k21 = term7(i,1) + term8(i,1)/denom
4335 denom = 1. + (c28 + c29*dtym10 )*sqrtu(i)
4336 k22 = term7(i,2) + term8(i,2)/denom
4337 tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
4338 tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
4339 tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800)
4340 ! ! H2O line+STRAER trn 650--800 cm-1
4341 tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650)
4342 ! ! H2O line+STRAER trn 500--650 cm-1
4343 tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
4344 tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
4345 tr9(i) = tr1*tr5
4346 tr10(i) = tr2*tr6
4347 trab2(i)= 0.65*tr9(i) + 0.35*tr10(i)
4348 th2o(i) = tr10(i)
4349 end do
4350 !
4351 ! abso(i,3) o3 9.6 micrometer (nu3 and nu1 bands)
4352 !
4353 do i=1,ncol
4354 te = (tbar(i,kn)*r293)**.7
4355 dplos = abs(plos(i,k2+1) - plos(i,k2))
4356 u1 = zinpl(i,kn)*18.29*dplos/te
4357 u2 = zinpl(i,kn)*.5649*dplos/te
4358 tlocal = tbar(i,kn)
4359 tcrfac = sqrt(tlocal*r250)*te
4360 beta = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac)
4361 realnu = te/beta
4362 tmp1 = u1/sqrt(4. + u1*(1. + realnu))
4363 tmp2 = u2/sqrt(4. + u2*(1. + realnu))
4364 o3bndi = 74.*te*log(1. + tmp1 + tmp2)
4365 abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2))
4366 to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
4367 end do
4368 !
4369 ! abso(i,4) co2 15 micrometer band system
4370 !
4371 do i=1,ncol
4372 dplco2 = plco2(i,k2+1) - plco2(i,k2)
4373 sqwp = sqrt(uinpl(i,kn)*dplco2)
4374 et = exp(-480./tbar(i,kn))
4375 sqti(i) = sqrt(tbar(i,kn))
4376 rsqti = 1./sqti(i)
4377 et2 = et*et
4378 et4 = et2*et2
4379 omet = (1. - 1.5*et2)
4380 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
4381 f1sqwp(i)= f1co2*sqwp
4382 t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
4383 oneme = 1. - et2
4384 alphat = oneme**3*rsqti
4385 pi = abs(dpnm(i))*winpl(i,kn)
4386 wco2 = 2.5221*co2vmr*pi*rga
4387 u7(i) = 4.9411e4*alphat*et2*wco2
4388 u8 = 3.9744e4*alphat*et4*wco2
4389 u9 = 1.0447e5*alphat*et4*et2*wco2
4390 u13 = 2.8388e3*alphat*et4*wco2
4391 tpath = tbar(i,kn)
4392 tlocal = tbar(i,kn)
4393 tcrfac = sqrt((tlocal*r250)*(tpath*r300))
4394 posqt = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti
4395 rbeta7(i)= 1./(5.3228*posqt)
4396 rbeta8 = 1./(10.6576*posqt)
4397 rbeta9 = rbeta7(i)
4398 rbeta13 = rbeta9
4399 f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + &
4400 u8 /sqrt(4. + u8*(1. + rbeta8)) + &
4401 u9 /sqrt(4. + u9*(1. + rbeta9))
4402 f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
4403 tmp1 = log(1. + f1sqwp(i))
4404 tmp2 = log(1. + f2co2(i))
4405 tmp3 = log(1. + f3co2(i))
4406 absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
4407 abso(i,4)= trab2(i)*emm(i,kn)*absbnd
4408 tco2(i) = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))
4409 end do ! do i =
4410 !
4411 ! Calculate trace gas absorptivity for nearest layer, abstrc
4412 !
4413 call trcabn(lchnk ,ncol ,pcols, pverp, &
4414 k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
4415 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
4416 uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
4417 winpl ,pinpl ,tco2 ,th2o ,to3 , &
4418 uptype ,dw ,s2c ,u ,pnew , &
4419 abstrc ,uinpl , &
4420 aer_trn_ngh)
4421 !
4422 ! Total next layer absorptivity:
4423 !
4424 do i=1,ncol
4425 absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + &
4426 abso(i,3) + abso(i,4) + abstrc(i)
4427 end do
4428 end do ! do kn =
4429 end do ! do k2 =
4430
4431 return
4432 end subroutine radabs
4433
4434 function psi(tpx,iband)
4435 !
4436 ! History: First version for Hitran 1996 (C/H/E)
4437 ! Current version for Hitran 2000 (C/LT/E)
4438 ! Short function for Hulst-Curtis-Godson temperature factors for
4439 ! computing effective H2O path
4440 ! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing
4441 ! lines between 500 and 2820 cm^-1.
4442 ! See cfa-www.harvard.edu/HITRAN
4443 ! Isotopes of H2O: all
4444 ! Line widths: air-broadened only (self set to 0)
4445 ! Code for line strengths and widths: GENLN3
4446 ! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
4447 ! Transmittance and Radiance Model, Version 3.0 Description
4448 ! and Users Guide, NCAR/TN-367+STR, 147 pp.
4449 !
4450 ! Note: functions have been normalized by dividing by their values at
4451 ! a path temperature of 160K
4452 !
4453 ! spectral intervals:
4454 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
4455 ! 2 = 800-1200 cm^-1
4456 !
4457 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
4458 ! 2nd edition, Oxford University Press, 1989.
4459 ! Psi: function for pressure along path
4460 ! eq. 6.30, p. 228
4461 !
4462 real(r8),intent(in):: tpx ! path temperature
4463 integer, intent(in):: iband ! band to process
4464 real(r8) psi ! psi for given band
4465 real(r8),parameter :: psi_r0(nbands) = (/ 5.65308452E-01, -7.30087891E+01/)
4466 real(r8),parameter :: psi_r1(nbands) = (/ 4.07519005E-03, 1.22199547E+00/)
4467 real(r8),parameter :: psi_r2(nbands) = (/-1.04347237E-05, -7.12256227E-03/)
4468 real(r8),parameter :: psi_r3(nbands) = (/ 1.23765354E-08, 1.47852825E-05/)
4469
4470 psi = (((psi_r3(iband) * tpx) + psi_r2(iband)) * tpx + psi_r1(iband)) * tpx + psi_r0(iband)
4471 end function psi
4472
4473 function phi(tpx,iband)
4474 !
4475 ! History: First version for Hitran 1996 (C/H/E)
4476 ! Current version for Hitran 2000 (C/LT/E)
4477 ! Short function for Hulst-Curtis-Godson temperature factors for
4478 ! computing effective H2O path
4479 ! Line data for H2O: Hitran 2000, plus H2O patches v11.0 for 1341 missing
4480 ! lines between 500 and 2820 cm^-1.
4481 ! See cfa-www.harvard.edu/HITRAN
4482 ! Isotopes of H2O: all
4483 ! Line widths: air-broadened only (self set to 0)
4484 ! Code for line strengths and widths: GENLN3
4485 ! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
4486 ! Transmittance and Radiance Model, Version 3.0 Description
4487 ! and Users Guide, NCAR/TN-367+STR, 147 pp.
4488 !
4489 ! Note: functions have been normalized by dividing by their values at
4490 ! a path temperature of 160K
4491 !
4492 ! spectral intervals:
4493 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
4494 ! 2 = 800-1200 cm^-1
4495 !
4496 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
4497 ! 2nd edition, Oxford University Press, 1989.
4498 ! Phi: function for H2O path
4499 ! eq. 6.25, p. 228
4500 !
4501 real(r8),intent(in):: tpx ! path temperature
4502 integer, intent(in):: iband ! band to process
4503 real(r8) phi ! phi for given band
4504 real(r8),parameter :: phi_r0(nbands) = (/ 9.60917711E-01, -2.21031342E+01/)
4505 real(r8),parameter :: phi_r1(nbands) = (/ 4.86076751E-04, 4.24062610E-01/)
4506 real(r8),parameter :: phi_r2(nbands) = (/-1.84806265E-06, -2.95543415E-03/)
4507 real(r8),parameter :: phi_r3(nbands) = (/ 2.11239959E-09, 7.52470896E-06/)
4508
4509 phi = (((phi_r3(iband) * tpx) + phi_r2(iband)) * tpx + phi_r1(iband)) &
4510 * tpx + phi_r0(iband)
4511 end function phi
4512
4513 function fh2oself( temp )
4514 !
4515 ! Short function for H2O self-continuum temperature factor in
4516 ! calculation of effective H2O self-continuum path length
4517 !
4518 ! H2O Continuum: CKD 2.4
4519 ! Code for continuum: GENLN3
4520 ! Reference: Edwards, D.P., 1992: GENLN2, A General Line-by-Line Atmospheric
4521 ! Transmittance and Radiance Model, Version 3.0 Description
4522 ! and Users Guide, NCAR/TN-367+STR, 147 pp.
4523 !
4524 ! In GENLN, the temperature scaling of the self-continuum is handled
4525 ! by exponential interpolation/extrapolation from observations at
4526 ! 260K and 296K by:
4527 !
4528 ! TFAC = (T(IPATH) - 296.0)/(260.0 - 296.0)
4529 ! CSFFT = CSFF296*(CSFF260/CSFF296)**TFAC
4530 !
4531 ! For 800-1200 cm^-1, (CSFF260/CSFF296) ranges from ~2.1 to ~1.9
4532 ! with increasing wavenumber. The ratio <CSFF260>/<CSFF296>,
4533 ! where <> indicates average over wavenumber, is ~2.07
4534 !
4535 ! fh2oself is (<CSFF260>/<CSFF296>)**TFAC
4536 !
4537 real(r8),intent(in) :: temp ! path temperature
4538 real(r8) fh2oself ! mean ratio of self-continuum at temp and 296K
4539
4540 fh2oself = 2.0727484**((296.0 - temp) / 36.0)
4541 end function fh2oself
4542
4543 ! from wv_saturation.F90
4544
4545 real(r8) function estblf( td )
4546 !
4547 ! Saturation vapor pressure table lookup
4548 !
4549 real(r8), intent(in) :: td ! Temperature for saturation lookup
4550 !
4551 real(r8) :: e ! intermediate variable for es look-up
4552 real(r8) :: ai
4553 integer :: i
4554 !
4555 e = max(min(td,tmax),tmin) ! partial pressure
4556 i = int(e-tmin)+1
4557 ai = aint(e-tmin)
4558 estblf = (tmin+ai-e+1.)* &
4559 estbl(i)-(tmin+ai-e)* &
4560 estbl(i+1)
4561 end function estblf
4562
4563
4564 subroutine esinti(epslon ,latvap ,latice ,rh2o ,cpair ,tmelt )
4565 !-----------------------------------------------------------------------
4566 !
4567 ! Purpose:
4568 ! Initialize es lookup tables
4569 !
4570 ! Method:
4571 ! <Describe the algorithm(s) used in the routine.>
4572 ! <Also include any applicable external references.>
4573 !
4574 ! Author: J. Hack
4575 !
4576 !-----------------------------------------------------------------------
4577 ! use shr_kind_mod, only: r8 => shr_kind_r8
4578 ! use wv_saturation, only: gestbl
4579 implicit none
4580 !------------------------------Arguments--------------------------------
4581 !
4582 ! Input arguments
4583 !
4584 real(r8), intent(in) :: epslon ! Ratio of h2o to dry air molecular weights
4585 real(r8), intent(in) :: latvap ! Latent heat of vaporization
4586 real(r8), intent(in) :: latice ! Latent heat of fusion
4587 real(r8), intent(in) :: rh2o ! Gas constant for water vapor
4588 real(r8), intent(in) :: cpair ! Specific heat of dry air
4589 real(r8), intent(in) :: tmelt ! Melting point of water (K)
4590 !
4591 !---------------------------Local workspace-----------------------------
4592 !
4593 real(r8) tmn ! Minimum temperature entry in table
4594 real(r8) tmx ! Maximum temperature entry in table
4595 real(r8) trice ! Trans range from es over h2o to es over ice
4596 logical ip ! Ice phase (true or false)
4597 !
4598 !-----------------------------------------------------------------------
4599 !
4600 ! Specify control parameters first
4601 !
4602 tmn = 173.16
4603 tmx = 375.16
4604 trice = 20.00
4605 ip = .true.
4606 !
4607 ! Call gestbl to build saturation vapor pressure table.
4608 !
4609 call gestbl(tmn ,tmx ,trice ,ip ,epslon , &
4610 latvap ,latice ,rh2o ,cpair ,tmelt )
4611 !
4612 return
4613 end subroutine esinti
4614
4615 subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , &
4616 latvap ,latice ,rh2o ,cpair ,tmeltx )
4617 !-----------------------------------------------------------------------
4618 !
4619 ! Purpose:
4620 ! Builds saturation vapor pressure table for later lookup procedure.
4621 !
4622 ! Method:
4623 ! Uses Goff & Gratch (1946) relationships to generate the table
4624 ! according to a set of free parameters defined below. Auxiliary
4625 ! routines are also included for making rapid estimates (well with 1%)
4626 ! of both es and d(es)/dt for the particular table configuration.
4627 !
4628 ! Author: J. Hack
4629 !
4630 !-----------------------------------------------------------------------
4631 ! use pmgrid, only: masterproc
4632 implicit none
4633 !------------------------------Arguments--------------------------------
4634 !
4635 ! Input arguments
4636 !
4637 real(r8), intent(in) :: tmn ! Minimum temperature entry in es lookup table
4638 real(r8), intent(in) :: tmx ! Maximum temperature entry in es lookup table
4639 real(r8), intent(in) :: epsil ! Ratio of h2o to dry air molecular weights
4640 real(r8), intent(in) :: trice ! Transition range from es over range to es over ice
4641 real(r8), intent(in) :: latvap ! Latent heat of vaporization
4642 real(r8), intent(in) :: latice ! Latent heat of fusion
4643 real(r8), intent(in) :: rh2o ! Gas constant for water vapor
4644 real(r8), intent(in) :: cpair ! Specific heat of dry air
4645 real(r8), intent(in) :: tmeltx ! Melting point of water (K)
4646 !
4647 !---------------------------Local variables-----------------------------
4648 !
4649 real(r8) t ! Temperature
4650 real(r8) rgasv
4651 real(r8) cp
4652 real(r8) hlatf
4653 real(r8) ttrice
4654 real(r8) hlatv
4655 integer n ! Increment counter
4656 integer lentbl ! Calculated length of lookup table
4657 integer itype ! Ice phase: 0 -> no ice phase
4658 ! 1 -> ice phase, no transition
4659 ! -x -> ice phase, x degree transition
4660 logical ip ! Ice phase logical flag
4661 logical icephs
4662 !
4663 !-----------------------------------------------------------------------
4664 !
4665 ! Set es table parameters
4666 !
4667 tmin = tmn ! Minimum temperature entry in table
4668 tmax = tmx ! Maximum temperature entry in table
4669 ttrice = trice ! Trans. range from es over h2o to es over ice
4670 icephs = ip ! Ice phase (true or false)
4671 !
4672 ! Set physical constants required for es calculation
4673 !
4674 epsqs = epsil
4675 hlatv = latvap
4676 hlatf = latice
4677 rgasv = rh2o
4678 cp = cpair
4679 tmelt = tmeltx
4680 !
4681 lentbl = INT(tmax-tmin+2.000001)
4682 if (lentbl .gt. plenest) then
4683 write(6,9000) tmax, tmin, plenest
4684 ! call endrun ('GESTBL') ! Abnormal termination
4685 end if
4686 !
4687 ! Begin building es table.
4688 ! Check whether ice phase requested.
4689 ! If so, set appropriate transition range for temperature
4690 !
4691 if (icephs) then
4692 if (ttrice /= 0.0) then
4693 itype = -ttrice
4694 else
4695 itype = 1
4696 end if
4697 else
4698 itype = 0
4699 end if
4700 !
4701 t = tmin - 1.0
4702 do n=1,lentbl
4703 t = t + 1.0
4704 call gffgch(t,estbl(n),itype)
4705 end do
4706 !
4707 do n=lentbl+1,plenest
4708 estbl(n) = -99999.0
4709 end do
4710 !
4711 ! Table complete -- Set coefficients for polynomial approximation of
4712 ! difference between saturation vapor press over water and saturation
4713 ! pressure over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial
4714 ! is valid in the range -40 < t < 0 (degrees C).
4715 !
4716 ! --- Degree 5 approximation ---
4717 !
4718 pcf(1) = 5.04469588506e-01
4719 pcf(2) = -5.47288442819e+00
4720 pcf(3) = -3.67471858735e-01
4721 pcf(4) = -8.95963532403e-03
4722 pcf(5) = -7.78053686625e-05
4723 !
4724 ! --- Degree 6 approximation ---
4725 !
4726 !-----pcf(1) = 7.63285250063e-02
4727 !-----pcf(2) = -5.86048427932e+00
4728 !-----pcf(3) = -4.38660831780e-01
4729 !-----pcf(4) = -1.37898276415e-02
4730 !-----pcf(5) = -2.14444472424e-04
4731 !-----pcf(6) = -1.36639103771e-06
4732 !
4733 if (masterproc) then
4734 write(6,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***'
4735 end if
4736
4737 return
4738 !
4739 9000 format('GESTBL: FATAL ERROR *********************************',/, &
4740 ' TMAX AND TMIN REQUIRE A LARGER DIMENSION ON THE LENGTH', &
4741 ' OF THE SATURATION VAPOR PRESSURE TABLE ESTBL(PLENEST)',/, &
4742 ' TMAX, TMIN, AND PLENEST => ', 2f7.2, i3)
4743 !
4744 end subroutine gestbl
4745
4746 subroutine gffgch(t ,es ,itype )
4747 !-----------------------------------------------------------------------
4748 !
4749 ! Purpose:
4750 ! Computes saturation vapor pressure over water and/or over ice using
4751 ! Goff & Gratch (1946) relationships.
4752 ! <Say what the routine does>
4753 !
4754 ! Method:
4755 ! T (temperature), and itype are input parameters, while es (saturation
4756 ! vapor pressure) is an output parameter. The input parameter itype
4757 ! serves two purposes: a value of zero indicates that saturation vapor
4758 ! pressures over water are to be returned (regardless of temperature),
4759 ! while a value of one indicates that saturation vapor pressures over
4760 ! ice should be returned when t is less than freezing degrees. If itype
4761 ! is negative, its absolute value is interpreted to define a temperature
4762 ! transition region below freezing in which the returned
4763 ! saturation vapor pressure is a weighted average of the respective ice
4764 ! and water value. That is, in the temperature range 0 => -itype
4765 ! degrees c, the saturation vapor pressures are assumed to be a weighted
4766 ! average of the vapor pressure over supercooled water and ice (all
4767 ! water at 0 c; all ice at -itype c). Maximum transition range => 40 c
4768 !
4769 ! Author: J. Hack
4770 !
4771 !-----------------------------------------------------------------------
4772 ! use shr_kind_mod, only: r8 => shr_kind_r8
4773 ! use physconst, only: tmelt
4774 ! use abortutils, only: endrun
4775
4776 implicit none
4777 !------------------------------Arguments--------------------------------
4778 !
4779 ! Input arguments
4780 !
4781 real(r8), intent(in) :: t ! Temperature
4782 !
4783 ! Output arguments
4784 !
4785 integer, intent(inout) :: itype ! Flag for ice phase and associated transition
4786
4787 real(r8), intent(out) :: es ! Saturation vapor pressure
4788 !
4789 !---------------------------Local variables-----------------------------
4790 !
4791 real(r8) e1 ! Intermediate scratch variable for es over water
4792 real(r8) e2 ! Intermediate scratch variable for es over water
4793 real(r8) eswtr ! Saturation vapor pressure over water
4794 real(r8) f ! Intermediate scratch variable for es over water
4795 real(r8) f1 ! Intermediate scratch variable for es over water
4796 real(r8) f2 ! Intermediate scratch variable for es over water
4797 real(r8) f3 ! Intermediate scratch variable for es over water
4798 real(r8) f4 ! Intermediate scratch variable for es over water
4799 real(r8) f5 ! Intermediate scratch variable for es over water
4800 real(r8) ps ! Reference pressure (mb)
4801 real(r8) t0 ! Reference temperature (freezing point of water)
4802 real(r8) term1 ! Intermediate scratch variable for es over ice
4803 real(r8) term2 ! Intermediate scratch variable for es over ice
4804 real(r8) term3 ! Intermediate scratch variable for es over ice
4805 real(r8) tr ! Transition range for es over water to es over ice
4806 real(r8) ts ! Reference temperature (boiling point of water)
4807 real(r8) weight ! Intermediate scratch variable for es transition
4808 integer itypo ! Intermediate scratch variable for holding itype
4809 !
4810 !-----------------------------------------------------------------------
4811 !
4812 ! Check on whether there is to be a transition region for es
4813 !
4814 if (itype < 0) then
4815 tr = abs(float(itype))
4816 itypo = itype
4817 itype = 1
4818 else
4819 tr = 0.0
4820 itypo = itype
4821 end if
4822 if (tr > 40.0) then
4823 write(6,900) tr
4824 ! call endrun ('GFFGCH') ! Abnormal termination
4825 end if
4826 !
4827 if(t < (tmelt - tr) .and. itype == 1) go to 10
4828 !
4829 ! Water
4830 !
4831 ps = 1013.246
4832 ts = 373.16
4833 e1 = 11.344*(1.0 - t/ts)
4834 e2 = -3.49149*(ts/t - 1.0)
4835 f1 = -7.90298*(ts/t - 1.0)
4836 f2 = 5.02808*log10(ts/t)
4837 f3 = -1.3816*(10.0**e1 - 1.0)/10000000.0
4838 f4 = 8.1328*(10.0**e2 - 1.0)/1000.0
4839 f5 = log10(ps)
4840 f = f1 + f2 + f3 + f4 + f5
4841 es = (10.0**f)*100.0
4842 eswtr = es
4843 !
4844 if(t >= tmelt .or. itype == 0) go to 20
4845 !
4846 ! Ice
4847 !
4848 10 continue
4849 t0 = tmelt
4850 term1 = 2.01889049/(t0/t)
4851 term2 = 3.56654*log(t0/t)
4852 term3 = 20.947031*(t0/t)
4853 es = 575.185606e10*exp(-(term1 + term2 + term3))
4854 !
4855 if (t < (tmelt - tr)) go to 20
4856 !
4857 ! Weighted transition between water and ice
4858 !
4859 weight = min((tmelt - t)/tr,1.0_r8)
4860 es = weight*es + (1.0 - weight)*eswtr
4861 !
4862 20 continue
4863 itype = itypo
4864 return
4865 !
4866 900 format('GFFGCH: FATAL ERROR ******************************',/, &
4867 'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', &
4868 ' PRESSURE, TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', &
4869 ' 40.0 DEGREES C',/, ' TR = ',f7.2)
4870 !
4871 end subroutine gffgch
4872
4873 subroutine radems(lchnk ,ncol ,pcols, pver, pverp, &
4874 s2c ,tcg ,w ,tplnke ,plh2o , &
4875 pnm ,plco2 ,tint ,tint4 ,tlayr , &
4876 tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
4877 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
4878 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
4879 bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
4880 co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
4881 plh2ob ,wb , &
4882 aer_trn_ttl)
4883 !-----------------------------------------------------------------------
4884 !
4885 ! Purpose:
4886 ! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12
4887 !
4888 ! Method:
4889 ! H2O .... Uses nonisothermal emissivity method for water vapor from
4890 ! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
4891 ! Emissivity and Absorptivity Formulation for Water Vapor
4892 ! Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666
4893 !
4894 ! Implementation updated by Collins,Hackney, and Edwards 2001
4895 ! using line-by-line calculations based upon Hitran 1996 and
4896 ! CKD 2.1 for absorptivity and emissivity
4897 !
4898 ! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
4899 ! using line-by-line calculations based upon Hitran 2000 and
4900 ! CKD 2.4 for absorptivity and emissivity
4901 !
4902 ! CO2 .... Uses absorptance parameterization of the 15 micro-meter
4903 ! (500 - 800 cm-1) band system of Carbon Dioxide, from
4904 ! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
4905 ! of the Absorptance Due to the 15 micro-meter Band System
4906 ! of Carbon Dioxide Jouranl of Geophysical Research,
4907 ! vol. 96., D5, pp 9013-9019. Also includes the effects
4908 ! of the 9.4 and 10.4 micron bands of CO2.
4909 !
4910 ! O3 .... Uses absorptance parameterization of the 9.6 micro-meter
4911 ! band system of ozone, from Ramanathan, V. and R. Dickinson,
4912 ! 1979: The Role of stratospheric ozone in the zonal and
4913 ! seasonal radiative energy balance of the earth-troposphere
4914 ! system. Journal of the Atmospheric Sciences, Vol. 36,
4915 ! pp 1084-1104
4916 !
4917 ! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
4918 !
4919 ! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
4920 ! bands of nitrous oxide
4921 !
4922 ! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
4923 ! micron bands of CFC11
4924 !
4925 ! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
4926 ! micron bands of CFC12
4927 !
4928 !
4929 ! Computes individual emissivities, accounting for band overlap, and
4930 ! sums to obtain the total.
4931 !
4932 ! Author: W. Collins (H2O emissivity) and J. Kiehl
4933 !
4934 !-----------------------------------------------------------------------
4935 !------------------------------Arguments--------------------------------
4936 !
4937 ! Input arguments
4938 !
4939 integer, intent(in) :: lchnk ! chunk identifier
4940 integer, intent(in) :: ncol ! number of atmospheric columns
4941 integer, intent(in) :: pcols, pver, pverp
4942
4943 real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
4944 real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
4945 real(r8), intent(in) :: w(pcols,pverp) ! H2o path length
4946 real(r8), intent(in) :: tplnke(pcols) ! Layer planck temperature
4947 real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wghted path length
4948 real(r8), intent(in) :: pnm(pcols,pverp) ! Model interface pressure
4949 real(r8), intent(in) :: plco2(pcols,pverp) ! Prs wghted path of co2
4950 real(r8), intent(in) :: tint(pcols,pverp) ! Model interface temperatures
4951 real(r8), intent(in) :: tint4(pcols,pverp) ! Tint to the 4th power
4952 real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 model layer temperature
4953 real(r8), intent(in) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
4954 real(r8), intent(in) :: plol(pcols,pverp) ! Pressure wghtd ozone path
4955 real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path
4956 real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
4957 ! Hulst-Curtis-Godson temp. factor
4958 ! for H2O bands
4959 real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
4960 ! Hulst-Curtis-Godson temp. factor
4961 ! for H2O bands
4962
4963 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW)
4964 ! ! [fraction] Total strat. aerosol
4965 ! ! transmission between interfaces k1 and k2
4966
4967 !
4968 ! Trace gas variables
4969 !
4970 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
4971 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
4972 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
4973 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
4974 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
4975 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
4976 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
4977 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
4978 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
4979 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
4980 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
4981 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
4982 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
4983 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
4984 real(r8), intent(in) :: uptype(pcols,pverp) ! p-type continuum path length
4985 !
4986 ! Output arguments
4987 !
4988 real(r8), intent(out) :: emstot(pcols,pverp) ! Total emissivity
4989 real(r8), intent(out) :: co2em(pcols,pverp) ! Layer co2 normalzd plnck funct drvtv
4990 real(r8), intent(out) :: co2eml(pcols,pver) ! Intrfc co2 normalzd plnck func drvtv
4991 real(r8), intent(out) :: co2t(pcols,pverp) ! Tmp and prs weighted path length
4992 real(r8), intent(out) :: h2otr(pcols,pverp) ! H2o transmission over o3 band
4993 real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
4994 real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
4995
4996 !
4997 !---------------------------Local variables-----------------------------
4998 !
4999 integer i ! Longitude index
5000 integer k ! Level index]
5001 integer k1 ! Level index
5002 !
5003 ! Local variables for H2O:
5004 !
5005 real(r8) h2oems(pcols,pverp) ! H2o emissivity
5006 real(r8) tpathe ! Used to compute h2o emissivity
5007 real(r8) dtx(pcols) ! Planck temperature minus 250 K
5008 real(r8) dty(pcols) ! Path temperature minus 250 K
5009 !
5010 ! The 500-800 cm^-1 emission in emis(i,4) has been combined
5011 ! into the 0-800 cm^-1 emission in emis(i,1)
5012 !
5013 real(r8) emis(pcols,2) ! H2O emissivity
5014 !
5015 !
5016 !
5017 real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
5018 real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
5019 real(r8) tr1(pcols) ! Equation(6) in table A2 for 650-800
5020 real(r8) tr2(pcols) ! Equation(6) in table A2 for 500-650
5021 real(r8) tr3(pcols) ! Equation(4) in table A2 for 650-800
5022 real(r8) tr4(pcols) ! Equation(4),table A2 of R&D for 500-650
5023 real(r8) tr7(pcols) ! Equation (6) times eq(4) in table A2
5024 ! of R&D for 650-800 cm-1 region
5025 real(r8) tr8(pcols) ! Equation (6) times eq(4) in table A2
5026 ! of R&D for 500-650 cm-1 region
5027 real(r8) k21(pcols) ! Exponential coefficient used to calc
5028 ! rot band transmissivity in the 650-800
5029 ! cm-1 region (tr1)
5030 real(r8) k22(pcols) ! Exponential coefficient used to calc
5031 ! rot band transmissivity in the 500-650
5032 ! cm-1 region (tr2)
5033 real(r8) u(pcols) ! Pressure weighted H2O path length
5034 real(r8) ub(nbands) ! Pressure weighted H2O path length with
5035 ! Hulst-Curtis-Godson correction for
5036 ! each band
5037 real(r8) pnew ! Effective pressure for h2o linewidth
5038 real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
5039 ! Hulst-Curtis-Godson correction for
5040 ! each band
5041 real(r8) uc1(pcols) ! H2o continuum pathlength 500-800 cm-1
5042 real(r8) fwk ! Equation(33) in R&D far wing correction
5043 real(r8) troco2(pcols,pverp) ! H2o overlap factor for co2 absorption
5044 real(r8) emplnk(14,pcols) ! emissivity Planck factor
5045 real(r8) emstrc(pcols,pverp) ! total trace gas emissivity
5046 !
5047 ! Local variables for CO2:
5048 !
5049 real(r8) co2ems(pcols,pverp) ! Co2 emissivity
5050 real(r8) co2plk(pcols) ! Used to compute co2 emissivity
5051 real(r8) sum(pcols) ! Used to calculate path temperature
5052 real(r8) t1i ! Co2 hot band temperature factor
5053 real(r8) sqti ! Sqrt of temperature
5054 real(r8) pi ! Pressure used in co2 mean line width
5055 real(r8) et ! Co2 hot band factor
5056 real(r8) et2 ! Co2 hot band factor
5057 real(r8) et4 ! Co2 hot band factor
5058 real(r8) omet ! Co2 stimulated emission term
5059 real(r8) ex ! Part of co2 planck function
5060 real(r8) f1co2 ! Co2 weak band factor
5061 real(r8) f2co2 ! Co2 weak band factor
5062 real(r8) f3co2 ! Co2 weak band factor
5063 real(r8) t1co2 ! Overlap factor weak bands strong band
5064 real(r8) sqwp ! Sqrt of co2 pathlength
5065 real(r8) f1sqwp ! Main co2 band factor
5066 real(r8) oneme ! Co2 stimulated emission term
5067 real(r8) alphat ! Part of the co2 stimulated emiss term
5068 real(r8) wco2 ! Consts used to define co2 pathlength
5069 real(r8) posqt ! Effective pressure for co2 line width
5070 real(r8) rbeta7 ! Inverse of co2 hot band line width par
5071 real(r8) rbeta8 ! Inverse of co2 hot band line width par
5072 real(r8) rbeta9 ! Inverse of co2 hot band line width par
5073 real(r8) rbeta13 ! Inverse of co2 hot band line width par
5074 real(r8) tpath ! Path temp used in co2 band model
5075 real(r8) tmp1 ! Co2 band factor
5076 real(r8) tmp2 ! Co2 band factor
5077 real(r8) tmp3 ! Co2 band factor
5078 real(r8) tlayr5 ! Temperature factor in co2 Planck func
5079 real(r8) rsqti ! Reciprocal of sqrt of temperature
5080 real(r8) exm1sq ! Part of co2 Planck function
5081 real(r8) u7 ! Absorber amt for various co2 band systems
5082 real(r8) u8 ! Absorber amt for various co2 band systems
5083 real(r8) u9 ! Absorber amt for various co2 band systems
5084 real(r8) u13 ! Absorber amt for various co2 band systems
5085 real(r8) r250 ! Inverse 250K
5086 real(r8) r300 ! Inverse 300K
5087 real(r8) rsslp ! Inverse standard sea-level pressure
5088 !
5089 ! Local variables for O3:
5090 !
5091 real(r8) o3ems(pcols,pverp) ! Ozone emissivity
5092 real(r8) dbvtt(pcols) ! Tmp drvtv of planck fctn for tplnke
5093 real(r8) dbvt,fo3,t,ux,vx
5094 real(r8) te ! Temperature factor
5095 real(r8) u1 ! Path length factor
5096 real(r8) u2 ! Path length factor
5097 real(r8) phat ! Effecitive path length pressure
5098 real(r8) tlocal ! Local planck function temperature
5099 real(r8) tcrfac ! Scaled temperature factor
5100 real(r8) beta ! Absorption funct factor voigt effect
5101 real(r8) realnu ! Absorption function factor
5102 real(r8) o3bndi ! Band absorption factor
5103 !
5104 ! Transmission terms for various spectral intervals:
5105 !
5106 real(r8) absbnd ! Proportional to co2 band absorptance
5107 real(r8) tco2(pcols) ! co2 overlap factor
5108 real(r8) th2o(pcols) ! h2o overlap factor
5109 real(r8) to3(pcols) ! o3 overlap factor
5110 !
5111 ! Variables for new H2O parameterization
5112 !
5113 ! Notation:
5114 ! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
5115 ! P = atmospheric pressure
5116 ! P_0 = reference atmospheric pressure
5117 ! W = precipitable water path
5118 ! T_e = emission temperature
5119 ! T_p = path temperature
5120 ! RH = path relative humidity
5121 !
5122 real(r8) fe ! asymptotic value of emis. as U->infinity
5123 real(r8) e_star ! normalized non-window emissivity
5124 real(r8) l_star ! interpolated line transmission
5125 real(r8) c_star ! interpolated continuum transmission
5126
5127 real(r8) te1 ! emission temperature
5128 real(r8) te2 ! te^2
5129 real(r8) te3 ! te^3
5130 real(r8) te4 ! te^4
5131 real(r8) te5 ! te^5
5132
5133 real(r8) log_u ! log base 10 of U
5134 real(r8) log_uc ! log base 10 of H2O continuum path
5135 real(r8) log_p ! log base 10 of P
5136 real(r8) t_p ! T_p
5137 real(r8) t_e ! T_e (offset by T_p)
5138
5139 integer iu ! index for log10(U)
5140 integer iu1 ! iu + 1
5141 integer iuc ! index for log10(H2O continuum path)
5142 integer iuc1 ! iuc + 1
5143 integer ip ! index for log10(P)
5144 integer ip1 ! ip + 1
5145 integer itp ! index for T_p
5146 integer itp1 ! itp + 1
5147 integer ite ! index for T_e
5148 integer ite1 ! ite + 1
5149 integer irh ! index for RH
5150 integer irh1 ! irh + 1
5151
5152 real(r8) dvar ! normalized variation in T_p/T_e/P/U
5153 real(r8) uvar ! U * diffusivity factor
5154 real(r8) uscl ! factor for lineary scaling as U->0
5155
5156 real(r8) wu ! weight for U
5157 real(r8) wu1 ! 1 - wu
5158 real(r8) wuc ! weight for H2O continuum path
5159 real(r8) wuc1 ! 1 - wuc
5160 real(r8) wp ! weight for P
5161 real(r8) wp1 ! 1 - wp
5162 real(r8) wtp ! weight for T_p
5163 real(r8) wtp1 ! 1 - wtp
5164 real(r8) wte ! weight for T_e
5165 real(r8) wte1 ! 1 - wte
5166 real(r8) wrh ! weight for RH
5167 real(r8) wrh1 ! 1 - wrh
5168
5169 real(r8) w_0_0_ ! weight for Tp/Te combination
5170 real(r8) w_0_1_ ! weight for Tp/Te combination
5171 real(r8) w_1_0_ ! weight for Tp/Te combination
5172 real(r8) w_1_1_ ! weight for Tp/Te combination
5173
5174 real(r8) w_0_00 ! weight for Tp/Te/RH combination
5175 real(r8) w_0_01 ! weight for Tp/Te/RH combination
5176 real(r8) w_0_10 ! weight for Tp/Te/RH combination
5177 real(r8) w_0_11 ! weight for Tp/Te/RH combination
5178 real(r8) w_1_00 ! weight for Tp/Te/RH combination
5179 real(r8) w_1_01 ! weight for Tp/Te/RH combination
5180 real(r8) w_1_10 ! weight for Tp/Te/RH combination
5181 real(r8) w_1_11 ! weight for Tp/Te/RH combination
5182
5183 real(r8) w00_00 ! weight for P/Tp/Te/RH combination
5184 real(r8) w00_01 ! weight for P/Tp/Te/RH combination
5185 real(r8) w00_10 ! weight for P/Tp/Te/RH combination
5186 real(r8) w00_11 ! weight for P/Tp/Te/RH combination
5187 real(r8) w01_00 ! weight for P/Tp/Te/RH combination
5188 real(r8) w01_01 ! weight for P/Tp/Te/RH combination
5189 real(r8) w01_10 ! weight for P/Tp/Te/RH combination
5190 real(r8) w01_11 ! weight for P/Tp/Te/RH combination
5191 real(r8) w10_00 ! weight for P/Tp/Te/RH combination
5192 real(r8) w10_01 ! weight for P/Tp/Te/RH combination
5193 real(r8) w10_10 ! weight for P/Tp/Te/RH combination
5194 real(r8) w10_11 ! weight for P/Tp/Te/RH combination
5195 real(r8) w11_00 ! weight for P/Tp/Te/RH combination
5196 real(r8) w11_01 ! weight for P/Tp/Te/RH combination
5197 real(r8) w11_10 ! weight for P/Tp/Te/RH combination
5198 real(r8) w11_11 ! weight for P/Tp/Te/RH combination
5199
5200 integer ib ! spectral interval:
5201 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
5202 ! 2 = 800-1200 cm^-1
5203
5204 real(r8) pch2o ! H2O continuum path
5205 real(r8) fch2o ! temp. factor for continuum
5206 real(r8) uch2o ! U corresponding to H2O cont. path (window)
5207
5208 real(r8) fdif ! secant(zenith angle) for diffusivity approx.
5209
5210 real(r8) sslp_mks ! Sea-level pressure in MKS units
5211 real(r8) esx ! saturation vapor pressure returned by vqsatd
5212 real(r8) qsx ! saturation mixing ratio returned by vqsatd
5213 real(r8) pnew_mks ! pnew in MKS units
5214 real(r8) q_path ! effective specific humidity along path
5215 real(r8) rh_path ! effective relative humidity along path
5216 real(r8) omeps ! 1 - epsilo
5217
5218 integer iest ! index in estblh2o
5219
5220 !
5221 !---------------------------Statement functions-------------------------
5222 !
5223 ! Derivative of planck function at 9.6 micro-meter wavelength, and
5224 ! an absorption function factor:
5225 !
5226 !
5227 dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
5228 (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
5229 !
5230 fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx))
5231 !
5232 !
5233 !
5234 !-----------------------------------------------------------------------
5235 !
5236 ! Initialize
5237 !
5238 r250 = 1./250.
5239 r300 = 1./300.
5240 rsslp = 1./sslp
5241 !
5242 ! Constants for computing U corresponding to H2O cont. path
5243 !
5244 fdif = 1.66
5245 sslp_mks = sslp / 10.0
5246 omeps = 1.0 - epsilo
5247 !
5248 ! Planck function for co2
5249 !
5250 do i=1,ncol
5251 ex = exp(960./tplnke(i))
5252 co2plk(i) = 5.e8/((tplnke(i)**4)*(ex - 1.))
5253 co2t(i,ntoplw) = tplnke(i)
5254 sum(i) = co2t(i,ntoplw)*pnm(i,ntoplw)
5255 end do
5256 k = ntoplw
5257 do k1=pverp,ntoplw+1,-1
5258 k = k + 1
5259 do i=1,ncol
5260 sum(i) = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1))
5261 ex = exp(960./tlayr(i,k1))
5262 tlayr5 = tlayr(i,k1)*tlayr4(i,k1)
5263 co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2)
5264 co2t(i,k) = sum(i)/pnm(i,k)
5265 end do
5266 end do
5267 !
5268 ! Initialize planck function derivative for O3
5269 !
5270 do i=1,ncol
5271 dbvtt(i) = dbvt(tplnke(i))
5272 end do
5273 !
5274 ! Calculate trace gas Planck functions
5275 !
5276 call trcplk(lchnk ,ncol ,pcols, pver, pverp, &
5277 tint ,tlayr ,tplnke ,emplnk ,abplnk1 , &
5278 abplnk2 )
5279 !
5280 ! Interface loop
5281 !
5282 do k1=ntoplw,pverp
5283 !
5284 ! H2O emissivity
5285 !
5286 ! emis(i,1) 0 - 800 cm-1 h2o rotation band
5287 ! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
5288 ! emis(i,2) 800 - 1200 cm-1 h2o window
5289 !
5290 ! Separation between rotation and vibration-rotation dropped, so
5291 ! only 2 slots needed for H2O emissivity
5292 !
5293 ! emis(i,3) = 0.0
5294 !
5295 ! For the p type continuum
5296 !
5297 do i=1,ncol
5298 u(i) = plh2o(i,k1)
5299 pnew = u(i)/w(i,k1)
5300 pnew_mks = pnew * sslp_mks
5301 !
5302 ! Apply scaling factor for 500-800 continuum
5303 !
5304 uc1(i) = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ &
5305 (1. + 15.*s2c(i,k1))
5306 pch2o = s2c(i,k1)
5307 !
5308 ! Changed effective path temperature to std. Curtis-Godson form
5309 !
5310 tpathe = tcg(i,k1)/w(i,k1)
5311 t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o)
5312 iest = floor(t_p) - min_tp_h2o
5313 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
5314 (t_p - min_tp_h2o - iest)
5315 qsx = epsilo * esx / (pnew_mks - omeps * esx)
5316 !
5317 ! Compute effective RH along path
5318 !
5319 q_path = w(i,k1) / pnm(i,k1) / rga
5320 !
5321 ! Calculate effective u, pnew for each band using
5322 ! Hulst-Curtis-Godson approximation:
5323 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
5324 ! 2nd edition, Oxford University Press, 1989.
5325 ! Effective H2O path (w)
5326 ! eq. 6.24, p. 228
5327 ! Effective H2O path pressure (pnew = u/w):
5328 ! eq. 6.29, p. 228
5329 !
5330 ub(1) = plh2ob(1,i,k1) / psi(t_p,1)
5331 ub(2) = plh2ob(2,i,k1) / psi(t_p,2)
5332
5333 pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1)
5334 pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2)
5335 !
5336 !
5337 !
5338 dtx(i) = tplnke(i) - 250.
5339 dty(i) = tpathe - 250.
5340 !
5341 ! Define variables for C/H/E (now C/LT/E) fit
5342 !
5343 ! emis(i,1) 0 - 800 cm-1 h2o rotation band
5344 ! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
5345 ! emis(i,2) 800 - 1200 cm-1 h2o window
5346 !
5347 ! Separation between rotation and vibration-rotation dropped, so
5348 ! only 2 slots needed for H2O emissivity
5349 !
5350 ! emis(i,3) = 0.0
5351 !
5352 ! Notation:
5353 ! U = integral (P/P_0 dW)
5354 ! P = atmospheric pressure
5355 ! P_0 = reference atmospheric pressure
5356 ! W = precipitable water path
5357 ! T_e = emission temperature
5358 ! T_p = path temperature
5359 ! RH = path relative humidity
5360 !
5361 ! Terms for asymptotic value of emissivity
5362 !
5363 te1 = tplnke(i)
5364 te2 = te1 * te1
5365 te3 = te2 * te1
5366 te4 = te3 * te1
5367 te5 = te4 * te1
5368 !
5369 ! Band-independent indices for lines and continuum tables
5370 !
5371 dvar = (t_p - min_tp_h2o) / dtp_h2o
5372 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
5373 itp1 = itp + 1
5374 wtp = dvar - floor(dvar)
5375 wtp1 = 1.0 - wtp
5376
5377 t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o)
5378 dvar = (t_e - min_te_h2o) / dte_h2o
5379 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
5380 ite1 = ite + 1
5381 wte = dvar - floor(dvar)
5382 wte1 = 1.0 - wte
5383
5384 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
5385 dvar = (rh_path - min_rh_h2o) / drh_h2o
5386 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
5387 irh1 = irh + 1
5388 wrh = dvar - floor(dvar)
5389 wrh1 = 1.0 - wrh
5390
5391 w_0_0_ = wtp * wte
5392 w_0_1_ = wtp * wte1
5393 w_1_0_ = wtp1 * wte
5394 w_1_1_ = wtp1 * wte1
5395
5396 w_0_00 = w_0_0_ * wrh
5397 w_0_01 = w_0_0_ * wrh1
5398 w_0_10 = w_0_1_ * wrh
5399 w_0_11 = w_0_1_ * wrh1
5400 w_1_00 = w_1_0_ * wrh
5401 w_1_01 = w_1_0_ * wrh1
5402 w_1_10 = w_1_1_ * wrh
5403 w_1_11 = w_1_1_ * wrh1
5404 !
5405 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
5406 !
5407 ! Assume foreign continuum dominates total H2O continuum in these bands
5408 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
5409 ! Then the effective H2O path is just
5410 ! U_c = integral[ f(P) dW ]
5411 ! where
5412 ! W = water-vapor mass and
5413 ! f(P) = dependence of foreign continuum on pressure
5414 ! = P / sslp
5415 ! Then
5416 ! U_c = U (the same effective H2O path as for lines)
5417 !
5418 !
5419 ! Continuum terms for 800-1200 cm^-1
5420 !
5421 ! Assume self continuum dominates total H2O continuum for this band
5422 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
5423 ! Then the effective H2O self-continuum path is
5424 ! U_c = integral[ h(e,T) dW ] (*eq. 1*)
5425 ! where
5426 ! W = water-vapor mass and
5427 ! e = partial pressure of H2O along path
5428 ! T = temperature along path
5429 ! h(e,T) = dependence of foreign continuum on e,T
5430 ! = e / sslp * f(T)
5431 !
5432 ! Replacing
5433 ! e =~ q * P / epsilo
5434 ! q = mixing ratio of H2O
5435 ! epsilo = 0.622
5436 !
5437 ! and using the definition
5438 ! U = integral [ (P / sslp) dW ]
5439 ! = (P / sslp) W (homogeneous path)
5440 !
5441 ! the effective path length for the self continuum is
5442 ! U_c = (q / epsilo) f(T) U (*eq. 2*)
5443 !
5444 ! Once values of T, U, and q have been calculated for the inhomogeneous
5445 ! path, this sets U_c for the corresponding
5446 ! homogeneous atmosphere. However, this need not equal the
5447 ! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
5448 ! under consideration.
5449 !
5450 ! Solution: hold T and q constant, solve for U' that gives U_c' by
5451 ! inverting eq. (2):
5452 !
5453 ! U' = (U_c * epsilo) / (q * f(T))
5454 !
5455 fch2o = fh2oself(t_p)
5456 uch2o = (pch2o * epsilo) / (q_path * fch2o)
5457
5458 !
5459 ! Band-dependent indices for non-window
5460 !
5461 ib = 1
5462
5463 uvar = ub(ib) * fdif
5464 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
5465 dvar = (log_u - min_lu_h2o) / dlu_h2o
5466 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
5467 iu1 = iu + 1
5468 wu = dvar - floor(dvar)
5469 wu1 = 1.0 - wu
5470
5471 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
5472 dvar = (log_p - min_lp_h2o) / dlp_h2o
5473 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
5474 ip1 = ip + 1
5475 wp = dvar - floor(dvar)
5476 wp1 = 1.0 - wp
5477
5478 w00_00 = wp * w_0_00
5479 w00_01 = wp * w_0_01
5480 w00_10 = wp * w_0_10
5481 w00_11 = wp * w_0_11
5482 w01_00 = wp * w_1_00
5483 w01_01 = wp * w_1_01
5484 w01_10 = wp * w_1_10
5485 w01_11 = wp * w_1_11
5486 w10_00 = wp1 * w_0_00
5487 w10_01 = wp1 * w_0_01
5488 w10_10 = wp1 * w_0_10
5489 w10_11 = wp1 * w_0_11
5490 w11_00 = wp1 * w_1_00
5491 w11_01 = wp1 * w_1_01
5492 w11_10 = wp1 * w_1_10
5493 w11_11 = wp1 * w_1_11
5494
5495 !
5496 ! Asymptotic value of emissivity as U->infinity
5497 !
5498 fe = fet(1,ib) + &
5499 fet(2,ib) * te1 + &
5500 fet(3,ib) * te2 + &
5501 fet(4,ib) * te3 + &
5502 fet(5,ib) * te4 + &
5503 fet(6,ib) * te5
5504
5505 e_star = &
5506 eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
5507 eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
5508 eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
5509 eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
5510 eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
5511 eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
5512 eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
5513 eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
5514 eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
5515 eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
5516 eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
5517 eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
5518 eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
5519 eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
5520 eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
5521 eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
5522 eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
5523 eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
5524 eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
5525 eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
5526 eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
5527 eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
5528 eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
5529 eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
5530 eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
5531 eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
5532 eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
5533 eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
5534 eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
5535 eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
5536 eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
5537 eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
5538 emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * &
5539 aer_trn_ttl(i,k1,1,ib)), &
5540 0.0_r8), 1.0_r8)
5541 !
5542 ! Invoke linear limit for scaling wrt u below min_u_h2o
5543 !
5544 if (uvar < min_u_h2o) then
5545 uscl = uvar / min_u_h2o
5546 emis(i,ib) = emis(i,ib) * uscl
5547 endif
5548
5549
5550
5551 !
5552 ! Band-dependent indices for window
5553 !
5554 ib = 2
5555
5556 uvar = ub(ib) * fdif
5557 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
5558 dvar = (log_u - min_lu_h2o) / dlu_h2o
5559 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
5560 iu1 = iu + 1
5561 wu = dvar - floor(dvar)
5562 wu1 = 1.0 - wu
5563
5564 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
5565 dvar = (log_p - min_lp_h2o) / dlp_h2o
5566 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
5567 ip1 = ip + 1
5568 wp = dvar - floor(dvar)
5569 wp1 = 1.0 - wp
5570
5571 w00_00 = wp * w_0_00
5572 w00_01 = wp * w_0_01
5573 w00_10 = wp * w_0_10
5574 w00_11 = wp * w_0_11
5575 w01_00 = wp * w_1_00
5576 w01_01 = wp * w_1_01
5577 w01_10 = wp * w_1_10
5578 w01_11 = wp * w_1_11
5579 w10_00 = wp1 * w_0_00
5580 w10_01 = wp1 * w_0_01
5581 w10_10 = wp1 * w_0_10
5582 w10_11 = wp1 * w_0_11
5583 w11_00 = wp1 * w_1_00
5584 w11_01 = wp1 * w_1_01
5585 w11_10 = wp1 * w_1_10
5586 w11_11 = wp1 * w_1_11
5587
5588 log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
5589 dvar = (log_uc - min_lu_h2o) / dlu_h2o
5590 iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
5591 iuc1 = iuc + 1
5592 wuc = dvar - floor(dvar)
5593 wuc1 = 1.0 - wuc
5594 !
5595 ! Asymptotic value of emissivity as U->infinity
5596 !
5597 fe = fet(1,ib) + &
5598 fet(2,ib) * te1 + &
5599 fet(3,ib) * te2 + &
5600 fet(4,ib) * te3 + &
5601 fet(5,ib) * te4 + &
5602 fet(6,ib) * te5
5603
5604 l_star = &
5605 ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
5606 ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
5607 ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
5608 ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
5609 ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
5610 ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
5611 ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
5612 ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
5613 ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
5614 ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
5615 ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
5616 ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
5617 ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
5618 ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
5619 ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
5620 ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
5621 ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
5622 ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
5623 ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
5624 ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
5625 ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
5626 ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
5627 ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
5628 ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
5629 ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
5630 ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
5631 ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
5632 ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
5633 ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
5634 ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
5635 ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
5636 ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
5637
5638 c_star = &
5639 cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
5640 cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
5641 cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
5642 cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
5643 cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
5644 cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
5645 cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
5646 cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
5647 cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
5648 cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
5649 cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
5650 cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
5651 cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
5652 cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
5653 cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
5654 cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
5655 cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
5656 cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
5657 cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
5658 cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
5659 cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
5660 cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
5661 cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
5662 cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
5663 cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
5664 cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
5665 cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
5666 cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
5667 cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
5668 cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
5669 cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
5670 cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
5671 emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * &
5672 aer_trn_ttl(i,k1,1,ib)), &
5673 0.0_r8), 1.0_r8)
5674 !
5675 ! Invoke linear limit for scaling wrt u below min_u_h2o
5676 !
5677 if (uvar < min_u_h2o) then
5678 uscl = uvar / min_u_h2o
5679 emis(i,ib) = emis(i,ib) * uscl
5680 endif
5681
5682
5683 !
5684 ! Compute total emissivity for H2O
5685 !
5686 h2oems(i,k1) = emis(i,1)+emis(i,2)
5687
5688 end do
5689 !
5690 !
5691 !
5692
5693 do i=1,ncol
5694 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i))
5695 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i))
5696 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i))
5697 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i))
5698 end do
5699 do i=1,ncol
5700 !
5701 ! 500 - 800 cm-1 rotation band overlap with co2
5702 !
5703 k21(i) = term7(i,1) + term8(i,1)/ &
5704 (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i)))
5705 k22(i) = term7(i,2) + term8(i,2)/ &
5706 (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i)))
5707 fwk = fwcoef + fwc1/(1.+fwc2*u(i))
5708 tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
5709 tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
5710 tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800)
5711 ! ! H2O line+aer trn 650--800 cm-1
5712 tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650)
5713 ! ! H2O line+aer trn 500--650 cm-1
5714 tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i)))
5715 tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i)))
5716 tr7(i) = tr1(i)*tr3(i)
5717 tr8(i) = tr2(i)*tr4(i)
5718 troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i)
5719 th2o(i) = tr8(i)
5720 end do
5721 !
5722 ! CO2 emissivity for 15 micron band system
5723 !
5724 do i=1,ncol
5725 t1i = exp(-480./co2t(i,k1))
5726 sqti = sqrt(co2t(i,k1))
5727 rsqti = 1./sqti
5728 et = t1i
5729 et2 = et*et
5730 et4 = et2*et2
5731 omet = 1. - 1.5*et2
5732 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
5733 sqwp = sqrt(plco2(i,k1))
5734 f1sqwp = f1co2*sqwp
5735 t1co2 = 1./(1. + 245.18*omet*sqwp*rsqti)
5736 oneme = 1. - et2
5737 alphat = oneme**3*rsqti
5738 wco2 = 2.5221*co2vmr*pnm(i,k1)*rga
5739 u7 = 4.9411e4*alphat*et2*wco2
5740 u8 = 3.9744e4*alphat*et4*wco2
5741 u9 = 1.0447e5*alphat*et4*et2*wco2
5742 u13 = 2.8388e3*alphat*et4*wco2
5743 !
5744 tpath = co2t(i,k1)
5745 tlocal = tplnke(i)
5746 tcrfac = sqrt((tlocal*r250)*(tpath*r300))
5747 pi = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac
5748 posqt = pi/(2.*sqti)
5749 rbeta7 = 1./( 5.3288*posqt)
5750 rbeta8 = 1./ (10.6576*posqt)
5751 rbeta9 = rbeta7
5752 rbeta13= rbeta9
5753 f2co2 = (u7/sqrt(4. + u7*(1. + rbeta7))) + &
5754 (u8/sqrt(4. + u8*(1. + rbeta8))) + &
5755 (u9/sqrt(4. + u9*(1. + rbeta9)))
5756 f3co2 = u13/sqrt(4. + u13*(1. + rbeta13))
5757 tmp1 = log(1. + f1sqwp)
5758 tmp2 = log(1. + f2co2)
5759 tmp3 = log(1. + f3co2)
5760 absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti
5761 tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7))))
5762 co2ems(i,k1) = troco2(i,k1)*absbnd*co2plk(i)
5763 ex = exp(960./tint(i,k1))
5764 exm1sq = (ex - 1.)**2
5765 co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq)
5766 end do
5767 !
5768 ! O3 emissivity
5769 !
5770 do i=1,ncol
5771 h2otr(i,k1) = exp(-12.*s2c(i,k1))
5772 h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200)
5773 te = (co2t(i,k1)/293.)**.7
5774 u1 = 18.29*plos(i,k1)/te
5775 u2 = .5649*plos(i,k1)/te
5776 phat = plos(i,k1)/plol(i,k1)
5777 tlocal = tplnke(i)
5778 tcrfac = sqrt(tlocal*r250)*te
5779 beta = (1./.3205)*((1./phat) + (dpfo3*tcrfac))
5780 realnu = (1./beta)*te
5781 o3bndi = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu))
5782 o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi
5783 to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu))
5784 end do
5785 !
5786 ! Calculate trace gas emissivities
5787 !
5788 call trcems(lchnk ,ncol ,pcols, pverp, &
5789 k1 ,co2t ,pnm ,ucfc11 ,ucfc12 , &
5790 un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
5791 bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
5792 uco222 ,uco223 ,uptype ,w ,s2c , &
5793 u ,emplnk ,th2o ,tco2 ,to3 , &
5794 emstrc , &
5795 aer_trn_ttl)
5796 !
5797 ! Total emissivity:
5798 !
5799 do i=1,ncol
5800 emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1) &
5801 + emstrc(i,k1)
5802 end do
5803 end do ! End of interface loop
5804
5805 return
5806 end subroutine radems
5807
5808 subroutine radtpl(lchnk ,ncol ,pcols, pver, pverp, &
5809 tnm ,lwupcgs ,qnm ,pnm ,plco2 ,plh2o , &
5810 tplnka ,s2c ,tcg ,w ,tplnke , &
5811 tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
5812 piln ,plh2ob ,wb )
5813 !--------------------------------------------------------------------
5814 !
5815 ! Purpose:
5816 ! Compute temperatures and path lengths for longwave radiation
5817 !
5818 ! Method:
5819 ! <Describe the algorithm(s) used in the routine.>
5820 ! <Also include any applicable external references.>
5821 !
5822 ! Author: CCM1
5823 !
5824 !--------------------------------------------------------------------
5825
5826 !------------------------------Arguments-----------------------------
5827 !
5828 ! Input arguments
5829 !
5830 integer, intent(in) :: lchnk ! chunk identifier
5831 integer, intent(in) :: ncol ! number of atmospheric columns
5832 integer, intent(in) :: pcols, pver, pverp
5833
5834 real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures
5835 real(r8), intent(in) :: lwupcgs(pcols) ! Surface longwave up flux
5836 real(r8), intent(in) :: qnm(pcols,pver) ! Model level specific humidity
5837 real(r8), intent(in) :: pnm(pcols,pverp) ! Pressure at model interfaces (dynes/cm2)
5838 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
5839 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
5840 !
5841 ! Output arguments
5842 !
5843 real(r8), intent(out) :: plco2(pcols,pverp) ! Pressure weighted co2 path
5844 real(r8), intent(out) :: plh2o(pcols,pverp) ! Pressure weighted h2o path
5845 real(r8), intent(out) :: tplnka(pcols,pverp) ! Level temperature from interface temperatures
5846 real(r8), intent(out) :: s2c(pcols,pverp) ! H2o continuum path length
5847 real(r8), intent(out) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
5848 real(r8), intent(out) :: w(pcols,pverp) ! H2o path length
5849 real(r8), intent(out) :: tplnke(pcols) ! Equal to tplnka
5850 real(r8), intent(out) :: tint(pcols,pverp) ! Layer interface temperature
5851 real(r8), intent(out) :: tint4(pcols,pverp) ! Tint to the 4th power
5852 real(r8), intent(out) :: tlayr(pcols,pverp) ! K-1 level temperature
5853 real(r8), intent(out) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
5854 real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
5855 ! Hulst-Curtis-Godson temp. factor
5856 ! for H2O bands
5857 real(r8), intent(out) :: wb(nbands,pcols,pverp) ! H2o path length with
5858 ! Hulst-Curtis-Godson temp. factor
5859 ! for H2O bands
5860
5861 !
5862 !---------------------------Local variables--------------------------
5863 !
5864 integer i ! Longitude index
5865 integer k ! Level index
5866 integer kp1 ! Level index + 1
5867
5868 real(r8) repsil ! Inver ratio mol weight h2o to dry air
5869 real(r8) dy ! Thickness of layer for tmp interp
5870 real(r8) dpnm ! Pressure thickness of layer
5871 real(r8) dpnmsq ! Prs squared difference across layer
5872 real(r8) dw ! Increment in H2O path length
5873 real(r8) dplh2o ! Increment in plh2o
5874 real(r8) cpwpl ! Const in co2 mix ratio to path length conversn
5875
5876 !--------------------------------------------------------------------
5877 !
5878 repsil = 1./epsilo
5879 !
5880 ! Compute co2 and h2o paths
5881 !
5882 cpwpl = amco2/amd * 0.5/(gravit*p0)
5883 do i=1,ncol
5884 plh2o(i,ntoplw) = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw)
5885 plco2(i,ntoplw) = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw)
5886 end do
5887 do k=ntoplw,pver
5888 do i=1,ncol
5889 plh2o(i,k+1) = plh2o(i,k) + rgsslp* &
5890 (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k)
5891 plco2(i,k+1) = co2vmr*cpwpl*pnm(i,k+1)**2
5892 end do
5893 end do
5894 !
5895 ! Set the top and bottom intermediate level temperatures,
5896 ! top level planck temperature and top layer temp**4.
5897 !
5898 ! Tint is lower interface temperature
5899 ! (not available for bottom layer, so use ground temperature)
5900 !
5901 do i=1,ncol
5902 tint4(i,pverp) = lwupcgs(i)/stebol
5903 tint(i,pverp) = sqrt(sqrt(tint4(i,pverp)))
5904 tplnka(i,ntoplw) = tnm(i,ntoplw)
5905 tint(i,ntoplw) = tplnka(i,ntoplw)
5906 tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4
5907 tint4(i,ntoplw) = tlayr4(i,ntoplw)
5908 end do
5909 !
5910 ! Intermediate level temperatures are computed using temperature
5911 ! at the full level below less dy*delta t,between the full level
5912 !
5913 do k=ntoplw+1,pver
5914 do i=1,ncol
5915 dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k))
5916 tint(i,k) = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1))
5917 tint4(i,k) = tint(i,k)**4
5918 end do
5919 end do
5920 !
5921 ! Now set the layer temp=full level temperatures and establish a
5922 ! planck temperature for absorption (tplnka) which is the average
5923 ! the intermediate level temperatures. Note that tplnka is not
5924 ! equal to the full level temperatures.
5925 !
5926 do k=ntoplw+1,pverp
5927 do i=1,ncol
5928 tlayr(i,k) = tnm(i,k-1)
5929 tlayr4(i,k) = tlayr(i,k)**4
5930 tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1))
5931 end do
5932 end do
5933 !
5934 ! Calculate tplank for emissivity calculation.
5935 ! Assume isothermal tplnke i.e. all levels=ttop.
5936 !
5937 do i=1,ncol
5938 tplnke(i) = tplnka(i,ntoplw)
5939 tlayr(i,ntoplw) = tint(i,ntoplw)
5940 end do
5941 !
5942 ! Now compute h2o path fields:
5943 !
5944 do i=1,ncol
5945 !
5946 ! Changed effective path temperature to std. Curtis-Godson form
5947 !
5948 tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw)
5949 w(i,ntoplw) = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw)
5950 !
5951 ! Hulst-Curtis-Godson scaling for H2O path
5952 !
5953 wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1)
5954 wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2)
5955 !
5956 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
5957 !
5958 plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1)
5959 plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2)
5960
5961 s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil
5962 end do
5963
5964 do k=ntoplw,pver
5965 do i=1,ncol
5966 dpnm = pnm(i,k+1) - pnm(i,k)
5967 dpnmsq = pnm(i,k+1)**2 - pnm(i,k)**2
5968 dw = rga*qnm(i,k)*dpnm
5969 kp1 = k+1
5970 w(i,kp1) = w(i,k) + dw
5971 !
5972 ! Hulst-Curtis-Godson scaling for H2O path
5973 !
5974 wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1)
5975 wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2)
5976 !
5977 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
5978 !
5979 dplh2o = plh2o(i,kp1) - plh2o(i,k)
5980
5981 plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1)
5982 plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2)
5983 !
5984 ! Changed effective path temperature to std. Curtis-Godson form
5985 !
5986 tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k)
5987 s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* &
5988 fh2oself(tnm(i,k))*qnm(i,k)*repsil
5989 end do
5990 end do
5991 !
5992 return
5993 end subroutine radtpl
5994
5995 subroutine radaeini( pstdx, mwdryx, mwco2x )
5996
5997 USE module_wrf_error
5998 USE module_dm
5999
6000 !
6001 ! Initialize radae module data
6002 !
6003 !
6004 ! Input variables
6005 !
6006 real(r8), intent(in) :: pstdx ! Standard pressure (dynes/cm^2)
6007 real(r8), intent(in) :: mwdryx ! Molecular weight of dry air
6008 real(r8), intent(in) :: mwco2x ! Molecular weight of carbon dioxide
6009 !
6010 ! Variables for loading absorptivity/emissivity
6011 !
6012 integer ncid_ae ! NetCDF file id for abs/ems file
6013
6014 integer pdimid ! pressure dimension id
6015 integer psize ! pressure dimension size
6016
6017 integer tpdimid ! path temperature dimension id
6018 integer tpsize ! path temperature size
6019
6020 integer tedimid ! emission temperature dimension id
6021 integer tesize ! emission temperature size
6022
6023 integer udimid ! u (H2O path) dimension id
6024 integer usize ! u (H2O path) dimension size
6025
6026 integer rhdimid ! relative humidity dimension id
6027 integer rhsize ! relative humidity dimension size
6028
6029 integer ah2onwid ! var. id for non-wndw abs.
6030 integer eh2onwid ! var. id for non-wndw ems.
6031 integer ah2owid ! var. id for wndw abs. (adjacent layers)
6032 integer cn_ah2owid ! var. id for continuum trans. for wndw abs.
6033 integer cn_eh2owid ! var. id for continuum trans. for wndw ems.
6034 integer ln_ah2owid ! var. id for line trans. for wndw abs.
6035 integer ln_eh2owid ! var. id for line trans. for wndw ems.
6036
6037 ! character*(NF_MAX_NAME) tmpname! dummy variable for var/dim names
6038 character(len=256) locfn ! local filename
6039 integer tmptype ! dummy variable for variable type
6040 integer ndims ! number of dimensions
6041 ! integer dims(NF_MAX_VAR_DIMS) ! vector of dimension ids
6042 integer natt ! number of attributes
6043 !
6044 ! Variables for setting up H2O table
6045 !
6046 integer t ! path temperature
6047 integer tmin ! mininum path temperature
6048 integer tmax ! maximum path temperature
6049 integer itype ! type of sat. pressure (=0 -> H2O only)
6050 integer i
6051 real(r8) tdbl
6052
6053 LOGICAL :: opened
6054 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
6055
6056 CHARACTER*80 errmess
6057 INTEGER cam_abs_unit
6058
6059 !
6060 ! Constants to set
6061 !
6062 p0 = pstdx
6063 amd = mwdryx
6064 amco2 = mwco2x
6065 !
6066 ! Coefficients for h2o emissivity and absorptivity for overlap of H2O
6067 ! and trace gases.
6068 !
6069 c16 = coefj(3,1)/coefj(2,1)
6070 c17 = coefk(3,1)/coefk(2,1)
6071 c26 = coefj(3,2)/coefj(2,2)
6072 c27 = coefk(3,2)/coefk(2,2)
6073 c28 = .5
6074 c29 = .002053
6075 c30 = .1
6076 c31 = 3.0e-5
6077 !
6078 ! Initialize further longwave constants referring to far wing
6079 ! correction for overlap of H2O and trace gases; R&D refers to:
6080 !
6081 ! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
6082 ! Emissivity and Absorptivity Formulation for Water Vapor
6083 ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
6084 !
6085 fwcoef = .1 ! See eq(33) R&D
6086 fwc1 = .30 ! See eq(33) R&D
6087 fwc2 = 4.5 ! See eq(33) and eq(34) in R&D
6088 fc1 = 2.6 ! See eq(34) R&D
6089
6090 IF ( wrf_dm_on_monitor() ) THEN
6091 DO i = 10,99
6092 INQUIRE ( i , OPENED = opened )
6093 IF ( .NOT. opened ) THEN
6094 cam_abs_unit = i
6095 GOTO 2010
6096 ENDIF
6097 ENDDO
6098 cam_abs_unit = -1
6099 2010 CONTINUE
6100 ENDIF
6101 CALL wrf_dm_bcast_bytes ( cam_abs_unit , IWORDSIZE )
6102 IF ( cam_abs_unit < 0 ) THEN
6103 CALL wrf_error_fatal ( 'module_ra_cam: radaeinit: Can not find unused fortran unit to read in lookup table.' )
6104 ENDIF
6105
6106 IF ( wrf_dm_on_monitor() ) THEN
6107 OPEN(cam_abs_unit,FILE='CAM_ABS_DATA', &
6108 FORM='UNFORMATTED',STATUS='OLD',ERR=9010)
6109 call wrf_debug(50,'reading CAM_ABS_DATA')
6110 ENDIF
6111
6112 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * r8 )
6113
6114 IF ( wrf_dm_on_monitor() ) then
6115 READ (cam_abs_unit,ERR=9010) ah2onw
6116 READ (cam_abs_unit,ERR=9010) eh2onw
6117 READ (cam_abs_unit,ERR=9010) ah2ow
6118 READ (cam_abs_unit,ERR=9010) cn_ah2ow
6119 READ (cam_abs_unit,ERR=9010) cn_eh2ow
6120 READ (cam_abs_unit,ERR=9010) ln_ah2ow
6121 READ (cam_abs_unit,ERR=9010) ln_eh2ow
6122
6123 endif
6124
6125 DM_BCAST_MACRO(ah2onw)
6126 DM_BCAST_MACRO(eh2onw)
6127 DM_BCAST_MACRO(ah2ow)
6128 DM_BCAST_MACRO(cn_ah2ow)
6129 DM_BCAST_MACRO(cn_eh2ow)
6130 DM_BCAST_MACRO(ln_ah2ow)
6131 DM_BCAST_MACRO(ln_eh2ow)
6132
6133 IF ( wrf_dm_on_monitor() ) CLOSE (cam_abs_unit)
6134
6135 ! Set up table of H2O saturation vapor pressures for use in calculation
6136 ! effective path RH. Need separate table from table in wv_saturation
6137 ! because:
6138 ! (1. Path temperatures can fall below minimum of that table; and
6139 ! (2. Abs/Emissivity tables are derived with RH for water only.
6140 !
6141 tmin = nint(min_tp_h2o)
6142 tmax = nint(max_tp_h2o)+1
6143 itype = 0
6144 do t = tmin, tmax
6145 ! call gffgch(dble(t),estblh2o(t-tmin),itype)
6146 tdbl = t
6147 call gffgch(tdbl,estblh2o(t-tmin),itype)
6148 end do
6149
6150 RETURN
6151 9010 CONTINUE
6152 WRITE( errmess , '(A35,I4)' ) 'module_ra_cam: error reading unit ',cam_abs_unit
6153 CALL wrf_error_fatal(errmess)
6154 end subroutine radaeini
6155
6156 subroutine radclwmx(lchnk ,ncol ,pcols, pver, pverp, &
6157 lwupcgs ,tnm ,qnm ,o3vmr , &
6158 pmid ,pint ,pmln ,piln , &
6159 n2o ,ch4 ,cfc11 ,cfc12 , &
6160 cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
6161 doabsems, abstot, absnxt, emstot, &
6162 flns ,flnt ,flnsc ,flntc ,flwds , &
6163 flut ,flutc , &
6164 flup ,flupc ,fldn ,fldnc , &
6165 aer_mass)
6166 !-----------------------------------------------------------------------
6167 !
6168 ! Purpose:
6169 ! Compute longwave radiation heating rates and boundary fluxes
6170 !
6171 ! Method:
6172 ! Uses broad band absorptivity/emissivity method to compute clear sky;
6173 ! assumes randomly overlapped clouds with variable cloud emissivity to
6174 ! include effects of clouds.
6175 !
6176 ! Computes clear sky absorptivity/emissivity at lower frequency (in
6177 ! general) than the model radiation frequency; uses previously computed
6178 ! and stored values for efficiency
6179 !
6180 ! Note: This subroutine contains vertical indexing which proceeds
6181 ! from bottom to top rather than the top to bottom indexing
6182 ! used in the rest of the model.
6183 !
6184 ! Author: B. Collins
6185 !
6186 !-----------------------------------------------------------------------
6187 ! use shr_kind_mod, only: r8 => shr_kind_r8
6188 ! use ppgrid
6189 ! use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d
6190 ! use volcrad
6191
6192 implicit none
6193
6194 integer pverp2,pverp3,pverp4
6195 ! parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4)
6196
6197 real(r8) cldmin
6198 parameter (cldmin = 1.0d-80)
6199 !------------------------------Commons----------------------------------
6200 !-----------------------------------------------------------------------
6201 !------------------------------Arguments--------------------------------
6202 !
6203 ! Input arguments
6204 !
6205 integer, intent(in) :: lchnk ! chunk identifier
6206 integer, intent(in) :: pcols, pver, pverp
6207 integer, intent(in) :: ncol ! number of atmospheric columns
6208 ! maximally overlapped region.
6209 ! 0->pmxrgn(i,1) is range of pmid for
6210 ! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
6211 ! 2nd region, etc
6212 integer, intent(in) :: nmxrgn(pcols) ! Number of maximally overlapped regions
6213 logical, intent(in) :: doabsems
6214
6215 real(r8), intent(in) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
6216 real(r8), intent(in) :: lwupcgs(pcols) ! Longwave up flux in CGS units
6217 !
6218 ! Input arguments which are only passed to other routines
6219 !
6220 real(r8), intent(in) :: tnm(pcols,pver) ! Level temperature
6221 real(r8), intent(in) :: qnm(pcols,pver) ! Level moisture field
6222 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
6223 real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
6224 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressure
6225 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmid)
6226 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pint)
6227 real(r8), intent(in) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio
6228 real(r8), intent(in) :: ch4(pcols,pver) ! methane mass mixing ratio
6229 real(r8), intent(in) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio
6230 real(r8), intent(in) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio
6231 real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover
6232 real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
6233 real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer
6234
6235 !
6236 ! Output arguments
6237 !
6238 real(r8), intent(out) :: qrl(pcols,pver) ! Longwave heating rate
6239 real(r8), intent(out) :: flns(pcols) ! Surface cooling flux
6240 real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux
6241 real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model
6242 real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing
6243 real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux
6244 real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model
6245 real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface
6246 ! Added downward/upward total and clear sky fluxes
6247 real(r8), intent(out) :: flup(pcols,pverp) ! Total sky upward longwave flux
6248 real(r8), intent(out) :: flupc(pcols,pverp) ! Clear sky upward longwave flux
6249 real(r8), intent(out) :: fldn(pcols,pverp) ! Total sky downward longwave flux
6250 real(r8), intent(out) :: fldnc(pcols,pverp) ! Clear sky downward longwave flux
6251 !
6252 real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
6253 real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
6254 real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
6255
6256 !---------------------------Local variables-----------------------------
6257 !
6258 integer i ! Longitude index
6259 integer ilon ! Longitude index
6260 integer ii ! Longitude index
6261 integer iimx ! Longitude index (max overlap)
6262 integer k ! Level index
6263 integer k1 ! Level index
6264 integer k2 ! Level index
6265 integer k3 ! Level index
6266 integer km ! Level index
6267 integer km1 ! Level index
6268 integer km3 ! Level index
6269 integer km4 ! Level index
6270 integer irgn ! Index for max-overlap regions
6271 integer l ! Index for clouds to overlap
6272 integer l1 ! Index for clouds to overlap
6273 integer n ! Counter
6274
6275 !
6276 real(r8) :: plco2(pcols,pverp) ! Path length co2
6277 real(r8) :: plh2o(pcols,pverp) ! Path length h2o
6278 real(r8) tmp(pcols) ! Temporary workspace
6279 real(r8) tmp2(pcols) ! Temporary workspace
6280 real(r8) absbt(pcols) ! Downward emission at model top
6281 real(r8) plol(pcols,pverp) ! O3 pressure wghted path length
6282 real(r8) plos(pcols,pverp) ! O3 path length
6283 real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level
6284 real(r8) co2em(pcols,pverp) ! Layer co2 normalized planck funct. derivative
6285 real(r8) co2eml(pcols,pver) ! Interface co2 normalized planck funct. deriv.
6286 real(r8) delt(pcols) ! Diff t**4 mid layer to top interface
6287 real(r8) delt1(pcols) ! Diff t**4 lower intrfc to mid layer
6288 real(r8) bk1(pcols) ! Absrptvty for vertical quadrature
6289 real(r8) bk2(pcols) ! Absrptvty for vertical quadrature
6290 real(r8) cldp(pcols,pverp) ! Cloud cover with extra layer
6291 real(r8) ful(pcols,pverp) ! Total upwards longwave flux
6292 real(r8) fsul(pcols,pverp) ! Clear sky upwards longwave flux
6293 real(r8) fdl(pcols,pverp) ! Total downwards longwave flux
6294 real(r8) fsdl(pcols,pverp) ! Clear sky downwards longwv flux
6295 real(r8) fclb4(pcols,-1:pver) ! Sig t**4 for cld bottom interfc
6296 real(r8) fclt4(pcols,0:pver) ! Sig t**4 for cloud top interfc
6297 real(r8) s(pcols,pverp,pverp) ! Flx integral sum
6298 real(r8) tplnka(pcols,pverp) ! Planck fnctn temperature
6299 real(r8) s2c(pcols,pverp) ! H2o cont amount
6300 real(r8) tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
6301 real(r8) w(pcols,pverp) ! H2o path
6302 real(r8) tplnke(pcols) ! Planck fnctn temperature
6303 real(r8) h2otr(pcols,pverp) ! H2o trnmsn for o3 overlap
6304 real(r8) co2t(pcols,pverp) ! Prs wghted temperature path
6305 real(r8) tint(pcols,pverp) ! Interface temperature
6306 real(r8) tint4(pcols,pverp) ! Interface temperature**4
6307 real(r8) tlayr(pcols,pverp) ! Level temperature
6308 real(r8) tlayr4(pcols,pverp) ! Level temperature**4
6309 real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
6310 ! Hulst-Curtis-Godson temp. factor
6311 ! for H2O bands
6312 real(r8) wb(nbands,pcols,pverp) ! H2o path length with
6313 ! Hulst-Curtis-Godson temp. factor
6314 ! for H2O bands
6315
6316 real(r8) cld0 ! previous cloud amt (for max overlap)
6317 real(r8) cld1 ! next cloud amt (for max overlap)
6318 real(r8) emx(0:pverp) ! Emissivity factors (max overlap)
6319 real(r8) emx0 ! Emissivity factors for BCs (max overlap)
6320 real(r8) trans ! 1 - emis
6321 real(r8) asort(pver) ! 1 - cloud amounts to be sorted for max ovrlp.
6322 real(r8) atmp ! Temporary storage for sort when nxs = 2
6323 real(r8) maxcld(pcols) ! Maximum cloud at any layer
6324
6325 integer indx(pcols) ! index vector of gathered array values
6326 !!$ integer indxmx(pcols+1,pverp)! index vector of gathered array values
6327 integer indxmx(pcols,pverp)! index vector of gathered array values
6328 ! (max overlap)
6329 integer nrgn(pcols) ! Number of max overlap regions at longitude
6330 integer npts ! number of values satisfying some criterion
6331 integer ncolmx(pverp) ! number of columns with clds in region
6332 integer kx1(pcols,pverp) ! Level index for top of max-overlap region
6333 integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region
6334 integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld()
6335 ! in descending order
6336 integer nxs(pcols,pverp) ! Number of cloudy layers between kx1 and kx2
6337 integer nxsk ! Number of cloudy layers between (kx1/kx2)&k
6338 integer ksort(0:pverp) ! Level indices of cloud amounts to be sorted
6339 ! for max ovrlp. calculation
6340 integer ktmp ! Temporary storage for sort when nxs = 2
6341
6342 ! real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
6343 real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
6344 ! ! transmission between interfaces k1 and k2
6345 !
6346 ! Pointer variables to 3d structures
6347 !
6348 ! real(r8), pointer :: abstot(:,:,:)
6349 ! real(r8), pointer :: absnxt(:,:,:)
6350 ! real(r8), pointer :: emstot(:,:)
6351
6352 !
6353 ! Trace gas variables
6354 !
6355 real(r8) ucfc11(pcols,pverp) ! CFC11 path length
6356 real(r8) ucfc12(pcols,pverp) ! CFC12 path length
6357 real(r8) un2o0(pcols,pverp) ! N2O path length
6358 real(r8) un2o1(pcols,pverp) ! N2O path length (hot band)
6359 real(r8) uch4(pcols,pverp) ! CH4 path length
6360 real(r8) uco211(pcols,pverp) ! CO2 9.4 micron band path length
6361 real(r8) uco212(pcols,pverp) ! CO2 9.4 micron band path length
6362 real(r8) uco213(pcols,pverp) ! CO2 9.4 micron band path length
6363 real(r8) uco221(pcols,pverp) ! CO2 10.4 micron band path length
6364 real(r8) uco222(pcols,pverp) ! CO2 10.4 micron band path length
6365 real(r8) uco223(pcols,pverp) ! CO2 10.4 micron band path length
6366 real(r8) bn2o0(pcols,pverp) ! pressure factor for n2o
6367 real(r8) bn2o1(pcols,pverp) ! pressure factor for n2o
6368 real(r8) bch4(pcols,pverp) ! pressure factor for ch4
6369 real(r8) uptype(pcols,pverp) ! p-type continuum path length
6370 real(r8) abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
6371 real(r8) abplnk2(14,pcols,pverp) ! nearest layer factor
6372 !
6373 !
6374 !-----------------------------------------------------------------------
6375 !
6376 !
6377 pverp2=pver+2
6378 pverp3=pver+3
6379 pverp4=pver+4
6380 !
6381 ! Set pointer variables
6382 !
6383 ! abstot => abstot_3d(:,:,:,lchnk)
6384 ! absnxt => absnxt_3d(:,:,:,lchnk)
6385 ! emstot => emstot_3d(:,:,lchnk)
6386 !
6387 ! accumulate mass path from top of atmosphere
6388 !
6389 call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp)
6390
6391 !
6392 ! Calculate some temperatures needed to derive absorptivity and
6393 ! emissivity, as well as some h2o path lengths
6394 !
6395 call radtpl(lchnk ,ncol ,pcols, pver, pverp, &
6396 tnm ,lwupcgs ,qnm ,pint ,plco2 ,plh2o , &
6397 tplnka ,s2c ,tcg ,w ,tplnke , &
6398 tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
6399 piln ,plh2ob ,wb )
6400 if (doabsems) then
6401 !
6402 ! Compute ozone path lengths at frequency of a/e calculation.
6403 !
6404 call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
6405 !
6406 ! Compute trace gas path lengths
6407 !
6408 call trcpth(lchnk ,ncol ,pcols, pver, pverp, &
6409 tnm ,pint ,cfc11 ,cfc12 ,n2o , &
6410 ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , &
6411 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
6412 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
6413 bch4 ,uptype )
6414
6415 ! Compute transmission through STRAER absorption continuum
6416 call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp)
6417
6418 !
6419 !
6420 ! Compute total emissivity:
6421 !
6422 call radems(lchnk ,ncol ,pcols, pver, pverp, &
6423 s2c ,tcg ,w ,tplnke ,plh2o , &
6424 pint ,plco2 ,tint ,tint4 ,tlayr , &
6425 tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
6426 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
6427 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
6428 bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
6429 co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
6430 plh2ob ,wb , &
6431 aer_trn_ttl)
6432 !
6433 ! Compute total absorptivity:
6434 !
6435 call radabs(lchnk ,ncol ,pcols, pver, pverp, &
6436 pmid ,pint ,co2em ,co2eml ,tplnka , &
6437 s2c ,tcg ,w ,h2otr ,plco2 , &
6438 plh2o ,co2t ,tint ,tlayr ,plol , &
6439 plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
6440 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
6441 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
6442 bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
6443 abstot ,absnxt ,plh2ob ,wb , &
6444 aer_mpp ,aer_trn_ttl)
6445 end if
6446 !
6447 ! Compute sums used in integrals (all longitude points)
6448 !
6449 ! Definition of bk1 & bk2 depends on finite differencing. for
6450 ! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent
6451 ! layers only.
6452 !
6453 ! delt=t**4 in layer above current sigma level km.
6454 ! delt1=t**4 in layer below current sigma level km.
6455 !
6456 do i=1,ncol
6457 delt(i) = tint4(i,pver) - tlayr4(i,pverp)
6458 delt1(i) = tlayr4(i,pverp) - tint4(i,pverp)
6459 s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4))
6460 s(i,pver,pverp) = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3))
6461 end do
6462 do k=ntoplw,pver-1
6463 do i=1,ncol
6464 bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5
6465 bk1(i) = bk2(i)
6466 s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
6467 end do
6468 end do
6469 !
6470 ! All k, km>1
6471 !
6472 do km=pver,ntoplw+1,-1
6473 do i=1,ncol
6474 delt(i) = tint4(i,km-1) - tlayr4(i,km)
6475 delt1(i) = tlayr4(i,km) - tint4(i,km)
6476 end do
6477 do k=pverp,ntoplw,-1
6478 if (k == km) then
6479 do i=1,ncol
6480 bk2(i) = absnxt(i,km-1,4)
6481 bk1(i) = absnxt(i,km-1,1)
6482 end do
6483 else if (k == km-1) then
6484 do i=1,ncol
6485 bk2(i) = absnxt(i,km-1,2)
6486 bk1(i) = absnxt(i,km-1,3)
6487 end do
6488 else
6489 do i=1,ncol
6490 bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5
6491 bk1(i) = bk2(i)
6492 end do
6493 end if
6494 do i=1,ncol
6495 s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
6496 end do
6497 end do
6498 end do
6499 !
6500 ! Computation of clear sky fluxes always set first level of fsul
6501 !
6502 do i=1,ncol
6503 fsul(i,pverp) = lwupcgs(i)
6504 end do
6505 !
6506 ! Downward clear sky fluxes store intermediate quantities in down flux
6507 ! Initialize fluxes to clear sky values.
6508 !
6509 do i=1,ncol
6510 tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp)
6511 fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1)
6512 fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw)
6513 end do
6514 !
6515 ! fsdl(i,pverp) assumes isothermal layer
6516 !
6517 do k=ntoplw+1,pver
6518 do i=1,ncol
6519 fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1)
6520 fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1))
6521 end do
6522 end do
6523 !
6524 ! Store the downward emission from level 1 = total gas emission * sigma
6525 ! t**4. fsdl does not yet include all terms
6526 !
6527 do i=1,ncol
6528 absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp)
6529 fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1)
6530 end do
6531 !
6532 !----------------------------------------------------------------------
6533 ! Modifications for clouds -- max/random overlap assumption
6534 !
6535 ! The column is divided into sets of adjacent layers, called regions,
6536 ! in which the clouds are maximally overlapped. The clouds are
6537 ! randomly overlapped between different regions. The number of
6538 ! regions in a column is set by nmxrgn, and the range of pressures
6539 ! included in each region is set by pmxrgn. The max/random overlap
6540 ! can be written in terms of the solutions of random overlap with
6541 ! cloud amounts = 1. The random overlap assumption is equivalent to
6542 ! setting the flux boundary conditions (BCs) at the edges of each region
6543 ! equal to the mean all-sky flux at those boundaries. Since the
6544 ! emissivity array for propogating BCs is only computed for the
6545 ! TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated
6546 ! in terms of solutions to the random overlap equations. This is done
6547 ! by writing the flux BCs as the sum of a clear-sky flux and emission
6548 ! from a cloud outside the region weighted by an emissivity. This
6549 ! emissivity is determined from the location of the cloud and the
6550 ! flux BC.
6551 !
6552 ! Copy cloud amounts to buffer with extra layer (needed for overlap logic)
6553 !
6554 cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver)
6555 cldp(:ncol,pverp) = 0.0
6556 !
6557 !
6558 ! Select only those locations where there are no clouds
6559 ! (maximum cloud fraction <= 1.e-3 treated as clear)
6560 ! Set all-sky fluxes to clear-sky values.
6561 !
6562 maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2)
6563
6564 npts = 0
6565 do i=1,ncol
6566 if (maxcld(i) < cldmin) then
6567 npts = npts + 1
6568 indx(npts) = i
6569 end if
6570 end do
6571
6572 do ii = 1, npts
6573 i = indx(ii)
6574 do k = ntoplw, pverp
6575 fdl(i,k) = fsdl(i,k)
6576 ful(i,k) = fsul(i,k)
6577 end do
6578 end do
6579 !
6580 ! Select only those locations where there are clouds
6581 !
6582 npts = 0
6583 do i=1,ncol
6584 if (maxcld(i) >= cldmin) then
6585 npts = npts + 1
6586 indx(npts) = i
6587 end if
6588 end do
6589
6590 !
6591 ! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions
6592 !
6593 do ii = 1, npts
6594 i = indx(ii)
6595 fdl(i,ntoplw) = fsdl(i,ntoplw)
6596 fdl(i,pverp) = 0.0
6597 ful(i,ntoplw) = 0.0
6598 ful(i,pverp) = fsul(i,pverp)
6599 do k = ntoplw+1, pver
6600 fdl(i,k) = 0.0
6601 ful(i,k) = 0.0
6602 end do
6603 !
6604 ! Initialize Planck emission from layer boundaries
6605 !
6606 do k = ntoplw, pver
6607 fclt4(i,k-1) = stebol*tint4(i,k)
6608 fclb4(i,k-1) = stebol*tint4(i,k+1)
6609 enddo
6610 fclb4(i,ntoplw-2) = stebol*tint4(i,ntoplw)
6611 fclt4(i,pver) = stebol*tint4(i,pverp)
6612 !
6613 ! Initialize indices for layers to be max-overlapped
6614 !
6615 do irgn = 0, nmxrgn(i)
6616 kx2(i,irgn) = ntoplw-1
6617 end do
6618 nrgn(i) = 0
6619 end do
6620
6621 !----------------------------------------------------------------------
6622 ! INDEX CALCULATIONS FOR MAX OVERLAP
6623
6624 do ii = 1, npts
6625 ilon = indx(ii)
6626
6627 !
6628 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
6629 !
6630 do irgn = 1, nmxrgn(ilon)
6631 !
6632 ! Calculate min/max layer indices inside region.
6633 !
6634 n = 0
6635 if (kx2(ilon,irgn-1) < pver) then
6636 nrgn(ilon) = irgn
6637 k1 = kx2(ilon,irgn-1)+1
6638 kx1(ilon,irgn) = k1
6639 kx2(ilon,irgn) = 0
6640 do k2 = pver, k1, -1
6641 if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then
6642 kx2(ilon,irgn) = k2
6643 exit
6644 end if
6645 end do
6646 !
6647 ! Identify columns with clouds in the given region.
6648 !
6649 do k = k1, k2
6650 if (cldp(ilon,k) >= cldmin) then
6651 n = n+1
6652 indxmx(n,irgn) = ilon
6653 exit
6654 endif
6655 end do
6656 endif
6657 ncolmx(irgn) = n
6658 !
6659 ! Dummy value for handling clear-sky regions
6660 !
6661 !!$ indxmx(ncolmx(irgn)+1,irgn) = ncol+1
6662 !
6663 ! Outer loop over columns with clouds in the max-overlap region
6664 !
6665 do iimx = 1, ncolmx(irgn)
6666 i = indxmx(iimx,irgn)
6667 !
6668 ! Sort cloud areas and corresponding level indices.
6669 !
6670 n = 0
6671 do k = kx1(i,irgn),kx2(i,irgn)
6672 if (cldp(i,k) >= cldmin) then
6673 n = n+1
6674 ksort(n) = k
6675 !
6676 ! We need indices for clouds in order of largest to smallest, so
6677 ! sort 1-cld in ascending order
6678 !
6679 asort(n) = 1.0-cldp(i,k)
6680 end if
6681 end do
6682 nxs(i,irgn) = n
6683 !
6684 ! If nxs(i,irgn) eq 1, no need to sort.
6685 ! If nxs(i,irgn) eq 2, sort by swapping if necessary
6686 ! If nxs(i,irgn) ge 3, sort using local sort routine
6687 !
6688 if (nxs(i,irgn) == 2) then
6689 if (asort(2) < asort(1)) then
6690 ktmp = ksort(1)
6691 ksort(1) = ksort(2)
6692 ksort(2) = ktmp
6693
6694 atmp = asort(1)
6695 asort(1) = asort(2)
6696 asort(2) = atmp
6697 endif
6698 else if (nxs(i,irgn) >= 3) then
6699 call sortarray(nxs(i,irgn),asort,ksort(1:))
6700 endif
6701
6702 do l = 1, nxs(i,irgn)
6703 kxs(l,i,irgn) = ksort(l)
6704 end do
6705 !
6706 ! End loop over longitude i for fluxes
6707 !
6708 end do
6709 !
6710 ! End loop over regions irgn for max-overlap
6711 !
6712 end do
6713 !
6714 !----------------------------------------------------------------------
6715 ! DOWNWARD FLUXES:
6716 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
6717 !
6718 do irgn = 1, nmxrgn(ilon)
6719 !
6720 ! Compute clear-sky fluxes for regions without clouds
6721 !
6722 iimx = 1
6723 if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
6724 !
6725 ! Calculate emissivity so that downward flux at upper boundary of region
6726 ! can be cast in form of solution for downward flux from cloud above
6727 ! that boundary. Then solutions for fluxes at other levels take form of
6728 ! random overlap expressions. Try to locate "cloud" as close as possible
6729 ! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
6730 !
6731 k1 = kx1(ilon,irgn)
6732 do km1 = ntoplw-2, k1-2
6733 km4 = km1+3
6734 k2 = k1
6735 k3 = k2+1
6736 tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
6737 emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ &
6738 ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1))
6739 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
6740 end do
6741 km1 = min(km1,k1-2)
6742 do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1
6743 k3 = k2+1
6744 tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
6745 fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + &
6746 emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))
6747 end do
6748 else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
6749 iimx = iimx+1
6750 end if
6751 !
6752 ! Outer loop over columns with clouds in the max-overlap region
6753 !
6754 do iimx = 1, ncolmx(irgn)
6755 i = indxmx(iimx,irgn)
6756
6757 !
6758 ! Calculate emissivity so that downward flux at upper boundary of region
6759 ! can be cast in form of solution for downward flux from cloud above that
6760 ! boundary. Then solutions for fluxes at other levels take form of
6761 ! random overlap expressions. Try to locate "cloud" as close as possible
6762 ! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
6763 !
6764 k1 = kx1(i,irgn)
6765 do km1 = ntoplw-2,k1-2
6766 km4 = km1+3
6767 k2 = k1
6768 k3 = k2 + 1
6769 tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
6770 tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4)
6771 emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1))
6772 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
6773 end do
6774 km1 = min(km1,k1-2)
6775 ksort(0) = km1 + 1
6776 !
6777 ! Loop to calculate fluxes at level k
6778 !
6779 nxsk = 0
6780 do k = kx1(i,irgn), kx2(i,irgn)
6781 !
6782 ! Identify clouds (largest to smallest area) between kx1 and k
6783 ! Since nxsk will increase with increasing k up to nxs(i,irgn), once
6784 ! nxsk == nxs(i,irgn) then use the list constructed for previous k
6785 !
6786 if (nxsk < nxs(i,irgn)) then
6787 nxsk = 0
6788 do l = 1, nxs(i,irgn)
6789 k1 = kxs(l,i,irgn)
6790 if (k >= k1) then
6791 nxsk = nxsk + 1
6792 ksort(nxsk) = k1
6793 endif
6794 end do
6795 endif
6796 !
6797 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
6798 !
6799 ksort(nxsk+1) = pverp
6800 !
6801 ! Initialize iterated emissivity factors
6802 !
6803 do l = 1, nxsk
6804 emx(l) = emis(i,ksort(l))
6805 end do
6806 !
6807 ! Initialize iterated emissivity factor for bnd. condition at upper interface
6808 !
6809 emx(0) = emx0
6810 !
6811 ! Initialize previous cloud amounts
6812 !
6813 cld0 = 1.0
6814 !
6815 ! Indices for flux calculations
6816 !
6817 k2 = k+1
6818 k3 = k2+1
6819 tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
6820 !
6821 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
6822 !
6823 do l = 1, nxsk+1
6824 !
6825 ! Calculate downward fluxes
6826 !
6827 cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
6828 if (cld0 /= cld1) then
6829 fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2)
6830 do l1 = 0, l - 1
6831 km1 = ksort(l1)-1
6832 km4 = km1+3
6833 tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4)
6834 fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- &
6835 fsdl(i,k2))
6836 end do
6837 endif
6838 cld0 = cld1
6839 !
6840 ! Multiply emissivity factors by current cloud transmissivity
6841 !
6842 if (l <= nxsk) then
6843 k1 = ksort(l)
6844 trans = 1.0-emis(i,k1)
6845 !
6846 ! Ideally the upper bound on l1 would be l-1, but the sort routine
6847 ! scrambles the order of layers with identical cloud amounts
6848 !
6849 do l1 = 0, nxsk
6850 if (ksort(l1) < k1) then
6851 emx(l1) = emx(l1)*trans
6852 endif
6853 end do
6854 end if
6855 !
6856 ! End loop over number l of cloud levels
6857 !
6858 end do
6859 !
6860 ! End loop over level k for fluxes
6861 !
6862 end do
6863 !
6864 ! End loop over longitude i for fluxes
6865 !
6866 end do
6867 !
6868 ! End loop over regions irgn for max-overlap
6869 !
6870 end do
6871
6872 !
6873 !----------------------------------------------------------------------
6874 ! UPWARD FLUXES:
6875 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
6876 !
6877 do irgn = nmxrgn(ilon), 1, -1
6878 !
6879 ! Compute clear-sky fluxes for regions without clouds
6880 !
6881 iimx = 1
6882 if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
6883 !
6884 ! Calculate emissivity so that upward flux at lower boundary of region
6885 ! can be cast in form of solution for upward flux from cloud below that
6886 ! boundary. Then solutions for fluxes at other levels take form of
6887 ! random overlap expressions. Try to locate "cloud" as close as possible
6888 ! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
6889 ! Include allowance for surface emissivity (both numerator and denominator
6890 ! equal 1)
6891 !
6892 k1 = kx2(ilon,irgn)+1
6893 if (k1 < pverp) then
6894 do km1 = pver-1,kx2(ilon,irgn),-1
6895 km3 = km1+2
6896 k2 = k1
6897 k3 = k2+1
6898 tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
6899 emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ &
6900 ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1))
6901 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
6902 end do
6903 km1 = max(km1,kx2(ilon,irgn))
6904 else
6905 km1 = k1-1
6906 km3 = km1+2
6907 emx0 = 1.0
6908 endif
6909
6910 do k2 = kx1(ilon,irgn), kx2(ilon,irgn)
6911 k3 = k2+1
6912 !
6913 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
6914 !
6915 tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
6916 ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* &
6917 (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))
6918 end do
6919 else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
6920 iimx = iimx+1
6921 end if
6922 !
6923 ! Outer loop over columns with clouds in the max-overlap region
6924 !
6925 do iimx = 1, ncolmx(irgn)
6926 i = indxmx(iimx,irgn)
6927
6928 !
6929 ! Calculate emissivity so that upward flux at lower boundary of region
6930 ! can be cast in form of solution for upward flux from cloud at that
6931 ! boundary. Then solutions for fluxes at other levels take form of
6932 ! random overlap expressions. Try to locate "cloud" as close as possible
6933 ! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
6934 ! Include allowance for surface emissivity (both numerator and denominator
6935 ! equal 1)
6936 !
6937 k1 = kx2(i,irgn)+1
6938 if (k1 < pverp) then
6939 do km1 = pver-1,kx2(i,irgn),-1
6940 km3 = km1+2
6941 k2 = k1
6942 k3 = k2+1
6943 tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3)
6944 emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1))
6945 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
6946 end do
6947 km1 = max(km1,kx2(i,irgn))
6948 else
6949 emx0 = 1.0
6950 km1 = k1-1
6951 endif
6952 ksort(0) = km1 + 1
6953
6954 !
6955 ! Loop to calculate fluxes at level k
6956 !
6957 nxsk = 0
6958 do k = kx2(i,irgn), kx1(i,irgn), -1
6959 !
6960 ! Identify clouds (largest to smallest area) between k and kx2
6961 ! Since nxsk will increase with decreasing k up to nxs(i,irgn), once
6962 ! nxsk == nxs(i,irgn) then use the list constructed for previous k
6963 !
6964 if (nxsk < nxs(i,irgn)) then
6965 nxsk = 0
6966 do l = 1, nxs(i,irgn)
6967 k1 = kxs(l,i,irgn)
6968 if (k <= k1) then
6969 nxsk = nxsk + 1
6970 ksort(nxsk) = k1
6971 endif
6972 end do
6973 endif
6974 !
6975 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
6976 !
6977 ksort(nxsk+1) = pverp
6978 !
6979 ! Initialize iterated emissivity factors
6980 !
6981 do l = 1, nxsk
6982 emx(l) = emis(i,ksort(l))
6983 end do
6984 !
6985 ! Initialize iterated emissivity factor for bnd. condition at lower interface
6986 !
6987 emx(0) = emx0
6988 !
6989 ! Initialize previous cloud amounts
6990 !
6991 cld0 = 1.0
6992 !
6993 ! Indices for flux calculations
6994 !
6995 k2 = k
6996 k3 = k2+1
6997 !
6998 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
6999 !
7000 do l = 1, nxsk+1
7001 !
7002 ! Calculate upward fluxes
7003 !
7004 cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
7005 if (cld0 /= cld1) then
7006 ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2)
7007 do l1 = 0, l - 1
7008 km1 = ksort(l1)-1
7009 km3 = km1+2
7010 !
7011 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
7012 !
7013 tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3)
7014 ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* &
7015 (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2))
7016 end do
7017 endif
7018 cld0 = cld1
7019 !
7020 ! Multiply emissivity factors by current cloud transmissivity
7021 !
7022 if (l <= nxsk) then
7023 k1 = ksort(l)
7024 trans = 1.0-emis(i,k1)
7025 !
7026 ! Ideally the upper bound on l1 would be l-1, but the sort routine
7027 ! scrambles the order of layers with identical cloud amounts
7028 !
7029 do l1 = 0, nxsk
7030 if (ksort(l1) > k1) then
7031 emx(l1) = emx(l1)*trans
7032 endif
7033 end do
7034 end if
7035 !
7036 ! End loop over number l of cloud levels
7037 !
7038 end do
7039 !
7040 ! End loop over level k for fluxes
7041 !
7042 end do
7043 !
7044 ! End loop over longitude i for fluxes
7045 !
7046 end do
7047 !
7048 ! End loop over regions irgn for max-overlap
7049 !
7050 end do
7051 !
7052 ! End outermost longitude loop
7053 !
7054 end do
7055 !
7056 ! End cloud modification loops
7057 !
7058 !----------------------------------------------------------------------
7059 ! All longitudes: store history tape quantities
7060 !
7061 do i=1,ncol
7062 flwds(i) = fdl (i,pverp )
7063 flns(i) = ful (i,pverp ) - fdl (i,pverp )
7064 flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp )
7065 flnt(i) = ful (i,ntoplw) - fdl (i,ntoplw)
7066 flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw)
7067 flut(i) = ful (i,ntoplw)
7068 flutc(i) = fsul(i,ntoplw)
7069 end do
7070 !
7071 ! Computation of longwave heating (J/kg/s)
7072 !
7073 do k=ntoplw,pver
7074 do i=1,ncol
7075 qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* &
7076 1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
7077 end do
7078 end do
7079 ! Return 0 above solution domain
7080 if ( ntoplw > 1 )then
7081 qrl(:ncol,:ntoplw-1) = 0.
7082 end if
7083
7084 ! Added downward/upward total and clear sky fluxes
7085 !
7086 do k=ntoplw,pverp
7087 do i=1,ncol
7088 flup(i,k) = ful(i,k)
7089 flupc(i,k) = fsul(i,k)
7090 fldn(i,k) = fdl(i,k)
7091 fldnc(i,k) = fsdl(i,k)
7092 end do
7093 end do
7094 ! Return 0 above solution domain
7095 if ( ntoplw > 1 )then
7096 flup(:ncol,:ntoplw-1) = 0.
7097 flupc(:ncol,:ntoplw-1) = 0.
7098 fldn(:ncol,:ntoplw-1) = 0.
7099 fldnc(:ncol,:ntoplw-1) = 0.
7100 end if
7101 !
7102 return
7103 end subroutine radclwmx
7104
7105 subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, &
7106 pint ,pmid ,h2ommr ,rh ,o3mmr , &
7107 aermmr ,cld ,cicewp ,cliqwp ,rel , &
7108 ! rei ,eccf ,coszrs ,scon ,solin ,solcon, &
7109 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon, &
7110 asdir ,asdif ,aldir ,aldif ,nmxrgn , &
7111 pmxrgn ,qrs ,fsnt ,fsntc ,fsntoa , &
7112 fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns , &
7113 fsnsc ,fsdsc ,fsds ,sols ,soll , &
7114 solsd ,solld ,frc_day , &
7115 fsup ,fsupc ,fsdn ,fsdnc , &
7116 aertau ,aerssa ,aerasm ,aerfwd )
7117 !-----------------------------------------------------------------------
7118 !
7119 ! Purpose:
7120 ! Solar radiation code
7121 !
7122 ! Method:
7123 ! Basic method is Delta-Eddington as described in:
7124 !
7125 ! Briegleb, Bruce P., 1992: Delta-Eddington
7126 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
7127 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
7128 !
7129 ! Five changes to the basic method described above are:
7130 ! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993)
7131 ! (2) the distinction between liquid and ice particle clouds
7132 ! (Kiehl et al, 1996);
7133 ! (3) provision for calculating TOA fluxes with spectral response to
7134 ! match Nimbus-7 visible/near-IR radiometers (Collins, 1998);
7135 ! (4) max-random overlap (Collins, 2001)
7136 ! (5) The near-IR absorption by H2O was updated in 2003 by Collins,
7137 ! Lee-Taylor, and Edwards for consistency with the new line data in
7138 ! Hitran 2000 and the H2O continuum version CKD 2.4. Modifications
7139 ! were optimized by reducing RMS errors in heating rates relative
7140 ! to a series of benchmark calculations for the 5 standard AFGL
7141 ! atmospheres. The benchmarks were performed using DISORT2 combined
7142 ! with GENLN3. The near-IR scattering optical depths for Rayleigh
7143 ! scattering were also adjusted, as well as the correction for
7144 ! stratospheric heating by H2O.
7145 !
7146 ! The treatment of maximum-random overlap is described in the
7147 ! comment block "INDEX CALCULATIONS FOR MAX OVERLAP".
7148 !
7149 ! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters.
7150 ! solar flux fractions specified for each interval. allows for
7151 ! seasonally and diurnally varying solar input. Includes molecular,
7152 ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud,
7153 ! and surface absorption. Computes delta-eddington reflections and
7154 ! transmissions assuming homogeneously mixed layers. Adds the layers
7155 ! assuming scattering between layers to be isotropic, and distinguishes
7156 ! direct solar beam from scattered radiation.
7157 !
7158 ! Longitude loops are broken into 1 or 2 sections, so that only daylight
7159 ! (i.e. coszrs > 0) computations are done.
7160 !
7161 ! Note that an extra layer above the model top layer is added.
7162 !
7163 ! cgs units are used.
7164 !
7165 ! Special diagnostic calculation of the clear sky surface and total column
7166 ! absorbed flux is also done for cloud forcing diagnostics.
7167 !
7168 !-----------------------------------------------------------------------
7169 ! use shr_kind_mod, only: r8 => shr_kind_r8
7170 ! use ppgrid
7171 ! use ghg_surfvals, only: co2mmr
7172 ! use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, &
7173 ! idxDUSTfirst, numDUST, idxVOLC, naer_all
7174 ! use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, &
7175 ! ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, &
7176 ! kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc
7177 ! use abortutils, only: endrun
7178
7179 implicit none
7180
7181 integer nspint ! Num of spctrl intervals across solar spectrum
7182 integer naer_groups ! Num of aerosol groups for optical diagnostics
7183
7184 parameter ( nspint = 19 )
7185 parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, and all aerosols
7186 !-----------------------Constants for new band (640-700 nm)-------------
7187 real(r8) v_raytau_35
7188 real(r8) v_raytau_64
7189 real(r8) v_abo3_35
7190 real(r8) v_abo3_64
7191 parameter( &
7192 v_raytau_35 = 0.155208, &
7193 v_raytau_64 = 0.0392, &
7194 v_abo3_35 = 2.4058030e+01, &
7195 v_abo3_64 = 2.210e+01 &
7196 )
7197
7198
7199 !-------------Parameters for accelerating max-random solution-------------
7200 !
7201 ! The solution time scales like prod(j:1->N) (1 + n_j) where
7202 ! N = number of max-overlap regions (nmxrgn)
7203 ! n_j = number of unique cloud amounts in region j
7204 !
7205 ! Therefore the solution cost can be reduced by decreasing n_j.
7206 ! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky.
7207 ! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps)
7208 ! decimal places as identical
7209 !
7210 ! areamin reduces the cost by dropping configurations that occupy
7211 ! a surface area < areamin of the model grid box. The surface area
7212 ! for a configuration C(j,k_j), where j is the region number and k_j is the
7213 ! index for a unique cloud amount (in descending order from biggest to
7214 ! smallest clouds) in region j, is
7215 !
7216 ! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)]
7217 !
7218 ! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0.
7219 !
7220 ! nconfgmax reduces the cost and improves load balancing by setting an upper
7221 ! bound on the number of cloud configurations in the solution. If the number
7222 ! of configurations exceeds nconfgmax, the nconfgmax configurations with the
7223 ! largest area are retained, and the fluxes are normalized by the total area
7224 ! of these nconfgmax configurations. For the current max/random overlap
7225 ! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount
7226 ! parameterization, the mean and RMS number of configurations are
7227 ! both roughly 5. nconfgmax has been set to the mean+2*RMS number, or 15.
7228 !
7229 ! Minimum cloud amount (as a fraction of the grid-box area) to
7230 ! distinguish from clear sky
7231 !
7232 real(r8) cldmin
7233 parameter (cldmin = 1.0e-80_r8)
7234 !
7235 ! Minimimum horizontal area (as a fraction of the grid-box area) to retain
7236 ! for a unique cloud configuration in the max-random solution
7237 !
7238 real(r8) areamin
7239 parameter (areamin = 0.01_r8)
7240 !
7241 ! Decimal precision of cloud amount (0 -> preserve full resolution;
7242 ! 10^-n -> preserve n digits of cloud amount)
7243 !
7244 real(r8) cldeps
7245 parameter (cldeps = 0.0_r8)
7246 !
7247 ! Maximum number of configurations to include in solution
7248 !
7249 integer nconfgmax
7250 parameter (nconfgmax = 15)
7251 !------------------------------Commons----------------------------------
7252 !
7253 ! Input arguments
7254 !
7255 integer, intent(in) :: lchnk,jj ! chunk identifier
7256 integer, intent(in) :: pcols, pver, pverp
7257 integer, intent(in) :: ncol ! number of atmospheric columns
7258
7259 real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
7260 real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
7261 real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio)
7262 real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
7263 real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio
7264 real(r8), intent(in) :: rh(pcols,pver) ! Relative humidity (fraction)
7265 !
7266 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
7267 real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
7268 real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
7269 real(r8), intent(in) :: rel(pcols,pver) ! Liquid effective drop size (microns)
7270 real(r8), intent(in) :: rei(pcols,pver) ! Ice effective drop size (microns)
7271 !
7272 real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2)
7273 real, intent(in) :: solcon ! solar constant with eccentricity factor
7274 real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
7275 real(r8), intent(in) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad
7276 real(r8), intent(in) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad
7277 real(r8), intent(in) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad
7278 real(r8), intent(in) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad
7279
7280 real(r8), intent(in) :: scon ! solar constant
7281 !
7282 ! IN/OUT arguments
7283 !
7284 real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each
7285 ! ! maximally overlapped region.
7286 ! ! 0->pmxrgn(i,1) is range of pressure for
7287 ! ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
7288 ! ! 2nd region, etc
7289 integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
7290 !
7291 ! Output arguments
7292 !
7293
7294 real(r8), intent(out) :: solin(pcols) ! Incident solar flux
7295 real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
7296 real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
7297 real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux
7298 real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA
7299 real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface
7300 !
7301 real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux
7302 real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux
7303 real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx
7304 real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA
7305 real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7)
7306 real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7)
7307 real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7)
7308 real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7)
7309 real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa
7310 real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa
7311 real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns
7312 real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
7313 real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
7314
7315 ! Added downward/upward total and clear sky fluxes
7316 real(r8), intent(out) :: fsup(pcols,pverp) ! Total sky upward solar flux (spectrally summed)
7317 real(r8), intent(out) :: fsupc(pcols,pverp) ! Clear sky upward solar flux (spectrally summed)
7318 real(r8), intent(out) :: fsdn(pcols,pverp) ! Total sky downward solar flux (spectrally summed)
7319 real(r8), intent(out) :: fsdnc(pcols,pverp) ! Clear sky downward solar flux (spectrally summed)
7320 !
7321 real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns
7322 real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
7323 real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
7324 real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
7325 real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
7326 ! real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
7327 ! real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
7328 ! real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
7329 ! real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
7330 !
7331 !---------------------------Local variables-----------------------------
7332 !
7333 ! Max/random overlap variables
7334 !
7335 real(r8) asort(pverp) ! 1 - cloud amounts to be sorted for max ovrlp.
7336 real(r8) atmp ! Temporary storage for sort when nxs = 2
7337 real(r8) cld0 ! 1 - (cld amt) used to make wstr, cstr, nstr
7338 real(r8) totwgt ! Total of xwgts = total fractional area of
7339 ! grid-box covered by cloud configurations
7340 ! included in solution to fluxes
7341
7342 real(r8) wgtv(nconfgmax) ! Weights for fluxes
7343 ! 1st index is configuration number
7344 real(r8) wstr(pverp,pverp) ! area weighting factors for streams
7345 ! 1st index is for stream #,
7346 ! 2nd index is for region #
7347
7348 real(r8) xexpt ! solar direct beam trans. for layer above
7349 real(r8) xrdnd ! diffuse reflectivity for layer above
7350 real(r8) xrupd ! diffuse reflectivity for layer below
7351 real(r8) xrups ! direct-beam reflectivity for layer below
7352 real(r8) xtdnt ! total trans for layers above
7353
7354 real(r8) xwgt ! product of cloud amounts
7355
7356 real(r8) yexpt ! solar direct beam trans. for layer above
7357 real(r8) yrdnd ! diffuse reflectivity for layer above
7358 real(r8) yrupd ! diffuse reflectivity for layer below
7359 real(r8) ytdnd ! dif-beam transmission for layers above
7360 real(r8) ytupd ! dif-beam transmission for layers below
7361
7362 real(r8) zexpt ! solar direct beam trans. for layer above
7363 real(r8) zrdnd ! diffuse reflectivity for layer above
7364 real(r8) zrupd ! diffuse reflectivity for layer below
7365 real(r8) zrups ! direct-beam reflectivity for layer below
7366 real(r8) ztdnt ! total trans for layers above
7367
7368 logical new_term ! Flag for configurations to include in fluxes
7369 logical region_found ! flag for identifying regions
7370
7371 integer ccon(0:pverp,nconfgmax)
7372 ! flags for presence of clouds
7373 ! 1st index is for level # (including
7374 ! layer above top of model and at surface)
7375 ! 2nd index is for configuration #
7376 integer cstr(0:pverp,pverp)
7377 ! flags for presence of clouds
7378 ! 1st index is for level # (including
7379 ! layer above top of model and at surface)
7380 ! 2nd index is for stream #
7381 integer icond(0:pverp,nconfgmax)
7382 ! Indices for copying rad. properties from
7383 ! one identical downward cld config.
7384 ! to another in adding method (step 2)
7385 ! 1st index is for interface # (including
7386 ! layer above top of model and at surface)
7387 ! 2nd index is for configuration # range
7388 integer iconu(0:pverp,nconfgmax)
7389 ! Indices for copying rad. properties from
7390 ! one identical upward configuration
7391 ! to another in adding method (step 2)
7392 ! 1st index is for interface # (including
7393 ! layer above top of model and at surface)
7394 ! 2nd index is for configuration # range
7395 integer iconfig ! Counter for random-ovrlap configurations
7396 integer irgn ! Index for max-overlap regions
7397 integer is0 ! Lower end of stream index range
7398 integer is1 ! Upper end of stream index range
7399 integer isn ! Stream index
7400 integer istr(pverp+1) ! index for stream #s during flux calculation
7401 integer istrtd(0:pverp,0:nconfgmax+1)
7402 ! indices into icond
7403 ! 1st index is for interface # (including
7404 ! layer above top of model and at surface)
7405 ! 2nd index is for configuration # range
7406 integer istrtu(0:pverp,0:nconfgmax+1)
7407 ! indices into iconu
7408 ! 1st index is for interface # (including
7409 ! layer above top of model and at surface)
7410 ! 2nd index is for configuration # range
7411 integer j ! Configuration index
7412 integer k1 ! Level index
7413 integer k2 ! Level index
7414 integer ksort(pverp) ! Level indices of cloud amounts to be sorted
7415 integer ktmp ! Temporary storage for sort when nxs = 2
7416 integer kx1(0:pverp) ! Level index for top of max-overlap region
7417 integer kx2(0:pverp) ! Level index for bottom of max-overlap region
7418 integer l ! Index
7419 integer l0 ! Index
7420 integer mrgn ! Counter for nrgn
7421 integer mstr ! Counter for nstr
7422 integer n0 ! Number of configurations with ccon(k,:)==0
7423 integer n1 ! Number of configurations with ccon(k,:)==1
7424 integer nconfig ! Number of random-ovrlap configurations
7425 integer nconfigm ! Value of config before testing for areamin,
7426 ! nconfgmax
7427 integer npasses ! number of passes over the indexing loop
7428 integer nrgn ! Number of max overlap regions at current
7429 ! longitude
7430 integer nstr(pverp) ! Number of unique cloud configurations
7431 ! ("streams") in a max-overlapped region
7432 ! 1st index is for region #
7433 integer nuniq ! # of unique cloud configurations
7434 integer nuniqd(0:pverp) ! # of unique cloud configurations: TOA
7435 ! to level k
7436 integer nuniqu(0:pverp) ! # of unique cloud configurations: surface
7437 ! to level k
7438 integer nxs ! Number of cloudy layers between k1 and k2
7439 integer ptr0(nconfgmax) ! Indices of configurations with ccon(k,:)==0
7440 integer ptr1(nconfgmax) ! Indices of configurations with ccon(k,:)==1
7441 integer ptrc(nconfgmax) ! Pointer for configurations sorted by wgtv
7442 ! integer findvalue ! Function for finding kth smallest element
7443 ! in a vector
7444 ! external findvalue
7445
7446 !
7447 ! Other
7448 !
7449 integer ns ! Spectral loop index
7450 integer i ! Longitude loop index
7451 integer k ! Level loop index
7452 integer km1 ! k - 1
7453 integer kp1 ! k + 1
7454 integer n ! Loop index for daylight
7455 integer ndayc ! Number of daylight columns
7456 integer idayc(pcols) ! Daytime column indices
7457 integer indxsl ! Index for cloud particle properties
7458 integer ksz ! dust size bin index
7459 integer krh ! relative humidity bin index
7460 integer kaer ! aerosol group index
7461 real(r8) wrh ! weight for linear interpolation between lut points
7462 real(r8) :: rhtrunc ! rh, truncated for the purposes of extrapolating
7463 ! aerosol optical properties
7464 !
7465 ! A. Slingo's data for cloud particle radiative properties (from 'A GCM
7466 ! Parameterization for the Shortwave Properties of Water Clouds' JAS
7467 ! vol. 46 may 1989 pp 1419-1427)
7468 !
7469 real(r8) abarl(4) ! A coefficient for extinction optical depth
7470 real(r8) bbarl(4) ! B coefficient for extinction optical depth
7471 real(r8) cbarl(4) ! C coefficient for single scat albedo
7472 real(r8) dbarl(4) ! D coefficient for single scat albedo
7473 real(r8) ebarl(4) ! E coefficient for asymmetry parameter
7474 real(r8) fbarl(4) ! F coefficient for asymmetry parameter
7475
7476 save abarl, bbarl, cbarl, dbarl, ebarl, fbarl
7477
7478 data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/
7479 data bbarl/ 1.305 , 1.346 ,1.454 ,1.641 /
7480 data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201 /
7481 data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 /
7482 data ebarl/ 0.829 , 0.794 ,0.754 ,0.826 /
7483 data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/
7484
7485 real(r8) abarli ! A coefficient for current spectral band
7486 real(r8) bbarli ! B coefficient for current spectral band
7487 real(r8) cbarli ! C coefficient for current spectral band
7488 real(r8) dbarli ! D coefficient for current spectral band
7489 real(r8) ebarli ! E coefficient for current spectral band
7490 real(r8) fbarli ! F coefficient for current spectral band
7491 !
7492 ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor
7493 ! greater than 20 micro-meters
7494 !
7495 ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836)
7496 !
7497 real(r8) abari(4) ! a coefficient for extinction optical depth
7498 real(r8) bbari(4) ! b coefficient for extinction optical depth
7499 real(r8) cbari(4) ! c coefficient for single scat albedo
7500 real(r8) dbari(4) ! d coefficient for single scat albedo
7501 real(r8) ebari(4) ! e coefficient for asymmetry parameter
7502 real(r8) fbari(4) ! f coefficient for asymmetry parameter
7503
7504 save abari, bbari, cbari, dbari, ebari, fbari
7505
7506 data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/
7507 data bbari/ 2.431 , 2.431 ,2.431 ,2.431 /
7508 data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658 /
7509 data dbari/ 0.0 , 1.405e-05,8.328e-04,2.05e-05 /
7510 data ebari/ 0.7661 , 0.7730 ,0.794 ,0.9595 /
7511 data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/
7512
7513 real(r8) abarii ! A coefficient for current spectral band
7514 real(r8) bbarii ! B coefficient for current spectral band
7515 real(r8) cbarii ! C coefficient for current spectral band
7516 real(r8) dbarii ! D coefficient for current spectral band
7517 real(r8) ebarii ! E coefficient for current spectral band
7518 real(r8) fbarii ! F coefficient for current spectral band
7519 !
7520 real(r8) delta ! Pressure (in atm) for stratos. h2o limit
7521 real(r8) o2mmr ! O2 mass mixing ratio:
7522
7523 save delta, o2mmr
7524
7525 !
7526 ! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4
7527 !
7528 data delta / 0.0014257179260883 /
7529 !
7530 ! END UPDATE
7531 !
7532 data o2mmr / .23143 /
7533
7534 real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad
7535 real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad
7536 !
7537 ! Next series depends on spectral interval
7538 !
7539 real(r8) frcsol(nspint) ! Fraction of solar flux in spectral interval
7540 real(r8) wavmin(nspint) ! Min wavelength (micro-meters) of interval
7541 real(r8) wavmax(nspint) ! Max wavelength (micro-meters) of interval
7542 real(r8) raytau(nspint) ! Rayleigh scattering optical depth
7543 real(r8) abh2o(nspint) ! Absorption coefficiant for h2o (cm2/g)
7544 real(r8) abo3 (nspint) ! Absorption coefficiant for o3 (cm2/g)
7545 real(r8) abco2(nspint) ! Absorption coefficiant for co2 (cm2/g)
7546 real(r8) abo2 (nspint) ! Absorption coefficiant for o2 (cm2/g)
7547 real(r8) ph2o(nspint) ! Weight of h2o in spectral interval
7548 real(r8) pco2(nspint) ! Weight of co2 in spectral interval
7549 real(r8) po2 (nspint) ! Weight of o2 in spectral interval
7550 real(r8) nirwgt(nspint) ! Spectral Weights to simulate Nimbus-7 filter
7551 real(r8) wgtint ! Weight for specific spectral interval
7552
7553 save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , &
7554 abco2 ,abo2 ,ph2o ,pco2 ,po2 ,nirwgt
7555
7556 data frcsol / .001488, .001389, .001290, .001686, .002877, &
7557 .003869, .026336, .360739, .065392, .526861, &
7558 .526861, .526861, .526861, .526861, .526861, &
7559 .526861, .006239, .001834, .001834/
7560 !
7561 ! weight for 0.64 - 0.7 microns appropriate to clear skies over oceans
7562 !
7563 data nirwgt / 0.0, 0.0, 0.0, 0.0, 0.0, &
7564 0.0, 0.0, 0.0, 0.320518, 1.0, 1.0, &
7565 1.0, 1.0, 1.0, 1.0, 1.0, &
7566 1.0, 1.0, 1.0 /
7567
7568 data wavmin / .200, .245, .265, .275, .285, &
7569 .295, .305, .350, .640, .700, .701, &
7570 .701, .701, .701, .702, .702, &
7571 2.630, 4.160, 4.160/
7572
7573 data wavmax / .245, .265, .275, .285, .295, &
7574 .305, .350, .640, .700, 5.000, 5.000, &
7575 5.000, 5.000, 5.000, 5.000, 5.000, &
7576 2.860, 4.550, 4.550/
7577
7578 !
7579 ! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4
7580 !
7581 data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, &
7582 1.085, 0.730, v_raytau_35, v_raytau_64, &
7583 0.02899756, 0.01356763, 0.00537341, &
7584 0.00228515, 0.00105028, 0.00046631, &
7585 0.00025734, &
7586 .0001, .0001, .0001/
7587 !
7588 ! END UPDATE
7589 !
7590
7591 !
7592 ! Absorption coefficients
7593 !
7594 !
7595 ! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4
7596 !
7597 data abh2o / .000, .000, .000, .000, .000, &
7598 .000, .000, .000, .000, &
7599 0.00256608, 0.06310504, 0.42287445, 2.45397941, &
7600 11.20070807, 47.66091389, 240.19010243, &
7601 .000, .000, .000/
7602 !
7603 ! END UPDATE
7604 !
7605
7606 data abo3 /5.370e+04, 13.080e+04, 9.292e+04, 4.530e+04, 1.616e+04, &
7607 4.441e+03, 1.775e+02, v_abo3_35, v_abo3_64, .000, &
7608 .000, .000 , .000 , .000 , .000, &
7609 .000, .000 , .000 , .000 /
7610
7611 data abco2 / .000, .000, .000, .000, .000, &
7612 .000, .000, .000, .000, .000, &
7613 .000, .000, .000, .000, .000, &
7614 .000, .094, .196, 1.963/
7615
7616 data abo2 / .000, .000, .000, .000, .000, &
7617 .000, .000, .000,1.11e-05,6.69e-05, &
7618 .000, .000, .000, .000, .000, &
7619 .000, .000, .000, .000/
7620 !
7621 ! Spectral interval weights
7622 !
7623 data ph2o / .000, .000, .000, .000, .000, &
7624 .000, .000, .000, .000, .505, &
7625 .210, .120, .070, .048, .029, &
7626 .018, .000, .000, .000/
7627
7628 data pco2 / .000, .000, .000, .000, .000, &
7629 .000, .000, .000, .000, .000, &
7630 .000, .000, .000, .000, .000, &
7631 .000, 1.000, .640, .360/
7632
7633 data po2 / .000, .000, .000, .000, .000, &
7634 .000, .000, .000, 1.000, 1.000, &
7635 .000, .000, .000, .000, .000, &
7636 .000, .000, .000, .000/
7637 !
7638 ! Diagnostic and accumulation arrays; note that sfltot, fswup, and
7639 ! fswdn are not used in the computation,but are retained for future use.
7640 !
7641 real(r8) solflx ! Solar flux in current interval
7642 real(r8) sfltot ! Spectrally summed total solar flux
7643 real(r8) totfld(0:pver) ! Spectrally summed flux divergence
7644 real(r8) fswup(0:pverp) ! Spectrally summed up flux
7645 real(r8) fswdn(0:pverp) ! Spectrally summed down flux
7646 real(r8) fswupc(0:pverp) ! Spectrally summed up clear sky flux
7647 real(r8) fswdnc(0:pverp) ! Spectrally summed down clear sky flux
7648 !
7649 ! Cloud radiative property arrays
7650 !
7651 ! real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth
7652 ! real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth
7653 real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo
7654 real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
7655 real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
7656 real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo
7657 real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter
7658 real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction
7659 !
7660 ! Aerosol mass paths by species
7661 !
7662 real(r8) usul(pcols,pver) ! sulfate (SO4)
7663 real(r8) ubg(pcols,pver) ! background aerosol
7664 real(r8) usslt(pcols,pver) ! sea-salt (SSLT)
7665 real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI)
7666 real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO)
7667 real(r8) ucb(pcols,pver) ! black carbon (BCPHI + BCPHO)
7668 real(r8) uvolc(pcols,pver) ! volcanic mass
7669 real(r8) udst(ndstsz,pcols,pver) ! dust
7670
7671 !
7672 ! local variables used for the external mixing of aerosol species
7673 !
7674 real(r8) tau_sul ! optical depth, sulfate
7675 real(r8) tau_bg ! optical depth, background aerosol
7676 real(r8) tau_sslt ! optical depth, sea-salt
7677 real(r8) tau_cphil ! optical depth, hydrophilic carbon
7678 real(r8) tau_cphob ! optical depth, hydrophobic carbon
7679 real(r8) tau_cb ! optical depth, black carbon
7680 real(r8) tau_volc ! optical depth, volcanic
7681 real(r8) tau_dst(ndstsz) ! optical depth, dust, by size category
7682 real(r8) tau_dst_tot ! optical depth, total dust
7683 real(r8) tau_tot ! optical depth, total aerosol
7684
7685 real(r8) tau_w_sul ! optical depth * single scattering albedo, sulfate
7686 real(r8) tau_w_bg ! optical depth * single scattering albedo, background aerosol
7687 real(r8) tau_w_sslt ! optical depth * single scattering albedo, sea-salt
7688 real(r8) tau_w_cphil ! optical depth * single scattering albedo, hydrophilic carbon
7689 real(r8) tau_w_cphob ! optical depth * single scattering albedo, hydrophobic carbon
7690 real(r8) tau_w_cb ! optical depth * single scattering albedo, black carbon
7691 real(r8) tau_w_volc ! optical depth * single scattering albedo, volcanic
7692 real(r8) tau_w_dst(ndstsz) ! optical depth * single scattering albedo, dust, by size
7693 real(r8) tau_w_dst_tot ! optical depth * single scattering albedo, total dust
7694 real(r8) tau_w_tot ! optical depth * single scattering albedo, total aerosol
7695
7696 real(r8) tau_w_g_sul ! optical depth * single scattering albedo * asymmetry parameter, sulfate
7697 real(r8) tau_w_g_bg ! optical depth * single scattering albedo * asymmetry parameter, background aerosol
7698 real(r8) tau_w_g_sslt ! optical depth * single scattering albedo * asymmetry parameter, sea-salt
7699 real(r8) tau_w_g_cphil ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon
7700 real(r8) tau_w_g_cphob ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon
7701 real(r8) tau_w_g_cb ! optical depth * single scattering albedo * asymmetry parameter, black carbon
7702 real(r8) tau_w_g_volc ! optical depth * single scattering albedo * asymmetry parameter, volcanic
7703 real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size
7704 real(r8) tau_w_g_dst_tot ! optical depth * single scattering albedo * asymmetry parameter, total dust
7705 real(r8) tau_w_g_tot ! optical depth * single scattering albedo * asymmetry parameter, total aerosol
7706
7707 real(r8) f_sul ! forward scattering fraction, sulfate
7708 real(r8) f_bg ! forward scattering fraction, background aerosol
7709 real(r8) f_sslt ! forward scattering fraction, sea-salt
7710 real(r8) f_cphil ! forward scattering fraction, hydrophilic carbon
7711 real(r8) f_cphob ! forward scattering fraction, hydrophobic carbon
7712 real(r8) f_cb ! forward scattering fraction, black carbon
7713 real(r8) f_volc ! forward scattering fraction, volcanic
7714 real(r8) f_dst(ndstsz) ! forward scattering fraction, dust, by size
7715 real(r8) f_dst_tot ! forward scattering fraction, total dust
7716 real(r8) f_tot ! forward scattering fraction, total aerosol
7717
7718 real(r8) tau_w_f_sul ! optical depth * forward scattering fraction * single scattering albedo, sulfate
7719 real(r8) tau_w_f_bg ! optical depth * forward scattering fraction * single scattering albedo, background
7720 real(r8) tau_w_f_sslt ! optical depth * forward scattering fraction * single scattering albedo, sea-salt
7721 real(r8) tau_w_f_cphil ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C
7722 real(r8) tau_w_f_cphob ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C
7723 real(r8) tau_w_f_cb ! optical depth * forward scattering fraction * single scattering albedo, black C
7724 real(r8) tau_w_f_volc ! optical depth * forward scattering fraction * single scattering albedo, volcanic
7725 real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size
7726 real(r8) tau_w_f_dst_tot ! optical depth * forward scattering fraction * single scattering albedo, total dust
7727 real(r8) tau_w_f_tot ! optical depth * forward scattering fraction * single scattering albedo, total aerosol
7728 real(r8) w_dst_tot ! single scattering albedo, total dust
7729 real(r8) w_tot ! single scattering albedo, total aerosol
7730 real(r8) g_dst_tot ! asymmetry parameter, total dust
7731 real(r8) g_tot ! asymmetry parameter, total aerosol
7732 real(r8) ksuli ! specific extinction interpolated between rh look-up-table points, sulfate
7733 real(r8) ksslti ! specific extinction interpolated between rh look-up-table points, sea-salt
7734 real(r8) kcphili ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon
7735 real(r8) wsuli ! single scattering albedo interpolated between rh look-up-table points, sulfate
7736 real(r8) wsslti ! single scattering albedo interpolated between rh look-up-table points, sea-salt
7737 real(r8) wcphili ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon
7738 real(r8) gsuli ! asymmetry parameter interpolated between rh look-up-table points, sulfate
7739 real(r8) gsslti ! asymmetry parameter interpolated between rh look-up-table points, sea-salt
7740 real(r8) gcphili ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon
7741 !
7742 ! Aerosol radiative property arrays
7743 !
7744 real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth
7745 real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo
7746 real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter
7747 real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction
7748
7749 !
7750 ! Various arrays and other constants:
7751 !
7752 real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer
7753 real(r8) zenfac(pcols) ! Square root of cos solar zenith angle
7754 real(r8) sqrco2 ! Square root of the co2 mass mixg ratio
7755 real(r8) tmp1 ! Temporary constant array
7756 real(r8) tmp2 ! Temporary constant array
7757 real(r8) pdel ! Pressure difference across layer
7758 real(r8) path ! Mass path of layer
7759 real(r8) ptop ! Lower interface pressure of extra layer
7760 real(r8) ptho2 ! Used to compute mass path of o2
7761 real(r8) ptho3 ! Used to compute mass path of o3
7762 real(r8) pthco2 ! Used to compute mass path of co2
7763 real(r8) pthh2o ! Used to compute mass path of h2o
7764 real(r8) h2ostr ! Inverse sq. root h2o mass mixing ratio
7765 real(r8) wavmid(nspint) ! Spectral interval middle wavelength
7766 real(r8) trayoslp ! Rayleigh optical depth/standard pressure
7767 real(r8) tmp1l ! Temporary constant array
7768 real(r8) tmp2l ! Temporary constant array
7769 real(r8) tmp3l ! Temporary constant array
7770 real(r8) tmp1i ! Temporary constant array
7771 real(r8) tmp2i ! Temporary constant array
7772 real(r8) tmp3i ! Temporary constant array
7773 real(r8) rdenom ! Multiple scattering term
7774 real(r8) rdirexp ! layer direct ref times exp transmission
7775 real(r8) tdnmexp ! total transmission - exp transmission
7776 real(r8) psf(nspint) ! Frac of solar flux in spect interval
7777 !
7778 ! Layer absorber amounts; note that 0 refers to the extra layer added
7779 ! above the top model layer
7780 !
7781 real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o
7782 real(r8) uo3(pcols,0:pver) ! Layer absorber amount of o3
7783 real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2
7784 real(r8) uo2(pcols,0:pver) ! Layer absorber amount of o2
7785 real(r8) uaer(pcols,0:pver) ! Layer aerosol amount
7786 !
7787 ! Total column absorber amounts:
7788 !
7789 real(r8) uth2o(pcols) ! Total column absorber amount of h2o
7790 real(r8) uto3(pcols) ! Total column absorber amount of o3
7791 real(r8) utco2(pcols) ! Total column absorber amount of co2
7792 real(r8) uto2(pcols) ! Total column absorber amount of o2
7793 !
7794 ! These arrays are defined for pver model layers; 0 refers to the extra
7795 ! layer on top:
7796 !
7797 real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
7798 real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
7799 real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
7800 real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
7801 real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer
7802
7803 real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad
7804 real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad
7805 real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad
7806 real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad
7807 real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer
7808
7809 real(r8) flxdiv ! Flux divergence for layer
7810 !
7811 !
7812 ! Radiative Properties:
7813 !
7814 ! There are 1 classes of properties:
7815 ! (1. All-sky bulk properties
7816 ! (2. Clear-sky properties
7817 !
7818 ! The first set of properties are generated during step 2 of the solution.
7819 !
7820 ! These arrays are defined at model interfaces; in 1st index (for level #),
7821 ! 0 is the top of the extra layer above the model top, and
7822 ! pverp is the earth surface. 2nd index is for cloud configuration
7823 ! defined over a whole column.
7824 !
7825 real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above
7826 real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above
7827 real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below
7828 real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below
7829 real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above
7830 !
7831 ! Bulk properties used during the clear-sky calculation.
7832 !
7833 real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above
7834 real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above
7835 real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below
7836 real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below
7837 real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above
7838
7839 real(r8) fluxup(0:pverp) ! Up flux at model interface
7840 real(r8) fluxdn(0:pverp) ! Down flux at model interface
7841 real(r8) wexptdn ! Direct solar beam trans. to surface
7842
7843 !
7844 !-----------------------------------------------------------------------
7845 ! START OF CALCULATION
7846 !-----------------------------------------------------------------------
7847 !
7848 ! write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk
7849
7850 do i=1, ncol
7851 !
7852 ! Initialize output fields:
7853 !
7854 fsds(i) = 0.0_r8
7855
7856 fsnirtoa(i) = 0.0_r8
7857 fsnrtoac(i) = 0.0_r8
7858 fsnrtoaq(i) = 0.0_r8
7859
7860 fsns(i) = 0.0_r8
7861 fsnsc(i) = 0.0_r8
7862 fsdsc(i) = 0.0_r8
7863
7864 fsnt(i) = 0.0_r8
7865 fsntc(i) = 0.0_r8
7866 fsntoa(i) = 0.0_r8
7867 fsntoac(i) = 0.0_r8
7868
7869 solin(i) = 0.0_r8
7870
7871 sols(i) = 0.0_r8
7872 soll(i) = 0.0_r8
7873 solsd(i) = 0.0_r8
7874 solld(i) = 0.0_r8
7875
7876 ! initialize added downward/upward total and clear sky fluxes
7877
7878 do k=1,pverp
7879 fsup(i,k) = 0.0_r8
7880 fsupc(i,k) = 0.0_r8
7881 fsdn(i,k) = 0.0_r8
7882 fsdnc(i,k) = 0.0_r8
7883 tauxcl(i,k-1) = 0.0_r8
7884 tauxci(i,k-1) = 0.0_r8
7885 end do
7886
7887 do k=1, pver
7888 qrs(i,k) = 0.0_r8
7889 end do
7890
7891 ! initialize aerosol diagnostic fields to 0.0
7892 ! Average can be obtained by dividing <aerod>/<frc_day>
7893 do kaer = 1, naer_groups
7894 do ns = 1, nspint
7895 frc_day(i) = 0.0_r8
7896 aertau(i,ns,kaer) = 0.0_r8
7897 aerssa(i,ns,kaer) = 0.0_r8
7898 aerasm(i,ns,kaer) = 0.0_r8
7899 aerfwd(i,ns,kaer) = 0.0_r8
7900 end do
7901 end do
7902
7903 end do
7904 !
7905 ! Compute starting, ending daytime loop indices:
7906 ! *** Note this logic assumes day and night points are contiguous so
7907 ! *** will not work in general with chunked data structure.
7908 !
7909 ndayc = 0
7910 do i=1,ncol
7911 if (coszrs(i) > 0.0_r8) then
7912 ndayc = ndayc + 1
7913 idayc(ndayc) = i
7914 end if
7915 end do
7916 !
7917 ! If night everywhere, return:
7918 !
7919 if (ndayc == 0) return
7920 !
7921 ! Perform other initializations
7922 !
7923 tmp1 = 0.5_r8/(gravit*sslp)
7924 tmp2 = delta/gravit
7925 sqrco2 = sqrt(co2mmr)
7926
7927 do n=1,ndayc
7928 i=idayc(n)
7929 !
7930 ! Define solar incident radiation and interface pressures:
7931 !
7932 ! solin(i) = scon*eccf*coszrs(i)
7933 !WRF use SOLCON (MKS) calculated outside
7934 solin(i) = solcon*coszrs(i)*1000.
7935 pflx(i,0) = 0._r8
7936 do k=1,pverp
7937 pflx(i,k) = pint(i,k)
7938 end do
7939 !
7940 ! Compute optical paths:
7941 !
7942 ptop = pflx(i,1)
7943 ptho2 = o2mmr * ptop / gravit
7944 ptho3 = o3mmr(i,1) * ptop / gravit
7945 pthco2 = sqrco2 * (ptop / gravit)
7946 h2ostr = sqrt( 1._r8 / h2ommr(i,1) )
7947 zenfac(i) = sqrt(coszrs(i))
7948 pthh2o = ptop**2*tmp1 + (ptop*rga)* &
7949 (h2ostr*zenfac(i)*delta)
7950 uh2o(i,0) = h2ommr(i,1)*pthh2o
7951 uco2(i,0) = zenfac(i)*pthco2
7952 uo2 (i,0) = zenfac(i)*ptho2
7953 uo3 (i,0) = ptho3
7954 uaer(i,0) = 0.0_r8
7955 do k=1,pver
7956 pdel = pflx(i,k+1) - pflx(i,k)
7957 path = pdel / gravit
7958 ptho2 = o2mmr * path
7959 ptho3 = o3mmr(i,k) * path
7960 pthco2 = sqrco2 * path
7961 h2ostr = sqrt(1.0_r8/h2ommr(i,k))
7962 pthh2o = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2
7963 uh2o(i,k) = h2ommr(i,k)*pthh2o
7964 uco2(i,k) = zenfac(i)*pthco2
7965 uo2 (i,k) = zenfac(i)*ptho2
7966 uo3 (i,k) = ptho3
7967 usul(i,k) = aermmr(i,k,idxSUL) * path
7968 ubg(i,k) = aermmr(i,k,idxBG) * path
7969 usslt(i,k) = aermmr(i,k,idxSSLT) * path
7970 if (usslt(i,k) .lt. 0.0) then ! usslt is sometimes small and negative, will be fixed
7971 usslt(i,k) = 0.0
7972 end if
7973 ucphil(i,k) = aermmr(i,k,idxOCPHI) * path
7974 ucphob(i,k) = aermmr(i,k,idxOCPHO) * path
7975 ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path
7976 uvolc(i,k) = aermmr(i,k,idxVOLC)
7977 do ksz = 1, ndstsz
7978 udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path
7979 end do
7980 end do
7981 !
7982 ! Compute column absorber amounts for the clear sky computation:
7983 !
7984 uth2o(i) = 0.0_r8
7985 uto3(i) = 0.0_r8
7986 utco2(i) = 0.0_r8
7987 uto2(i) = 0.0_r8
7988
7989 do k=1,pver
7990 uth2o(i) = uth2o(i) + uh2o(i,k)
7991 uto3(i) = uto3(i) + uo3(i,k)
7992 utco2(i) = utco2(i) + uco2(i,k)
7993 uto2(i) = uto2(i) + uo2(i,k)
7994 end do
7995 !
7996 ! Set cloud properties for top (0) layer; so long as tauxcl is zero,
7997 ! there is no cloud above top of model; the other cloud properties
7998 ! are arbitrary:
7999 !
8000 tauxcl(i,0) = 0._r8
8001 wcl(i,0) = 0.999999_r8
8002 gcl(i,0) = 0.85_r8
8003 fcl(i,0) = 0.725_r8
8004 tauxci(i,0) = 0._r8
8005 wci(i,0) = 0.999999_r8
8006 gci(i,0) = 0.85_r8
8007 fci(i,0) = 0.725_r8
8008 !
8009 ! Aerosol
8010 !
8011 tauxar(i,0) = 0._r8
8012 wa(i,0) = 0.925_r8
8013 ga(i,0) = 0.850_r8
8014 fa(i,0) = 0.7225_r8
8015 !
8016 ! End do n=1,ndayc
8017 !
8018 end do
8019 !
8020 ! Begin spectral loop
8021 !
8022 do ns=1,nspint
8023 !
8024 ! Set index for cloud particle properties based on the wavelength,
8025 ! according to A. Slingo (1989) equations 1-3:
8026 ! Use index 1 (0.25 to 0.69 micrometers) for visible
8027 ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared
8028 ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared
8029 ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared
8030 !
8031 ! Note that the minimum wavelength is encoded (with .001, .002, .003)
8032 ! in order to specify the index appropriate for the near-infrared
8033 ! cloud absorption properties
8034 !
8035 if(wavmax(ns) <= 0.7_r8) then
8036 indxsl = 1
8037 else if(wavmin(ns) == 0.700_r8) then
8038 indxsl = 2
8039 else if(wavmin(ns) == 0.701_r8) then
8040 indxsl = 3
8041 else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then
8042 indxsl = 4
8043 end if
8044 !
8045 ! Set cloud extinction optical depth, single scatter albedo,
8046 ! asymmetry parameter, and forward scattered fraction:
8047 !
8048 abarli = abarl(indxsl)
8049 bbarli = bbarl(indxsl)
8050 cbarli = cbarl(indxsl)
8051 dbarli = dbarl(indxsl)
8052 ebarli = ebarl(indxsl)
8053 fbarli = fbarl(indxsl)
8054 !
8055 abarii = abari(indxsl)
8056 bbarii = bbari(indxsl)
8057 cbarii = cbari(indxsl)
8058 dbarii = dbari(indxsl)
8059 ebarii = ebari(indxsl)
8060 fbarii = fbari(indxsl)
8061 !
8062 ! adjustfraction within spectral interval to allow for the possibility of
8063 ! sub-divisions within a particular interval:
8064 !
8065 psf(ns) = 1.0_r8
8066 if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns)
8067 if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns)
8068 if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns)
8069
8070 do n=1,ndayc
8071 i=idayc(n)
8072
8073 frc_day(i) = 1.0_r8
8074 do kaer = 1, naer_groups
8075 aertau(i,ns,kaer) = 0.0
8076 aerssa(i,ns,kaer) = 0.0
8077 aerasm(i,ns,kaer) = 0.0
8078 aerfwd(i,ns,kaer) = 0.0
8079 end do
8080
8081 do k=1,pver
8082 !
8083 ! liquid
8084 !
8085 tmp1l = abarli + bbarli/rel(i,k)
8086 tmp2l = 1._r8 - cbarli - dbarli*rel(i,k)
8087 tmp3l = fbarli*rel(i,k)
8088 !
8089 ! ice
8090 !
8091 tmp1i = abarii + bbarii/rei(i,k)
8092 tmp2i = 1._r8 - cbarii - dbarii*rei(i,k)
8093 tmp3i = fbarii*rei(i,k)
8094
8095 if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
8096 tauxcl(i,k) = cliqwp(i,k)*tmp1l
8097 tauxci(i,k) = cicewp(i,k)*tmp1i
8098 else
8099 tauxcl(i,k) = 0.0
8100 tauxci(i,k) = 0.0
8101 endif
8102 !
8103 ! Do not let single scatter albedo be 1. Delta-eddington solution
8104 ! for non-conservative case has different analytic form from solution
8105 ! for conservative case, and raddedmx is written for non-conservative case.
8106 !
8107 wcl(i,k) = min(tmp2l,.999999_r8)
8108 gcl(i,k) = ebarli + tmp3l
8109 fcl(i,k) = gcl(i,k)*gcl(i,k)
8110 !
8111 wci(i,k) = min(tmp2i,.999999_r8)
8112 gci(i,k) = ebarii + tmp3i
8113 fci(i,k) = gci(i,k)*gci(i,k)
8114 !
8115 ! Set aerosol properties
8116 ! Conversion factor to adjust aerosol extinction (m2/g)
8117 !
8118 rhtrunc = rh(i,k)
8119 rhtrunc = min(rh(i,k),1._r8)
8120 ! if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX')
8121 krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1)
8122 wrh = rhtrunc * nrh - krh
8123
8124 ! linear interpolation of optical properties between rh table points
8125 ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh
8126 ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh
8127 kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh
8128 wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh
8129 wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh
8130 wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh
8131 gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh
8132 gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh
8133 gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh
8134
8135 tau_sul = 1.e4 * ksuli * usul(i,k)
8136 tau_sslt = 1.e4 * ksslti * usslt(i,k)
8137 tau_cphil = 1.e4 * kcphili * ucphil(i,k)
8138 tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k)
8139 tau_cb = 1.e4 * kcb(ns) * ucb(i,k)
8140 tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k)
8141 tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k)
8142 tau_bg = 1.e4 * kbg(ns) * ubg(i,k)
8143
8144 tau_w_sul = tau_sul * wsuli
8145 tau_w_sslt = tau_sslt * wsslti
8146 tau_w_cphil = tau_cphil * wcphili
8147 tau_w_cphob = tau_cphob * wcphob(ns)
8148 tau_w_cb = tau_cb * wcb(ns)
8149 tau_w_volc = tau_volc * wvolc(ns)
8150 tau_w_dst(:) = tau_dst(:) * wdst(:,ns)
8151 tau_w_bg = tau_bg * wbg(ns)
8152
8153 tau_w_g_sul = tau_w_sul * gsuli
8154 tau_w_g_sslt = tau_w_sslt * gsslti
8155 tau_w_g_cphil = tau_w_cphil * gcphili
8156 tau_w_g_cphob = tau_w_cphob * gcphob(ns)
8157 tau_w_g_cb = tau_w_cb * gcb(ns)
8158 tau_w_g_volc = tau_w_volc * gvolc(ns)
8159 tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns)
8160 tau_w_g_bg = tau_w_bg * gbg(ns)
8161
8162 f_sul = gsuli * gsuli
8163 f_sslt = gsslti * gsslti
8164 f_cphil = gcphili * gcphili
8165 f_cphob = gcphob(ns) * gcphob(ns)
8166 f_cb = gcb(ns) * gcb(ns)
8167 f_volc = gvolc(ns) * gvolc(ns)
8168 f_dst(:) = gdst(:,ns) * gdst(:,ns)
8169 f_bg = gbg(ns) * gbg(ns)
8170
8171 tau_w_f_sul = tau_w_sul * f_sul
8172 tau_w_f_bg = tau_w_bg * f_bg
8173 tau_w_f_sslt = tau_w_sslt * f_sslt
8174 tau_w_f_cphil = tau_w_cphil * f_cphil
8175 tau_w_f_cphob = tau_w_cphob * f_cphob
8176 tau_w_f_cb = tau_w_cb * f_cb
8177 tau_w_f_volc = tau_w_volc * f_volc
8178 tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:)
8179 !
8180 ! mix dust aerosol size bins
8181 ! w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere
8182 ! but calculate them anyway for future use
8183 !
8184 tau_dst_tot = sum(tau_dst)
8185 tau_w_dst_tot = sum(tau_w_dst)
8186 tau_w_g_dst_tot = sum(tau_w_g_dst)
8187 tau_w_f_dst_tot = sum(tau_w_f_dst)
8188
8189 if (tau_dst_tot .gt. 0.0) then
8190 w_dst_tot = tau_w_dst_tot / tau_dst_tot
8191 else
8192 w_dst_tot = 0.0
8193 endif
8194
8195 if (tau_w_dst_tot .gt. 0.0) then
8196 g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot
8197 f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot
8198 else
8199 g_dst_tot = 0.0
8200 f_dst_tot = 0.0
8201 endif
8202 !
8203 ! mix aerosols
8204 !
8205 tau_tot = tau_sul + tau_sslt &
8206 + tau_cphil + tau_cphob + tau_cb + tau_dst_tot
8207 tau_tot = tau_tot + tau_bg + tau_volc
8208
8209 tau_w_tot = tau_w_sul + tau_w_sslt &
8210 + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot
8211 tau_w_tot = tau_w_tot + tau_w_bg + tau_w_volc
8212
8213 tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt &
8214 + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot
8215 tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc
8216
8217 tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt &
8218 + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot
8219 tau_w_f_tot = tau_w_f_tot + tau_w_f_bg + tau_w_f_volc
8220
8221 if (tau_tot .gt. 0.0) then
8222 w_tot = tau_w_tot / tau_tot
8223 else
8224 w_tot = 0.0
8225 endif
8226
8227 if (tau_w_tot .gt. 0.0) then
8228 g_tot = tau_w_g_tot / tau_w_tot
8229 f_tot = tau_w_f_tot / tau_w_tot
8230 else
8231 g_tot = 0.0
8232 f_tot = 0.0
8233 endif
8234
8235 tauxar(i,k) = tau_tot
8236 wa(i,k) = min(w_tot, 0.999999_r8)
8237 if (g_tot.gt.1._r8) write(6,*) "g_tot > 1"
8238 if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1"
8239 ! if (g_tot.gt.1._r8) call endrun ('RADCSWMX')
8240 ! if (g_tot.lt.-1._r8) call endrun ('RADCSWMX')
8241 ga(i,k) = g_tot
8242 if (f_tot.gt.1._r8) write(6,*)"f_tot > 1"
8243 if (f_tot.lt.0._r8) write(6,*)"f_tot < 0"
8244 ! if (f_tot.gt.1._r8) call endrun ('RADCSWMX')
8245 ! if (f_tot.lt.0._r8) call endrun ('RADCSWMX')
8246 fa(i,k) = f_tot
8247
8248 aertau(i,ns,1) = aertau(i,ns,1) + tau_sul
8249 aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt
8250 aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb
8251 aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot
8252 aertau(i,ns,5) = aertau(i,ns,5) + tau_bg
8253 aertau(i,ns,6) = aertau(i,ns,6) + tau_volc
8254 aertau(i,ns,7) = aertau(i,ns,7) + tau_tot
8255
8256 aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul
8257 aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt
8258 aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb
8259 aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot
8260 aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg
8261 aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc
8262 aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot
8263
8264 aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul
8265 aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt
8266 aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb
8267 aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot
8268 aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg
8269 aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc
8270 aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot
8271
8272 aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul
8273 aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt
8274 aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb
8275 aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot
8276 aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg
8277 aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc
8278 aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot
8279
8280 !
8281 ! End do k=1,pver
8282 !
8283 end do
8284
8285 ! normalize aerosol optical diagnostic fields
8286 do kaer = 1, naer_groups
8287
8288 if (aerssa(i,ns,kaer) .gt. 0.0) then ! aerssa currently holds product of tau and ssa
8289 aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer)
8290 aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer)
8291 else
8292 aerasm(i,ns,kaer) = 0.0_r8
8293 aerfwd(i,ns,kaer) = 0.0_r8
8294 end if
8295
8296 if (aertau(i,ns,kaer) .gt. 0.0) then
8297 aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer)
8298 else
8299 aerssa(i,ns,kaer) = 0.0_r8
8300 end if
8301
8302 end do
8303
8304
8305 !
8306 ! End do n=1,ndayc
8307 !
8308 end do
8309
8310 !
8311 ! Set reflectivities for surface based on mid-point wavelength
8312 !
8313 wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns))
8314 !
8315 ! Wavelength less than 0.7 micro-meter
8316 !
8317 if (wavmid(ns) < 0.7_r8 ) then
8318 do n=1,ndayc
8319 i=idayc(n)
8320 albdir(i,ns) = asdir(i)
8321 albdif(i,ns) = asdif(i)
8322 end do
8323 !
8324 ! Wavelength greater than 0.7 micro-meter
8325 !
8326 else
8327 do n=1,ndayc
8328 i=idayc(n)
8329 albdir(i,ns) = aldir(i)
8330 albdif(i,ns) = aldif(i)
8331 end do
8332 end if
8333 trayoslp = raytau(ns)/sslp
8334 !
8335 ! Layer input properties now completely specified; compute the
8336 ! delta-Eddington solution reflectivities and transmissivities
8337 ! for each layer
8338 !
8339 call raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc , &
8340 abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , &
8341 uh2o ,uo3 ,uco2 ,uo2 , &
8342 trayoslp ,pflx ,ns , &
8343 tauxcl ,wcl ,gcl ,fcl , &
8344 tauxci ,wci ,gci ,fci , &
8345 tauxar ,wa ,ga ,fa , &
8346 rdir ,rdif ,tdir ,tdif ,explay , &
8347 rdirc ,rdifc ,tdirc ,tdifc ,explayc )
8348 !
8349 ! End spectral loop
8350 !
8351 end do
8352 !
8353 !----------------------------------------------------------------------
8354 !
8355 ! Solution for max/random cloud overlap.
8356 !
8357 ! Steps:
8358 ! (1. delta-Eddington solution for each layer (called above)
8359 !
8360 ! (2. The adding method is used to
8361 ! compute the reflectivity and transmissivity to direct and diffuse
8362 ! radiation from the top and bottom of the atmosphere for each
8363 ! cloud configuration. This calculation is based upon the
8364 ! max-random overlap assumption.
8365 !
8366 ! (3. to solve for the fluxes, combine the
8367 ! bulk properties of the atmosphere above/below the region.
8368 !
8369 ! Index calculations for steps 2-3 are performed outside spectral
8370 ! loop to avoid redundant calculations. Index calculations (with
8371 ! application of areamin & nconfgmax conditions) are performed
8372 ! first to identify the minimum subset of terms for the configurations
8373 ! satisfying the areamin & nconfgmax conditions. This minimum set is
8374 ! used to identify the corresponding minimum subset of terms in
8375 ! steps 2 and 3.
8376 !
8377
8378 do n=1,ndayc
8379 i=idayc(n)
8380
8381 !----------------------------------------------------------------------
8382 ! INDEX CALCULATIONS FOR MAX OVERLAP
8383 !
8384 ! The column is divided into sets of adjacent layers, called regions,
8385 ! in which the clouds are maximally overlapped. The clouds are
8386 ! randomly overlapped between different regions. The number of
8387 ! regions in a column is set by nmxrgn, and the range of pressures
8388 ! included in each region is set by pmxrgn.
8389 !
8390 ! The following calculations determine the number of unique cloud
8391 ! configurations (assuming maximum overlap), called "streams",
8392 ! within each region. Each stream consists of a vector of binary
8393 ! clouds (either 0 or 100% cloud cover). Over the depth of the region,
8394 ! each stream requires a separate calculation of radiative properties. These
8395 ! properties are generated using the adding method from
8396 ! the radiative properties for each layer calculated by raddedmx.
8397 !
8398 ! The upward and downward-propagating streams are treated
8399 ! separately.
8400 !
8401 ! We will refer to a particular configuration of binary clouds
8402 ! within a single max-overlapped region as a "stream". We will
8403 ! refer to a particular arrangement of binary clouds over the entire column
8404 ! as a "configuration".
8405 !
8406 ! This section of the code generates the following information:
8407 ! (1. nrgn : the true number of max-overlap regions (need not = nmxrgn)
8408 ! (2. nstr : the number of streams in a region (>=1)
8409 ! (3. cstr : flags for presence of clouds at each layer in each stream
8410 ! (4. wstr : the fractional horizontal area of a grid box covered
8411 ! by each stream
8412 ! (5. kx1,2 : level indices for top/bottom of each region
8413 !
8414 ! The max-overlap calculation proceeds in 3 stages:
8415 ! (1. compute layer radiative properties in raddedmx.
8416 ! (2. combine these properties between layers
8417 ! (3. combine properties to compute fluxes at each interface.
8418 !
8419 ! Most of the indexing information calculated here is used in steps 2-3
8420 ! after the call to raddedmx.
8421 !
8422 ! Initialize indices for layers to be max-overlapped
8423 !
8424 ! Loop to handle fix in totwgt=0. For original overlap config
8425 ! from npasses = 0.
8426 !
8427 npasses = 0
8428 do
8429 do irgn = 0, nmxrgn(i)
8430 kx2(irgn) = 0
8431 end do
8432 mrgn = 0
8433 !
8434 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
8435 !
8436 do irgn = 1, nmxrgn(i)
8437 !
8438 ! Calculate min/max layer indices inside region.
8439 !
8440 region_found = .false.
8441 if (kx2(irgn-1) < pver) then
8442 k1 = kx2(irgn-1)+1
8443 kx1(irgn) = k1
8444 kx2(irgn) = k1-1
8445 do k2 = pver, k1, -1
8446 if (pmid(i,k2) <= pmxrgn(i,irgn)) then
8447 kx2(irgn) = k2
8448 mrgn = mrgn+1
8449 region_found = .true.
8450 exit
8451 end if
8452 end do
8453 else
8454 exit
8455 endif
8456
8457 if (region_found) then
8458 !
8459 ! Sort cloud areas and corresponding level indices.
8460 !
8461 nxs = 0
8462 if (cldeps > 0) then
8463 do k = k1,k2
8464 if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
8465 nxs = nxs+1
8466 ksort(nxs) = k
8467 !
8468 ! We need indices for clouds in order of largest to smallest, so
8469 ! sort 1-cld in ascending order
8470 !
8471 asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps)
8472 end if
8473 end do
8474 else
8475 do k = k1,k2
8476 if (cld(i,k) >= cldmin) then
8477 nxs = nxs+1
8478 ksort(nxs) = k
8479 !
8480 ! We need indices for clouds in order of largest to smallest, so
8481 ! sort 1-cld in ascending order
8482 !
8483 asort(nxs) = 1.0_r8-cld(i,k)
8484 end if
8485 end do
8486 endif
8487 !
8488 ! If nxs eq 1, no need to sort.
8489 ! If nxs eq 2, sort by swapping if necessary
8490 ! If nxs ge 3, sort using local sort routine
8491 !
8492 if (nxs == 2) then
8493 if (asort(2) < asort(1)) then
8494 ktmp = ksort(1)
8495 ksort(1) = ksort(2)
8496 ksort(2) = ktmp
8497
8498 atmp = asort(1)
8499 asort(1) = asort(2)
8500 asort(2) = atmp
8501 endif
8502 else if (nxs >= 3) then
8503 call sortarray(nxs,asort,ksort)
8504 endif
8505 !
8506 ! Construct wstr, cstr, nstr for this region
8507 !
8508 cstr(k1:k2,1:nxs+1) = 0
8509 mstr = 1
8510 cld0 = 0.0_r8
8511 do l = 1, nxs
8512 if (asort(l) /= cld0) then
8513 wstr(mstr,mrgn) = asort(l) - cld0
8514 cld0 = asort(l)
8515 mstr = mstr + 1
8516 endif
8517 cstr(ksort(l),mstr:nxs+1) = 1
8518 end do
8519 nstr(mrgn) = mstr
8520 wstr(mstr,mrgn) = 1.0_r8 - cld0
8521 !
8522 ! End test of region_found = true
8523 !
8524 endif
8525 !
8526 ! End loop over regions irgn for max-overlap
8527 !
8528 end do
8529 nrgn = mrgn
8530 !
8531 ! Finish construction of cstr for additional top layer
8532 !
8533 cstr(0,1:nstr(1)) = 0
8534 !
8535 ! INDEX COMPUTATIONS FOR STEP 2-3
8536 ! This section of the code generates the following information:
8537 ! (1. totwgt step 3 total frac. area of configurations satisfying
8538 ! areamin & nconfgmax criteria
8539 ! (2. wgtv step 3 frac. area of configurations
8540 ! (3. ccon step 2 binary flag for clouds in each configuration
8541 ! (4. nconfig steps 2-3 number of configurations
8542 ! (5. nuniqu/d step 2 Number of unique cloud configurations for
8543 ! up/downwelling rad. between surface/TOA
8544 ! and level k
8545 ! (6. istrtu/d step 2 Indices into iconu/d
8546 ! (7. iconu/d step 2 Cloud configurations which are identical
8547 ! for up/downwelling rad. between surface/TOA
8548 ! and level k
8549 !
8550 ! Number of configurations (all permutations of streams in each region)
8551 !
8552 nconfigm = product(nstr(1: nrgn))
8553 !
8554 ! Construction of totwgt, wgtv, ccon, nconfig
8555 !
8556 istr(1: nrgn) = 1
8557 nconfig = 0
8558 totwgt = 0.0_r8
8559 new_term = .true.
8560 do iconfig = 1, nconfigm
8561 xwgt = 1.0_r8
8562 do mrgn = 1, nrgn
8563 xwgt = xwgt * wstr(istr(mrgn),mrgn)
8564 end do
8565 if (xwgt >= areamin) then
8566 nconfig = nconfig + 1
8567 if (nconfig <= nconfgmax) then
8568 j = nconfig
8569 ptrc(nconfig) = nconfig
8570 else
8571 nconfig = nconfgmax
8572 if (new_term) then
8573 j = findvalue(1,nconfig,wgtv,ptrc)
8574 endif
8575 if (wgtv(j) < xwgt) then
8576 totwgt = totwgt - wgtv(j)
8577 new_term = .true.
8578 else
8579 new_term = .false.
8580 endif
8581 endif
8582 if (new_term) then
8583 wgtv(j) = xwgt
8584 totwgt = totwgt + xwgt
8585 do mrgn = 1, nrgn
8586 ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn))
8587 end do
8588 endif
8589 endif
8590
8591 mrgn = nrgn
8592 istr(mrgn) = istr(mrgn) + 1
8593 do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1)
8594 istr(mrgn) = 1
8595 mrgn = mrgn - 1
8596 istr(mrgn) = istr(mrgn) + 1
8597 end do
8598 !
8599 ! End do iconfig = 1, nconfigm
8600 !
8601 end do
8602 !
8603 ! If totwgt = 0 implement maximum overlap and make another pass
8604 ! if totwgt = 0 on this second pass then terminate.
8605 !
8606 if (totwgt > 0.) then
8607 exit
8608 else
8609 npasses = npasses + 1
8610 if (npasses >= 2 ) then
8611 write(6,*)'RADCSWMX: Maximum overlap of column ','failed'
8612 ! call endrun
8613 endif
8614 nmxrgn(i)=1
8615 pmxrgn(i,1)=1.0e30
8616 end if
8617 !
8618 ! End npasses = 0, do
8619 !
8620 end do
8621 !
8622 !
8623 ! Finish construction of ccon
8624 !
8625 ccon(0,:) = 0
8626 ccon(pverp,:) = 0
8627 !
8628 ! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree
8629 !
8630 nuniqd(0) = 1
8631 nuniqu(pverp) = 1
8632
8633 istrtd(0,1) = 1
8634 istrtu(pverp,1) = 1
8635
8636 do j = 1, nconfig
8637 icond(0,j)=j
8638 iconu(pverp,j)=j
8639 end do
8640
8641 istrtd(0,2) = nconfig+1
8642 istrtu(pverp,2) = nconfig+1
8643
8644 do k = 1, pverp
8645 km1 = k-1
8646 nuniq = 0
8647 istrtd(k,1) = 1
8648 do l0 = 1, nuniqd(km1)
8649 is0 = istrtd(km1,l0)
8650 is1 = istrtd(km1,l0+1)-1
8651 n0 = 0
8652 n1 = 0
8653 do isn = is0, is1
8654 j = icond(km1,isn)
8655 if (ccon(k,j) == 0) then
8656 n0 = n0 + 1
8657 ptr0(n0) = j
8658 endif
8659 if (ccon(k,j) == 1) then
8660 n1 = n1 + 1
8661 ptr1(n1) = j
8662 endif
8663 end do
8664 if (n0 > 0) then
8665 nuniq = nuniq + 1
8666 istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0
8667 icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr0(1:n0)
8668 endif
8669 if (n1 > 0) then
8670 nuniq = nuniq + 1
8671 istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1
8672 icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr1(1:n1)
8673 endif
8674 end do
8675 nuniqd(k) = nuniq
8676 end do
8677
8678 do k = pver, 0, -1
8679 kp1 = k+1
8680 nuniq = 0
8681 istrtu(k,1) = 1
8682 do l0 = 1, nuniqu(kp1)
8683 is0 = istrtu(kp1,l0)
8684 is1 = istrtu(kp1,l0+1)-1
8685 n0 = 0
8686 n1 = 0
8687 do isn = is0, is1
8688 j = iconu(kp1,isn)
8689 if (ccon(k,j) == 0) then
8690 n0 = n0 + 1
8691 ptr0(n0) = j
8692 endif
8693 if (ccon(k,j) == 1) then
8694 n1 = n1 + 1
8695 ptr1(n1) = j
8696 endif
8697 end do
8698 if (n0 > 0) then
8699 nuniq = nuniq + 1
8700 istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0
8701 iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr0(1:n0)
8702 endif
8703 if (n1 > 0) then
8704 nuniq = nuniq + 1
8705 istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1
8706 iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1)
8707 endif
8708 end do
8709 nuniqu(k) = nuniq
8710 end do
8711 !
8712 !----------------------------------------------------------------------
8713 ! End of index calculations
8714 !----------------------------------------------------------------------
8715
8716
8717 !----------------------------------------------------------------------
8718 ! Start of flux calculations
8719 !----------------------------------------------------------------------
8720 !
8721 ! Initialize spectrally integrated totals:
8722 !
8723 do k=0,pver
8724 totfld(k) = 0.0_r8
8725 fswup (k) = 0.0_r8
8726 fswdn (k) = 0.0_r8
8727 fswupc (k) = 0.0_r8
8728 fswdnc (k) = 0.0_r8
8729 end do
8730
8731 sfltot = 0.0_r8
8732 fswup (pverp) = 0.0_r8
8733 fswdn (pverp) = 0.0_r8
8734 fswupc (pverp) = 0.0_r8
8735 fswdnc (pverp) = 0.0_r8
8736 !
8737 ! Start spectral interval
8738 !
8739 do ns = 1,nspint
8740 wgtint = nirwgt(ns)
8741 !----------------------------------------------------------------------
8742 ! STEP 2
8743 !
8744 !
8745 ! Apply adding method to solve for radiative properties
8746 !
8747 ! First initialize the bulk properties at TOA
8748 !
8749 rdndif(0,1:nconfig) = 0.0_r8
8750 exptdn(0,1:nconfig) = 1.0_r8
8751 tdntot(0,1:nconfig) = 1.0_r8
8752 !
8753 ! Solve for properties involving downward propagation of radiation.
8754 ! The bulk properties are:
8755 !
8756 ! (1. exptdn Sol. beam dwn. trans from layers above
8757 ! (2. rdndif Ref to dif rad for layers above
8758 ! (3. tdntot Total trans for layers above
8759 !
8760 do k = 1, pverp
8761 km1 = k - 1
8762 do l0 = 1, nuniqd(km1)
8763 is0 = istrtd(km1,l0)
8764 is1 = istrtd(km1,l0+1)-1
8765
8766 j = icond(km1,is0)
8767
8768 xexpt = exptdn(km1,j)
8769 xrdnd = rdndif(km1,j)
8770 tdnmexp = tdntot(km1,j) - xexpt
8771
8772 if (ccon(km1,j) == 1) then
8773 !
8774 ! If cloud in layer, use cloudy layer radiative properties
8775 !
8776 ytdnd = tdif(ns,i,km1)
8777 yrdnd = rdif(ns,i,km1)
8778
8779 rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
8780 rdirexp = rdir(ns,i,km1)*xexpt
8781
8782 zexpt = xexpt * explay(ns,i,km1)
8783 zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
8784 ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom
8785 else
8786 !
8787 ! If clear layer, use clear-sky layer radiative properties
8788 !
8789 ytdnd = tdifc(ns,i,km1)
8790 yrdnd = rdifc(ns,i,km1)
8791
8792 rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
8793 rdirexp = rdirc(ns,i,km1)*xexpt
8794
8795 zexpt = xexpt * explayc(ns,i,km1)
8796 zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
8797 ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* &
8798 (tdnmexp + xrdnd*rdirexp)*rdenom
8799 endif
8800
8801 !
8802 ! If 2 or more configurations share identical properties at a given level k,
8803 ! the properties (at level k) are computed once and copied to
8804 ! all the configurations for efficiency.
8805 !
8806 do isn = is0, is1
8807 j = icond(km1,isn)
8808 exptdn(k,j) = zexpt
8809 rdndif(k,j) = zrdnd
8810 tdntot(k,j) = ztdnt
8811 end do
8812 !
8813 ! end do l0 = 1, nuniqd(k)
8814 !
8815 end do
8816 !
8817 ! end do k = 1, pverp
8818 !
8819 end do
8820 !
8821 ! Solve for properties involving upward propagation of radiation.
8822 ! The bulk properties are:
8823 !
8824 ! (1. rupdif Ref to dif rad for layers below
8825 ! (2. rupdir Ref to dir rad for layers below
8826 !
8827 ! Specify surface boundary conditions (surface albedos)
8828 !
8829 rupdir(pverp,1:nconfig) = albdir(i,ns)
8830 rupdif(pverp,1:nconfig) = albdif(i,ns)
8831
8832 do k = pver, 0, -1
8833 do l0 = 1, nuniqu(k)
8834 is0 = istrtu(k,l0)
8835 is1 = istrtu(k,l0+1)-1
8836
8837 j = iconu(k,is0)
8838
8839 xrupd = rupdif(k+1,j)
8840 xrups = rupdir(k+1,j)
8841
8842 if (ccon(k,j) == 1) then
8843 !
8844 ! If cloud in layer, use cloudy layer radiative properties
8845 !
8846 yexpt = explay(ns,i,k)
8847 yrupd = rdif(ns,i,k)
8848 ytupd = tdif(ns,i,k)
8849
8850 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
8851 tdnmexp = (tdir(ns,i,k)-yexpt)
8852 rdirexp = xrups*yexpt
8853
8854 zrupd = yrupd + xrupd*(ytupd**2)*rdenom
8855 zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
8856 else
8857 !
8858 ! If clear layer, use clear-sky layer radiative properties
8859 !
8860 yexpt = explayc(ns,i,k)
8861 yrupd = rdifc(ns,i,k)
8862 ytupd = tdifc(ns,i,k)
8863
8864 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
8865 tdnmexp = (tdirc(ns,i,k)-yexpt)
8866 rdirexp = xrups*yexpt
8867
8868 zrupd = yrupd + xrupd*(ytupd**2)*rdenom
8869 zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
8870 endif
8871
8872 !
8873 ! If 2 or more configurations share identical properties at a given level k,
8874 ! the properties (at level k) are computed once and copied to
8875 ! all the configurations for efficiency.
8876 !
8877 do isn = is0, is1
8878 j = iconu(k,isn)
8879 rupdif(k,j) = zrupd
8880 rupdir(k,j) = zrups
8881 end do
8882 !
8883 ! end do l0 = 1, nuniqu(k)
8884 !
8885 end do
8886 !
8887 ! end do k = pver,0,-1
8888 !
8889 end do
8890 !
8891 !----------------------------------------------------------------------
8892 !
8893 ! STEP 3
8894 !
8895 ! Compute up and down fluxes for each interface k. This requires
8896 ! adding up the contributions from all possible permutations
8897 ! of streams in all max-overlap regions, weighted by the
8898 ! product of the fractional areas of the streams in each region
8899 ! (the random overlap assumption). The adding principle has been
8900 ! used in step 2 to combine the bulk radiative properties
8901 ! above and below the interface.
8902 !
8903 do k = 0,pverp
8904 !
8905 ! Initialize the fluxes
8906 !
8907 fluxup(k)=0.0_r8
8908 fluxdn(k)=0.0_r8
8909
8910 do iconfig = 1, nconfig
8911 xwgt = wgtv(iconfig)
8912 xexpt = exptdn(k,iconfig)
8913 xtdnt = tdntot(k,iconfig)
8914 xrdnd = rdndif(k,iconfig)
8915 xrupd = rupdif(k,iconfig)
8916 xrups = rupdir(k,iconfig)
8917 !
8918 ! Flux computation
8919 !
8920 rdenom = 1._r8/(1._r8 - xrdnd * xrupd)
8921
8922 fluxup(k) = fluxup(k) + xwgt * &
8923 ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom)
8924 fluxdn(k) = fluxdn(k) + xwgt * &
8925 (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom)
8926 !
8927 ! End do iconfig = 1, nconfig
8928 !
8929 end do
8930 !
8931 ! Normalize by total area covered by cloud configurations included
8932 ! in solution
8933 !
8934 fluxup(k)=fluxup(k) / totwgt
8935 fluxdn(k)=fluxdn(k) / totwgt
8936 !
8937 ! End do k = 0,pverp
8938 !
8939 end do
8940 !
8941 ! Initialize the direct-beam flux at surface
8942 !
8943 wexptdn = 0.0_r8
8944
8945 do iconfig = 1, nconfig
8946 wexptdn = wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig)
8947 end do
8948
8949 wexptdn = wexptdn / totwgt
8950 !
8951 ! Monochromatic computation completed; accumulate in totals
8952 !
8953 solflx = solin(i)*frcsol(ns)*psf(ns)
8954 fsnt(i) = fsnt(i) + solflx*(fluxdn(1) - fluxup(1))
8955 fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0))
8956 fsns(i) = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp))
8957 sfltot = sfltot + solflx
8958 fswup(0) = fswup(0) + solflx*fluxup(0)
8959 fswdn(0) = fswdn(0) + solflx*fluxdn(0)
8960 !
8961 ! Down spectral fluxes need to be in mks; thus the .001 conversion factors
8962 !
8963 if (wavmid(ns) < 0.7_r8) then
8964 sols(i) = sols(i) + wexptdn*solflx*0.001_r8
8965 solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
8966 else
8967 soll(i) = soll(i) + wexptdn*solflx*0.001_r8
8968 solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
8969 fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0))
8970 end if
8971 fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0))
8972
8973 do k=0,pver
8974 !
8975 ! Compute flux divergence in each layer using the interface up and down
8976 ! fluxes:
8977 !
8978 kp1 = k+1
8979 flxdiv = (fluxdn(k ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k ))
8980 totfld(k) = totfld(k) + solflx*flxdiv
8981 fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1)
8982 fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1)
8983 end do
8984 !
8985 ! Perform clear-sky calculation
8986 !
8987 exptdnc(0) = 1.0_r8
8988 rdndifc(0) = 0.0_r8
8989 tdntotc(0) = 1.0_r8
8990 rupdirc(pverp) = albdir(i,ns)
8991 rupdifc(pverp) = albdif(i,ns)
8992
8993 do k = 1, pverp
8994 km1 = k - 1
8995 xexpt = exptdnc(km1)
8996 xrdnd = rdndifc(km1)
8997 yrdnd = rdifc(ns,i,km1)
8998 ytdnd = tdifc(ns,i,km1)
8999
9000 exptdnc(k) = xexpt*explayc(ns,i,km1)
9001
9002 rdenom = 1._r8/(1._r8 - yrdnd*xrdnd)
9003 rdirexp = rdirc(ns,i,km1)*xexpt
9004 tdnmexp = tdntotc(km1) - xexpt
9005
9006 tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* &
9007 rdenom
9008 rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom
9009 end do
9010
9011 do k=pver,0,-1
9012 xrupd = rupdifc(k+1)
9013 yexpt = explayc(ns,i,k)
9014 yrupd = rdifc(ns,i,k)
9015 ytupd = tdifc(ns,i,k)
9016
9017 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
9018
9019 rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + &
9020 xrupd*(tdirc(ns,i,k)-yexpt))*rdenom
9021 rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom
9022 end do
9023
9024 do k=0,1
9025 rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
9026 fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
9027 rdenom
9028 fluxdn(k) = exptdnc(k) + &
9029 (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* &
9030 rdenom
9031 fswupc(k) = fswupc(k) + solflx*fluxup(k)
9032 fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
9033 end do
9034 ! k = pverp
9035 do k=2,pverp
9036 rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
9037 fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
9038 rdenom
9039 fluxdn(k) = exptdnc(k) + (tdntotc(k) - exptdnc(k) + &
9040 exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom
9041 fswupc(k) = fswupc(k) + solflx*fluxup(k)
9042 fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
9043 end do
9044
9045 fsntc(i) = fsntc(i)+solflx*(fluxdn(1)-fluxup(1))
9046 fsntoac(i) = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0))
9047 fsnsc(i) = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp))
9048 fsdsc(i) = fsdsc(i)+solflx*(fluxdn(pverp))
9049 fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0))
9050 !
9051 ! End of clear sky calculation
9052 !
9053
9054 !
9055 ! End of spectral interval loop
9056 !
9057 end do
9058 !
9059 ! Compute solar heating rate (J/kg/s)
9060 !
9061 do k=1,pver
9062 qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1))
9063 end do
9064
9065 ! Added downward/upward total and clear sky fluxes
9066
9067 do k=1,pverp
9068 fsup(i,k) = fswup(k)
9069 fsupc(i,k) = fswupc(k)
9070 fsdn(i,k) = fswdn(k)
9071 fsdnc(i,k) = fswdnc(k)
9072 end do
9073 !
9074 ! Set the downwelling flux at the surface
9075 !
9076 fsds(i) = fswdn(pverp)
9077 !
9078 ! End do n=1,ndayc
9079 !
9080 end do
9081
9082 ! write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk
9083
9084 return
9085 end subroutine radcswmx
9086
9087 subroutine raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc ,abh2o , &
9088 abo3 ,abco2 ,abo2 ,uh2o ,uo3 , &
9089 uco2 ,uo2 ,trayoslp,pflx ,ns , &
9090 tauxcl ,wcl ,gcl ,fcl ,tauxci , &
9091 wci ,gci ,fci ,tauxar ,wa , &
9092 ga ,fa ,rdir ,rdif ,tdir , &
9093 tdif ,explay ,rdirc ,rdifc ,tdirc , &
9094 tdifc ,explayc )
9095 !-----------------------------------------------------------------------
9096 !
9097 ! Purpose:
9098 ! Computes layer reflectivities and transmissivities, from the top down
9099 ! to the surface using the delta-Eddington solutions for each layer
9100 !
9101 ! Method:
9102 ! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington
9103 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
9104 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
9105 !
9106 ! Modified for maximum/random cloud overlap by Bill Collins and John
9107 ! Truesdale
9108 !
9109 ! Author: Bill Collins
9110 !
9111 !-----------------------------------------------------------------------
9112 ! use shr_kind_mod, only: r8 => shr_kind_r8
9113 ! use ppgrid
9114
9115 implicit none
9116
9117 integer nspint ! Num of spctrl intervals across solar spectrum
9118
9119 parameter ( nspint = 19 )
9120 !
9121 ! Minimum total transmission below which no layer computation are done:
9122 !
9123 real(r8) trmin ! Minimum total transmission allowed
9124 real(r8) wray ! Rayleigh single scatter albedo
9125 real(r8) gray ! Rayleigh asymetry parameter
9126 real(r8) fray ! Rayleigh forward scattered fraction
9127
9128 parameter (trmin = 1.e-3)
9129 parameter (wray = 0.999999)
9130 parameter (gray = 0.0)
9131 parameter (fray = 0.1)
9132 !
9133 !------------------------------Arguments--------------------------------
9134 !
9135 ! Input arguments
9136 !
9137 integer, intent(in) :: pver, pverp, pcols
9138 real(r8), intent(in) :: coszrs(pcols) ! Cosine zenith angle
9139 real(r8), intent(in) :: trayoslp ! Tray/sslp
9140 real(r8), intent(in) :: pflx(pcols,0:pverp) ! Interface pressure
9141 real(r8), intent(in) :: abh2o ! Absorption coefficiant for h2o
9142 real(r8), intent(in) :: abo3 ! Absorption coefficiant for o3
9143 real(r8), intent(in) :: abco2 ! Absorption coefficiant for co2
9144 real(r8), intent(in) :: abo2 ! Absorption coefficiant for o2
9145 real(r8), intent(in) :: uh2o(pcols,0:pver) ! Layer absorber amount of h2o
9146 real(r8), intent(in) :: uo3(pcols,0:pver) ! Layer absorber amount of o3
9147 real(r8), intent(in) :: uco2(pcols,0:pver) ! Layer absorber amount of co2
9148 real(r8), intent(in) :: uo2(pcols,0:pver) ! Layer absorber amount of o2
9149 real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid)
9150 real(r8), intent(in) :: wcl(pcols,0:pver) ! Cloud single scattering albedo (liquid)
9151 real(r8), intent(in) :: gcl(pcols,0:pver) ! Cloud asymmetry parameter (liquid)
9152 real(r8), intent(in) :: fcl(pcols,0:pver) ! Cloud forward scattered fraction (liquid)
9153 real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice)
9154 real(r8), intent(in) :: wci(pcols,0:pver) ! Cloud single scattering albedo (ice)
9155 real(r8), intent(in) :: gci(pcols,0:pver) ! Cloud asymmetry parameter (ice)
9156 real(r8), intent(in) :: fci(pcols,0:pver) ! Cloud forward scattered fraction (ice)
9157 real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth
9158 real(r8), intent(in) :: wa(pcols,0:pver) ! Aerosol single scattering albedo
9159 real(r8), intent(in) :: ga(pcols,0:pver) ! Aerosol asymmetry parameter
9160 real(r8), intent(in) :: fa(pcols,0:pver) ! Aerosol forward scattered fraction
9161
9162 integer, intent(in) :: ndayc ! Number of daylight columns
9163 integer, intent(in) :: idayc(pcols) ! Daylight column indices
9164 integer, intent(in) :: ns ! Index of spectral interval
9165 !
9166 ! Input/Output arguments
9167 !
9168 ! Following variables are defined for each layer; 0 refers to extra
9169 ! layer above top of model:
9170 !
9171 real(r8), intent(inout) :: rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
9172 real(r8), intent(inout) :: rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
9173 real(r8), intent(inout) :: tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
9174 real(r8), intent(inout) :: tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
9175 real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer
9176 !
9177 ! Corresponding quantities for clear-skies
9178 !
9179 real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver) ! Clear layer reflec. to direct rad
9180 real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver) ! Clear layer reflec. to diffuse rad
9181 real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver) ! Clear layer trans. to direct rad
9182 real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver) ! Clear layer trans. to diffuse rad
9183 real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer
9184 !
9185 !---------------------------Local variables-----------------------------
9186 !
9187 integer i ! Column indices
9188 integer k ! Level index
9189 integer nn ! Index of column loops (max=ndayc)
9190
9191 real(r8) taugab(pcols) ! Layer total gas absorption optical depth
9192 real(r8) tauray(pcols) ! Layer rayleigh optical depth
9193 real(r8) taucsc ! Layer cloud scattering optical depth
9194 real(r8) tautot ! Total layer optical depth
9195 real(r8) wtot ! Total layer single scatter albedo
9196 real(r8) gtot ! Total layer asymmetry parameter
9197 real(r8) ftot ! Total layer forward scatter fraction
9198 real(r8) wtau ! rayleigh layer scattering optical depth
9199 real(r8) wt ! layer total single scattering albedo
9200 real(r8) ts ! layer scaled extinction optical depth
9201 real(r8) ws ! layer scaled single scattering albedo
9202 real(r8) gs ! layer scaled asymmetry parameter
9203 !
9204 !---------------------------Statement functions-------------------------
9205 !
9206 ! Statement functions and other local variables
9207 !
9208 real(r8) alpha ! Term in direct reflect and transmissivity
9209 real(r8) gamma ! Term in direct reflect and transmissivity
9210 real(r8) el ! Term in alpha,gamma,n,u
9211 real(r8) taus ! Scaled extinction optical depth
9212 real(r8) omgs ! Scaled single particle scattering albedo
9213 real(r8) asys ! Scaled asymmetry parameter
9214 real(r8) u ! Term in diffuse reflect and
9215 ! transmissivity
9216 real(r8) n ! Term in diffuse reflect and
9217 ! transmissivity
9218 real(r8) lm ! Temporary for el
9219 real(r8) ne ! Temporary for n
9220 real(r8) w ! Dummy argument for statement function
9221 real(r8) uu ! Dummy argument for statement function
9222 real(r8) g ! Dummy argument for statement function
9223 real(r8) e ! Dummy argument for statement function
9224 real(r8) f ! Dummy argument for statement function
9225 real(r8) t ! Dummy argument for statement function
9226 real(r8) et ! Dummy argument for statement function
9227 !
9228 ! Intermediate terms for delta-eddington solution
9229 !
9230 real(r8) alp ! Temporary for alpha
9231 real(r8) gam ! Temporary for gamma
9232 real(r8) ue ! Temporary for u
9233 real(r8) arg ! Exponential argument
9234 real(r8) extins ! Extinction
9235 real(r8) amg ! Alp - gam
9236 real(r8) apg ! Alp + gam
9237 !
9238 alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu))
9239 gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu))
9240 el(w,g) = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g))
9241 taus(w,f,t) = (1._r8 - w*f)*t
9242 omgs(w,f) = (1._r8 - f)*w/(1._r8 - w*f)
9243 asys(g,f) = (g - f)/(1._r8 - f)
9244 u(w,g,e) = 1.5_r8*(1._r8 - w*g)/e
9245 n(uu,et) = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et)
9246 !
9247 !-----------------------------------------------------------------------
9248 !
9249 ! Compute layer radiative properties
9250 !
9251 ! Compute radiative properties (reflectivity and transmissivity for
9252 ! direct and diffuse radiation incident from above, under clear
9253 ! and cloudy conditions) and transmission of direct radiation
9254 ! (under clear and cloudy conditions) for each layer.
9255 !
9256 do k=0,pver
9257 do nn=1,ndayc
9258 i=idayc(nn)
9259 tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k))
9260 taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k)
9261 tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k)
9262 taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k)
9263 wtau = wray*tauray(i)
9264 wt = wtau + taucsc
9265 wtot = wt/tautot
9266 gtot = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) &
9267 + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt
9268 ftot = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) &
9269 + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt
9270 ts = taus(wtot,ftot,tautot)
9271 ws = omgs(wtot,ftot)
9272 gs = asys(gtot,ftot)
9273 lm = el(ws,gs)
9274 alp = alpha(ws,coszrs(i),gs,lm)
9275 gam = gamma(ws,coszrs(i),gs,lm)
9276 ue = u(ws,gs,lm)
9277 !
9278 ! Limit argument of exponential to 25, in case lm very large:
9279 !
9280 arg = min(lm*ts,25._r8)
9281 extins = exp(-arg)
9282 ne = n(ue,extins)
9283 rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
9284 tdif(ns,i,k) = 4._r8*ue/ne
9285 !
9286 ! Limit argument of exponential to 25, in case coszrs is very small:
9287 !
9288 arg = min(ts/coszrs(i),25._r8)
9289 explay(ns,i,k) = exp(-arg)
9290 apg = alp + gam
9291 amg = alp - gam
9292 rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k)
9293 tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k)
9294 !
9295 ! Under rare conditions, reflectivies and transmissivities can be
9296 ! negative; zero out any negative values
9297 !
9298 rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8)
9299 tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8)
9300 rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8)
9301 tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8)
9302 !
9303 ! Clear-sky calculation
9304 !
9305 if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then
9306
9307 rdirc(ns,i,k) = rdir(ns,i,k)
9308 tdirc(ns,i,k) = tdir(ns,i,k)
9309 rdifc(ns,i,k) = rdif(ns,i,k)
9310 tdifc(ns,i,k) = tdif(ns,i,k)
9311 explayc(ns,i,k) = explay(ns,i,k)
9312 else
9313 tautot = tauray(i) + taugab(i) + tauxar(i,k)
9314 taucsc = tauxar(i,k)*wa(i,k)
9315 !
9316 ! wtau already computed for all-sky
9317 !
9318 wt = wtau + taucsc
9319 wtot = wt/tautot
9320 gtot = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt
9321 ftot = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt
9322 ts = taus(wtot,ftot,tautot)
9323 ws = omgs(wtot,ftot)
9324 gs = asys(gtot,ftot)
9325 lm = el(ws,gs)
9326 alp = alpha(ws,coszrs(i),gs,lm)
9327 gam = gamma(ws,coszrs(i),gs,lm)
9328 ue = u(ws,gs,lm)
9329 !
9330 ! Limit argument of exponential to 25, in case lm very large:
9331 !
9332 arg = min(lm*ts,25._r8)
9333 extins = exp(-arg)
9334 ne = n(ue,extins)
9335 rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
9336 tdifc(ns,i,k) = 4._r8*ue/ne
9337 !
9338 ! Limit argument of exponential to 25, in case coszrs is very small:
9339 !
9340 arg = min(ts/coszrs(i),25._r8)
9341 explayc(ns,i,k) = exp(-arg)
9342 apg = alp + gam
9343 amg = alp - gam
9344 rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ &
9345 apg*rdifc(ns,i,k)
9346 tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* &
9347 explayc(ns,i,k)
9348 !
9349 ! Under rare conditions, reflectivies and transmissivities can be
9350 ! negative; zero out any negative values
9351 !
9352 rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8)
9353 tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8)
9354 rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8)
9355 tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8)
9356 end if
9357 end do
9358 end do
9359
9360 return
9361 end subroutine raddedmx
9362 subroutine radini(gravx ,cpairx ,epsilox ,stebolx, pstdx )
9363 !-----------------------------------------------------------------------
9364 !
9365 ! Purpose:
9366 ! Initialize various constants for radiation scheme; note that
9367 ! the radiation scheme uses cgs units.
9368 !
9369 ! Method:
9370 ! <Describe the algorithm(s) used in the routine.>
9371 ! <Also include any applicable external references.>
9372 !
9373 ! Author: W. Collins (H2O parameterization) and J. Kiehl
9374 !
9375 !-----------------------------------------------------------------------
9376 ! use shr_kind_mod, only: r8 => shr_kind_r8
9377 ! use ppgrid, only: pver, pverp
9378 ! use comozp, only: cplos, cplol
9379 ! use pmgrid, only: masterproc, plev, plevp
9380 ! use radae, only: radaeini
9381 ! use physconst, only: mwdry, mwco2
9382 #if ( defined SPMD )
9383 ! use mpishorthand
9384 #endif
9385 implicit none
9386
9387 !------------------------------Arguments--------------------------------
9388 !
9389 ! Input arguments
9390 !
9391 real, intent(in) :: gravx ! Acceleration of gravity (MKS)
9392 real, intent(in) :: cpairx ! Specific heat of dry air (MKS)
9393 real, intent(in) :: epsilox ! Ratio of mol. wght of H2O to dry air
9394 real, intent(in) :: stebolx ! Stefan-Boltzmann's constant (MKS)
9395 real(r8), intent(in) :: pstdx ! Standard pressure (Pascals)
9396 !
9397 !---------------------------Local variables-----------------------------
9398 !
9399 integer k ! Loop variable
9400
9401 real(r8) v0 ! Volume of a gas at stp (m**3/kmol)
9402 real(r8) p0 ! Standard pressure (pascals)
9403 real(r8) amd ! Effective molecular weight of dry air (kg/kmol)
9404 real(r8) goz ! Acceleration of gravity (m/s**2)
9405 !
9406 !-----------------------------------------------------------------------
9407 !
9408 ! Set general radiation consts; convert to cgs units where appropriate:
9409 !
9410 gravit = 100.*gravx
9411 rga = 1./gravit
9412 gravmks = gravx
9413 cpair = 1.e4*cpairx
9414 epsilo = epsilox
9415 sslp = 1.013250e6
9416 stebol = 1.e3*stebolx
9417 rgsslp = 0.5/(gravit*sslp)
9418 dpfo3 = 2.5e-3
9419 dpfco2 = 5.0e-3
9420 dayspy = 365.
9421 pie = 4.*atan(1.)
9422 !
9423 ! Initialize ozone data.
9424 !
9425 v0 = 22.4136 ! Volume of a gas at stp (m**3/kmol)
9426 p0 = 0.1*sslp ! Standard pressure (pascals)
9427 amd = 28.9644 ! Molecular weight of dry air (kg/kmol)
9428 goz = gravx ! Acceleration of gravity (m/s**2)
9429 !
9430 ! Constants for ozone path integrals (multiplication by 100 for unit
9431 ! conversion to cgs from mks):
9432 !
9433 cplos = v0/(amd*goz) *100.0
9434 cplol = v0/(amd*goz*p0)*0.5*100.0
9435 !
9436 ! Derived constants
9437 ! If the top model level is above ~90 km (0.1 Pa), set the top level to compute
9438 ! longwave cooling to about 80 km (1 Pa)
9439 ! WRF: assume top level > 0.1 mb
9440 ! if (hypm(1) .lt. 0.1) then
9441 ! do k = 1, pver
9442 ! if (hypm(k) .lt. 1.) ntoplw = k
9443 ! end do
9444 ! else
9445 ntoplw = 1
9446 ! end if
9447 ! if (masterproc) then
9448 ! write (6,*) 'RADINI: ntoplw =',ntoplw, ' pressure:',hypm(ntoplw)
9449 ! endif
9450
9451 call radaeini( pstdx, mwdry, mwco2 )
9452 return
9453 end subroutine radini
9454 subroutine radinp(lchnk ,ncol , pcols, pver, pverp, &
9455 pmid ,pint ,o3vmr , pmidrd ,&
9456 pintrd ,eccf ,o3mmr )
9457 !-----------------------------------------------------------------------
9458 !
9459 ! Purpose:
9460 ! Set latitude and time dependent arrays for input to solar
9461 ! and longwave radiation.
9462 ! Convert model pressures to cgs, and compute ozone mixing ratio, needed for
9463 ! the solar radiation.
9464 !
9465 ! Method:
9466 ! <Describe the algorithm(s) used in the routine.>
9467 ! <Also include any applicable external references.>
9468 !
9469 ! Author: CCM1, CMS Contact J. Kiehl
9470 !
9471 !-----------------------------------------------------------------------
9472 ! use shr_kind_mod, only: r8 => shr_kind_r8
9473 ! use ppgrid
9474 ! use time_manager, only: get_curr_calday
9475
9476 implicit none
9477
9478 !------------------------------Arguments--------------------------------
9479 !
9480 ! Input arguments
9481 !
9482 integer, intent(in) :: lchnk ! chunk identifier
9483 integer, intent(in) :: pcols, pver, pverp
9484 integer, intent(in) :: ncol ! number of atmospheric columns
9485
9486 real(r8), intent(in) :: pmid(pcols,pver) ! Pressure at model mid-levels (pascals)
9487 real(r8), intent(in) :: pint(pcols,pverp) ! Pressure at model interfaces (pascals)
9488 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
9489 !
9490 ! Output arguments
9491 !
9492 real(r8), intent(out) :: pmidrd(pcols,pver) ! Pressure at mid-levels (dynes/cm*2)
9493 real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2)
9494 real(r8), intent(out) :: eccf ! Earth-sun distance factor
9495 real(r8), intent(out) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
9496
9497 !
9498 !---------------------------Local variables-----------------------------
9499 !
9500 integer i ! Longitude loop index
9501 integer k ! Vertical loop index
9502
9503 real(r8) :: calday ! current calendar day
9504 real(r8) amd ! Effective molecular weight of dry air (g/mol)
9505 real(r8) amo ! Molecular weight of ozone (g/mol)
9506 real(r8) vmmr ! Ozone volume mixing ratio
9507 real(r8) delta ! Solar declination angle
9508
9509 save amd ,amo
9510
9511 data amd / 28.9644 /
9512 data amo / 48.0000 /
9513 !
9514 !-----------------------------------------------------------------------
9515 !
9516 ! calday = get_curr_calday()
9517 eccf = 1. ! declared intent(out) so fill a value (not used in WRF)
9518 ! call shr_orb_decl (calday ,eccen ,mvelpp ,lambm0 ,obliqr , &
9519 ! delta ,eccf)
9520
9521 !
9522 ! Convert pressure from pascals to dynes/cm2
9523 !
9524 do k=1,pver
9525 do i=1,ncol
9526 pmidrd(i,k) = pmid(i,k)*10.0
9527 pintrd(i,k) = pint(i,k)*10.0
9528 end do
9529 end do
9530 do i=1,ncol
9531 pintrd(i,pverp) = pint(i,pverp)*10.0
9532 end do
9533 !
9534 ! Convert ozone volume mixing ratio to mass mixing ratio:
9535 !
9536 vmmr = amo/amd
9537 do k=1,pver
9538 do i=1,ncol
9539 o3mmr(i,k) = vmmr*o3vmr(i,k)
9540 end do
9541 end do
9542 !
9543 return
9544 end subroutine radinp
9545 subroutine radoz2(lchnk ,ncol ,pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
9546 !-----------------------------------------------------------------------
9547 !
9548 ! Purpose:
9549 ! Computes the path length integrals to the model interfaces given the
9550 ! ozone volume mixing ratio
9551 !
9552 ! Method:
9553 ! <Describe the algorithm(s) used in the routine.>
9554 ! <Also include any applicable external references.>
9555 !
9556 ! Author: CCM1, CMS Contact J. Kiehl
9557 !
9558 !-----------------------------------------------------------------------
9559 ! use shr_kind_mod, only: r8 => shr_kind_r8
9560 ! use ppgrid
9561 ! use comozp
9562
9563 implicit none
9564 !------------------------------Input arguments--------------------------
9565 !
9566 integer, intent(in) :: lchnk ! chunk identifier
9567 integer, intent(in) :: ncol ! number of atmospheric columns
9568 integer, intent(in) :: pcols, pver, pverp
9569
9570 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
9571 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
9572
9573 integer, intent(in) :: ntoplw ! topmost level/layer longwave is solved for
9574
9575 !
9576 !----------------------------Output arguments---------------------------
9577 !
9578 real(r8), intent(out) :: plol(pcols,pverp) ! Ozone prs weighted path length (cm)
9579 real(r8), intent(out) :: plos(pcols,pverp) ! Ozone path length (cm)
9580
9581 !
9582 !---------------------------Local workspace-----------------------------
9583 !
9584 integer i ! longitude index
9585 integer k ! level index
9586 !
9587 !-----------------------------------------------------------------------
9588 !
9589 ! Evaluate the ozone path length integrals to interfaces;
9590 ! factors of .1 and .01 to convert pressures from cgs to mks:
9591 !
9592 do i=1,ncol
9593 plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw)
9594 plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw)
9595 end do
9596 do k=ntoplw+1,pverp
9597 do i=1,ncol
9598 plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1))
9599 plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* &
9600 (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1))
9601 end do
9602 end do
9603 !
9604 return
9605 end subroutine radoz2
9606
9607
9608 subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr)
9609 !-----------------------------------------------------------------------
9610 !
9611 ! Purpose: Interpolate ozone from current time-interpolated values to model levels
9612 !
9613 ! Method: Use pressure values to determine interpolation levels
9614 !
9615 ! Author: Bruce Briegleb
9616 !
9617 !--------------------------------------------------------------------------
9618 ! use shr_kind_mod, only: r8 => shr_kind_r8
9619 ! use ppgrid
9620 ! use phys_grid, only: get_lat_all_p, get_lon_all_p
9621 ! use comozp
9622 ! use abortutils, only: endrun
9623 !--------------------------------------------------------------------------
9624 implicit none
9625 !--------------------------------------------------------------------------
9626 !
9627 ! Arguments
9628 !
9629 integer, intent(in) :: lchnk ! chunk identifier
9630 integer, intent(in) :: pcols, pver
9631 integer, intent(in) :: ncol ! number of atmospheric columns
9632 integer, intent(in) :: levsiz ! number of ozone layers
9633
9634 real(r8), intent(in) :: pmid(pcols,pver) ! level pressures (mks)
9635 real(r8), intent(in) :: pin(levsiz) ! ozone data level pressures (mks)
9636 real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio
9637
9638 real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
9639 !
9640 ! local storage
9641 !
9642 integer i ! longitude index
9643 integer k, kk, kkstart ! level indices
9644 integer kupper(pcols) ! Level indices for interpolation
9645 integer kount ! Counter
9646 integer lats(pcols) ! latitude indices
9647 integer lons(pcols) ! latitude indices
9648
9649 real(r8) dpu ! upper level pressure difference
9650 real(r8) dpl ! lower level pressure difference
9651 !
9652 ! Initialize latitude indices
9653 !
9654 ! call get_lat_all_p(lchnk, ncol, lats)
9655 ! call get_lon_all_p(lchnk, ncol, lons)
9656 !
9657 ! Initialize index array
9658 !
9659 do i=1,ncol
9660 kupper(i) = 1
9661 end do
9662
9663 do k=1,pver
9664 !
9665 ! Top level we need to start looking is the top level for the previous k
9666 ! for all longitude points
9667 !
9668 kkstart = levsiz
9669 do i=1,ncol
9670 kkstart = min0(kkstart,kupper(i))
9671 end do
9672 kount = 0
9673 !
9674 ! Store level indices for interpolation
9675 !
9676 do kk=kkstart,levsiz-1
9677 do i=1,ncol
9678 if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then
9679 kupper(i) = kk
9680 kount = kount + 1
9681 end if
9682 end do
9683 !
9684 ! If all indices for this level have been found, do the interpolation and
9685 ! go to the next level
9686 !
9687 if (kount.eq.ncol) then
9688 do i=1,ncol
9689 dpu = pmid(i,k) - pin(kupper(i))
9690 dpl = pin(kupper(i)+1) - pmid(i,k)
9691 o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
9692 ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
9693 end do
9694 goto 35
9695 end if
9696 end do
9697 !
9698 ! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
9699 ! must extrapolate from the bottom or top ozone data level for at least some
9700 ! of the longitude points.
9701 !
9702 do i=1,ncol
9703 if (pmid(i,k) .lt. pin(1)) then
9704 o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1)
9705 else if (pmid(i,k) .gt. pin(levsiz)) then
9706 o3vmr(i,k) = ozmix(i,levsiz)
9707 else
9708 dpu = pmid(i,k) - pin(kupper(i))
9709 dpl = pin(kupper(i)+1) - pmid(i,k)
9710 o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
9711 ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
9712 end if
9713 end do
9714
9715 if (kount.gt.ncol) then
9716 ! call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected')
9717 end if
9718 35 continue
9719 end do
9720
9721 return
9722 end subroutine radozn
9723
9724
9725 subroutine sortarray(n, ain, indxa)
9726 !-----------------------------------------------
9727 !
9728 ! Purpose:
9729 ! Sort an array
9730 ! Alogrithm:
9731 ! Based on Shell's sorting method.
9732 !
9733 ! Author: T. Craig
9734 !-----------------------------------------------
9735 ! use shr_kind_mod, only: r8 => shr_kind_r8
9736 implicit none
9737 !
9738 ! Arguments
9739 !
9740 integer , intent(in) :: n ! total number of elements
9741 integer , intent(inout) :: indxa(n) ! array of integers
9742 real(r8), intent(inout) :: ain(n) ! array to sort
9743 !
9744 ! local variables
9745 !
9746 integer :: i, j ! Loop indices
9747 integer :: ni ! Starting increment
9748 integer :: itmp ! Temporary index
9749 real(r8):: atmp ! Temporary value to swap
9750
9751 ni = 1
9752 do while(.TRUE.)
9753 ni = 3*ni + 1
9754 if (ni <= n) cycle
9755 exit
9756 end do
9757
9758 do while(.TRUE.)
9759 ni = ni/3
9760 do i = ni + 1, n
9761 atmp = ain(i)
9762 itmp = indxa(i)
9763 j = i
9764 do while(.TRUE.)
9765 if (ain(j-ni) <= atmp) exit
9766 ain(j) = ain(j-ni)
9767 indxa(j) = indxa(j-ni)
9768 j = j - ni
9769 if (j > ni) cycle
9770 exit
9771 end do
9772 ain(j) = atmp
9773 indxa(j) = itmp
9774 end do
9775 if (ni > 1) cycle
9776 exit
9777 end do
9778 return
9779
9780 end subroutine sortarray
9781 subroutine trcab(lchnk ,ncol ,pcols, pverp, &
9782 k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
9783 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
9784 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
9785 bch4 ,to3co2 ,pnm ,dw ,pnew , &
9786 s2c ,uptype ,dplh2o ,abplnk1 ,tco2 , &
9787 th2o ,to3 ,abstrc , &
9788 aer_trn_ttl)
9789 !-----------------------------------------------------------------------
9790 !
9791 ! Purpose:
9792 ! Calculate absorptivity for non nearest layers for CH4, N2O, CFC11 and
9793 ! CFC12.
9794 !
9795 ! Method:
9796 ! See CCM3 description for equations.
9797 !
9798 ! Author: J. Kiehl
9799 !
9800 !-----------------------------------------------------------------------
9801 ! use shr_kind_mod, only: r8 => shr_kind_r8
9802 ! use ppgrid
9803 ! use volcrad
9804
9805 implicit none
9806
9807 !------------------------------Arguments--------------------------------
9808 !
9809 ! Input arguments
9810 !
9811 integer, intent(in) :: lchnk ! chunk identifier
9812 integer, intent(in) :: ncol ! number of atmospheric columns
9813 integer, intent(in) :: pcols, pverp
9814 integer, intent(in) :: k1,k2 ! level indices
9815 !
9816 real(r8), intent(in) :: to3co2(pcols) ! pressure weighted temperature
9817 real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressures
9818 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
9819 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
9820 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
9821 !
9822 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
9823 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
9824 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
9825 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
9826 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
9827 !
9828 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
9829 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
9830 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
9831 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
9832 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
9833 !
9834 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
9835 real(r8), intent(in) :: dw(pcols) ! h2o path length
9836 real(r8), intent(in) :: pnew(pcols) ! pressure
9837 real(r8), intent(in) :: s2c(pcols,pverp) ! continuum path length
9838 real(r8), intent(in) :: uptype(pcols,pverp) ! p-type h2o path length
9839 !
9840 real(r8), intent(in) :: dplh2o(pcols) ! p squared h2o path length
9841 real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! Planck factor
9842 real(r8), intent(in) :: tco2(pcols) ! co2 transmission factor
9843 real(r8), intent(in) :: th2o(pcols) ! h2o transmission factor
9844 real(r8), intent(in) :: to3(pcols) ! o3 transmission factor
9845
9846 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
9847
9848 !
9849 ! Output Arguments
9850 !
9851 real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
9852 !
9853 !--------------------------Local Variables------------------------------
9854 !
9855 integer i,l ! loop counters
9856
9857 real(r8) sqti(pcols) ! square root of mean temp
9858 real(r8) du1 ! cfc11 path length
9859 real(r8) du2 ! cfc12 path length
9860 real(r8) acfc1 ! cfc11 absorptivity 798 cm-1
9861 real(r8) acfc2 ! cfc11 absorptivity 846 cm-1
9862 !
9863 real(r8) acfc3 ! cfc11 absorptivity 933 cm-1
9864 real(r8) acfc4 ! cfc11 absorptivity 1085 cm-1
9865 real(r8) acfc5 ! cfc12 absorptivity 889 cm-1
9866 real(r8) acfc6 ! cfc12 absorptivity 923 cm-1
9867 real(r8) acfc7 ! cfc12 absorptivity 1102 cm-1
9868 !
9869 real(r8) acfc8 ! cfc12 absorptivity 1161 cm-1
9870 real(r8) du01 ! n2o path length
9871 real(r8) dbeta01 ! n2o pressure factor
9872 real(r8) dbeta11 ! "
9873 real(r8) an2o1 ! absorptivity of 1285 cm-1 n2o band
9874 !
9875 real(r8) du02 ! n2o path length
9876 real(r8) dbeta02 ! n2o pressure factor
9877 real(r8) an2o2 ! absorptivity of 589 cm-1 n2o band
9878 real(r8) du03 ! n2o path length
9879 real(r8) dbeta03 ! n2o pressure factor
9880 !
9881 real(r8) an2o3 ! absorptivity of 1168 cm-1 n2o band
9882 real(r8) duch4 ! ch4 path length
9883 real(r8) dbetac ! ch4 pressure factor
9884 real(r8) ach4 ! absorptivity of 1306 cm-1 ch4 band
9885 real(r8) du11 ! co2 path length
9886 !
9887 real(r8) du12 ! "
9888 real(r8) du13 ! "
9889 real(r8) dbetc1 ! co2 pressure factor
9890 real(r8) dbetc2 ! co2 pressure factor
9891 real(r8) aco21 ! absorptivity of 1064 cm-1 band
9892 !
9893 real(r8) du21 ! co2 path length
9894 real(r8) du22 ! "
9895 real(r8) du23 ! "
9896 real(r8) aco22 ! absorptivity of 961 cm-1 band
9897 real(r8) tt(pcols) ! temp. factor for h2o overlap factor
9898 !
9899 real(r8) psi1 ! "
9900 real(r8) phi1 ! "
9901 real(r8) p1 ! h2o overlap factor
9902 real(r8) w1 ! "
9903 real(r8) ds2c(pcols) ! continuum path length
9904 !
9905 real(r8) duptyp(pcols) ! p-type path length
9906 real(r8) tw(pcols,6) ! h2o transmission factor
9907 real(r8) g1(6) ! "
9908 real(r8) g2(6) ! "
9909 real(r8) g3(6) ! "
9910 !
9911 real(r8) g4(6) ! "
9912 real(r8) ab(6) ! h2o temp. factor
9913 real(r8) bb(6) ! "
9914 real(r8) abp(6) ! "
9915 real(r8) bbp(6) ! "
9916 !
9917 real(r8) tcfc3 ! transmission for cfc11 band
9918 real(r8) tcfc4 ! transmission for cfc11 band
9919 real(r8) tcfc6 ! transmission for cfc12 band
9920 real(r8) tcfc7 ! transmission for cfc12 band
9921 real(r8) tcfc8 ! transmission for cfc12 band
9922 !
9923 real(r8) tlw ! h2o transmission
9924 real(r8) tch4 ! ch4 transmission
9925 !
9926 !--------------------------Data Statements------------------------------
9927 !
9928 data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
9929 data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
9930 data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
9931 data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
9932 data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
9933 data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
9934 data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
9935 data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
9936 !
9937 !--------------------------Statement Functions--------------------------
9938 !
9939 real(r8) func, u, b
9940 func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
9941 !
9942 !------------------------------------------------------------------------
9943 !
9944 do i = 1,ncol
9945 sqti(i) = sqrt(to3co2(i))
9946 !
9947 ! h2o transmission
9948 !
9949 tt(i) = abs(to3co2(i) - 250.0)
9950 ds2c(i) = abs(s2c(i,k1) - s2c(i,k2))
9951 duptyp(i) = abs(uptype(i,k1) - uptype(i,k2))
9952 end do
9953 !
9954 do l = 1,6
9955 do i = 1,ncol
9956 psi1 = exp(abp(l)*tt(i) + bbp(l)*tt(i)*tt(i))
9957 phi1 = exp(ab(l)*tt(i) + bb(l)*tt(i)*tt(i))
9958 p1 = pnew(i)*(psi1/phi1)/sslp
9959 w1 = dw(i)*phi1
9960 tw(i,l) = exp(-g1(l)*p1*(sqrt(1.0 + g2(l)*(w1/p1)) - 1.0) - &
9961 g3(l)*ds2c(i)-g4(l)*duptyp(i))
9962 end do
9963 end do
9964 !
9965 do i=1,ncol
9966 tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
9967 0.3*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000))
9968 tw(i,2)=tw(i,2)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
9969 tw(i,3)=tw(i,3)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
9970 tw(i,4)=tw(i,4)*aer_trn_ttl(i,k1,k2,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
9971 tw(i,5)=tw(i,5)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
9972 tw(i,6)=tw(i,6)*aer_trn_ttl(i,k1,k2,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
9973 end do ! end loop over lon
9974 do i = 1,ncol
9975 du1 = abs(ucfc11(i,k1) - ucfc11(i,k2))
9976 du2 = abs(ucfc12(i,k1) - ucfc12(i,k2))
9977 !
9978 ! cfc transmissions
9979 !
9980 tcfc3 = exp(-175.005*du1)
9981 tcfc4 = exp(-1202.18*du1)
9982 tcfc6 = exp(-5786.73*du2)
9983 tcfc7 = exp(-2873.51*du2)
9984 tcfc8 = exp(-2085.59*du2)
9985 !
9986 ! Absorptivity for CFC11 bands
9987 !
9988 acfc1 = 50.0*(1.0 - exp(-54.09*du1))*tw(i,1)*abplnk1(7,i,k2)
9989 acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*abplnk1(8,i,k2)
9990 acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*abplnk1(9,i,k2)
9991 acfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*abplnk1(10,i,k2)
9992 !
9993 ! Absorptivity for CFC12 bands
9994 !
9995 acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*abplnk1(11,i,k2)
9996 acfc6 = 50.0*(1.0 - tcfc6)* tw(i,4) * abplnk1(12,i,k2)
9997 acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5) * tcfc4*abplnk1(13,i,k2)
9998 acfc8 = 70.0*(1.0 - tcfc8)* tw(i,6) * abplnk1(14,i,k2)
9999 !
10000 ! Emissivity for CH4 band 1306 cm-1
10001 !
10002 tlw = exp(-1.0*sqrt(dplh2o(i)))
10003 tlw=tlw*aer_trn_ttl(i,k1,k2,idx_LW_1200_2000)
10004 duch4 = abs(uch4(i,k1) - uch4(i,k2))
10005 dbetac = abs(bch4(i,k1) - bch4(i,k2))/duch4
10006 ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac))*tlw*abplnk1(3,i,k2)
10007 tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
10008 !
10009 ! Absorptivity for N2O bands
10010 !
10011 du01 = abs(un2o0(i,k1) - un2o0(i,k2))
10012 du11 = abs(un2o1(i,k1) - un2o1(i,k2))
10013 dbeta01 = abs(bn2o0(i,k1) - bn2o0(i,k2))/du01
10014 dbeta11 = abs(bn2o1(i,k1) - bn2o1(i,k2))/du11
10015 !
10016 ! 1285 cm-1 band
10017 !
10018 an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
10019 + func(du11,dbeta11))*tlw*tch4*abplnk1(4,i,k2)
10020 du02 = 0.100090*du01
10021 du12 = 0.0992746*du11
10022 dbeta02 = 0.964282*dbeta01
10023 !
10024 ! 589 cm-1 band
10025 !
10026 an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) + &
10027 func(du12,dbeta02))*th2o(i)*tco2(i)*abplnk1(5,i,k2)
10028 du03 = 0.0333767*du01
10029 dbeta03 = 0.982143*dbeta01
10030 !
10031 ! 1168 cm-1 band
10032 !
10033 an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03))* &
10034 tw(i,6)*tcfc8*abplnk1(6,i,k2)
10035 !
10036 ! Emissivity for 1064 cm-1 band of CO2
10037 !
10038 du11 = abs(uco211(i,k1) - uco211(i,k2))
10039 du12 = abs(uco212(i,k1) - uco212(i,k2))
10040 du13 = abs(uco213(i,k1) - uco213(i,k2))
10041 dbetc1 = 2.97558*abs(pnm(i,k1) + pnm(i,k2))/(2.0*sslp*sqti(i))
10042 dbetc2 = 2.0*dbetc1
10043 aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
10044 + func(du12,dbetc2) + func(du13,dbetc2)) &
10045 *to3(i)*tw(i,5)*tcfc4*tcfc7*abplnk1(2,i,k2)
10046 !
10047 ! Emissivity for 961 cm-1 band
10048 !
10049 du21 = abs(uco221(i,k1) - uco221(i,k2))
10050 du22 = abs(uco222(i,k1) - uco222(i,k2))
10051 du23 = abs(uco223(i,k1) - uco223(i,k2))
10052 aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
10053 + func(du22,dbetc1) + func(du23,dbetc2)) &
10054 *tw(i,4)*tcfc3*tcfc6*abplnk1(1,i,k2)
10055 !
10056 ! total trace gas absorptivity
10057 !
10058 abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
10059 acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
10060 aco21 + aco22
10061 end do
10062 !
10063 return
10064 !
10065 end subroutine trcab
10066
10067
10068
10069 subroutine trcabn(lchnk ,ncol ,pcols, pverp, &
10070 k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
10071 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
10072 uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
10073 winpl ,pinpl ,tco2 ,th2o ,to3 , &
10074 uptype ,dw ,s2c ,up2 ,pnew , &
10075 abstrc ,uinpl , &
10076 aer_trn_ngh)
10077 !-----------------------------------------------------------------------
10078 !
10079 ! Purpose:
10080 ! Calculate nearest layer absorptivity due to CH4, N2O, CFC11 and CFC12
10081 !
10082 ! Method:
10083 ! Equations in CCM3 description
10084 !
10085 ! Author: J. Kiehl
10086 !
10087 !-----------------------------------------------------------------------
10088 !
10089 ! use shr_kind_mod, only: r8 => shr_kind_r8
10090 ! use ppgrid
10091 ! use volcrad
10092
10093 implicit none
10094
10095 !------------------------------Arguments--------------------------------
10096 !
10097 ! Input arguments
10098 !
10099 integer, intent(in) :: lchnk ! chunk identifier
10100 integer, intent(in) :: ncol ! number of atmospheric columns
10101 integer, intent(in) :: pcols, pverp
10102 integer, intent(in) :: k2 ! level index
10103 integer, intent(in) :: kn ! level index
10104 !
10105 real(r8), intent(in) :: tbar(pcols,4) ! pressure weighted temperature
10106 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
10107 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
10108 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
10109 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
10110 !
10111 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
10112 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
10113 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
10114 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
10115 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
10116 !
10117 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
10118 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
10119 real(r8), intent(in) :: bplnk(14,pcols,4) ! weighted Planck fnc. for absorptivity
10120 real(r8), intent(in) :: winpl(pcols,4) ! fractional path length
10121 real(r8), intent(in) :: pinpl(pcols,4) ! pressure factor for subdivided layer
10122 !
10123 real(r8), intent(in) :: tco2(pcols) ! co2 transmission
10124 real(r8), intent(in) :: th2o(pcols) ! h2o transmission
10125 real(r8), intent(in) :: to3(pcols) ! o3 transmission
10126 real(r8), intent(in) :: dw(pcols) ! h2o path length
10127 real(r8), intent(in) :: pnew(pcols) ! pressure factor
10128 !
10129 real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum factor
10130 real(r8), intent(in) :: uptype(pcols,pverp) ! p-type path length
10131 real(r8), intent(in) :: up2(pcols) ! p squared path length
10132 real(r8), intent(in) :: uinpl(pcols,4) ! Nearest layer subdivision factor
10133 real(r8), intent(in) :: aer_trn_ngh(pcols,bnd_nbr_LW)
10134 ! [fraction] Total transmission between
10135 ! nearest neighbor sub-levels
10136 !
10137 ! Output Arguments
10138 !
10139 real(r8), intent(out) :: abstrc(pcols) ! total trace gas absorptivity
10140
10141 !
10142 !--------------------------Local Variables------------------------------
10143 !
10144 integer i,l ! loop counters
10145 !
10146 real(r8) sqti(pcols) ! square root of mean temp
10147 real(r8) rsqti(pcols) ! reciprocal of sqti
10148 real(r8) du1 ! cfc11 path length
10149 real(r8) du2 ! cfc12 path length
10150 real(r8) acfc1 ! absorptivity of cfc11 798 cm-1 band
10151 !
10152 real(r8) acfc2 ! absorptivity of cfc11 846 cm-1 band
10153 real(r8) acfc3 ! absorptivity of cfc11 933 cm-1 band
10154 real(r8) acfc4 ! absorptivity of cfc11 1085 cm-1 band
10155 real(r8) acfc5 ! absorptivity of cfc11 889 cm-1 band
10156 real(r8) acfc6 ! absorptivity of cfc11 923 cm-1 band
10157 !
10158 real(r8) acfc7 ! absorptivity of cfc11 1102 cm-1 band
10159 real(r8) acfc8 ! absorptivity of cfc11 1161 cm-1 band
10160 real(r8) du01 ! n2o path length
10161 real(r8) dbeta01 ! n2o pressure factors
10162 real(r8) dbeta11 ! "
10163 !
10164 real(r8) an2o1 ! absorptivity of the 1285 cm-1 n2o band
10165 real(r8) du02 ! n2o path length
10166 real(r8) dbeta02 ! n2o pressure factor
10167 real(r8) an2o2 ! absorptivity of the 589 cm-1 n2o band
10168 real(r8) du03 ! n2o path length
10169 !
10170 real(r8) dbeta03 ! n2o pressure factor
10171 real(r8) an2o3 ! absorptivity of the 1168 cm-1 n2o band
10172 real(r8) duch4 ! ch4 path length
10173 real(r8) dbetac ! ch4 pressure factor
10174 real(r8) ach4 ! absorptivity of the 1306 cm-1 ch4 band
10175 !
10176 real(r8) du11 ! co2 path length
10177 real(r8) du12 ! "
10178 real(r8) du13 ! "
10179 real(r8) dbetc1 ! co2 pressure factor
10180 real(r8) dbetc2 ! co2 pressure factor
10181 !
10182 real(r8) aco21 ! absorptivity of the 1064 cm-1 co2 band
10183 real(r8) du21 ! co2 path length
10184 real(r8) du22 ! "
10185 real(r8) du23 ! "
10186 real(r8) aco22 ! absorptivity of the 961 cm-1 co2 band
10187 !
10188 real(r8) tt(pcols) ! temp. factor for h2o overlap
10189 real(r8) psi1 ! "
10190 real(r8) phi1 ! "
10191 real(r8) p1 ! factor for h2o overlap
10192 real(r8) w1 ! "
10193 !
10194 real(r8) ds2c(pcols) ! continuum path length
10195 real(r8) duptyp(pcols) ! p-type path length
10196 real(r8) tw(pcols,6) ! h2o transmission overlap
10197 real(r8) g1(6) ! h2o overlap factor
10198 real(r8) g2(6) ! "
10199 !
10200 real(r8) g3(6) ! "
10201 real(r8) g4(6) ! "
10202 real(r8) ab(6) ! h2o temp. factor
10203 real(r8) bb(6) ! "
10204 real(r8) abp(6) ! "
10205 !
10206 real(r8) bbp(6) ! "
10207 real(r8) tcfc3 ! transmission of cfc11 band
10208 real(r8) tcfc4 ! transmission of cfc11 band
10209 real(r8) tcfc6 ! transmission of cfc12 band
10210 real(r8) tcfc7 ! "
10211 !
10212 real(r8) tcfc8 ! "
10213 real(r8) tlw ! h2o transmission
10214 real(r8) tch4 ! ch4 transmission
10215 !
10216 !--------------------------Data Statements------------------------------
10217 !
10218 data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
10219 data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
10220 data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
10221 data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
10222 data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
10223 data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
10224 data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
10225 data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
10226 !
10227 !--------------------------Statement Functions--------------------------
10228 !
10229 real(r8) func, u, b
10230 func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
10231 !
10232 !------------------------------------------------------------------
10233 !
10234 do i = 1,ncol
10235 sqti(i) = sqrt(tbar(i,kn))
10236 rsqti(i) = 1. / sqti(i)
10237 !
10238 ! h2o transmission
10239 !
10240 tt(i) = abs(tbar(i,kn) - 250.0)
10241 ds2c(i) = abs(s2c(i,k2+1) - s2c(i,k2))*uinpl(i,kn)
10242 duptyp(i) = abs(uptype(i,k2+1) - uptype(i,k2))*uinpl(i,kn)
10243 end do
10244 !
10245 do l = 1,6
10246 do i = 1,ncol
10247 psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
10248 phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
10249 p1 = pnew(i) * (psi1/phi1) / sslp
10250 w1 = dw(i) * winpl(i,kn) * phi1
10251 tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
10252 - g3(l)*ds2c(i)-g4(l)*duptyp(i))
10253 end do
10254 end do
10255 !
10256 do i=1,ncol
10257 tw(i,1)=tw(i,1)*(0.7*aer_trn_ngh(i,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
10258 0.3*aer_trn_ngh(i,idx_LW_0800_1000))
10259 tw(i,2)=tw(i,2)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
10260 tw(i,3)=tw(i,3)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
10261 tw(i,4)=tw(i,4)*aer_trn_ngh(i,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
10262 tw(i,5)=tw(i,5)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
10263 tw(i,6)=tw(i,6)*aer_trn_ngh(i,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
10264 end do ! end loop over lon
10265
10266 do i = 1,ncol
10267 !
10268 du1 = abs(ucfc11(i,k2+1) - ucfc11(i,k2)) * winpl(i,kn)
10269 du2 = abs(ucfc12(i,k2+1) - ucfc12(i,k2)) * winpl(i,kn)
10270 !
10271 ! cfc transmissions
10272 !
10273 tcfc3 = exp(-175.005*du1)
10274 tcfc4 = exp(-1202.18*du1)
10275 tcfc6 = exp(-5786.73*du2)
10276 tcfc7 = exp(-2873.51*du2)
10277 tcfc8 = exp(-2085.59*du2)
10278 !
10279 ! Absorptivity for CFC11 bands
10280 !
10281 acfc1 = 50.0*(1.0 - exp(-54.09*du1)) * tw(i,1)*bplnk(7,i,kn)
10282 acfc2 = 60.0*(1.0 - exp(-5130.03*du1))*tw(i,2)*bplnk(8,i,kn)
10283 acfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6 * bplnk(9,i,kn)
10284 acfc4 = 100.0*(1.0 - tcfc4)* tw(i,5) * bplnk(10,i,kn)
10285 !
10286 ! Absorptivity for CFC12 bands
10287 !
10288 acfc5 = 45.0*(1.0 - exp(-1272.35*du2))*tw(i,3)*bplnk(11,i,kn)
10289 acfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*bplnk(12,i,kn)
10290 acfc7 = 80.0*(1.0 - tcfc7)* tw(i,5)*tcfc4 *bplnk(13,i,kn)
10291 acfc8 = 70.0*(1.0 - tcfc8)*tw(i,6)*bplnk(14,i,kn)
10292 !
10293 ! Absorptivity for CH4 band 1306 cm-1
10294 !
10295 tlw = exp(-1.0*sqrt(up2(i)))
10296 tlw=tlw*aer_trn_ngh(i,idx_LW_1200_2000)
10297 duch4 = abs(uch4(i,k2+1) - uch4(i,k2)) * winpl(i,kn)
10298 dbetac = 2.94449 * pinpl(i,kn) * rsqti(i) / sslp
10299 ach4 = 6.00444*sqti(i)*log(1.0 + func(duch4,dbetac)) * tlw * bplnk(3,i,kn)
10300 tch4 = 1.0/(1.0 + 0.02*func(duch4,dbetac))
10301 !
10302 ! Absorptivity for N2O bands
10303 !
10304 du01 = abs(un2o0(i,k2+1) - un2o0(i,k2)) * winpl(i,kn)
10305 du11 = abs(un2o1(i,k2+1) - un2o1(i,k2)) * winpl(i,kn)
10306 dbeta01 = 19.399 * pinpl(i,kn) * rsqti(i) / sslp
10307 dbeta11 = dbeta01
10308 !
10309 ! 1285 cm-1 band
10310 !
10311 an2o1 = 2.35558*sqti(i)*log(1.0 + func(du01,dbeta01) &
10312 + func(du11,dbeta11)) * tlw * tch4 * bplnk(4,i,kn)
10313 du02 = 0.100090*du01
10314 du12 = 0.0992746*du11
10315 dbeta02 = 0.964282*dbeta01
10316 !
10317 ! 589 cm-1 band
10318 !
10319 an2o2 = 2.65581*sqti(i)*log(1.0 + func(du02,dbeta02) &
10320 + func(du12,dbeta02)) * tco2(i) * th2o(i) * bplnk(5,i,kn)
10321 du03 = 0.0333767*du01
10322 dbeta03 = 0.982143*dbeta01
10323 !
10324 ! 1168 cm-1 band
10325 !
10326 an2o3 = 2.54034*sqti(i)*log(1.0 + func(du03,dbeta03)) * &
10327 tw(i,6) * tcfc8 * bplnk(6,i,kn)
10328 !
10329 ! Absorptivity for 1064 cm-1 band of CO2
10330 !
10331 du11 = abs(uco211(i,k2+1) - uco211(i,k2)) * winpl(i,kn)
10332 du12 = abs(uco212(i,k2+1) - uco212(i,k2)) * winpl(i,kn)
10333 du13 = abs(uco213(i,k2+1) - uco213(i,k2)) * winpl(i,kn)
10334 dbetc1 = 2.97558 * pinpl(i,kn) * rsqti(i) / sslp
10335 dbetc2 = 2.0 * dbetc1
10336 aco21 = 3.7571*sqti(i)*log(1.0 + func(du11,dbetc1) &
10337 + func(du12,dbetc2) + func(du13,dbetc2)) &
10338 * to3(i) * tw(i,5) * tcfc4 * tcfc7 * bplnk(2,i,kn)
10339 !
10340 ! Absorptivity for 961 cm-1 band of co2
10341 !
10342 du21 = abs(uco221(i,k2+1) - uco221(i,k2)) * winpl(i,kn)
10343 du22 = abs(uco222(i,k2+1) - uco222(i,k2)) * winpl(i,kn)
10344 du23 = abs(uco223(i,k2+1) - uco223(i,k2)) * winpl(i,kn)
10345 aco22 = 3.8443*sqti(i)*log(1.0 + func(du21,dbetc1) &
10346 + func(du22,dbetc1) + func(du23,dbetc2)) &
10347 * tw(i,4) * tcfc3 * tcfc6 * bplnk(1,i,kn)
10348 !
10349 ! total trace gas absorptivity
10350 !
10351 abstrc(i) = acfc1 + acfc2 + acfc3 + acfc4 + acfc5 + acfc6 + &
10352 acfc7 + acfc8 + an2o1 + an2o2 + an2o3 + ach4 + &
10353 aco21 + aco22
10354 end do
10355 !
10356 return
10357 !
10358 end subroutine trcabn
10359
10360
10361
10362
10363
10364 subroutine trcems(lchnk ,ncol ,pcols, pverp, &
10365 k ,co2t ,pnm ,ucfc11 ,ucfc12 , &
10366 un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
10367 bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
10368 uco222 ,uco223 ,uptype ,w ,s2c , &
10369 up2 ,emplnk ,th2o ,tco2 ,to3 , &
10370 emstrc , &
10371 aer_trn_ttl)
10372 !-----------------------------------------------------------------------
10373 !
10374 ! Purpose:
10375 ! Calculate emissivity for CH4, N2O, CFC11 and CFC12 bands.
10376 !
10377 ! Method:
10378 ! See CCM3 Description for equations.
10379 !
10380 ! Author: J. Kiehl
10381 !
10382 !-----------------------------------------------------------------------
10383 ! use shr_kind_mod, only: r8 => shr_kind_r8
10384 ! use ppgrid
10385 ! use volcrad
10386
10387 implicit none
10388
10389 !
10390 !------------------------------Arguments--------------------------------
10391 !
10392 ! Input arguments
10393 !
10394 integer, intent(in) :: lchnk ! chunk identifier
10395 integer, intent(in) :: ncol ! number of atmospheric columns
10396 integer, intent(in) :: pcols, pverp
10397
10398 real(r8), intent(in) :: co2t(pcols,pverp) ! pressure weighted temperature
10399 real(r8), intent(in) :: pnm(pcols,pverp) ! interface pressure
10400 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
10401 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
10402 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
10403 !
10404 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
10405 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
10406 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
10407 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
10408 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
10409 !
10410 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
10411 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
10412 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
10413 real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
10414 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
10415 !
10416 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
10417 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
10418 real(r8), intent(in) :: emplnk(14,pcols) ! emissivity Planck factor
10419 real(r8), intent(in) :: th2o(pcols) ! water vapor overlap factor
10420 real(r8), intent(in) :: tco2(pcols) ! co2 overlap factor
10421 !
10422 real(r8), intent(in) :: to3(pcols) ! o3 overlap factor
10423 real(r8), intent(in) :: s2c(pcols,pverp) ! h2o continuum path length
10424 real(r8), intent(in) :: w(pcols,pverp) ! h2o path length
10425 real(r8), intent(in) :: up2(pcols) ! pressure squared h2o path length
10426 !
10427 integer, intent(in) :: k ! level index
10428
10429 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
10430
10431 !
10432 ! Output Arguments
10433 !
10434 real(r8), intent(out) :: emstrc(pcols,pverp) ! total trace gas emissivity
10435
10436 !
10437 !--------------------------Local Variables------------------------------
10438 !
10439 integer i,l ! loop counters
10440 !
10441 real(r8) sqti(pcols) ! square root of mean temp
10442 real(r8) ecfc1 ! emissivity of cfc11 798 cm-1 band
10443 real(r8) ecfc2 ! " " " 846 cm-1 band
10444 real(r8) ecfc3 ! " " " 933 cm-1 band
10445 real(r8) ecfc4 ! " " " 1085 cm-1 band
10446 !
10447 real(r8) ecfc5 ! " " cfc12 889 cm-1 band
10448 real(r8) ecfc6 ! " " " 923 cm-1 band
10449 real(r8) ecfc7 ! " " " 1102 cm-1 band
10450 real(r8) ecfc8 ! " " " 1161 cm-1 band
10451 real(r8) u01 ! n2o path length
10452 !
10453 real(r8) u11 ! n2o path length
10454 real(r8) beta01 ! n2o pressure factor
10455 real(r8) beta11 ! n2o pressure factor
10456 real(r8) en2o1 ! emissivity of the 1285 cm-1 N2O band
10457 real(r8) u02 ! n2o path length
10458 !
10459 real(r8) u12 ! n2o path length
10460 real(r8) beta02 ! n2o pressure factor
10461 real(r8) en2o2 ! emissivity of the 589 cm-1 N2O band
10462 real(r8) u03 ! n2o path length
10463 real(r8) beta03 ! n2o pressure factor
10464 !
10465 real(r8) en2o3 ! emissivity of the 1168 cm-1 N2O band
10466 real(r8) betac ! ch4 pressure factor
10467 real(r8) ech4 ! emissivity of 1306 cm-1 CH4 band
10468 real(r8) betac1 ! co2 pressure factor
10469 real(r8) betac2 ! co2 pressure factor
10470 !
10471 real(r8) eco21 ! emissivity of 1064 cm-1 CO2 band
10472 real(r8) eco22 ! emissivity of 961 cm-1 CO2 band
10473 real(r8) tt(pcols) ! temp. factor for h2o overlap factor
10474 real(r8) psi1 ! narrow band h2o temp. factor
10475 real(r8) phi1 ! "
10476 !
10477 real(r8) p1 ! h2o line overlap factor
10478 real(r8) w1 ! "
10479 real(r8) tw(pcols,6) ! h2o transmission overlap
10480 real(r8) g1(6) ! h2o overlap factor
10481 real(r8) g2(6) ! "
10482 !
10483 real(r8) g3(6) ! "
10484 real(r8) g4(6) ! "
10485 real(r8) ab(6) ! "
10486 real(r8) bb(6) ! "
10487 real(r8) abp(6) ! "
10488 !
10489 real(r8) bbp(6) ! "
10490 real(r8) tcfc3 ! transmission for cfc11 band
10491 real(r8) tcfc4 ! "
10492 real(r8) tcfc6 ! transmission for cfc12 band
10493 real(r8) tcfc7 ! "
10494 !
10495 real(r8) tcfc8 ! "
10496 real(r8) tlw ! h2o overlap factor
10497 real(r8) tch4 ! ch4 overlap factor
10498 !
10499 !--------------------------Data Statements------------------------------
10500 !
10501 data g1 /0.0468556,0.0397454,0.0407664,0.0304380,0.0540398,0.0321962/
10502 data g2 /14.4832,4.30242,5.23523,3.25342,0.698935,16.5599/
10503 data g3 /26.1898,18.4476,15.3633,12.1927,9.14992,8.07092/
10504 data g4 /0.0261782,0.0369516,0.0307266,0.0243854,0.0182932,0.0161418/
10505 data ab /3.0857e-2,2.3524e-2,1.7310e-2,2.6661e-2,2.8074e-2,2.2915e-2/
10506 data bb /-1.3512e-4,-6.8320e-5,-3.2609e-5,-1.0228e-5,-9.5743e-5,-1.0304e-4/
10507 data abp/2.9129e-2,2.4101e-2,1.9821e-2,2.6904e-2,2.9458e-2,1.9892e-2/
10508 data bbp/-1.3139e-4,-5.5688e-5,-4.6380e-5,-8.0362e-5,-1.0115e-4,-8.8061e-5/
10509 !
10510 !--------------------------Statement Functions--------------------------
10511 !
10512 real(r8) func, u, b
10513 func(u,b) = u/sqrt(4.0 + u*(1.0 + 1.0 / b))
10514 !
10515 !-----------------------------------------------------------------------
10516 !
10517 do i = 1,ncol
10518 sqti(i) = sqrt(co2t(i,k))
10519 !
10520 ! Transmission for h2o
10521 !
10522 tt(i) = abs(co2t(i,k) - 250.0)
10523 end do
10524 !
10525 do l = 1,6
10526 do i = 1,ncol
10527 psi1 = exp(abp(l)*tt(i)+bbp(l)*tt(i)*tt(i))
10528 phi1 = exp(ab(l)*tt(i)+bb(l)*tt(i)*tt(i))
10529 p1 = pnm(i,k) * (psi1/phi1) / sslp
10530 w1 = w(i,k) * phi1
10531 tw(i,l) = exp(- g1(l)*p1*(sqrt(1.0+g2(l)*(w1/p1))-1.0) &
10532 - g3(l)*s2c(i,k)-g4(l)*uptype(i,k))
10533 end do
10534 end do
10535
10536 ! Overlap H2O tranmission with STRAER continuum in 6 trace gas
10537 ! subbands
10538
10539 do i=1,ncol
10540 tw(i,1)=tw(i,1)*(0.7*aer_trn_ttl(i,k,1,idx_LW_0650_0800)+&! l=1: 0750--0820 cm-1
10541 0.3*aer_trn_ttl(i,k,1,idx_LW_0800_1000))
10542 tw(i,2)=tw(i,2)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=2: 0820--0880 cm-1
10543 tw(i,3)=tw(i,3)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=3: 0880--0900 cm-1
10544 tw(i,4)=tw(i,4)*aer_trn_ttl(i,k,1,idx_LW_0800_1000) ! l=4: 0900--1000 cm-1
10545 tw(i,5)=tw(i,5)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=5: 1000--1120 cm-1
10546 tw(i,6)=tw(i,6)*aer_trn_ttl(i,k,1,idx_LW_1000_1200) ! l=6: 1120--1170 cm-1
10547 end do ! end loop over lon
10548 !
10549 do i = 1,ncol
10550 !
10551 ! transmission due to cfc bands
10552 !
10553 tcfc3 = exp(-175.005*ucfc11(i,k))
10554 tcfc4 = exp(-1202.18*ucfc11(i,k))
10555 tcfc6 = exp(-5786.73*ucfc12(i,k))
10556 tcfc7 = exp(-2873.51*ucfc12(i,k))
10557 tcfc8 = exp(-2085.59*ucfc12(i,k))
10558 !
10559 ! Emissivity for CFC11 bands
10560 !
10561 ecfc1 = 50.0*(1.0 - exp(-54.09*ucfc11(i,k))) * tw(i,1) * emplnk(7,i)
10562 ecfc2 = 60.0*(1.0 - exp(-5130.03*ucfc11(i,k)))* tw(i,2) * emplnk(8,i)
10563 ecfc3 = 60.0*(1.0 - tcfc3)*tw(i,4)*tcfc6*emplnk(9,i)
10564 ecfc4 = 100.0*(1.0 - tcfc4)*tw(i,5)*emplnk(10,i)
10565 !
10566 ! Emissivity for CFC12 bands
10567 !
10568 ecfc5 = 45.0*(1.0 - exp(-1272.35*ucfc12(i,k)))*tw(i,3)*emplnk(11,i)
10569 ecfc6 = 50.0*(1.0 - tcfc6)*tw(i,4)*emplnk(12,i)
10570 ecfc7 = 80.0*(1.0 - tcfc7)*tw(i,5)* tcfc4 * emplnk(13,i)
10571 ecfc8 = 70.0*(1.0 - tcfc8)*tw(i,6) * emplnk(14,i)
10572 !
10573 ! Emissivity for CH4 band 1306 cm-1
10574 !
10575 tlw = exp(-1.0*sqrt(up2(i)))
10576
10577 ! Overlap H2O vibration rotation band with STRAER continuum
10578 ! for CH4 1306 cm-1 and N2O 1285 cm-1 bands
10579
10580 tlw=tlw*aer_trn_ttl(i,k,1,idx_LW_1200_2000)
10581 betac = bch4(i,k)/uch4(i,k)
10582 ech4 = 6.00444*sqti(i)*log(1.0 + func(uch4(i,k),betac)) *tlw * emplnk(3,i)
10583 tch4 = 1.0/(1.0 + 0.02*func(uch4(i,k),betac))
10584 !
10585 ! Emissivity for N2O bands
10586 !
10587 u01 = un2o0(i,k)
10588 u11 = un2o1(i,k)
10589 beta01 = bn2o0(i,k)/un2o0(i,k)
10590 beta11 = bn2o1(i,k)/un2o1(i,k)
10591 !
10592 ! 1285 cm-1 band
10593 !
10594 en2o1 = 2.35558*sqti(i)*log(1.0 + func(u01,beta01) + &
10595 func(u11,beta11))*tlw*tch4*emplnk(4,i)
10596 u02 = 0.100090*u01
10597 u12 = 0.0992746*u11
10598 beta02 = 0.964282*beta01
10599 !
10600 ! 589 cm-1 band
10601 !
10602 en2o2 = 2.65581*sqti(i)*log(1.0 + func(u02,beta02) + &
10603 func(u12,beta02)) * tco2(i) * th2o(i) * emplnk(5,i)
10604 u03 = 0.0333767*u01
10605 beta03 = 0.982143*beta01
10606 !
10607 ! 1168 cm-1 band
10608 !
10609 en2o3 = 2.54034*sqti(i)*log(1.0 + func(u03,beta03)) * &
10610 tw(i,6) * tcfc8 * emplnk(6,i)
10611 !
10612 ! Emissivity for 1064 cm-1 band of CO2
10613 !
10614 betac1 = 2.97558*pnm(i,k) / (sslp*sqti(i))
10615 betac2 = 2.0 * betac1
10616 eco21 = 3.7571*sqti(i)*log(1.0 + func(uco211(i,k),betac1) &
10617 + func(uco212(i,k),betac2) + func(uco213(i,k),betac2)) &
10618 * to3(i) * tw(i,5) * tcfc4 * tcfc7 * emplnk(2,i)
10619 !
10620 ! Emissivity for 961 cm-1 band
10621 !
10622 eco22 = 3.8443*sqti(i)*log(1.0 + func(uco221(i,k),betac1) &
10623 + func(uco222(i,k),betac1) + func(uco223(i,k),betac2)) &
10624 * tw(i,4) * tcfc3 * tcfc6 * emplnk(1,i)
10625 !
10626 ! total trace gas emissivity
10627 !
10628 emstrc(i,k) = ecfc1 + ecfc2 + ecfc3 + ecfc4 + ecfc5 +ecfc6 + &
10629 ecfc7 + ecfc8 + en2o1 + en2o2 + en2o3 + ech4 + &
10630 eco21 + eco22
10631 end do
10632 !
10633 return
10634 !
10635 end subroutine trcems
10636
10637 subroutine trcmix(lchnk ,ncol ,pcols, pver, &
10638 pmid ,clat, n2o ,ch4 , &
10639 cfc11 , cfc12 )
10640 !-----------------------------------------------------------------------
10641 !
10642 ! Purpose:
10643 ! Specify zonal mean mass mixing ratios of CH4, N2O, CFC11 and
10644 ! CFC12
10645 !
10646 ! Method:
10647 ! Distributions assume constant mixing ratio in the troposphere
10648 ! and a decrease of mixing ratio in the stratosphere. Tropopause
10649 ! defined by ptrop. The scale height of the particular trace gas
10650 ! depends on latitude. This assumption produces a more realistic
10651 ! stratospheric distribution of the various trace gases.
10652 !
10653 ! Author: J. Kiehl
10654 !
10655 !-----------------------------------------------------------------------
10656 ! use shr_kind_mod, only: r8 => shr_kind_r8
10657 ! use ppgrid
10658 ! use phys_grid, only: get_rlat_all_p
10659 ! use physconst, only: mwdry, mwch4, mwn2o, mwf11, mwf12
10660 ! use ghg_surfvals, only: ch4vmr, n2ovmr, f11vmr, f12vmr
10661
10662 implicit none
10663
10664 !-----------------------------Arguments---------------------------------
10665 !
10666 ! Input
10667 !
10668 integer, intent(in) :: lchnk ! chunk identifier
10669 integer, intent(in) :: ncol ! number of atmospheric columns
10670 integer, intent(in) :: pcols, pver
10671
10672 real(r8), intent(in) :: pmid(pcols,pver) ! model pressures
10673 real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns
10674 !
10675 ! Output
10676 !
10677 real(r8), intent(out) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio
10678 real(r8), intent(out) :: ch4(pcols,pver) ! methane mass mixing ratio
10679 real(r8), intent(out) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio
10680 real(r8), intent(out) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio
10681
10682 !
10683 !--------------------------Local Variables------------------------------
10684
10685 real(r8) :: rmwn2o ! ratio of molecular weight n2o to dry air
10686 real(r8) :: rmwch4 ! ratio of molecular weight ch4 to dry air
10687 real(r8) :: rmwf11 ! ratio of molecular weight cfc11 to dry air
10688 real(r8) :: rmwf12 ! ratio of molecular weight cfc12 to dry air
10689 !
10690 integer i ! longitude loop index
10691 integer k ! level index
10692 !
10693 ! real(r8) clat(pcols) ! latitude in radians for columns
10694 real(r8) coslat(pcols) ! cosine of latitude
10695 real(r8) dlat ! latitude in degrees
10696 real(r8) ptrop ! pressure level of tropopause
10697 real(r8) pratio ! pressure divided by ptrop
10698 !
10699 real(r8) xn2o ! pressure scale height for n2o
10700 real(r8) xch4 ! pressure scale height for ch4
10701 real(r8) xcfc11 ! pressure scale height for cfc11
10702 real(r8) xcfc12 ! pressure scale height for cfc12
10703 !
10704 real(r8) ch40 ! tropospheric mass mixing ratio for ch4
10705 real(r8) n2o0 ! tropospheric mass mixing ratio for n2o
10706 real(r8) cfc110 ! tropospheric mass mixing ratio for cfc11
10707 real(r8) cfc120 ! tropospheric mass mixing ratio for cfc12
10708 !
10709 !-----------------------------------------------------------------------
10710 rmwn2o = mwn2o/mwdry ! ratio of molecular weight n2o to dry air
10711 rmwch4 = mwch4/mwdry ! ratio of molecular weight ch4 to dry air
10712 rmwf11 = mwf11/mwdry ! ratio of molecular weight cfc11 to dry air
10713 rmwf12 = mwf12/mwdry ! ratio of molecular weight cfc12 to dry air
10714 !
10715 ! get latitudes
10716 !
10717 ! call get_rlat_all_p(lchnk, ncol, clat)
10718 do i = 1, ncol
10719 coslat(i) = cos(clat(i))
10720 end do
10721 !
10722 ! set tropospheric mass mixing ratios
10723 !
10724 ch40 = rmwch4 * ch4vmr
10725 n2o0 = rmwn2o * n2ovmr
10726 cfc110 = rmwf11 * f11vmr
10727 cfc120 = rmwf12 * f12vmr
10728
10729 do i = 1, ncol
10730 coslat(i) = cos(clat(i))
10731 end do
10732 !
10733 do k = 1,pver
10734 do i = 1,ncol
10735 !
10736 ! set stratospheric scale height factor for gases
10737 dlat = abs(57.2958 * clat(i))
10738 if(dlat.le.45.0) then
10739 xn2o = 0.3478 + 0.00116 * dlat
10740 xch4 = 0.2353
10741 xcfc11 = 0.7273 + 0.00606 * dlat
10742 xcfc12 = 0.4000 + 0.00222 * dlat
10743 else
10744 xn2o = 0.4000 + 0.013333 * (dlat - 45)
10745 xch4 = 0.2353 + 0.0225489 * (dlat - 45)
10746 xcfc11 = 1.00 + 0.013333 * (dlat - 45)
10747 xcfc12 = 0.50 + 0.024444 * (dlat - 45)
10748 end if
10749 !
10750 ! pressure of tropopause
10751 ptrop = 250.0e2 - 150.0e2*coslat(i)**2.0
10752 !
10753 ! determine output mass mixing ratios
10754 if (pmid(i,k) >= ptrop) then
10755 ch4(i,k) = ch40
10756 n2o(i,k) = n2o0
10757 cfc11(i,k) = cfc110
10758 cfc12(i,k) = cfc120
10759 else
10760 pratio = pmid(i,k)/ptrop
10761 ch4(i,k) = ch40 * (pratio)**xch4
10762 n2o(i,k) = n2o0 * (pratio)**xn2o
10763 cfc11(i,k) = cfc110 * (pratio)**xcfc11
10764 cfc12(i,k) = cfc120 * (pratio)**xcfc12
10765 end if
10766 end do
10767 end do
10768 !
10769 return
10770 !
10771 end subroutine trcmix
10772
10773 subroutine trcplk(lchnk ,ncol ,pcols, pver, pverp, &
10774 tint ,tlayr ,tplnke ,emplnk ,abplnk1 , &
10775 abplnk2 )
10776 !-----------------------------------------------------------------------
10777 !
10778 ! Purpose:
10779 ! Calculate Planck factors for absorptivity and emissivity of
10780 ! CH4, N2O, CFC11 and CFC12
10781 !
10782 ! Method:
10783 ! Planck function and derivative evaluated at the band center.
10784 !
10785 ! Author: J. Kiehl
10786 !
10787 !-----------------------------------------------------------------------
10788 ! use shr_kind_mod, only: r8 => shr_kind_r8
10789 ! use ppgrid
10790
10791 implicit none
10792 !------------------------------Arguments--------------------------------
10793 !
10794 ! Input arguments
10795 !
10796 integer, intent(in) :: lchnk ! chunk identifier
10797 integer, intent(in) :: ncol ! number of atmospheric columns
10798 integer, intent(in) :: pcols, pver, pverp
10799
10800 real(r8), intent(in) :: tint(pcols,pverp) ! interface temperatures
10801 real(r8), intent(in) :: tlayr(pcols,pverp) ! k-1 level temperatures
10802 real(r8), intent(in) :: tplnke(pcols) ! Top Layer temperature
10803 !
10804 ! output arguments
10805 !
10806 real(r8), intent(out) :: emplnk(14,pcols) ! emissivity Planck factor
10807 real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
10808 real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
10809
10810 !
10811 !--------------------------Local Variables------------------------------
10812 !
10813 integer wvl ! wavelength index
10814 integer i,k ! loop counters
10815 !
10816 real(r8) f1(14) ! Planck function factor
10817 real(r8) f2(14) ! "
10818 real(r8) f3(14) ! "
10819 !
10820 !--------------------------Data Statements------------------------------
10821 !
10822 data f1 /5.85713e8,7.94950e8,1.47009e9,1.40031e9,1.34853e8, &
10823 1.05158e9,3.35370e8,3.99601e8,5.35994e8,8.42955e8, &
10824 4.63682e8,5.18944e8,8.83202e8,1.03279e9/
10825 data f2 /2.02493e11,3.04286e11,6.90698e11,6.47333e11, &
10826 2.85744e10,4.41862e11,9.62780e10,1.21618e11, &
10827 1.79905e11,3.29029e11,1.48294e11,1.72315e11, &
10828 3.50140e11,4.31364e11/
10829 data f3 /1383.0,1531.0,1879.0,1849.0,848.0,1681.0, &
10830 1148.0,1217.0,1343.0,1561.0,1279.0,1328.0, &
10831 1586.0,1671.0/
10832 !
10833 !-----------------------------------------------------------------------
10834 !
10835 ! Calculate emissivity Planck factor
10836 !
10837 do wvl = 1,14
10838 do i = 1,ncol
10839 emplnk(wvl,i) = f1(wvl)/(tplnke(i)**4.0*(exp(f3(wvl)/tplnke(i))-1.0))
10840 end do
10841 end do
10842 !
10843 ! Calculate absorptivity Planck factor for tint and tlayr temperatures
10844 !
10845 do wvl = 1,14
10846 do k = ntoplw, pverp
10847 do i = 1, ncol
10848 !
10849 ! non-nearlest layer function
10850 !
10851 abplnk1(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tint(i,k))) &
10852 /(tint(i,k)**5.0*(exp(f3(wvl)/tint(i,k))-1.0)**2.0)
10853 !
10854 ! nearest layer function
10855 !
10856 abplnk2(wvl,i,k) = (f2(wvl)*exp(f3(wvl)/tlayr(i,k))) &
10857 /(tlayr(i,k)**5.0*(exp(f3(wvl)/tlayr(i,k))-1.0)**2.0)
10858 end do
10859 end do
10860 end do
10861 !
10862 return
10863 end subroutine trcplk
10864
10865 subroutine trcpth(lchnk ,ncol ,pcols, pver, pverp, &
10866 tnm ,pnm ,cfc11 ,cfc12 ,n2o , &
10867 ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , &
10868 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
10869 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
10870 bch4 ,uptype )
10871 !-----------------------------------------------------------------------
10872 !
10873 ! Purpose:
10874 ! Calculate path lengths and pressure factors for CH4, N2O, CFC11
10875 ! and CFC12.
10876 !
10877 ! Method:
10878 ! See CCM3 description for details
10879 !
10880 ! Author: J. Kiehl
10881 !
10882 !-----------------------------------------------------------------------
10883 ! use shr_kind_mod, only: r8 => shr_kind_r8
10884 ! use ppgrid
10885 ! use ghg_surfvals, only: co2mmr
10886
10887 implicit none
10888
10889 !------------------------------Arguments--------------------------------
10890 !
10891 ! Input arguments
10892 !
10893 integer, intent(in) :: lchnk ! chunk identifier
10894 integer, intent(in) :: ncol ! number of atmospheric columns
10895 integer, intent(in) :: pcols, pver, pverp
10896
10897 real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures
10898 real(r8), intent(in) :: pnm(pcols,pverp) ! Pres. at model interfaces (dynes/cm2)
10899 real(r8), intent(in) :: qnm(pcols,pver) ! h2o specific humidity
10900 real(r8), intent(in) :: cfc11(pcols,pver) ! CFC11 mass mixing ratio
10901 !
10902 real(r8), intent(in) :: cfc12(pcols,pver) ! CFC12 mass mixing ratio
10903 real(r8), intent(in) :: n2o(pcols,pver) ! N2O mass mixing ratio
10904 real(r8), intent(in) :: ch4(pcols,pver) ! CH4 mass mixing ratio
10905
10906 !
10907 ! Output arguments
10908 !
10909 real(r8), intent(out) :: ucfc11(pcols,pverp) ! CFC11 path length
10910 real(r8), intent(out) :: ucfc12(pcols,pverp) ! CFC12 path length
10911 real(r8), intent(out) :: un2o0(pcols,pverp) ! N2O path length
10912 real(r8), intent(out) :: un2o1(pcols,pverp) ! N2O path length (hot band)
10913 real(r8), intent(out) :: uch4(pcols,pverp) ! CH4 path length
10914 !
10915 real(r8), intent(out) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
10916 real(r8), intent(out) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
10917 real(r8), intent(out) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
10918 real(r8), intent(out) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
10919 real(r8), intent(out) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
10920 !
10921 real(r8), intent(out) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
10922 real(r8), intent(out) :: bn2o0(pcols,pverp) ! pressure factor for n2o
10923 real(r8), intent(out) :: bn2o1(pcols,pverp) ! pressure factor for n2o
10924 real(r8), intent(out) :: bch4(pcols,pverp) ! pressure factor for ch4
10925 real(r8), intent(out) :: uptype(pcols,pverp) ! p-type continuum path length
10926
10927 !
10928 !---------------------------Local variables-----------------------------
10929 !
10930 integer i ! Longitude index
10931 integer k ! Level index
10932 !
10933 real(r8) co2fac(pcols,1) ! co2 factor
10934 real(r8) alpha1(pcols) ! stimulated emission term
10935 real(r8) alpha2(pcols) ! stimulated emission term
10936 real(r8) rt(pcols) ! reciprocal of local temperature
10937 real(r8) rsqrt(pcols) ! reciprocal of sqrt of temp
10938 !
10939 real(r8) pbar(pcols) ! mean pressure
10940 real(r8) dpnm(pcols) ! difference in pressure
10941 real(r8) diff ! diffusivity factor
10942 !
10943 !--------------------------Data Statements------------------------------
10944 !
10945 data diff /1.66/
10946 !
10947 !-----------------------------------------------------------------------
10948 !
10949 ! Calculate path lengths for the trace gases at model top
10950 !
10951 do i = 1,ncol
10952 ucfc11(i,ntoplw) = 1.8 * cfc11(i,ntoplw) * pnm(i,ntoplw) * rga
10953 ucfc12(i,ntoplw) = 1.8 * cfc12(i,ntoplw) * pnm(i,ntoplw) * rga
10954 un2o0(i,ntoplw) = diff * 1.02346e5 * n2o(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw))
10955 un2o1(i,ntoplw) = diff * 2.01909 * un2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw))
10956 uch4(i,ntoplw) = diff * 8.60957e4 * ch4(i,ntoplw) * pnm(i,ntoplw) * rga / sqrt(tnm(i,ntoplw))
10957 co2fac(i,1) = diff * co2mmr * pnm(i,ntoplw) * rga
10958 alpha1(i) = (1.0 - exp(-1540.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw))
10959 alpha2(i) = (1.0 - exp(-1360.0/tnm(i,ntoplw)))**3.0/sqrt(tnm(i,ntoplw))
10960 uco211(i,ntoplw) = 3.42217e3 * co2fac(i,1) * alpha1(i) * exp(-1849.7/tnm(i,ntoplw))
10961 uco212(i,ntoplw) = 6.02454e3 * co2fac(i,1) * alpha1(i) * exp(-2782.1/tnm(i,ntoplw))
10962 uco213(i,ntoplw) = 5.53143e3 * co2fac(i,1) * alpha1(i) * exp(-3723.2/tnm(i,ntoplw))
10963 uco221(i,ntoplw) = 3.88984e3 * co2fac(i,1) * alpha2(i) * exp(-1997.6/tnm(i,ntoplw))
10964 uco222(i,ntoplw) = 3.67108e3 * co2fac(i,1) * alpha2(i) * exp(-3843.8/tnm(i,ntoplw))
10965 uco223(i,ntoplw) = 6.50642e3 * co2fac(i,1) * alpha2(i) * exp(-2989.7/tnm(i,ntoplw))
10966 bn2o0(i,ntoplw) = diff * 19.399 * pnm(i,ntoplw)**2.0 * n2o(i,ntoplw) * &
10967 1.02346e5 * rga / (sslp*tnm(i,ntoplw))
10968 bn2o1(i,ntoplw) = bn2o0(i,ntoplw) * exp(-847.36/tnm(i,ntoplw)) * 2.06646e5
10969 bch4(i,ntoplw) = diff * 2.94449 * ch4(i,ntoplw) * pnm(i,ntoplw)**2.0 * rga * &
10970 8.60957e4 / (sslp*tnm(i,ntoplw))
10971 uptype(i,ntoplw) = diff * qnm(i,ntoplw) * pnm(i,ntoplw)**2.0 * &
10972 exp(1800.0*(1.0/tnm(i,ntoplw) - 1.0/296.0)) * rga / sslp
10973 end do
10974 !
10975 ! Calculate trace gas path lengths through model atmosphere
10976 !
10977 do k = ntoplw,pver
10978 do i = 1,ncol
10979 rt(i) = 1./tnm(i,k)
10980 rsqrt(i) = sqrt(rt(i))
10981 pbar(i) = 0.5 * (pnm(i,k+1) + pnm(i,k)) / sslp
10982 dpnm(i) = (pnm(i,k+1) - pnm(i,k)) * rga
10983 alpha1(i) = diff * rsqrt(i) * (1.0 - exp(-1540.0/tnm(i,k)))**3.0
10984 alpha2(i) = diff * rsqrt(i) * (1.0 - exp(-1360.0/tnm(i,k)))**3.0
10985 ucfc11(i,k+1) = ucfc11(i,k) + 1.8 * cfc11(i,k) * dpnm(i)
10986 ucfc12(i,k+1) = ucfc12(i,k) + 1.8 * cfc12(i,k) * dpnm(i)
10987 un2o0(i,k+1) = un2o0(i,k) + diff * 1.02346e5 * n2o(i,k) * rsqrt(i) * dpnm(i)
10988 un2o1(i,k+1) = un2o1(i,k) + diff * 2.06646e5 * n2o(i,k) * &
10989 rsqrt(i) * exp(-847.36/tnm(i,k)) * dpnm(i)
10990 uch4(i,k+1) = uch4(i,k) + diff * 8.60957e4 * ch4(i,k) * rsqrt(i) * dpnm(i)
10991 uco211(i,k+1) = uco211(i,k) + 1.15*3.42217e3 * alpha1(i) * &
10992 co2mmr * exp(-1849.7/tnm(i,k)) * dpnm(i)
10993 uco212(i,k+1) = uco212(i,k) + 1.15*6.02454e3 * alpha1(i) * &
10994 co2mmr * exp(-2782.1/tnm(i,k)) * dpnm(i)
10995 uco213(i,k+1) = uco213(i,k) + 1.15*5.53143e3 * alpha1(i) * &
10996 co2mmr * exp(-3723.2/tnm(i,k)) * dpnm(i)
10997 uco221(i,k+1) = uco221(i,k) + 1.15*3.88984e3 * alpha2(i) * &
10998 co2mmr * exp(-1997.6/tnm(i,k)) * dpnm(i)
10999 uco222(i,k+1) = uco222(i,k) + 1.15*3.67108e3 * alpha2(i) * &
11000 co2mmr * exp(-3843.8/tnm(i,k)) * dpnm(i)
11001 uco223(i,k+1) = uco223(i,k) + 1.15*6.50642e3 * alpha2(i) * &
11002 co2mmr * exp(-2989.7/tnm(i,k)) * dpnm(i)
11003 bn2o0(i,k+1) = bn2o0(i,k) + diff * 19.399 * pbar(i) * rt(i) &
11004 * 1.02346e5 * n2o(i,k) * dpnm(i)
11005 bn2o1(i,k+1) = bn2o1(i,k) + diff * 19.399 * pbar(i) * rt(i) &
11006 * 2.06646e5 * exp(-847.36/tnm(i,k)) * n2o(i,k)*dpnm(i)
11007 bch4(i,k+1) = bch4(i,k) + diff * 2.94449 * rt(i) * pbar(i) &
11008 * 8.60957e4 * ch4(i,k) * dpnm(i)
11009 uptype(i,k+1) = uptype(i,k) + diff *qnm(i,k) * &
11010 exp(1800.0*(1.0/tnm(i,k) - 1.0/296.0)) * pbar(i) * dpnm(i)
11011 end do
11012 end do
11013 !
11014 return
11015 end subroutine trcpth
11016 subroutine aqsat(t ,p ,es ,qs ,ii , &
11017 ilen ,kk ,kstart ,kend )
11018 !-----------------------------------------------------------------------
11019 !
11020 ! Purpose:
11021 ! Utility procedure to look up and return saturation vapor pressure from
11022 ! precomputed table, calculate and return saturation specific humidity
11023 ! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk)
11024 ! This routine is useful for evaluating only a selected region in the
11025 ! vertical.
11026 !
11027 ! Method:
11028 ! <Describe the algorithm(s) used in the routine.>
11029 ! <Also include any applicable external references.>
11030 !
11031 ! Author: J. Hack
11032 !
11033 !------------------------------Arguments--------------------------------
11034 !
11035 ! Input arguments
11036 !
11037 integer, intent(in) :: ii ! I dimension of arrays t, p, es, qs
11038 integer, intent(in) :: kk ! K dimension of arrays t, p, es, qs
11039 integer, intent(in) :: ilen ! Length of vectors in I direction which
11040 integer, intent(in) :: kstart ! Starting location in K direction
11041 integer, intent(in) :: kend ! Ending location in K direction
11042 real(r8), intent(in) :: t(ii,kk) ! Temperature
11043 real(r8), intent(in) :: p(ii,kk) ! Pressure
11044 !
11045 ! Output arguments
11046 !
11047 real(r8), intent(out) :: es(ii,kk) ! Saturation vapor pressure
11048 real(r8), intent(out) :: qs(ii,kk) ! Saturation specific humidity
11049 !
11050 !---------------------------Local workspace-----------------------------
11051 !
11052 real(r8) omeps ! 1 - 0.622
11053 integer i, k ! Indices
11054 !
11055 !-----------------------------------------------------------------------
11056 !
11057 omeps = 1.0 - epsqs
11058 do k=kstart,kend
11059 do i=1,ilen
11060 es(i,k) = estblf(t(i,k))
11061 !
11062 ! Saturation specific humidity
11063 !
11064 qs(i,k) = epsqs*es(i,k)/(p(i,k) - omeps*es(i,k))
11065 !
11066 ! The following check is to avoid the generation of negative values
11067 ! that can occur in the upper stratosphere and mesosphere
11068 !
11069 qs(i,k) = min(1.0_r8,qs(i,k))
11070 !
11071 if (qs(i,k) < 0.0) then
11072 qs(i,k) = 1.0
11073 es(i,k) = p(i,k)
11074 end if
11075 end do
11076 end do
11077 !
11078 return
11079 end subroutine aqsat
11080 !===============================================================================
11081 subroutine cldefr(lchnk ,ncol ,pcols, pver, pverp, &
11082 landfrac,t ,rel ,rei ,ps ,pmid , landm, icefrac, snowh)
11083 !-----------------------------------------------------------------------
11084 !
11085 ! Purpose:
11086 ! Compute cloud water and ice particle size
11087 !
11088 ! Method:
11089 ! use empirical formulas to construct effective radii
11090 !
11091 ! Author: J.T. Kiehl, B. A. Boville, P. Rasch
11092 !
11093 !-----------------------------------------------------------------------
11094
11095 implicit none
11096 !------------------------------Arguments--------------------------------
11097 !
11098 ! Input arguments
11099 !
11100 integer, intent(in) :: lchnk ! chunk identifier
11101 integer, intent(in) :: ncol ! number of atmospheric columns
11102 integer, intent(in) :: pcols, pver, pverp
11103
11104 real(r8), intent(in) :: landfrac(pcols) ! Land fraction
11105 real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
11106 real(r8), intent(in) :: t(pcols,pver) ! Temperature
11107 real(r8), intent(in) :: ps(pcols) ! Surface pressure
11108 real(r8), intent(in) :: pmid(pcols,pver) ! Midpoint pressures
11109 real(r8), intent(in) :: landm(pcols)
11110 real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
11111 !
11112 ! Output arguments
11113 !
11114 real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
11115 real(r8), intent(out) :: rei(pcols,pver) ! Ice effective drop size (microns)
11116 !
11117
11118 !++pjr
11119 ! following Kiehl
11120 call reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
11121
11122 ! following Kristjansson and Mitchell
11123 call reitab(ncol, pcols, pver, t, rei)
11124 !--pjr
11125 !
11126 !
11127 return
11128 end subroutine cldefr
11129
11130 !===============================================================================
11131 subroutine cldems(lchnk ,ncol ,pcols, pver, pverp, clwp ,fice ,rei ,emis )
11132 !-----------------------------------------------------------------------
11133 !
11134 ! Purpose:
11135 ! Compute cloud emissivity using cloud liquid water path (g/m**2)
11136 !
11137 ! Method:
11138 ! <Describe the algorithm(s) used in the routine.>
11139 ! <Also include any applicable external references.>
11140 !
11141 ! Author: J.T. Kiehl
11142 !
11143 !-----------------------------------------------------------------------
11144
11145 implicit none
11146 !------------------------------Parameters-------------------------------
11147 !
11148 real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
11149 parameter (kabsl = 0.090361)
11150 !
11151 !------------------------------Arguments--------------------------------
11152 !
11153 ! Input arguments
11154 !
11155 integer, intent(in) :: lchnk ! chunk identifier
11156 integer, intent(in) :: ncol ! number of atmospheric columns
11157 integer, intent(in) :: pcols, pver, pverp
11158
11159 real(r8), intent(in) :: clwp(pcols,pver) ! cloud liquid water path (g/m**2)
11160 real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
11161 real(r8), intent(in) :: fice(pcols,pver) ! fractional ice content within cloud
11162 !
11163 ! Output arguments
11164 !
11165 real(r8), intent(out) :: emis(pcols,pver) ! cloud emissivity (fraction)
11166 !
11167 !---------------------------Local workspace-----------------------------
11168 !
11169 integer i,k ! longitude, level indices
11170 real(r8) kabs ! longwave absorption coeff (m**2/g)
11171 real(r8) kabsi ! ice absorption coefficient
11172 !
11173 !-----------------------------------------------------------------------
11174 !
11175 do k=1,pver
11176 do i=1,ncol
11177 kabsi = 0.005 + 1./rei(i,k)
11178 kabs = kabsl*(1.-fice(i,k)) + kabsi*fice(i,k)
11179 emis(i,k) = 1. - exp(-1.66*kabs*clwp(i,k))
11180 end do
11181 end do
11182 !
11183 return
11184 end subroutine cldems
11185
11186 !===============================================================================
11187 subroutine cldovrlap(lchnk ,ncol ,pcols, pver, pverp, pint ,cld ,nmxrgn ,pmxrgn )
11188 !-----------------------------------------------------------------------
11189 !
11190 ! Purpose:
11191 ! Partitions each column into regions with clouds in neighboring layers.
11192 ! This information is used to implement maximum overlap in these regions
11193 ! with random overlap between them.
11194 ! On output,
11195 ! nmxrgn contains the number of regions in each column
11196 ! pmxrgn contains the interface pressures for the lower boundaries of
11197 ! each region!
11198 ! Method:
11199
11200 !
11201 ! Author: W. Collins
11202 !
11203 !-----------------------------------------------------------------------
11204
11205 implicit none
11206 !
11207 ! Input arguments
11208 !
11209 integer, intent(in) :: lchnk ! chunk identifier
11210 integer, intent(in) :: ncol ! number of atmospheric columns
11211 integer, intent(in) :: pcols, pver, pverp
11212
11213 real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
11214 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
11215 !
11216 ! Output arguments
11217 !
11218 real(r8), intent(out) :: pmxrgn(pcols,pverp)! Maximum values of pressure for each
11219 ! maximally overlapped region.
11220 ! 0->pmxrgn(i,1) is range of pressure for
11221 ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
11222 ! 2nd region, etc
11223 integer nmxrgn(pcols) ! Number of maximally overlapped regions
11224 !
11225 !---------------------------Local variables-----------------------------
11226 !
11227 integer i ! Longitude index
11228 integer k ! Level index
11229 integer n ! Max-overlap region counter
11230
11231 real(r8) pnm(pcols,pverp) ! Interface pressure
11232
11233 logical cld_found ! Flag for detection of cloud
11234 logical cld_layer(pver) ! Flag for cloud in layer
11235 !
11236 !------------------------------------------------------------------------
11237 !
11238
11239 do i = 1, ncol
11240 cld_found = .false.
11241 cld_layer(:) = cld(i,:) > 0.0_r8
11242 pmxrgn(i,:) = 0.0
11243 pnm(i,:)=pint(i,:)*10.
11244 n = 1
11245 do k = 1, pver
11246 if (cld_layer(k) .and. .not. cld_found) then
11247 cld_found = .true.
11248 else if ( .not. cld_layer(k) .and. cld_found) then
11249 cld_found = .false.
11250 if (count(cld_layer(k:pver)) == 0) then
11251 exit
11252 endif
11253 pmxrgn(i,n) = pnm(i,k)
11254 n = n + 1
11255 endif
11256 end do
11257 pmxrgn(i,n) = pnm(i,pverp)
11258 nmxrgn(i) = n
11259 end do
11260
11261 return
11262 end subroutine cldovrlap
11263
11264 !===============================================================================
11265 subroutine cldclw(lchnk ,ncol ,pcols, pver, pverp, zi ,clwp ,tpw ,hl )
11266 !-----------------------------------------------------------------------
11267 !
11268 ! Purpose:
11269 ! Evaluate cloud liquid water path clwp (g/m**2)
11270 !
11271 ! Method:
11272 ! <Describe the algorithm(s) used in the routine.>
11273 ! <Also include any applicable external references.>
11274 !
11275 ! Author: J.T. Kiehl
11276 !
11277 !-----------------------------------------------------------------------
11278
11279 implicit none
11280
11281 !
11282 ! Input arguments
11283 !
11284 integer, intent(in) :: lchnk ! chunk identifier
11285 integer, intent(in) :: ncol ! number of atmospheric columns
11286 integer, intent(in) :: pcols, pver, pverp
11287
11288 real(r8), intent(in) :: zi(pcols,pverp) ! height at layer interfaces(m)
11289 real(r8), intent(in) :: tpw(pcols) ! total precipitable water (mm)
11290 !
11291 ! Output arguments
11292 !
11293 real(r8) clwp(pcols,pver) ! cloud liquid water path (g/m**2)
11294 real(r8) hl(pcols) ! liquid water scale height
11295 real(r8) rhl(pcols) ! 1/hl
11296
11297 !
11298 !---------------------------Local workspace-----------------------------
11299 !
11300 integer i,k ! longitude, level indices
11301 real(r8) clwc0 ! reference liquid water concentration (g/m**3)
11302 real(r8) emziohl(pcols,pverp) ! exp(-zi/hl)
11303 !
11304 !-----------------------------------------------------------------------
11305 !
11306 ! Set reference liquid water concentration
11307 !
11308 clwc0 = 0.21
11309 !
11310 ! Diagnose liquid water scale height from precipitable water
11311 !
11312 do i=1,ncol
11313 hl(i) = 700.0*log(max(tpw(i)+1.0_r8,1.0_r8))
11314 rhl(i) = 1.0/hl(i)
11315 end do
11316 !
11317 ! Evaluate cloud liquid water path (vertical integral of exponential fn)
11318 !
11319 do k=1,pverp
11320 do i=1,ncol
11321 emziohl(i,k) = exp(-zi(i,k)*rhl(i))
11322 end do
11323 end do
11324 do k=1,pver
11325 do i=1,ncol
11326 clwp(i,k) = clwc0*hl(i)*(emziohl(i,k+1) - emziohl(i,k))
11327 end do
11328 end do
11329 !
11330 return
11331 end subroutine cldclw
11332
11333
11334 !===============================================================================
11335 subroutine reltab(ncol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
11336 !-----------------------------------------------------------------------
11337 !
11338 ! Purpose:
11339 ! Compute cloud water size
11340 !
11341 ! Method:
11342 ! analytic formula following the formulation originally developed by J. T. Kiehl
11343 !
11344 ! Author: Phil Rasch
11345 !
11346 !-----------------------------------------------------------------------
11347 ! use physconst, only: tmelt
11348 implicit none
11349 !------------------------------Arguments--------------------------------
11350 !
11351 ! Input arguments
11352 !
11353 integer, intent(in) :: ncol
11354 integer, intent(in) :: pcols, pver
11355 real(r8), intent(in) :: landfrac(pcols) ! Land fraction
11356 real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
11357 real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
11358 real(r8), intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
11359 real(r8), intent(in) :: t(pcols,pver) ! Temperature
11360
11361 !
11362 ! Output arguments
11363 !
11364 real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
11365 !
11366 !---------------------------Local workspace-----------------------------
11367 !
11368 integer i,k ! Lon, lev indices
11369 real(r8) rliqland ! liquid drop size if over land
11370 real(r8) rliqocean ! liquid drop size if over ocean
11371 real(r8) rliqice ! liquid drop size if over sea ice
11372 !
11373 !-----------------------------------------------------------------------
11374 !
11375 rliqocean = 14.0_r8
11376 rliqice = 14.0_r8
11377 rliqland = 8.0_r8
11378 do k=1,pver
11379 do i=1,ncol
11380 ! jrm Reworked effective radius algorithm
11381 ! Start with temperature-dependent value appropriate for continental air
11382 ! Note: findmcnew has a pressure dependence here
11383 rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0_r8,max(0.0_r8,(tmelt-t(i,k))*0.05))
11384 ! Modify for snow depth over land
11385 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,snowh(i)*10.))
11386 ! Ramp between polluted value over land to clean value over ocean.
11387 rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,1.0-landm(i)))
11388 ! Ramp between the resultant value and a sea ice value in the presence of ice.
11389 rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0_r8,max(0.0_r8,icefrac(i)))
11390 ! end jrm
11391 end do
11392 end do
11393 end subroutine reltab
11394
11395 !===============================================================================
11396 subroutine reitab(ncol, pcols, pver, t, re)
11397 !
11398
11399 integer, intent(in) :: ncol, pcols, pver
11400 real(r8), intent(out) :: re(pcols,pver)
11401 real(r8), intent(in) :: t(pcols,pver)
11402 real(r8) retab(95)
11403 real(r8) corr
11404 integer i
11405 integer k
11406 integer index
11407 !
11408 ! Tabulated values of re(T) in the temperature interval
11409 ! 180 K -- 274 K; hexagonal columns assumed:
11410 !
11411 data retab / &
11412 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
11413 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
11414 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
11415 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
11416 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
11417 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
11418 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
11419 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
11420 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
11421 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
11422 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
11423 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
11424 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
11425 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
11426 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
11427 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
11428 !
11429 save retab
11430 !
11431 do k=1,pver
11432 do i=1,ncol
11433 index = int(t(i,k)-179.)
11434 index = min(max(index,1),94)
11435 corr = t(i,k) - int(t(i,k))
11436 re(i,k) = retab(index)*(1.-corr) &
11437 +retab(index+1)*corr
11438 ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
11439 end do
11440 end do
11441 !
11442 return
11443 end subroutine reitab
11444
11445
11446 function findvalue(ix,n,ain,indxa)
11447 !-----------------------------------------------------------------------
11448 !
11449 ! Purpose:
11450 ! Subroutine for finding ix-th smallest value in the array
11451 ! The elements are rearranged so that the ix-th smallest
11452 ! element is in the ix place and all smaller elements are
11453 ! moved to the elements up to ix (with random order).
11454 !
11455 ! Algorithm: Based on the quicksort algorithm.
11456 !
11457 ! Author: T. Craig
11458 !
11459 !-----------------------------------------------------------------------
11460 ! use shr_kind_mod, only: r8 => shr_kind_r8
11461 implicit none
11462 !
11463 ! arguments
11464 !
11465 integer, intent(in) :: ix ! element to search for
11466 integer, intent(in) :: n ! total number of elements
11467 integer, intent(inout):: indxa(n) ! array of integers
11468 real(r8), intent(in) :: ain(n) ! array to search
11469 !
11470 integer findvalue ! return value
11471 !
11472 ! local variables
11473 !
11474 integer i,j
11475 integer il,im,ir
11476
11477 integer ia
11478 integer itmp
11479 !
11480 !---------------------------Routine-----------------------------
11481 !
11482 il=1
11483 ir=n
11484 do
11485 if (ir-il <= 1) then
11486 if (ir-il == 1) then
11487 if (ain(indxa(ir)) < ain(indxa(il))) then
11488 itmp=indxa(il)
11489 indxa(il)=indxa(ir)
11490 indxa(ir)=itmp
11491 endif
11492 endif
11493 findvalue=indxa(ix)
11494 return
11495 else
11496 im=(il+ir)/2
11497 itmp=indxa(im)
11498 indxa(im)=indxa(il+1)
11499 indxa(il+1)=itmp
11500 if (ain(indxa(il+1)) > ain(indxa(ir))) then
11501 itmp=indxa(il+1)
11502 indxa(il+1)=indxa(ir)
11503 indxa(ir)=itmp
11504 endif
11505 if (ain(indxa(il)) > ain(indxa(ir))) then
11506 itmp=indxa(il)
11507 indxa(il)=indxa(ir)
11508 indxa(ir)=itmp
11509 endif
11510 if (ain(indxa(il+1)) > ain(indxa(il))) then
11511 itmp=indxa(il+1)
11512 indxa(il+1)=indxa(il)
11513 indxa(il)=itmp
11514 endif
11515 i=il+1
11516 j=ir
11517 ia=indxa(il)
11518 do
11519 do
11520 i=i+1
11521 if (ain(indxa(i)) >= ain(ia)) exit
11522 end do
11523 do
11524 j=j-1
11525 if (ain(indxa(j)) <= ain(ia)) exit
11526 end do
11527 if (j < i) exit
11528 itmp=indxa(i)
11529 indxa(i)=indxa(j)
11530 indxa(j)=itmp
11531 end do
11532 indxa(il)=indxa(j)
11533 indxa(j)=ia
11534 if (j >= ix)ir=j-1
11535 if (j <= ix)il=i
11536 endif
11537 end do
11538 end function findvalue
11539
11540 #endif
11541
11542
11543
11544 END MODULE module_ra_cam