| blob | c8378f4f1b11163b8817125d29609644c8e6b3d1 |
1 MODULE module_ra_cam
2 use module_ra_cam_support
3 use module_cam_support, only: endrun
5 implicit none
6 !
7 ! A. Slingo's data for cloud particle radiative properties (from 'A GCM
8 ! Parameterization for the Shortwave Properties of Water Clouds' JAS
9 ! vol. 46 may 1989 pp 1419-1427)
10 !
11 real(r8) abarl(4) ! A coefficient for extinction optical depth
12 real(r8) bbarl(4) ! B coefficient for extinction optical depth
13 real(r8) cbarl(4) ! C coefficient for single scat albedo
14 real(r8) dbarl(4) ! D coefficient for single scat albedo
15 real(r8) ebarl(4) ! E coefficient for asymmetry parameter
16 real(r8) fbarl(4) ! F coefficient for asymmetry parameter
18 save abarl, bbarl, cbarl, dbarl, ebarl, fbarl
20 data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/
21 data bbarl/ 1.305 , 1.346 ,1.454 ,1.641 /
22 data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201 /
23 data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 /
24 data ebarl/ 0.829 , 0.794 ,0.754 ,0.826 /
25 data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/
27 #if 0
28 ! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
29 real(r8) abarli ! A coefficient for current spectral band
30 real(r8) bbarli ! B coefficient for current spectral band
31 real(r8) cbarli ! C coefficient for current spectral band
32 real(r8) dbarli ! D coefficient for current spectral band
33 real(r8) ebarli ! E coefficient for current spectral band
34 real(r8) fbarli ! F coefficient for current spectral band
35 #endif
36 !
37 ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor
38 ! greater than 20 micro-meters
39 !
40 ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836)
41 !
42 real(r8) abari(4) ! a coefficient for extinction optical depth
43 real(r8) bbari(4) ! b coefficient for extinction optical depth
44 real(r8) cbari(4) ! c coefficient for single scat albedo
45 real(r8) dbari(4) ! d coefficient for single scat albedo
46 real(r8) ebari(4) ! e coefficient for asymmetry parameter
47 real(r8) fbari(4) ! f coefficient for asymmetry parameter
49 save abari, bbari, cbari, dbari, ebari, fbari
51 data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/
52 data bbari/ 2.431 , 2.431 ,2.431 ,2.431 /
53 data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658 /
54 data dbari/ 0.0 , 1.405e-05,8.328e-04,2.05e-05 /
55 data ebari/ 0.7661 , 0.7730 ,0.794 ,0.9595 /
56 data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/
58 #if 0
59 ! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
60 real(r8) abarii ! A coefficient for current spectral band
61 real(r8) bbarii ! B coefficient for current spectral band
62 real(r8) cbarii ! C coefficient for current spectral band
63 real(r8) dbarii ! D coefficient for current spectral band
64 real(r8) ebarii ! E coefficient for current spectral band
65 real(r8) fbarii ! F coefficient for current spectral band
66 #endif
67 !
68 real(r8) delta ! Pressure (in atm) for stratos. h2o limit
69 real(r8) o2mmr ! O2 mass mixing ratio:
71 save delta, o2mmr
73 !
74 ! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4
75 !
76 data delta / 0.0014257179260883 /
77 !
78 ! END UPDATE
79 !
80 data o2mmr / .23143 /
82 ! Next series depends on spectral interval
83 !
84 real(r8) frcsol(nspint) ! Fraction of solar flux in spectral interval
85 real(r8) wavmin(nspint) ! Min wavelength (micro-meters) of interval
86 real(r8) wavmax(nspint) ! Max wavelength (micro-meters) of interval
87 real(r8) raytau(nspint) ! Rayleigh scattering optical depth
88 real(r8) abh2o(nspint) ! Absorption coefficiant for h2o (cm2/g)
89 real(r8) abo3 (nspint) ! Absorption coefficiant for o3 (cm2/g)
90 real(r8) abco2(nspint) ! Absorption coefficiant for co2 (cm2/g)
91 real(r8) abo2 (nspint) ! Absorption coefficiant for o2 (cm2/g)
92 real(r8) ph2o(nspint) ! Weight of h2o in spectral interval
93 real(r8) pco2(nspint) ! Weight of co2 in spectral interval
94 real(r8) po2 (nspint) ! Weight of o2 in spectral interval
95 real(r8) nirwgt(nspint) ! Spectral Weights to simulate Nimbus-7 filter
96 save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , &
97 abco2 ,abo2 ,ph2o ,pco2 ,po2 ,nirwgt
99 data frcsol / .001488, .001389, .001290, .001686, .002877, &
100 .003869, .026336, .360739, .065392, .526861, &
101 .526861, .526861, .526861, .526861, .526861, &
102 .526861, .006239, .001834, .001834/
103 !
104 ! weight for 0.64 - 0.7 microns appropriate to clear skies over oceans
105 !
106 data nirwgt / 0.0, 0.0, 0.0, 0.0, 0.0, &
107 0.0, 0.0, 0.0, 0.320518, 1.0, 1.0, &
108 1.0, 1.0, 1.0, 1.0, 1.0, &
109 1.0, 1.0, 1.0 /
111 data wavmin / .200, .245, .265, .275, .285, &
112 .295, .305, .350, .640, .700, .701, &
113 .701, .701, .701, .702, .702, &
114 2.630, 4.160, 4.160/
116 data wavmax / .245, .265, .275, .285, .295, &
117 .305, .350, .640, .700, 5.000, 5.000, &
118 5.000, 5.000, 5.000, 5.000, 5.000, &
119 2.860, 4.550, 4.550/
121 !
122 ! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4
123 !
124 real(r8) v_raytau_35
125 real(r8) v_raytau_64
126 real(r8) v_abo3_35
127 real(r8) v_abo3_64
128 parameter( &
129 v_raytau_35 = 0.155208, &
130 v_raytau_64 = 0.0392, &
131 v_abo3_35 = 2.4058030e+01, &
132 v_abo3_64 = 2.210e+01 &
133 )
135 data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, &
136 1.085, 0.730, v_raytau_35, v_raytau_64, &
137 0.02899756, 0.01356763, 0.00537341, &
138 0.00228515, 0.00105028, 0.00046631, &
139 0.00025734, &
140 .0001, .0001, .0001/
141 !
142 ! END UPDATE
143 !
145 !
146 ! Absorption coefficients
147 !
148 !
149 ! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4
150 !
151 data abh2o / .000, .000, .000, .000, .000, &
152 .000, .000, .000, .000, &
153 0.00256608, 0.06310504, 0.42287445, 2.45397941, &
154 11.20070807, 47.66091389, 240.19010243, &
155 .000, .000, .000/
156 !
157 ! END UPDATE
158 !
160 data abo3 /5.370e+04, 13.080e+04, 9.292e+04, 4.530e+04, 1.616e+04, &
161 4.441e+03, 1.775e+02, v_abo3_35, v_abo3_64, .000, &
162 .000, .000 , .000 , .000 , .000, &
163 .000, .000 , .000 , .000 /
165 data abco2 / .000, .000, .000, .000, .000, &
166 .000, .000, .000, .000, .000, &
167 .000, .000, .000, .000, .000, &
168 .000, .094, .196, 1.963/
170 data abo2 / .000, .000, .000, .000, .000, &
171 .000, .000, .000,1.11e-05,6.69e-05, &
172 .000, .000, .000, .000, .000, &
173 .000, .000, .000, .000/
174 !
175 ! Spectral interval weights
176 !
177 data ph2o / .000, .000, .000, .000, .000, &
178 .000, .000, .000, .000, .505, &
179 .210, .120, .070, .048, .029, &
180 .018, .000, .000, .000/
182 data pco2 / .000, .000, .000, .000, .000, &
183 .000, .000, .000, .000, .000, &
184 .000, .000, .000, .000, .000, &
185 .000, 1.000, .640, .360/
187 data po2 / .000, .000, .000, .000, .000, &
188 .000, .000, .000, 1.000, 1.000, &
189 .000, .000, .000, .000, .000, &
190 .000, .000, .000, .000/
192 real(r8) amo ! Molecular weight of ozone (g/mol)
193 save amo
195 data amo / 48.0000 /
197 contains
198 subroutine camrad(RTHRATENLW,RTHRATENSW,RTHRATENLWC,RTHRATENSWC, &
199 dolw,dosw, &
200 SWUPT,SWUPTC,SWDNT,SWDNTC, &
201 LWUPT,LWUPTC,LWDNT,LWDNTC, &
202 SWUPB,SWUPBC,SWDNB,SWDNBC, &
203 LWUPB,LWUPBC,LWDNB,LWDNBC, &
204 swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr, &
205 GSW,GLW,XLAT,XLONG, &
206 ALBEDO,t_phy,TSK,EMISS, &
207 QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, &
208 ALSWVISDIR,ALSWVISDIF, & !ssib
209 ALSWNIRDIR,ALSWNIRDIF, & !ssib
210 SWVISDIR,SWVISDIF, & !ssib
211 SWNIRDIR,SWNIRDIF, & !ssib
212 sf_surface_physics, & !ssib
213 SWDDIR,SWDDIF,SWDDNI, & ! amontornes-bcodina (2014-04-20)
214 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
215 f_ice_phy,f_rain_phy, &
216 p_phy,p8w,z,pi_phy,rho_phy,dz8w, &
217 CLDFRA,XLAND,XICE,SNOW, &
218 ozmixm,pin0,levsiz,num_months, &
219 m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0, &
220 cam_abs_dim1, cam_abs_dim2, &
221 paerlev,naer_c, &
222 GMT,JULDAY,JULIAN,YR,DT,XTIME,DECLIN,SOLCON, &
223 RADT,DEGRAD,n_cldadv, &
224 abstot_3d, absnxt_3d, emstot_3d, &
225 doabsems, ghg_input, &
226 ids,ide, jds,jde, kds,kde, &
227 ims,ime, jms,jme, kms,kme, &
228 its,ite, jts,jte, kts,kte, &
229 coszen )
231 !ccc To use CLWRF time-varying trace gases
232 USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
233 USE module_wrf_error
234 USE module_state_description, ONLY : SSIBSCHEME, CLMSCHEME !ssib & clm
236 !------------------------------------------------------------------
237 IMPLICIT NONE
238 !------------------------------------------------------------------
240 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
241 ims,ime, jms,jme, kms,kme, &
242 its,ite, jts,jte, kts,kte
243 LOGICAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
244 LOGICAL, INTENT(INout) :: doabsems
245 LOGICAL, INTENT(IN ) :: dolw,dosw
247 INTEGER, INTENT(IN ) :: n_cldadv
248 INTEGER, INTENT(IN ) :: JULDAY
249 REAL, INTENT(IN ) :: JULIAN
250 INTEGER, INTENT(IN ) :: YR
251 REAL, INTENT(IN ) :: DT
252 INTEGER, INTENT(IN ) :: levsiz, num_months
253 INTEGER, INTENT(IN ) :: paerlev, naer_c
254 INTEGER, INTENT(IN ) :: cam_abs_dim1, cam_abs_dim2
256 INTEGER, INTENT(IN ) :: ghg_input
258 REAL, INTENT(IN ) :: RADT,DEGRAD, &
259 XTIME,DECLIN,SOLCON,GMT
260 !
261 !
262 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
263 INTENT(IN ) :: P_PHY, &
264 P8W, &
265 Z, &
266 pi_PHY, &
267 rho_PHY, &
268 dz8w, &
269 T_PHY, &
270 QV3D, &
271 QC3D, &
272 QR3D, &
273 QI3D, &
274 QS3D, &
275 QG3D, &
276 CLDFRA
278 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
279 INTENT(INOUT) :: RTHRATENLW, &
280 RTHRATENLWC, &
281 RTHRATENSW, &
282 RTHRATENSWC
283 !
284 REAL, DIMENSION( ims:ime, jms:jme ), &
285 INTENT(IN ) :: XLAT, &
286 XLONG, &
287 XLAND, &
288 XICE, &
289 SNOW, &
290 EMISS, &
291 TSK, &
292 ALBEDO
294 REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
295 INTENT(IN ) :: OZMIXM
297 REAL, DIMENSION(levsiz), INTENT(IN ) :: PIN0
299 REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN ) :: m_psp,m_psn
300 REAL, DIMENSION(paerlev), intent(in) :: m_hybi0
301 REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
302 INTENT(IN ) :: aerosolcp, aerosolcn
304 !
305 REAL, DIMENSION( ims:ime, jms:jme ), &
306 INTENT(INOUT) :: GSW, GLW
308 !---------SSiB variables (fds 06/2010)----------------
309 REAL, DIMENSION( ims:ime, jms:jme ), &
310 INTENT(IN) :: ALSWVISDIR, &
311 ALSWVISDIF, &
312 ALSWNIRDIR, &
313 ALSWNIRDIF
315 REAL, DIMENSION( ims:ime, jms:jme ), &
316 INTENT(OUT) :: SWVISDIR, &
317 SWVISDIF, &
318 SWNIRDIR, &
319 SWNIRDIF, &
320 SWDDIR, &
321 SWDDNI, &
322 SWDDIF
324 INTEGER, INTENT(IN) :: sf_surface_physics
325 !--------------------------------------
326 ! saving arrays for doabsems reduction of radiation calcs
328 REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ), &
329 INTENT(INOUT) :: abstot_3d
330 REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1 , jms:jme ), &
331 INTENT(INOUT) :: absnxt_3d
332 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
333 INTENT(INOUT) :: emstot_3d
336 ! Added outputs of total and clearsky fluxes etc
337 ! Note that k=1 refers to the half level below the model lowest level (Sfc)
338 ! k=kme refers to the half level above the model highest level (TOA)
339 !
340 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
341 ! INTENT(INOUT) :: swup, &
342 ! swupclear, &
343 ! swdn, &
344 ! swdnclear, &
345 ! lwup, &
346 ! lwupclear, &
347 ! lwdn, &
348 ! lwdnclear
350 REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
351 SWUPT,SWUPTC,SWDNT,SWDNTC, &
352 LWUPT,LWUPTC,LWDNT,LWDNTC, &
353 SWUPB,SWUPBC,SWDNB,SWDNBC, &
354 LWUPB,LWUPBC,LWDNB,LWDNBC
356 REAL, DIMENSION( ims:ime, jms:jme ), &
357 INTENT(INOUT) :: swcf, &
358 lwcf, &
359 olr, &
360 coszr
361 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
362 INTENT(OUT ) :: cemiss, & ! cloud emissivity for isccp
363 taucldc, & ! cloud water optical depth for isccp
364 taucldi ! cloud ice optical depth for isccp
365 !
366 !
367 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
368 INTENT(IN ) :: &
369 F_ICE_PHY, &
370 F_RAIN_PHY
372 real, dimension(ims:ime,jms:jme), optional, intent(in) :: coszen
374 ! LOCAL VARIABLES
376 INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp
377 INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n
378 integer :: begchunk, endchunk
379 integer :: nyrm, nyrp
380 real(r8) doymodel, doydatam, doydatap, deltat, fact1, fact2
382 REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24
384 real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups
385 real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps
386 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t
387 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) :: pint, lnpint
388 real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q
389 ! real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm ! reference pressures at midpoints
390 ! real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi ! reference pressures at interfaces
391 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cicewp ! in-cloud cloud ice water path
392 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: cliqwp ! in-cloud cloud liquid water path
393 real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxcl ! cloud water optical depth
394 real(r8), dimension( 1:ite-its+1, 0:kte-kts+1 ) :: tauxci ! cloud ice optical depth
395 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: emis ! cloud emissivity
396 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rel ! effective drop radius (microns)
397 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: rei ! ice effective drop size (microns)
398 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn ! Maximum values of pressure for each
399 integer , dimension( 1:ite-its+1 ) :: nmxrgn ! Number of maximally overlapped regions
401 real(r8), dimension( 1:ite-its+1 ) :: fsns ! Surface absorbed solar flux
402 real(r8), dimension( 1:ite-its+1 ) :: fsnt ! Net column abs solar flux at model top
403 real(r8), dimension( 1:ite-its+1 ) :: flns ! Srf longwave cooling (up-down) flux
404 real(r8), dimension( 1:ite-its+1 ) :: flnt ! Net outgoing lw flux at model top
405 ! Added outputs of total and clearsky fluxes etc
406 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsup ! Upward total sky solar
407 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsupc ! Upward clear sky solar
408 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdn ! Downward total sky solar
409 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdnc ! Downward clear sky solar
410 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdndir ! Direct Downward total sky solar amontornes-bcodina (2014-04-20)
411 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdncdir ! Direct Downward clear sky solar amontornes-bcodina (2014-04-20)
412 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdndif ! Diffuse Downward total sky solar amontornes-bcodina (2014-04-20)
413 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdncdif ! Diffuse Downward clear sky solar amontornes-bcodina (2014-04-20)
414 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flup ! Upward total sky longwave
415 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flupc ! Upward clear sky longwave
416 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldn ! Downward total sky longwave
417 real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldnc ! Downward clear sky longwave
418 real(r8), dimension( 1:ite-its+1 ) :: swcftoa ! Top of the atmosphere solar cloud forcing
419 real(r8), dimension( 1:ite-its+1 ) :: lwcftoa ! Top of the atmosphere longwave cloud forcing
420 real(r8), dimension( 1:ite-its+1 ) :: olrtoa ! Top of the atmosphere outgoing longwave
421 !
422 real(r8), dimension( 1:ite-its+1 ) :: sols ! Downward solar rad onto surface (sw direct)
423 real(r8), dimension( 1:ite-its+1 ) :: soll ! Downward solar rad onto surface (lw direct)
424 real(r8), dimension( 1:ite-its+1 ) :: solsd ! Downward solar rad onto surface (sw diffuse)
425 real(r8), dimension( 1:ite-its+1 ) :: solld ! Downward solar rad onto surface (lw diffuse)
426 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrs ! Solar heating rate
427 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrscs ! Clear sky solar heating rate
428 real(r8), dimension( 1:ite-its+1 ) :: fsds ! Flux Shortwave Downwelling Surface
429 real(r8), dimension( 1:ite-its+1 ) :: fsdsdir ! Flux Shortwave Direct Downwelling Surface
430 real(r8), dimension( 1:ite-its+1 ) :: fsdsdif ! Flux Shortwave Diffuse Downwelling Surface
431 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrl ! Longwave cooling rate
432 real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrlcs ! Clear sky longwave cooling rate
433 real(r8), dimension( 1:ite-its+1 ) :: flwds ! Surface down longwave flux
434 real(r8), dimension( 1:ite-its+1, levsiz, num_months ) :: ozmixmj ! monthly ozone mixing ratio
435 real(r8), dimension( 1:ite-its+1, levsiz ) :: ozmix ! ozone mixing ratio (time interpolated)
436 real(r8), dimension(levsiz) :: pin ! ozone pressure level
437 real(r8), dimension(1:ite-its+1) :: m_psjp,m_psjn ! MATCH surface pressure
438 real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljp ! monthly aerosol concentrations
439 real(r8), dimension( 1:ite-its+1, paerlev, naer_c ) :: aerosoljn ! monthly aerosol concentrations
440 real(r8), dimension(paerlev) :: m_hybi
441 real(r8), dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns
442 real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity
443 real(r8), dimension(its:ite,kts:kte,4) :: absnxt ! Total nearest layer absorptivity
444 real(r8), dimension(its:ite,kts:kte+1) :: emstot ! Total emissivity
445 CHARACTER(LEN=256) :: msgstr
447 !ccc
448 REAL(r8) :: co2vmr, n2ovmr, ch4vmr, f11vmr, f12vmr
449 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
450 CHARACTER(LEN=256) :: message
452 !ccc
454 #if !defined(MAC_KLUDGE)
455 lchnk = 1
456 begchunk = ims
457 endchunk = ime
458 ncol = ite - its + 1
459 pcols= ite - its + 1
460 pver = kte - kts + 1
461 pverp= pver + 1
462 pverr = kte - kts + 1
463 pverrp= pverr + 1
464 ! number of advected constituents and non-advected constituents (including water vapor)
465 ppcnst = n_cldadv
466 ! number of non-advected constituents
467 pnats = 0
468 pcnst = ppcnst-pnats
470 ! check the # species defined for the input climatology and naer
472 ! if(naer_c.ne.naer) then
473 ! WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer
474 if(naer_c.ne.naer_all) then
475 WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all
476 CALL wrf_error_fatal ( wrf_err_message )
477 endif
479 ! update CO2 volume mixing ratio (co2vmr)
481 ! determine time interpolation factors, check sanity
482 ! of interpolation factors to within 32-bit roundoff
483 ! assume that day of year is 1 for all input data
484 !
486 IF (ghg_input.eq.1) then
487 CALL read_CAMgases(yr,julian,.false.,"CAM",co2vmr,n2ovmr,ch4vmr,f11vmr,f12vmr)
488 IF ( wrf_dm_on_monitor() ) THEN
489 WRITE(message,*)'write CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian
490 call wrf_debug( 100, message)
491 WRITE(message,*)' CAM-CLWRF co2vmr: ',co2vmr,' n2ovmr:',n2ovmr,' ch4vmr:',ch4vmr,' cfc11:'&
492 ,f11vmr,' cfc12:',f12vmr
493 call wrf_debug( 100, message)
494 ENDIF
495 ELSE
496 nyrm = yr - yrdata(1) + 1
497 nyrp = nyrm + 1
498 doymodel = yr*365. + julian
499 doydatam = yrdata(nyrm)*365. + 1.
500 doydatap = yrdata(nyrp)*365. + 1.
501 deltat = doydatap - doydatam
502 fact1 = (doydatap - doymodel)/deltat
503 fact2 = (doymodel - doydatam)/deltat
504 co2vmr = (co2(nyrm)*fact1 + co2(nyrp)*fact2)*1.e-06
505 ENDIF
507 co2mmr=co2vmr*mwco2/mwdry
508 !
509 !===================================================
510 ! Radiation computations
511 !===================================================
513 do k=1,levsiz
514 pin(k)=pin0(k)
515 enddo
517 do k=1,paerlev
518 m_hybi(k)=m_hybi0(k)
519 enddo
521 ! check for uninitialized arrays
522 if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems .and. dolw)then
523 CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart')
524 doabsems = .true.
525 endif
527 do j =jts,jte
529 !
530 ! Cosine solar zenith angle for current time step
531 !
533 ! call zenith (calday, clat, clon, coszrs, ncol)
535 if (present(coszen)) then
536 do i=its,ite
537 ii=i-its+1
538 clat(ii)=XLAT(I,J)*DEGRAD
539 coszrs(ii)=coszen(i,j)
540 enddo
541 else
542 do i = its,ite
543 ii = i - its + 1
544 ! XT24 is the fractional part of simulation days plus half of RADT expressed in
545 ! units of minutes
546 ! JULIAN is in days
547 ! RADT is in minutes
548 XT24=MOD(XTIME+RADT*0.5,1440.)
549 TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
550 HRANG=15.*(TLOCTM-12.)*DEGRAD
551 XXLAT=XLAT(I,J)*DEGRAD
552 clat(ii)=xxlat
553 coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
554 enddo
555 end if
557 ! moist variables
559 do k = kts,kte
560 kk = kte - k + kts
561 do i = its,ite
562 ii = i - its + 1
563 ! convert to specific humidity
564 q(ii,kk,1) = max(1.e-10,qv3d(i,k,j)/(1.+qv3d(i,k,j)))
565 IF ( F_QI .and. F_QC .and. F_QS ) THEN
566 q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
567 q(ii,kk,ixcldice) = max(0.,(qi3d(i,k,j)+qs3d(i,k,j))/(1.+qv3d(i,k,j)))
568 ELSE IF ( F_QC .and. F_QI ) THEN
569 ! For Ferrier (note fixed after V3.8.1 for hires window Ferrier)
570 q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)/(1.+qv3d(i,k,j)))
571 q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
572 ELSE IF ( F_QC .and. F_QR ) THEN
573 ! Warm rain or simple ice
574 q(ii,kk,ixcldliq) = 0.
575 q(ii,kk,ixcldice) = 0.
576 if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
577 if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
578 ELSE
579 q(ii,kk,ixcldliq) = 0.
580 q(ii,kk,ixcldice) = 0.
581 ENDIF
582 cld(ii,kk) = CLDFRA(I,K,J)
583 enddo
584 enddo
586 do i = its,ite
587 ii = i - its + 1
588 landfrac(ii) = 2.-XLAND(I,J)
589 landm(ii) = landfrac(ii)
590 snowh(ii) = 0.001*SNOW(I,J)
591 icefrac(ii) = XICE(I,J)
592 enddo
594 do m=1,num_months-1
595 do k=1,levsiz
596 do i = its,ite
597 ii = i - its + 1
598 ozmixmj(ii,k,m) = ozmixm(i,k,j,m+1)
599 enddo
600 enddo
601 enddo
603 do i = its,ite
604 ii = i - its + 1
605 m_psjp(ii) = m_psp(i,j)
606 m_psjn(ii) = m_psn(i,j)
607 enddo
609 do n=1,naer_c
610 do k=1,paerlev
611 do i = its,ite
612 ii = i - its + 1
613 aerosoljp(ii,k,n) = aerosolcp(i,k,j,n)
614 aerosoljn(ii,k,n) = aerosolcn(i,k,j,n)
615 enddo
616 enddo
617 enddo
619 !
620 ! Complete radiation calculations
621 !
622 do i = its,ite
623 ii = i - its + 1
624 lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4
625 enddo
627 do k = kts,kte+1
628 kk = kte - k + kts + 1
629 do i = its,ite
630 ii = i - its + 1
631 pint(ii,kk) = p8w(i,k,j)
632 if(k.eq.kts)ps(ii)=pint(ii,kk)
633 lnpint(ii,kk) = log(pint(ii,kk))
634 enddo
635 enddo
637 if(.not.doabsems .and. dolw)then
638 ! do kk = kts,kte+1
639 do kk = 1,cam_abs_dim2
640 do kk1 = kts,kte+1
641 do i = its,ite
642 abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j)
643 enddo
644 enddo
645 enddo
646 ! do kk = 1,4
647 do kk = 1,cam_abs_dim1
648 do kk1 = kts,kte
649 do i = its,ite
650 absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j)
651 enddo
652 enddo
653 enddo
654 do kk = kts,kte+1
655 do i = its,ite
656 emstot(i,kk) = emstot_3d(i,kk,j)
657 enddo
658 enddo
659 endif
661 do k = kts,kte
662 kk = kte - k + kts
663 do i = its,ite
664 ii = i - its + 1
665 pmid(ii,kk) = p_phy(i,k,j)
666 lnpmid(ii,kk) = log(pmid(ii,kk))
667 lnpint(ii,kk) = log(pint(ii,kk))
668 pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk)
669 t(ii,kk) = t_phy(i,k,j)
670 zm(ii,kk) = z(i,k,j)
671 enddo
672 enddo
675 ! Compute cloud water/ice paths and optical properties for input to radiation
677 call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, &
678 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh)
680 !-----fds (06/2010)----------------------------
681 SELECT CASE(sf_surface_physics)
682 CASE (SSIBSCHEME)
683 if (xtime .gt. 1.0) then
684 ! call wrf_message("using SSiB albedoes for land points")
685 do i = its,ite
686 ii = i - its + 1
687 if (xland(i,j).lt.1.5) then !land points only
688 asdir(ii) = ALSWVISDIR(i,j) ! SSiB visdir albedo
689 asdif(ii) = ALSWVISDIF(i,j) ! SSiB visdif albedo
690 aldir(ii) = ALSWNIRDIR(i,j) ! SSiB nirdir albedo
691 aldif(ii) = ALSWNIRDIF(i,j) ! SSiB nirdif albedo
692 else
693 asdir(ii) = albedo(i,j)
694 asdif(ii) = albedo(i,j)
695 aldir(ii) = albedo(i,j)
696 aldif(ii) = albedo(i,j)
697 endif
698 enddo
699 else
700 do i = its,ite
701 ii = i - its + 1
702 asdir(ii) = albedo(i,j)
703 asdif(ii) = albedo(i,j)
704 aldir(ii) = albedo(i,j)
705 aldif(ii) = albedo(i,j)
706 enddo
707 endif
708 CASE (CLMSCHEME)
709 if (xtime .gt. 1.0) then
710 do i = its,ite
711 ii = i - its + 1
712 if (xland(i,j).lt.1.5) then !land points only
713 asdir(ii) = ALSWVISDIR(i,j) ! CLM visdir albedo
714 asdif(ii) = ALSWVISDIF(i,j) ! CLM visdif albedo
715 aldir(ii) = ALSWNIRDIR(i,j) ! CLM nirdir albedo
716 aldif(ii) = ALSWNIRDIF(i,j) ! CLM nirdif albedo
717 else
718 asdir(ii) = albedo(i,j)
719 asdif(ii) = albedo(i,j)
720 aldir(ii) = albedo(i,j)
721 aldif(ii) = albedo(i,j)
722 endif
723 enddo
724 else
725 do i = its,ite
726 ii = i - its + 1
727 asdir(ii) = albedo(i,j)
728 asdif(ii) = albedo(i,j)
729 aldir(ii) = albedo(i,j)
730 aldif(ii) = albedo(i,j)
731 enddo
732 endif
734 CASE DEFAULT
735 do i = its,ite
736 ii = i - its + 1
737 ! use same albedo for direct and diffuse
738 ! change this when separate values are provided
739 asdir(ii) = albedo(i,j)
740 asdif(ii) = albedo(i,j)
741 aldir(ii) = albedo(i,j)
742 aldif(ii) = albedo(i,j)
743 enddo
744 END SELECT
745 !-----------------------------------------------
747 ! WRF allocate space here (not needed if oznini is called)
748 ! allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90
750 call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid, &
751 pint, lnpmid, lnpint, pdel, t, q, &
752 cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif, &
753 aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
754 pin, ozmixmj, ozmix, levsiz, num_months,ghg_input, &
755 m_psjp,m_psjn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, &
756 dolw, dosw, doabsems, abstot, absnxt, emstot, &
757 fsup, fsupc, fsdn, fsdnc, &
758 fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes
759 flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, &
760 fsns, fsnt ,flns ,flnt , &
761 qrs, qrscs, qrl, qrlcs, flwds, rel, rei, &
762 sols, soll, solsd, solld, &
763 n2ovmr, ch4vmr, f11vmr, f12vmr , &
764 landfrac, zm, fsds, fsdsdir, fsdsdif) ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes
766 do k = kts,kte
767 kk = kte - k + kts
768 do i = its,ite
769 ii = i - its + 1
770 if(dolw)RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
771 if(dosw)RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j))
772 if(dolw)RTHRATENLWC(I,K,J) = 1.e4*qrlcs(ii,kk)/(cpair*pi_phy(i,k,j))
773 if(dosw)RTHRATENSWC(I,K,J) = 1.e4*qrscs(ii,kk)/(cpair*pi_phy(i,k,j))
774 cemiss(i,k,j) = emis(ii,kk)
775 taucldc(i,k,j) = tauxcl(ii,kk)
776 taucldi(i,k,j) = tauxci(ii,kk)
777 enddo
778 enddo
780 if(doabsems .and. dolw)then
781 ! do kk = kts,kte+1
782 do kk = 1,cam_abs_dim2
783 do kk1 = kts,kte+1
784 do i = its,ite
785 abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk)
786 enddo
787 enddo
788 enddo
789 ! do kk = 1,4
790 do kk = 1,cam_abs_dim1
791 do kk1 = kts,kte
792 do i = its,ite
793 absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk)
794 enddo
795 enddo
796 enddo
797 do kk = kts,kte+1
798 do i = its,ite
799 emstot_3d(i,kk,j) = emstot(i,kk)
800 enddo
801 enddo
802 endif
804 IF(PRESENT(SWUPT))THEN
805 if(dosw)then
806 ! Added shortwave and longwave upward/downward total and clear sky fluxes
807 do k = kts,kte+1
808 kk = kte +1 - k + kts
809 do i = its,ite
810 ii = i - its + 1
811 ! swup(i,k,j) = fsup(ii,kk)
812 ! swupclear(i,k,j) = fsupc(ii,kk)
813 ! swdn(i,k,j) = fsdn(ii,kk)
814 ! swdnclear(i,k,j) = fsdnc(ii,kk)
815 if(k.eq.kte+1)then
816 swupt(i,j) = fsup(ii,kk)
817 swuptc(i,j) = fsupc(ii,kk)
818 swdnt(i,j) = fsdn(ii,kk)
819 swdntc(i,j) = fsdnc(ii,kk)
820 endif
821 if(k.eq.kts)then
822 swupb(i,j) = fsup(ii,kk)
823 swupbc(i,j) = fsupc(ii,kk)
824 swdnb(i,j) = fsdn(ii,kk)
825 swdnbc(i,j) = fsdnc(ii,kk)
826 endif
827 ! if(i.eq.30.and.j.eq.30) then
828 ! print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk)
829 ! 1234 format (a6,4i4,4f10.3)
830 ! endif
831 enddo
832 enddo
833 endif
834 if(dolw)then
835 ! Added shortwave and longwave upward/downward total and clear sky fluxes
836 do k = kts,kte+1
837 kk = kte +1 - k + kts
838 do i = its,ite
839 ii = i - its + 1
840 ! lwup(i,k,j) = flup(ii,kk)
841 ! lwupclear(i,k,j) = flupc(ii,kk)
842 ! lwdn(i,k,j) = fldn(ii,kk)
843 ! lwdnclear(i,k,j) = fldnc(ii,kk)
844 if(k.eq.kte+1)then
845 lwupt(i,j) = flup(ii,kk)
846 lwuptc(i,j) = flupc(ii,kk)
847 lwdnt(i,j) = fldn(ii,kk)
848 lwdntc(i,j) = fldnc(ii,kk)
849 endif
850 if(k.eq.kts)then
851 lwupb(i,j) = flup(ii,kk)
852 lwupbc(i,j) = flupc(ii,kk)
853 lwdnb(i,j) = fldn(ii,kk)
854 lwdnbc(i,j) = fldnc(ii,kk)
855 endif
856 ! if(i.eq.30.and.j.eq.30) then
857 ! print 1234, 'long ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk)
858 ! 1234 format (a6,4i4,4f10.3)
859 ! endif
860 enddo
861 enddo
862 endif
863 ENDIF
865 do i = its,ite
866 ii = i - its + 1
867 ! Added shortwave and longwave cloud forcing at TOA and surface
868 if(dolw)then
869 GLW(I,J) = flwds(ii)
870 lwcf(i,j) = lwcftoa(ii)
871 olr(i,j) = olrtoa(ii)
872 endif
873 if(dosw)then
874 GSW(I,J) = fsns(ii)
875 swcf(i,j) = swcftoa(ii)
876 coszr(i,j) = coszrs(ii)
877 SWDDIR(i,j)= fsdsdir(ii) ! amontornes-bcodina (2014-04-20)
878 SWDDNI(i,j)= fsdsdir(ii)/coszrs(ii) ! amontornes-bcodina (2014-04-20)
879 SWDDIF(i,j)= fsdsdif(ii) ! amontornes-bcodina (2014-04-20)
880 endif
881 enddo
882 !-------fds (06/2010)---------
883 SELECT CASE(sf_surface_physics)
884 CASE (SSIBSCHEME)
885 ! call wrf_message("CAM using ssib albedo2")
886 if(dosw)then
887 do i = its,ite
888 ii = i - its + 1
889 SWVISDIR(I,J) = sols(ii) !SSiB
890 SWVISDIF(I,J) = solsd(ii) !SSiB
891 SWNIRDIR(I,J) = soll(ii) !SSiB
892 SWNIRDIF(I,J) = solld(ii) !SSiB
893 enddo
894 endif
895 CASE (CLMSCHEME)
896 if(dosw)then
897 do i = its,ite
898 ii = i - its + 1
899 SWVISDIR(I,J) = sols(ii) !CLM
900 SWVISDIF(I,J) = solsd(ii) !CLM
901 SWNIRDIR(I,J) = soll(ii) !CLM
902 SWNIRDIF(I,J) = solld(ii) !CLM
903 enddo
904 endif
906 END SELECT
907 !-----------------------------
909 enddo ! j-loop
911 #endif
913 end subroutine camrad
914 !====================================================================
915 SUBROUTINE camradinit( &
916 R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop, &
917 ozmixm,pin,levsiz,XLAT,num_months, &
918 m_psp,m_psn,m_hybi,aerosolcp,aerosolcn, &
919 paerlev,naer_c, &
920 ids, ide, jds, jde, kds, kde, &
921 ims, ime, jms, jme, kms, kme, &
922 its, ite, jts, jte, kts, kte )
924 USE module_wrf_error
925 USE module_state_description
926 !USE module_configure
928 !--------------------------------------------------------------------
929 IMPLICIT NONE
930 !--------------------------------------------------------------------
931 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
932 ims, ime, jms, jme, kms, kme, &
933 its, ite, jts, jte, kts, kte
934 REAL, intent(in) :: pptop
935 REAL, INTENT(IN) :: R_D,R_V,CP,G,STBOLT,EP_2
937 REAL, DIMENSION( kms:kme ) :: shalf
939 INTEGER, INTENT(IN ) :: levsiz, num_months
940 INTEGER, INTENT(IN ) :: paerlev, naer_c
942 REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT
944 REAL, DIMENSION( ims:ime, levsiz, jms:jme, num_months ), &
945 INTENT(INOUT ) :: OZMIXM
947 REAL, DIMENSION(levsiz), INTENT(INOUT ) :: PIN
948 REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT ) :: m_psp,m_psn
949 REAL, DIMENSION(paerlev), INTENT(INOUT ) :: m_hybi
950 REAL, DIMENSION( ims:ime, paerlev, jms:jme, naer_c ), &
951 INTENT(INOUT) :: aerosolcp,aerosolcn
953 REAL(r8) :: pstd
954 REAL(r8) :: rh2o, cpair
956 ! These were made allocatable 20090612 to save static memory allocation. JM
957 IF ( .NOT. ALLOCATED( ksul ) ) ALLOCATE( ksul( nrh, nspint ) )
958 IF ( .NOT. ALLOCATED( wsul ) ) ALLOCATE( wsul( nrh, nspint ) )
959 IF ( .NOT. ALLOCATED( gsul ) ) ALLOCATE( gsul( nrh, nspint ) )
960 IF ( .NOT. ALLOCATED( ksslt ) ) ALLOCATE( ksslt( nrh, nspint ) )
961 IF ( .NOT. ALLOCATED( wsslt ) ) ALLOCATE( wsslt( nrh, nspint ) )
962 IF ( .NOT. ALLOCATED( gsslt ) ) ALLOCATE( gsslt( nrh, nspint ) )
963 IF ( .NOT. ALLOCATED( kcphil ) ) ALLOCATE( kcphil( nrh, nspint ) )
964 IF ( .NOT. ALLOCATED( wcphil ) ) ALLOCATE( wcphil( nrh, nspint ) )
965 IF ( .NOT. ALLOCATED( gcphil ) ) ALLOCATE( gcphil( nrh, nspint ) )
967 IF ( .NOT. ALLOCATED(ah2onw ) ) ALLOCATE( ah2onw(n_p, n_tp, n_u, n_te, n_rh) )
968 IF ( .NOT. ALLOCATED(eh2onw ) ) ALLOCATE( eh2onw(n_p, n_tp, n_u, n_te, n_rh) )
969 IF ( .NOT. ALLOCATED(ah2ow ) ) ALLOCATE( ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
970 IF ( .NOT. ALLOCATED(cn_ah2ow) ) ALLOCATE( cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
971 IF ( .NOT. ALLOCATED(cn_eh2ow) ) ALLOCATE( cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
972 IF ( .NOT. ALLOCATED(ln_ah2ow) ) ALLOCATE( ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
973 IF ( .NOT. ALLOCATED(ln_eh2ow) ) ALLOCATE( ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
975 #if !defined(MAC_KLUDGE)
976 ozncyc = .true.
977 indirect = .true.
978 ixcldliq = 2
979 ixcldice = 3
980 #if (NMM_CORE != 1)
981 ! aerosol array is not in the NMM Registry
982 ! since CAM radiation not available to NMM (yet)
983 ! so this is blocked out to enable CAM compilation with NMM
984 idxSUL = P_SUL
985 idxSSLT = P_SSLT
986 idxDUSTfirst = P_DUST1
987 idxOCPHO = P_OCPHO
988 idxCARBONfirst = P_OCPHO
989 idxBCPHO = P_BCPHO
990 idxOCPHI = P_OCPHI
991 idxBCPHI = P_BCPHI
992 idxBG = P_BG
993 idxVOLC = P_VOLC
994 #endif
996 pstd = 101325.0
997 ! from physconst module
998 mwdry = 28.966 ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
999 mwco2 = 44. ! molecular weight co2
1000 mwh2o = 18.016 ! molecular weight water vapor (shr_const_mwwv)
1001 mwch4 = 16. ! molecular weight ch4
1002 mwn2o = 44. ! molecular weight n2o
1003 mwf11 = 136. ! molecular weight cfc11
1004 mwf12 = 120. ! molecular weight cfc12
1005 cappa = R_D/CP
1006 rair = R_D
1007 tmelt = 273.16 ! freezing T of fresh water ~ K
1008 r_universal = 6.02214e26 * STBOLT ! Universal gas constant ~ J/K/kmole
1009 latvap = 2.501e6 ! latent heat of evaporation ~ J/kg
1010 latice = 3.336e5 ! latent heat of fusion ~ J/kg
1011 zvir = R_V/R_D - 1.
1012 rh2o = R_V
1013 cpair = CP
1014 !
1015 epsqs = EP_2
1017 CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 )
1018 CALL esinti(epsqs ,latvap ,latice ,rh2o ,cpair ,tmelt )
1019 CALL oznini(ozmixm,pin,levsiz,num_months,XLAT, &
1020 ids, ide, jds, jde, kds, kde, &
1021 ims, ime, jms, jme, kms, kme, &
1022 its, ite, jts, jte, kts, kte)
1023 CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop, &
1024 ids, ide, jds, jde, kds, kde, &
1025 ims, ime, jms, jme, kms, kme, &
1026 its, ite, jts, jte, kts, kte)
1028 #endif
1030 END SUBROUTINE camradinit
1031 #if !defined(MAC_KLUDGE)
1034 subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
1036 IMPLICIT NONE
1038 INTEGER, INTENT(IN ) :: levsiz, num_months,pcols
1040 REAL(r8), DIMENSION( pcols, levsiz, num_months ), &
1041 INTENT(IN ) :: ozmixmj
1043 REAL, INTENT(IN ) :: XTIME,GMT
1044 INTEGER, INTENT(IN ) :: JULDAY
1045 REAL, INTENT(IN ) :: JULIAN
1046 REAL, INTENT(IN ) :: DT
1048 REAL(r8), DIMENSION( pcols, levsiz ), &
1049 INTENT(OUT ) :: ozmix
1050 !Local
1051 REAL(r8) :: intJULIAN
1052 integer :: np1,np,nm,m,k,i
1053 integer :: IJUL
1054 integer, dimension(12) :: date_oz
1055 data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
1056 real(r8) :: cdayozp, cdayozm
1057 real(r8) :: fact1, fact2
1058 logical :: finddate
1059 CHARACTER(LEN=256) :: msgstr
1061 ! JULIAN starts from 0.0 at 0Z on 1 Jan.
1062 intJULIAN = JULIAN + 1.0_r8 ! offset by one day
1063 ! jan 1st 00z is julian=1.0 here
1064 IJUL=INT(intJULIAN)
1065 ! Note that following will drift.
1066 ! Need to use actual month/day info to compute julian.
1067 intJULIAN=intJULIAN-FLOAT(IJUL)
1068 IJUL=MOD(IJUL,365)
1069 IF(IJUL.EQ.0)IJUL=365
1070 intJULIAN=intJULIAN+IJUL
1071 np1=1
1072 finddate=.false.
1073 ! do m=1,num_months
1074 do m=1,12
1075 if(date_oz(m).gt.intjulian.and..not.finddate) then
1076 np1=m
1077 finddate=.true.
1078 endif
1079 enddo
1080 cdayozp=date_oz(np1)
1081 if(np1.gt.1) then
1082 cdayozm=date_oz(np1-1)
1083 np=np1
1084 nm=np-1
1085 else
1086 cdayozm=date_oz(12)
1087 np=np1
1088 nm=12
1089 endif
1090 call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, &
1091 fact1, fact2)
1093 !
1094 ! Time interpolation.
1095 !
1096 do k=1,levsiz
1097 do i=1,pcols
1098 ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2
1099 end do
1100 end do
1102 END subroutine oznint
1105 subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
1106 aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale)
1107 !------------------------------------------------------------------
1108 !
1109 ! Input:
1110 ! time at which aerosol mmrs are needed (get_curr_calday())
1111 ! chunk index
1112 ! CAM's vertical grid (pint)
1113 !
1114 ! Output:
1115 ! values for Aerosol Mass Mixing Ratios at specified time
1116 ! on vertical grid specified by CAM (AEROSOLt)
1117 !
1118 ! Method:
1119 ! first determine which indexs of aerosols are the bounding data sets
1120 ! interpolate both onto vertical grid aerm(),aerp().
1121 ! from those two, interpolate in time.
1122 !
1123 !------------------------------------------------------------------
1125 ! use volcanicmass, only: get_volcanic_mass
1126 ! use timeinterp, only: getfactors
1127 !
1128 ! aerosol fields interpolated to current time step
1129 ! on pressure levels of this time step.
1130 ! these should be made read-only for other modules
1131 ! Is allocation done correctly here?
1132 !
1133 integer, intent(in) :: c ! Chunk Id.
1134 integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp
1135 real(r8), intent(in) :: pint(pcols,pverp) ! midpoint pres.
1136 real(r8), intent(in) :: scale(naer_all) ! scale each aerosol by this amount
1137 REAL, INTENT(IN ) :: XTIME,GMT
1138 INTEGER, INTENT(IN ) :: JULDAY
1139 REAL, INTENT(IN ) :: JULIAN
1140 REAL, INTENT(IN ) :: DT
1141 real(r8), intent(in ) :: m_psp(pcols),m_psn(pcols) ! Match surface pressure
1142 real(r8), intent(in ) :: aerosoljp(pcols,paerlev,naer_c)
1143 real(r8), intent(in ) :: aerosoljn(pcols,paerlev,naer_c)
1144 real(r8), intent(in ) :: m_hybi(paerlev)
1146 real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
1147 !
1148 ! Local workspace
1149 !
1150 real(r8) caldayloc ! calendar day of current timestep
1151 real(r8) fact1, fact2 ! time interpolation factors
1153 integer :: nm = 1 ! index to prv month in array. init to 1 and toggle between 1 and 2
1154 integer :: np = 2 ! index to nxt month in array. init to 2 and toggle between 1 and 2
1155 integer :: mo_nxt = bigint ! index to nxt month in file
1156 integer :: mo_prv ! index to previous month
1158 real(r8) :: cdaym = inf ! calendar day of prv month
1159 real(r8) :: cdayp = inf ! calendar day of next month
1160 real(r8) :: Mid(12) ! Days into year for mid month date
1161 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 /
1163 integer i, k, j ! spatial indices
1164 integer m ! constituent index
1165 integer lats(pcols),lons(pcols) ! latitude and longitudes of column
1166 integer ncol ! number of columns
1167 INTEGER IJUL
1168 REAL(r8) intJULIAN
1170 real(r8) speciesmin(naer) ! minimal value for each species
1171 !
1172 ! values before current time step "the minus month"
1173 ! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr
1174 ! aerosolp(pcols,pver) is value of next month's aerosol mmr
1175 ! (think minus and plus or values to left and right of point to be interpolated)
1176 !
1177 real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month
1178 !
1179 ! values beyond (or at) current time step "the plus month"
1180 !
1181 real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month
1182 CHARACTER(LEN=256) :: msgstr
1184 ! JULIAN starts from 0.0 at 0Z on 1 Jan.
1185 intJULIAN = JULIAN + 1.0_r8 ! offset by one day
1186 ! jan 1st 00z is julian=1.0 here
1187 IJUL=INT(intJULIAN)
1188 ! Note that following will drift.
1189 ! Need to use actual month/day info to compute julian.
1190 intJULIAN=intJULIAN-FLOAT(IJUL)
1191 IJUL=MOD(IJUL,365)
1192 IF(IJUL.EQ.0)IJUL=365
1193 caldayloc=intJULIAN+IJUL
1195 if (caldayloc < Mid(1)) then
1196 mo_prv = 12
1197 mo_nxt = 1
1198 else if (caldayloc >= Mid(12)) then
1199 mo_prv = 12
1200 mo_nxt = 1
1201 else
1202 do i = 2 , 12
1203 if (caldayloc < Mid(i)) then
1204 mo_prv = i-1
1205 mo_nxt = i
1206 exit
1207 end if
1208 end do
1209 end if
1210 !
1211 ! Set initial calendar day values
1212 !
1213 cdaym = Mid(mo_prv)
1214 cdayp = Mid(mo_nxt)
1216 !
1217 ! Determine time interpolation factors. 1st arg says we are cycling 1 year of data
1218 !
1219 call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, &
1220 fact1, fact2)
1221 !
1222 ! interpolate (prv and nxt month) bounding datasets onto cam vertical grid.
1223 ! compute mass mixing ratios on CAMS's pressure coordinate
1224 ! for both the "minus" and "plus" months
1225 !
1226 ! ncol = get_ncols_p(c)
1227 ncol = pcols
1229 ! call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c)
1230 ! call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c)
1232 call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c)
1233 call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c)
1235 !
1236 ! Time interpolate.
1237 !
1238 do m=1,naer
1239 do k=1,pver
1240 do i=1,ncol
1241 AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2
1242 end do
1243 end do
1244 end do
1246 ! do i=1,ncol
1247 ! Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2
1248 ! end do
1249 !
1250 ! get background aerosol (tuning) field
1251 !
1252 call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG))
1254 !
1255 ! find volcanic aerosol masses
1256 !
1257 ! if (strat_volcanic) then
1258 ! call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC))
1259 ! else
1260 AEROSOLt(:,:,idxVOLC) = 0._r8
1261 ! endif
1263 !
1264 ! exit if mmr is negative (we have previously set
1265 ! cumulative mass to be a decreasing function.)
1266 !
1267 speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species
1269 do m=1,naer
1270 do k=1,pver
1271 do i=1,ncol
1272 if (AEROSOLt(i, k, m) < speciesmin(m)) then
1273 write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting'
1274 write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m)
1275 print *,'naer:',naer,' pver:',pver,' ncol:',ncol
1276 PRINT *,'ERROR -- error -- ERROR -- error -- ERROR -- error'
1277 CALL wrf_error_fatal('CLWRF-module_ra_cam. : AEROSOLt=NaN')
1278 call endrun ()
1279 end if
1280 end do
1281 end do
1282 end do
1283 !
1284 ! scale any AEROSOLS as required
1285 !
1286 call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale)
1288 return
1289 end subroutine get_aerosol
1292 subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
1293 !--------------------------------------------------------------
1294 ! Compute effect of sulfate on effective liquid water radius
1295 ! Method of Martin et. al.
1296 !--------------------------------------------------------------
1298 ! use constituents, only: ppcnst, cnst_get_ind
1299 ! use history, only: outfld
1301 !#include "comctl.h"
1303 integer, intent(in) :: ncol ! number of atmospheric columns
1304 integer, intent(in) :: lchnk ! chunk identifier
1305 integer, intent(in) :: pcols,pver,ppcnst
1307 real(r8), intent(in) :: landfrac(pcols) ! land fraction
1308 real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
1309 real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
1310 real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
1311 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
1312 real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
1313 real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
1314 !
1315 ! local variables
1316 !
1317 real(r8) locrhoair(pcols,pver) ! dry air density [kg/m^3 ]
1318 real(r8) lwcwat(pcols,pver) ! in-cloud liquid water path [kg/m^3 ]
1319 real(r8) sulfmix(pcols,pver) ! sulfate mass mixing ratio [kg/kg ]
1320 real(r8) so4mass(pcols,pver) ! sulfate mass concentration [g/cm^3 ]
1321 real(r8) Aso4(pcols,pver) ! sulfate # concentration [#/cm^3 ]
1322 real(r8) Ntot(pcols,pver) ! ccn # concentration [#/cm^3 ]
1323 real(r8) relmod(pcols,pver) ! effective radius [microns]
1325 real(r8) wrel(pcols,pver) ! weighted effective radius [microns]
1326 real(r8) wlwc(pcols,pver) ! weighted liq. water content [kg/m^3 ]
1327 real(r8) cldfrq(pcols,pver) ! frequency of occurance of...
1328 ! ! clouds (cld => 0.01) [fraction]
1329 real(r8) locPi ! my piece of the pi
1330 real(r8) Rdryair ! gas constant of dry air [J/deg/kg]
1331 real(r8) rhowat ! density of water [kg/m^3 ]
1332 real(r8) Acoef ! m->A conversion factor; assumes
1333 ! ! Dbar=0.10, sigma=2.0 [g^-1 ]
1334 real(r8) rekappa ! kappa in evaluation of re(lmod)
1335 real(r8) recoef ! temp. coeficient for calc of re(lmod)
1336 real(r8) reexp ! 1.0/3.0
1337 real(r8) Ntotb ! temp var to hold below cloud ccn
1338 ! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)...
1339 real(r8) Cmarn ! Coef for CDNC_marine [cm^-3]
1340 real(r8) Cland ! Coef for CDNC_land [cm^-3]
1341 real(r8) Hmarn ! Scale height for CDNC_marine [m]
1342 real(r8) Hland ! Scale height for CDNC_land [m]
1343 parameter ( Cmarn = 50.0, Cland = 100.0 )
1344 parameter ( Hmarn = 1000.0, Hland = 2000.0 )
1345 real(r8) bgaer ! temp var to hold background CDNC
1347 integer i,k ! loop indices
1348 !
1349 ! Statement functions
1350 !
1351 logical land ! is this a column over land?
1352 land(i) = nint(landfrac(i)).gt.0.5_r8
1354 if (indirect) then
1356 ! call endrun ('AEROSOL_INDIRECT: indirect effect is obsolete')
1358 ! ramping is not yet resolved so sulfmix is 0.
1359 sulfmix(1:ncol,1:pver) = 0._r8
1361 locPi = 3.141592654
1362 Rdryair = 287.04
1363 rhowat = 1000.0
1364 Acoef = 1.2930E14
1365 recoef = 3.0/(4.0*locPi*rhowat)
1366 reexp = 1.0/3.0
1368 ! call cnst_get_ind('CLDLIQ', ixcldliq)
1369 do k=pver,1,-1
1370 do i = 1,ncol
1371 locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) )
1372 lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* &
1373 locrhoair(i,k)
1374 ! NOTE: 0.001 converts kg/m3 -> g/cm3
1375 so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001
1376 Aso4(i,k) = so4mass(i,k)*Acoef
1378 if (Aso4(i,k) <= 280.0) then
1379 Aso4(i,k) = max(36.0_r8,Aso4(i,k))
1380 Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30
1381 rekappa = 0.80
1382 else
1383 Aso4(i,k) = min(1500.0_r8,Aso4(i,k))
1384 Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9
1385 rekappa = 0.67
1386 end if
1387 if (land(i)) then ! Account for local background aerosol;
1388 bgaer = Cland*exp(-(zm(i,k)/Hland))
1389 Ntot(i,k) = max(bgaer,Ntot(i,k))
1390 else
1391 bgaer = Cmarn*exp(-(zm(i,k)/Hmarn))
1392 Ntot(i,k) = max(bgaer,Ntot(i,k))
1393 end if
1395 if (k == pver) then
1396 Ntotb = Ntot(i,k)
1397 else
1398 Ntotb = Ntot(i,k+1)
1399 end if
1401 relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0
1402 relmod(i,k) = max(4.0_r8,relmod(i,k))
1403 relmod(i,k) = min(20.0_r8,relmod(i,k))
1404 if (cld(i,k) >= 0.01) then
1405 cldfrq(i,k) = 1.0
1406 else
1407 cldfrq(i,k) = 0.0
1408 end if
1409 wrel(i,k) = relmod(i,k)*cldfrq(i,k)
1410 wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k)
1411 end do
1412 end do
1413 ! call outfld('MSO4 ',so4mass,pcols,lchnk)
1414 ! call outfld('LWC ',lwcwat ,pcols,lchnk)
1415 ! call outfld('CLDFRQ ',cldfrq ,pcols,lchnk)
1416 ! call outfld('WREL ',wrel ,pcols,lchnk)
1417 ! call outfld('WLWC ',wlwc ,pcols,lchnk)
1418 ! write(6,*)'WARNING: indirect calculation has no effects'
1419 else
1420 do k = 1, pver
1421 do i = 1, ncol
1422 relmod(i,k) = rel(i,k)
1423 end do
1424 end do
1425 endif
1427 ! call outfld('REL ',relmod ,pcols,lchnk)
1429 return
1430 end subroutine aerosol_indirect
1433 subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp )
1434 !
1435 ! Purpose: Compute strat. aerosol transmissions needed in absorptivity/
1436 ! emissivity calculations
1437 ! aer_trn() is called by radclw() when doabsems is .true.
1438 !
1439 ! use shr_kind_mod, only: r8 => shr_kind_r8
1440 ! use pmgrid
1441 ! use ppgrid
1442 ! use prescribed_aerosols, only: strat_volcanic
1443 implicit none
1445 ! Input arguments
1446 !
1447 ! [kg m-2] Volcanics path above kth interface level
1448 !
1449 integer, intent(in) :: pcols, plev, plevp
1450 real(r8), intent(in) :: aer_mpp(pcols,plevp)
1452 ! Output arguments
1453 !
1454 ! [fraction] Total volcanic transmission between interfaces k1 and k2
1455 !
1456 real(r8), intent(out) :: aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW)
1458 !-------------------------------------------------------------------------
1459 ! Local variables
1461 integer bnd_idx ! LW band index
1462 integer i ! lon index
1463 integer k1 ! lev index
1464 integer k2 ! lev index
1465 real(r8) aer_pth_dlt ! [kg m-2] Volcanics path between interface
1466 ! levels k1 and k2
1467 real(r8) odap_aer_ttl ! [fraction] Total path absorption optical
1468 ! depth
1470 !-------------------------------------------------------------------------
1472 if (strat_volcanic) then
1473 do bnd_idx=1,bnd_nbr_LW
1474 do i=1,pcols
1475 aer_trn_ttl(i,1,1,bnd_idx)=1.0
1476 end do
1477 do k1=2,plevp
1478 do i=1,pcols
1479 aer_trn_ttl(i,k1,k1,bnd_idx)=1.0
1481 aer_pth_dlt = abs(aer_mpp(i,k1) - aer_mpp(i,1))
1482 odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
1484 aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl)
1485 end do
1486 end do
1488 do k1=2,plev
1489 do k2=k1+1,plevp
1490 do i=1,pcols
1491 aer_trn_ttl(i,k1,k2,bnd_idx) = &
1492 aer_trn_ttl(i,1,k2,bnd_idx) / &
1493 aer_trn_ttl(i,1,k1,bnd_idx)
1494 end do
1495 end do
1496 end do
1498 do k1=2,plevp
1499 do k2=1,k1-1
1500 do i=1,pcols
1501 aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx)
1502 end do
1503 end do
1504 end do
1505 end do
1506 else
1507 aer_trn_ttl = 1.0
1508 endif
1510 return
1511 end subroutine aer_trn
1513 subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp)
1514 !------------------------------------------------------
1515 ! Purpose: convert mass per layer to cumulative mass from Top
1516 !------------------------------------------------------
1517 ! use shr_kind_mod, only: r8 => shr_kind_r8
1518 ! use ppgrid
1519 ! use pmgrid
1520 implicit none
1521 !#include "crdcon.h"
1523 ! Parameters
1524 ! Input
1525 integer, intent(in) :: pcols, plev, plevp
1526 real(r8), intent(in):: aer_mass(pcols,plev) ! Rad level aerosol mass mixing ratio
1527 integer, intent(in):: ncol
1528 !
1529 ! Output
1530 real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface
1531 !
1532 ! Local
1533 integer i ! Column index
1534 integer k ! Level index
1535 !------------------------------------------------------
1536 !------------------------------------------------------
1538 aer_mpp(1:ncol,1) = 0._r8
1539 do k=2,plevp
1540 aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1)
1541 enddo
1542 !
1543 return
1544 end subroutine aer_pth
1546 subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, &
1547 lwups ,emis , &
1548 pmid ,pint ,pmln ,piln ,pdel ,t , &
1549 ! qm1 ,cld ,cicewp ,cliqwp ,coszrs, clat, &
1550 qm1 ,cld ,cicewp ,cliqwp ,tauxcl, tauxci, coszrs, clat, &
1551 asdir ,asdif ,aldir ,aldif ,solcon, GMT,JULDAY,JULIAN,DT,XTIME, &
1552 pin, ozmixmj, ozmix, levsiz, num_months, ghg_input, &
1553 m_psp, m_psn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn , &
1554 nmxrgn , &
1555 dolw, dosw, doabsems, abstot, absnxt, emstot, &
1556 fsup ,fsupc ,fsdn ,fsdnc , &
1557 fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes
1558 flup ,flupc ,fldn ,fldnc , &
1559 swcf ,lwcf ,flut , &
1560 fsns ,fsnt ,flns ,flnt , &
1561 qrs ,qrscs ,qrl ,qrlcs ,flwds ,rel ,rei , &
1562 sols ,soll ,solsd ,solld , &
1563 n2ovmr, ch4vmr, f11vmr, f12vmr , &
1564 landfrac,zm ,fsds, fsdsdir,fsdsdif ) ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes
1565 !-----------------------------------------------------------------------
1566 !
1567 ! Purpose:
1568 ! Driver for radiation computation.
1569 !
1570 ! Method:
1571 ! Radiation uses cgs units, so conversions must be done from
1572 ! model fields to radiation fields.
1573 !
1574 ! Author: CCM1, CMS Contact: J. Truesdale
1575 !
1576 !-----------------------------------------------------------------------
1577 ! use shr_kind_mod, only: r8 => shr_kind_r8
1578 ! use ppgrid
1579 ! use pspect
1580 ! use commap
1581 ! use history, only: outfld
1582 ! use constituents, only: ppcnst, cnst_get_ind
1583 ! use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, &
1584 ! aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC
1585 ! use physics_types, only: physics_state
1586 ! use wv_saturation, only: aqsat
1587 ! use chemistry, only: trace_gas
1588 ! use physconst, only: cpair, epsilo
1589 ! use aer_optics, only: idxVIS
1590 ! use aerosol_intr, only: set_aerosol_from_prognostics
1593 implicit none
1595 !
1596 ! Input arguments
1597 !
1598 integer, intent(in) :: lchnk,j ! chunk identifier
1599 integer, intent(in) :: ncol ! number of atmospheric columns
1600 integer, intent(in) :: levsiz ! number of ozone data levels
1601 integer, intent(in) :: num_months ! 12 months
1602 integer, intent(in) :: ghg_input
1603 integer, intent(in) :: paerlev,naer_c ! aerosol vertical level and # species
1604 integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst
1605 logical, intent(in) :: dolw,dosw,doabsems
1608 integer nspint ! Num of spctrl intervals across solar spectrum
1609 integer naer_groups ! Num of aerosol groups for optical diagnostics
1610 parameter ( nspint = 19 )
1611 parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols
1614 real(r8), intent(in) :: lwups(pcols) ! Longwave up flux at surface
1615 real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
1616 real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures
1617 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
1618 real(r8), intent(in) :: pmln(pcols,pver) ! Natural log of pmid
1619 real(r8), intent(in) :: rel(pcols,pver) ! liquid effective drop size (microns)
1620 real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
1621 real(r8), intent(in) :: piln(pcols,pverp) ! Natural log of pint
1622 real(r8), intent(in) :: pdel(pcols,pverp) ! Pressure difference across layer
1623 real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures
1624 real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
1625 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
1626 real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
1627 real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
1628 real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth
1629 real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth
1630 real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
1631 real(r8), intent(in) :: clat(pcols) ! latitude in radians for columns
1632 real(r8), intent(in) :: asdir(pcols) ! albedo shortwave direct
1633 real(r8), intent(in) :: asdif(pcols) ! albedo shortwave diffuse
1634 real(r8), intent(in) :: aldir(pcols) ! albedo longwave direct
1635 real(r8), intent(in) :: aldif(pcols) ! albedo longwave diffuse
1636 real(r8), intent(in) :: landfrac(pcols) ! land fraction
1637 real(r8), intent(in) :: zm(pcols,pver) ! Height of midpoints (above surface)
1638 real(r8), intent(in) :: pin(levsiz) ! Pressure levels of ozone data
1639 real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months) ! monthly ozone mixing ratio
1640 real(r8), intent(inout) :: ozmix(pcols,levsiz) ! Ozone data
1641 real, intent(in) :: solcon ! solar constant with eccentricity factor
1642 REAL, INTENT(IN ) :: XTIME,GMT
1643 INTEGER, INTENT(IN ) :: JULDAY
1644 REAL, INTENT(IN ) :: JULIAN
1645 REAL, INTENT(IN ) :: DT
1646 real(r8), intent(in) :: m_psp(pcols),m_psn(pcols) ! MATCH surface pressure
1647 real(r8), intent(in) :: aerosoljp(pcols,paerlev,naer_c) ! aerosol concentrations
1648 real(r8), intent(in) :: aerosoljn(pcols,paerlev,naer_c) ! aerosol concentrations
1649 real(r8), intent(in) :: m_hybi(paerlev)
1650 ! type(physics_state), intent(in) :: state
1651 real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
1652 ! maximally overlapped region.
1653 ! 0->pmxrgn(i,1) is range of pmid for
1654 ! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
1655 ! 2nd region, etc
1656 integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
1658 real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn
1659 integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn
1661 !
1662 ! Output solar arguments
1663 !
1664 real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
1665 real(r8), intent(out) :: fsnt(pcols) ! Net column abs solar flux at model top
1666 real(r8), intent(out) :: flns(pcols) ! Srf longwave cooling (up-down) flux
1667 real(r8), intent(out) :: flnt(pcols) ! Net outgoing lw flux at model top
1668 real(r8), intent(out) :: sols(pcols) ! Downward solar rad onto surface (sw direct)
1669 real(r8), intent(out) :: soll(pcols) ! Downward solar rad onto surface (lw direct)
1670 real(r8), intent(out) :: solsd(pcols) ! Downward solar rad onto surface (sw diffuse)
1671 real(r8), intent(out) :: solld(pcols) ! Downward solar rad onto surface (lw diffuse)
1672 real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
1673 real(r8), intent(out) :: qrscs(pcols,pver) ! Clear sky solar heating rate
1674 real(r8), intent(out) :: fsds(pcols) ! Flux Shortwave Downwelling Surface
1675 real(r8), intent(out) :: fsdsdir(pcols) ! Flux Shortwave Direct Downwelling Surface (amontornes-bcodina 2014-04-20)
1676 real(r8), intent(out) :: fsdsdif(pcols) ! Flux Shortwave Diffuse Downwelling Surface (amontornes-bcodina 2014-04-20)
1677 ! Added outputs of total and clearsky fluxes etc
1678 real(r8), intent(out) :: fsup(pcols,pverp) ! Upward total sky solar
1679 real(r8), intent(out) :: fsupc(pcols,pverp) ! Upward clear sky solar
1680 real(r8), intent(out) :: fsdn(pcols,pverp) ! Downward total sky solar
1681 real(r8), intent(out) :: fsdnc(pcols,pverp) ! Downward clear sky solar
1682 real(r8), intent(out) :: fsdndir(pcols,pverp) ! Downward Direct total sky solar (amontornes-bcodina 2014-04-20)
1683 real(r8), intent(out) :: fsdncdir(pcols,pverp)! Downward Direct clear sky solar (amontornes-bcodina 2014-04-20)
1684 real(r8), intent(out) :: fsdndif(pcols,pverp) ! Downward Diffuse total sky solar (amontornes-bcodina 2014-04-20)
1685 real(r8), intent(out) :: fsdncdif(pcols,pverp)! Downward Diffuse clear sky solar (amontornes-bcodina 2014-04-20)
1686 real(r8), intent(out) :: flup(pcols,pverp) ! Upward total sky longwave
1687 real(r8), intent(out) :: flupc(pcols,pverp) ! Upward clear sky longwave
1688 real(r8), intent(out) :: fldn(pcols,pverp) ! Downward total sky longwave
1689 real(r8), intent(out) :: fldnc(pcols,pverp) ! Downward clear sky longwave
1690 real(r8), intent(out) :: swcf(pcols) ! Top of the atmosphere solar cloud forcing
1691 real(r8), intent(out) :: lwcf(pcols) ! Top of the atmosphere longwave cloud forcing
1692 real(r8), intent(out) :: flut(pcols) ! Top of the atmosphere outgoing longwave
1693 !
1694 ! Output longwave arguments
1695 !
1696 real(r8), intent(out) :: qrl(pcols,pver) ! Longwave cooling rate
1697 real(r8), intent(out) :: qrlcs(pcols,pver) ! Clear sky longwave cooling rate
1698 real(r8), intent(out) :: flwds(pcols) ! Surface down longwave flux
1700 real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
1701 real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
1702 real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
1705 !
1706 !---------------------------Local variables-----------------------------
1707 !
1708 integer i, k ! index
1710 integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array
1712 real(r8) solin(pcols) ! Solar incident flux
1713 ! real(r8) fsds(pcols) ! Flux Shortwave Downwelling Surface
1714 real(r8) fsntoa(pcols) ! Net solar flux at TOA
1715 real(r8) fsntoac(pcols) ! Clear sky net solar flux at TOA
1716 real(r8) fsnirt(pcols) ! Near-IR flux absorbed at toa
1717 real(r8) fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa
1718 real(r8) fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns
1719 real(r8) fsntc(pcols) ! Clear sky total column abs solar flux
1720 real(r8) fsnsc(pcols) ! Clear sky surface abs solar flux
1721 real(r8) fsdsc(pcols) ! Clear sky surface downwelling solar flux
1722 real(r8) fsdscdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20)
1723 real(r8) fsdscdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20)
1724 ! real(r8) flut(pcols) ! Upward flux at top of model
1725 ! real(r8) lwcf(pcols) ! longwave cloud forcing
1726 ! real(r8) swcf(pcols) ! shortwave cloud forcing
1727 real(r8) flutc(pcols) ! Upward Clear Sky flux at top of model
1728 real(r8) flntc(pcols) ! Clear sky lw flux at model top
1729 real(r8) flnsc(pcols) ! Clear sky lw flux at srf (up-down)
1730 real(r8) ftem(pcols,pver) ! temporary array for outfld
1732 real(r8) pbr(pcols,pverr) ! Model mid-level pressures (dynes/cm2)
1733 real(r8) pnm(pcols,pverrp) ! Model interface pressures (dynes/cm2)
1734 real(r8) o3vmr(pcols,pverr) ! Ozone volume mixing ratio
1735 real(r8) o3mmr(pcols,pverr) ! Ozone mass mixing ratio
1736 real(r8) eccf ! Earth/sun distance factor
1737 real(r8) n2o(pcols,pver) ! nitrous oxide mass mixing ratio
1738 real(r8) ch4(pcols,pver) ! methane mass mixing ratio
1739 real(r8) cfc11(pcols,pver) ! cfc11 mass mixing ratio
1740 real(r8) cfc12(pcols,pver) ! cfc12 mass mixing ratio
1741 real(r8) rh(pcols,pverr) ! level relative humidity (fraction)
1742 real(r8) lwupcgs(pcols) ! Upward longwave flux in cgs units
1744 real(r8) esat(pcols,pverr) ! saturation vapor pressure
1745 real(r8) qsat(pcols,pverr) ! saturation specific humidity
1747 real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums
1748 real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
1749 real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
1750 real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
1751 real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
1753 real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios
1754 real(r8) scales(naer_all) ! scaling factors for aerosols
1756 real(r8), INTENT(IN) :: n2ovmr, ch4vmr, f11vmr, f12vmr
1757 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
1758 CHARACTER (LEN=256) :: message
1759 !ccc
1761 !
1762 ! Interpolate ozone volume mixing ratio to model levels
1763 !
1764 ! WRF: added pin, levsiz, ozmix here
1765 call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
1767 call radozn(lchnk ,ncol &
1768 ,pcols, pver &
1769 ,pmid ,pin, levsiz, ozmix, o3vmr )
1771 ! call outfld('O3VMR ',o3vmr ,pcols, lchnk)
1773 !
1774 ! Set chunk dependent radiation input
1775 !
1776 call radinp(lchnk ,ncol ,pcols, pver, pverp, &
1777 pmid ,pint ,o3vmr , pbr ,&
1778 pnm ,eccf ,o3mmr )
1780 !
1781 ! Solar radiation computation
1782 !
1783 if (dosw) then
1785 !
1786 ! calculate heating with aerosols
1787 !
1788 call aqsat(t, pmid, esat, qsat, pcols, &
1789 ncol, pver, 1, pver)
1791 ! calculate relative humidity
1792 ! rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
1793 ! ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
1794 ! ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo)
1795 rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
1796 ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
1797 ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo)
1799 if (radforce) then
1801 pmxrgnrf = pmxrgn
1802 nmxrgnrf = nmxrgn
1804 call get_rf_scales(scales)
1806 call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
1807 aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
1809 ! overwrite with prognostics aerosols
1811 ! no feedback from prognostic aerosols
1812 ! call set_aerosol_from_prognostics (ncol, q, aerosol)
1814 call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
1816 ! call t_startf('radcswmx_rf')
1817 call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
1818 pnm ,pbr ,qm1 ,rh ,o3mmr , &
1819 aerosol ,cld ,cicewp ,cliqwp ,rel , &
1820 ! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
1821 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
1822 asdir ,asdif ,aldir ,aldif ,nmxrgnrf, &
1823 pmxrgnrf,qrs ,qrscs ,fsnt ,fsntc ,fsntoa , &
1824 fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
1825 fsnsc ,fsdsc ,fsds ,sols ,soll , &
1826 solsd ,solld ,frc_day , &
1827 fsup ,fsupc ,fsdn ,fsdnc , &
1828 fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profile
1829 fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc
1830 aertau ,aerssa ,aerasm ,aerfwd )
1831 ! call t_stopf('radcswmx_rf')
1833 !
1834 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
1835 !
1837 do i = 1, ncol
1838 solin(i) = solin(i)*1.e-3
1839 fsnt(i) = fsnt(i) *1.e-3
1840 fsns(i) = fsns(i) *1.e-3
1841 fsntc(i) = fsntc(i)*1.e-3
1842 fsnsc(i) = fsnsc(i)*1.e-3
1843 end do
1844 ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
1845 !
1846 ! Dump shortwave radiation information to history tape buffer (diagnostics)
1847 !
1848 ! call outfld('QRS_RF ',ftem ,pcols,lchnk)
1849 ! call outfld('FSNT_RF ',fsnt ,pcols,lchnk)
1850 ! call outfld('FSNS_RF ',fsns ,pcols,lchnk)
1851 ! call outfld('FSNTC_RF',fsntc ,pcols,lchnk)
1852 ! call outfld('FSNSC_RF',fsnsc ,pcols,lchnk)
1854 endif ! if (radforce)
1856 call get_int_scales(scales)
1858 call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
1859 m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
1861 ! overwrite with prognostics aerosols
1862 ! call set_aerosol_from_prognostics (ncol, q, aerosol)
1864 call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
1865 ! call t_startf('radcswmx')
1867 call radcswmx(j, lchnk ,ncol ,pcols, pver, pverp, &
1868 pnm ,pbr ,qm1 ,rh ,o3mmr , &
1869 aerosol ,cld ,cicewp ,cliqwp ,rel , &
1870 ! rei ,eccf ,coszrs ,scon ,solin ,solcon , &
1871 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon , &
1872 asdir ,asdif ,aldir ,aldif ,nmxrgn , &
1873 pmxrgn ,qrs ,qrscs ,fsnt ,fsntc ,fsntoa , &
1874 fsntoac ,fsnirt ,fsnrtc ,fsnirtsq,fsns , &
1875 fsnsc ,fsdsc ,fsds ,sols ,soll , &
1876 solsd ,solld ,frc_day , &
1877 fsup ,fsupc ,fsdn ,fsdnc , &
1878 fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profiles
1879 fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc
1880 aertau ,aerssa ,aerasm ,aerfwd )
1881 ! call t_stopf('radcswmx')
1883 ! -- tls ---------------------------------------------------------------2
1884 !
1885 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
1886 !
1887 do i=1,ncol
1888 solin(i) = solin(i)*1.e-3
1889 fsds(i) = fsds(i)*1.e-3
1890 fsnirt(i)= fsnirt(i)*1.e-3
1891 fsnrtc(i)= fsnrtc(i)*1.e-3
1892 fsnirtsq(i)= fsnirtsq(i)*1.e-3
1893 fsnt(i) = fsnt(i) *1.e-3
1894 fsns(i) = fsns(i) *1.e-3
1895 fsntc(i) = fsntc(i)*1.e-3
1896 fsnsc(i) = fsnsc(i)*1.e-3
1897 fsdsc(i) = fsdsc(i)*1.e-3
1898 fsntoa(i)=fsntoa(i)*1.e-3
1899 fsntoac(i)=fsntoac(i)*1.e-3
1900 swcf(i) = fsntoa(i) - fsntoac(i)
1902 fsdsdir(i) = fsdsdir(i)*1.e-3 ! amontornes-bcodina (2014-04-20)
1903 fsdsdif(i) = fsdsdif(i)*1.e-3 ! amontornes-bcodina (2014-04-20)
1904 fsdscdir(i) = fsdscdir(i)*1.e-3 ! amontornes-bcodina (2014-04-20)
1905 fsdscdif(i) = fsdscdif(i)*1.e-3 ! amontornes-bcodina (2014-04-20)
1906 end do
1907 ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
1909 ! Added upward/downward total and clear sky fluxes
1910 do k = 1, pverp
1911 do i = 1, ncol
1912 fsup(i,k) = fsup(i,k)*1.e-3
1913 fsupc(i,k) = fsupc(i,k)*1.e-3
1914 fsdn(i,k) = fsdn(i,k)*1.e-3
1915 fsdnc(i,k) = fsdnc(i,k)*1.e-3
1916 end do
1917 end do
1919 !
1920 ! Dump shortwave radiation information to history tape buffer (diagnostics)
1921 !
1923 ! call outfld('frc_day ', frc_day, pcols, lchnk)
1924 ! call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk)
1925 ! call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk)
1926 ! call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk)
1927 ! call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk)
1928 ! call outfld('BGOD_v ', aertau(:,idxVIS,5) ,pcols,lchnk)
1929 ! call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk)
1930 ! call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk)
1931 ! call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk)
1932 ! call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk)
1933 ! call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk)
1934 ! call aerosol_diagnostics (lchnk, ncol, pdel, aerosol)
1936 ! call outfld('QRS ',ftem ,pcols,lchnk)
1937 ! call outfld('SOLIN ',solin ,pcols,lchnk)
1938 ! call outfld('FSDS ',fsds ,pcols,lchnk)
1939 ! call outfld('FSNIRTOA',fsnirt,pcols,lchnk)
1940 ! call outfld('FSNRTOAC',fsnrtc,pcols,lchnk)
1941 ! call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk)
1942 ! call outfld('FSNT ',fsnt ,pcols,lchnk)
1943 ! call outfld('FSNS ',fsns ,pcols,lchnk)
1944 ! call outfld('FSNTC ',fsntc ,pcols,lchnk)
1945 ! call outfld('FSNSC ',fsnsc ,pcols,lchnk)
1946 ! call outfld('FSDSC ',fsdsc ,pcols,lchnk)
1947 ! call outfld('FSNTOA ',fsntoa,pcols,lchnk)
1948 ! call outfld('FSNTOAC ',fsntoac,pcols,lchnk)
1949 ! call outfld('SOLS ',sols ,pcols,lchnk)
1950 ! call outfld('SOLL ',soll ,pcols,lchnk)
1951 ! call outfld('SOLSD ',solsd ,pcols,lchnk)
1952 ! call outfld('SOLLD ',solld ,pcols,lchnk)
1954 end if
1955 !
1956 ! Longwave radiation computation
1957 !
1958 if (dolw) then
1960 call get_int_scales(scales)
1962 call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
1963 m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
1965 !
1966 ! Convert upward longwave flux units to CGS
1967 !
1968 do i=1,ncol
1969 ! lwupcgs(i) = lwup(i)*1000.
1970 lwupcgs(i) = lwups(i)
1971 end do
1972 !
1973 ! Do longwave computation. If not implementing greenhouse gas code then
1974 ! first specify trace gas mixing ratios. If greenhouse gas code then:
1975 ! o ixtrcg => indx of advected n2o tracer
1976 ! o ixtrcg+1 => indx of advected ch4 tracer
1977 ! o ixtrcg+2 => indx of advected cfc11 tracer
1978 ! o ixtrcg+3 => indx of advected cfc12 tracer
1979 !
1980 if (trace_gas) then
1981 ! call cnst_get_ind('N2O' , in2o)
1982 ! call cnst_get_ind('CH4' , ich4)
1983 ! call cnst_get_ind('CFC11', if11)
1984 ! call cnst_get_ind('CFC12', if12)
1985 ! call t_startf("radclwmx")
1986 call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
1987 lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
1988 pbr ,pnm ,pmln ,piln , &
1989 qm1(1,1,in2o) ,qm1(1,1,ich4) , &
1990 qm1(1,1,if11) ,qm1(1,1,if12) , &
1991 cld ,emis ,pmxrgn ,nmxrgn , &
1992 qrl ,qrlcs , &
1993 doabsems,abstot ,absnxt ,emstot , &
1994 flns ,flnt ,flnsc ,flntc ,flwds , &
1995 flut ,flutc , &
1996 flup ,flupc ,fldn ,fldnc , &
1997 aerosol(:,:,idxVOLC))
1998 ! call t_stopf("radclwmx")
1999 else
2001 IF (ghg_input.eq.1) THEN
2002 IF ( wrf_dm_on_monitor() ) THEN
2003 WRITE(message,*)'CLWRF-CAM_call-trcmix n2ovmr:',n2ovmr,' ch4vmr:',ch4vmr,' f11vmr:',f11vmr,' f12vmr:',f12vmr
2004 CALL wrf_debug(1, message)
2005 END IF
2006 call trcmix_clwrf(lchnk ,ncol ,pcols, pver, &
2007 pmid ,clat, n2ovmr, ch4vmr, f11vmr, f12vmr, n2o, &
2008 ch4, cfc11, cfc12 )
2010 ELSE
2011 call trcmix(lchnk ,ncol ,pcols, pver, &
2012 pmid ,clat, n2o ,ch4 , &
2013 cfc11 ,cfc12 )
2014 ENDIF
2015 IF ( wrf_dm_on_monitor() ) THEN
2016 WRITE(message,*)'CLWRF post_trcmix_values. n2o:', n2o(pcols/2,pver/2), ' ch4:', &
2017 ch4(pcols/2,pver/2),' cfc11:', cfc11(pcols/2,pver/2),' cfc12:', cfc12(pcols/2,pver/2)
2018 CALL wrf_debug(1, message)
2019 END IF
2020 !ccc
2021 ! call t_startf("radclwmx")
2022 call radclwmx(lchnk ,ncol ,pcols, pver, pverp , &
2023 lwupcgs ,t ,qm1(1,1,1) ,o3vmr , &
2024 pbr ,pnm ,pmln ,piln , &
2025 n2o ,ch4 ,cfc11 ,cfc12 , &
2026 cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
2027 qrlcs, doabsems, abstot, absnxt, emstot, &
2028 flns ,flnt ,flnsc ,flntc ,flwds , &
2029 flut ,flutc , &
2030 flup ,flupc ,fldn ,fldnc , &
2031 aerosol(:,:,idxVOLC))
2032 ! call t_stopf("radclwmx")
2033 endif
2034 !
2035 ! Convert units of longwave fields needed by rest of model from CGS to MKS
2036 !
2037 do i=1,ncol
2038 flnt(i) = flnt(i)*1.e-3
2039 flut(i) = flut(i)*1.e-3
2040 flutc(i) = flutc(i)*1.e-3
2041 flns(i) = flns(i)*1.e-3
2042 flntc(i) = flntc(i)*1.e-3
2043 flnsc(i) = flnsc(i)*1.e-3
2044 flwds(i) = flwds(i)*1.e-3
2045 lwcf(i) = flutc(i) - flut(i)
2046 end do
2048 ! Added upward/downward total and clear sky fluxes
2049 do k = 1, pverp
2050 do i = 1, ncol
2051 flup(i,k) = flup(i,k)*1.e-3
2052 flupc(i,k) = flupc(i,k)*1.e-3
2053 fldn(i,k) = fldn(i,k)*1.e-3
2054 fldnc(i,k) = fldnc(i,k)*1.e-3
2055 end do
2056 end do
2057 !
2058 ! Dump longwave radiation information to history tape buffer (diagnostics)
2059 !
2060 ! call outfld('QRL ',qrl(:ncol,:)/cpair,ncol,lchnk)
2061 ! call outfld('FLNT ',flnt ,pcols,lchnk)
2062 ! call outfld('FLUT ',flut ,pcols,lchnk)
2063 ! call outfld('FLUTC ',flutc ,pcols,lchnk)
2064 ! call outfld('FLNTC ',flntc ,pcols,lchnk)
2065 ! call outfld('FLNS ',flns ,pcols,lchnk)
2066 ! call outfld('FLNSC ',flnsc ,pcols,lchnk)
2067 ! call outfld('LWCF ',lwcf ,pcols,lchnk)
2068 ! call outfld('SWCF ',swcf ,pcols,lchnk)
2069 !
2070 end if
2071 !
2072 return
2073 end subroutine radctl
2074 subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, &
2075 q, cldn, landfrac, landm,icefrac, &
2076 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh )
2077 !
2078 ! Compute (liquid+ice) water path and cloud water/ice diagnostics
2079 ! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios
2080 !
2081 ! **** mixes interface and physics code temporarily
2082 !-----------------------------------------------------------------------
2083 ! use physics_types, only: physics_state
2084 ! use history, only: outfld
2085 ! use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw
2087 implicit none
2089 ! Arguments
2090 integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst
2091 real(r8), intent(in) :: q(pcols,pver,ppcnst) ! moisture arrays
2092 real(r8), intent(in) :: cldn(pcols,pver) ! new cloud fraction
2093 real(r8), intent(in) :: pdel(pcols,pver) ! pressure thickness
2094 real(r8), intent(in) :: t(pcols,pver) ! temperature
2095 real(r8), intent(in) :: pmid(pcols,pver) ! pressure
2096 real(r8), intent(in) :: pint(pcols,pverp) ! pressure
2097 real(r8), intent(in) :: ps(pcols) ! surface pressure
2098 real(r8), intent(in) :: landfrac(pcols) ! Land fraction
2099 real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
2100 real(r8), intent(in) :: landm(pcols) ! Land fraction ramped
2101 real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
2103 !!$ real(r8), intent(out) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
2104 real(r8), intent(out) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
2105 real(r8), intent(out) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
2106 real(r8), intent(out) :: emis (pcols,pver) ! cloud emissivity
2107 real(r8), intent(out) :: rel (pcols,pver) ! effective drop radius (microns)
2108 real(r8), intent(out) :: rei (pcols,pver) ! ice effective drop size (microns)
2109 real(r8), intent(out) :: pmxrgn(pcols,pver+1) ! Maximum values of pressure for each
2110 integer , intent(out) :: nmxrgn(pcols) ! Number of maximally overlapped regions
2112 ! Local variables
2113 real(r8) :: cwp (pcols,pver) ! in-cloud cloud (total) water path
2114 !!$ real(r8) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
2115 !!$ real(r8) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
2116 real(r8) :: effcld(pcols,pver) ! effective cloud=cld*emis
2117 real(r8) :: gicewp(pcols,pver) ! grid-box cloud ice water path
2118 real(r8) :: gliqwp(pcols,pver) ! grid-box cloud liquid water path
2119 real(r8) :: gwp (pcols,pver) ! grid-box cloud (total) water path
2120 real(r8) :: hl (pcols) ! Liquid water scale height
2121 real(r8) :: tgicewp(pcols) ! Vertically integrated ice water path
2122 real(r8) :: tgliqwp(pcols) ! Vertically integrated liquid water path
2123 real(r8) :: tgwp (pcols) ! Vertically integrated (total) cloud water path
2124 real(r8) :: tpw (pcols) ! total precipitable water
2125 real(r8) :: clwpold(pcols,pver) ! Presribed cloud liq. h2o path
2126 real(r8) :: ficemr (pcols,pver) ! Ice fraction from ice and liquid mixing ratios
2128 real(r8) :: rgrav ! inverse gravitational acceleration
2130 integer :: i,k ! loop indexes
2131 integer :: lchnk
2133 !-----------------------------------------------------------------------
2135 ! Compute liquid and ice water paths
2136 tgicewp(:ncol) = 0.
2137 tgliqwp(:ncol) = 0.
2138 do k=1,pver
2139 do i = 1,ncol
2140 gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0 ! Grid box ice water path.
2141 gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0 ! Grid box liquid water path.
2142 !!$ gwp (i,k) = gicewp(i,k) + gliqwp(i,k)
2143 cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
2144 cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
2145 !!$ cwp (i,k) = gwp (i,k) / max(0.01_r8,cldn(i,k))
2146 ficemr(i,k) = q(i,k,ixcldice) / &
2147 max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq)))
2149 tgicewp(i) = tgicewp(i) + gicewp(i,k)
2150 tgliqwp(i) = tgliqwp(i) + gliqwp(i,k)
2151 end do
2152 end do
2153 tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol)
2154 gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver)
2155 cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
2157 ! Compute total preciptable water in column (in mm)
2158 tpw(:ncol) = 0.0
2159 rgrav = 1.0/gravmks
2160 do k=1,pver
2161 do i=1,ncol
2162 tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav
2163 end do
2164 end do
2166 ! Diagnostic liquid water path (old specified form)
2167 ! call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl)
2169 ! Cloud water and ice particle sizes
2170 call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
2172 ! Cloud emissivity.
2173 call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis)
2175 ! Effective cloud cover
2176 do k=1,pver
2177 do i=1,ncol
2178 effcld(i,k) = cldn(i,k)*emis(i,k)
2179 end do
2180 end do
2182 ! Determine parameters for maximum/random overlap
2183 call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn)
2185 ! call outfld('GCLDLWP' ,gwp , pcols,lchnk)
2186 ! call outfld('TGCLDCWP',tgwp , pcols,lchnk)
2187 ! call outfld('TGCLDLWP',tgliqwp, pcols,lchnk)
2188 ! call outfld('TGCLDIWP',tgicewp, pcols,lchnk)
2189 ! call outfld('ICLDLWP' ,cwp , pcols,lchnk)
2190 ! call outfld('SETLWP' ,clwpold, pcols,lchnk)
2191 ! call outfld('EFFCLD' ,effcld , pcols,lchnk)
2192 ! call outfld('LWSH' ,hl , pcols,lchnk)
2194 end subroutine param_cldoptics_calc
2196 subroutine radabs(lchnk ,ncol ,pcols, pver, pverp, &
2197 pbr ,pnm ,co2em ,co2eml ,tplnka , &
2198 s2c ,tcg ,w ,h2otr ,plco2 , &
2199 plh2o ,co2t ,tint ,tlayr ,plol , &
2200 plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
2201 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
2202 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
2203 bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
2204 abstot ,absnxt ,plh2ob ,wb , &
2205 aer_mpp ,aer_trn_ttl)
2206 !-----------------------------------------------------------------------
2207 !
2208 ! Purpose:
2209 ! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12
2210 !
2211 ! Method:
2212 ! h2o .... Uses nonisothermal emissivity method for water vapor from
2213 ! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
2214 ! Emissivity and Absorptivity Formulation for Water Vapor
2215 ! Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
2216 !
2217 ! Implementation updated by Collins, Hackney, and Edwards (2001)
2218 ! using line-by-line calculations based upon Hitran 1996 and
2219 ! CKD 2.1 for absorptivity and emissivity
2220 !
2221 ! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
2222 ! using line-by-line calculations based upon Hitran 2000 and
2223 ! CKD 2.4 for absorptivity and emissivity
2224 !
2225 ! co2 .... Uses absorptance parameterization of the 15 micro-meter
2226 ! (500 - 800 cm-1) band system of Carbon Dioxide, from
2227 ! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
2228 ! of the Absorptance Due to the 15 micro-meter Band System
2229 ! of Carbon Dioxide Jouranl of Geophysical Research,
2230 ! vol. 96., D5, pp 9013-9019.
2231 ! Parameterizations for the 9.4 and 10.4 mircon bands of CO2
2232 ! are also included.
2233 !
2234 ! o3 .... Uses absorptance parameterization of the 9.6 micro-meter
2235 ! band system of ozone, from Ramanathan, V. and R.Dickinson,
2236 ! 1979: The Role of stratospheric ozone in the zonal and
2237 ! seasonal radiative energy balance of the earth-troposphere
2238 ! system. Journal of the Atmospheric Sciences, Vol. 36,
2239 ! pp 1084-1104
2240 !
2241 ! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
2242 !
2243 ! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
2244 ! bands of nitrous oxide
2245 !
2246 ! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
2247 ! micron bands of CFC11
2248 !
2249 ! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
2250 ! micron bands of CFC12
2251 !
2252 !
2253 ! Computes individual absorptivities for non-adjacent layers, accounting
2254 ! for band overlap, and sums to obtain the total; then, computes the
2255 ! nearest layer contribution.
2256 !
2257 ! Author: W. Collins (H2O absorptivity) and J. Kiehl
2258 !
2259 !-----------------------------------------------------------------------
2260 !------------------------------Arguments--------------------------------
2261 !
2262 ! Input arguments
2263 !
2264 integer, intent(in) :: lchnk ! chunk identifier
2265 integer, intent(in) :: ncol ! number of atmospheric columns
2266 integer, intent(in) :: pcols, pver, pverp
2268 real(r8), intent(in) :: pbr(pcols,pver) ! Prssr at mid-levels (dynes/cm2)
2269 real(r8), intent(in) :: pnm(pcols,pverp) ! Prssr at interfaces (dynes/cm2)
2270 real(r8), intent(in) :: co2em(pcols,pverp) ! Co2 emissivity function
2271 real(r8), intent(in) :: co2eml(pcols,pver) ! Co2 emissivity function
2272 real(r8), intent(in) :: tplnka(pcols,pverp) ! Planck fnctn level temperature
2273 real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
2274 real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
2275 real(r8), intent(in) :: w(pcols,pverp) ! H2o prs wghted path
2276 real(r8), intent(in) :: h2otr(pcols,pverp) ! H2o trnsmssn fnct for o3 overlap
2277 real(r8), intent(in) :: plco2(pcols,pverp) ! Co2 prs wghted path length
2278 real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wfhted path length
2279 real(r8), intent(in) :: co2t(pcols,pverp) ! Tmp and prs wghted path length
2280 real(r8), intent(in) :: tint(pcols,pverp) ! Interface temperatures
2281 real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 level temperatures
2282 real(r8), intent(in) :: plol(pcols,pverp) ! Ozone prs wghted path length
2283 real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path length
2284 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
2285 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
2286 real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
2287 ! Hulst-Curtis-Godson temp. factor
2288 ! for H2O bands
2289 real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
2290 ! Hulst-Curtis-Godson temp. factor
2291 ! for H2O bands
2293 real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level
2294 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
2297 !
2298 ! Trace gas variables
2299 !
2300 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
2301 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
2302 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
2303 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
2304 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
2305 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
2306 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
2307 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
2308 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
2309 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
2310 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
2311 real(r8), intent(in) :: uptype(pcols,pverp) ! continuum path length
2312 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
2313 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
2314 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
2315 real(r8), intent(in) :: abplnk1(14,pcols,pverp) ! non-nearest layer Planck factor
2316 real(r8), intent(in) :: abplnk2(14,pcols,pverp) ! nearest layer factor
2317 !
2318 ! Output arguments
2319 !
2320 real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity
2321 real(r8), intent(out) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
2322 !
2323 !---------------------------Local variables-----------------------------
2324 !
2325 integer i ! Longitude index
2326 integer k ! Level index
2327 integer k1 ! Level index
2328 integer k2 ! Level index
2329 integer kn ! Nearest level index
2330 integer wvl ! Wavelength index
2332 real(r8) abstrc(pcols) ! total trace gas absorptivity
2333 real(r8) bplnk(14,pcols,4) ! Planck functions for sub-divided layers
2334 real(r8) pnew(pcols) ! Effective pressure for H2O vapor linewidth
2335 real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
2336 ! Hulst-Curtis-Godson correction for
2337 ! each band
2338 real(r8) u(pcols) ! Pressure weighted H2O path length
2339 real(r8) ub(nbands) ! Pressure weighted H2O path length with
2340 ! Hulst-Curtis-Godson correction for
2341 ! each band
2342 real(r8) tbar(pcols,4) ! Mean layer temperature
2343 real(r8) emm(pcols,4) ! Mean co2 emissivity
2344 real(r8) o3emm(pcols,4) ! Mean o3 emissivity
2345 real(r8) o3bndi ! Ozone band parameter
2346 real(r8) temh2o(pcols,4) ! Mean layer temperature equivalent to tbar
2347 real(r8) k21 ! Exponential coefficient used to calculate
2348 ! ! rotation band transmissvty in the 650-800
2349 ! ! cm-1 region (tr1)
2350 real(r8) k22 ! Exponential coefficient used to calculate
2351 ! ! rotation band transmissvty in the 500-650
2352 ! ! cm-1 region (tr2)
2353 real(r8) uc1(pcols) ! H2o continuum pathlength in 500-800 cm-1
2354 real(r8) to3h2o(pcols) ! H2o trnsmsn for overlap with o3
2355 real(r8) pi ! For co2 absorptivity computation
2356 real(r8) sqti(pcols) ! Used to store sqrt of mean temperature
2357 real(r8) et ! Co2 hot band factor
2358 real(r8) et2 ! Co2 hot band factor squared
2359 real(r8) et4 ! Co2 hot band factor to fourth power
2360 real(r8) omet ! Co2 stimulated emission term
2361 real(r8) f1co2 ! Co2 central band factor
2362 real(r8) f2co2(pcols) ! Co2 weak band factor
2363 real(r8) f3co2(pcols) ! Co2 weak band factor
2364 real(r8) t1co2(pcols) ! Overlap factr weak bands on strong band
2365 real(r8) sqwp ! Sqrt of co2 pathlength
2366 real(r8) f1sqwp(pcols) ! Main co2 band factor
2367 real(r8) oneme ! Co2 stimulated emission term
2368 real(r8) alphat ! Part of the co2 stimulated emission term
2369 real(r8) wco2 ! Constants used to define co2 pathlength
2370 real(r8) posqt ! Effective pressure for co2 line width
2371 real(r8) u7(pcols) ! Co2 hot band path length
2372 real(r8) u8 ! Co2 hot band path length
2373 real(r8) u9 ! Co2 hot band path length
2374 real(r8) u13 ! Co2 hot band path length
2375 real(r8) rbeta7(pcols) ! Inverse of co2 hot band line width par
2376 real(r8) rbeta8 ! Inverse of co2 hot band line width par
2377 real(r8) rbeta9 ! Inverse of co2 hot band line width par
2378 real(r8) rbeta13 ! Inverse of co2 hot band line width par
2379 real(r8) tpatha ! For absorptivity computation
2380 real(r8) abso(pcols,4) ! Absorptivity for various gases/bands
2381 real(r8) dtx(pcols) ! Planck temperature minus 250 K
2382 real(r8) dty(pcols) ! Path temperature minus 250 K
2383 real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
2384 real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
2385 real(r8) tr1 ! Eqn(6) in table A2 of R&D for 650-800
2386 real(r8) tr10(pcols) ! Eqn (6) times eq(4) in table A2
2387 ! ! of R&D for 500-650 cm-1 region
2388 real(r8) tr2 ! Eqn(6) in table A2 of R&D for 500-650
2389 real(r8) tr5 ! Eqn(4) in table A2 of R&D for 650-800
2390 real(r8) tr6 ! Eqn(4) in table A2 of R&D for 500-650
2391 real(r8) tr9(pcols) ! Equation (6) times eq(4) in table A2
2392 ! ! of R&D for 650-800 cm-1 region
2393 real(r8) sqrtu(pcols) ! Sqrt of pressure weighted h20 pathlength
2394 real(r8) fwk(pcols) ! Equation(33) in R&D far wing correction
2395 real(r8) fwku(pcols) ! GU term in eqs(1) and (6) in table A2
2396 real(r8) to3co2(pcols) ! P weighted temp in ozone band model
2397 real(r8) dpnm(pcols) ! Pressure difference between two levels
2398 real(r8) pnmsq(pcols,pverp) ! Pressure squared
2399 real(r8) dw(pcols) ! Amount of h2o between two levels
2400 real(r8) uinpl(pcols,4) ! Nearest layer subdivision factor
2401 real(r8) winpl(pcols,4) ! Nearest layer subdivision factor
2402 real(r8) zinpl(pcols,4) ! Nearest layer subdivision factor
2403 real(r8) pinpl(pcols,4) ! Nearest layer subdivision factor
2404 real(r8) dplh2o(pcols) ! Difference in press weighted h2o amount
2405 real(r8) r293 ! 1/293
2406 real(r8) r250 ! 1/250
2407 real(r8) r3205 ! Line width factor for o3 (see R&Di)
2408 real(r8) r300 ! 1/300
2409 real(r8) rsslp ! Reciprocal of sea level pressure
2410 real(r8) r2sslp ! 1/2 of rsslp
2411 real(r8) ds2c ! Y in eq(7) in table A2 of R&D
2412 real(r8) dplos ! Ozone pathlength eq(A2) in R&Di
2413 real(r8) dplol ! Pressure weighted ozone pathlength
2414 real(r8) tlocal ! Local interface temperature
2415 real(r8) beta ! Ozone mean line parameter eq(A3) in R&Di
2416 ! (includes Voigt line correction factor)
2417 real(r8) rphat ! Effective pressure for ozone beta
2418 real(r8) tcrfac ! Ozone temperature factor table 1 R&Di
2419 real(r8) tmp1 ! Ozone band factor see eq(A1) in R&Di
2420 real(r8) u1 ! Effective ozone pathlength eq(A2) in R&Di
2421 real(r8) realnu ! 1/beta factor in ozone band model eq(A1)
2422 real(r8) tmp2 ! Ozone band factor see eq(A1) in R&Di
2423 real(r8) u2 ! Effective ozone pathlength eq(A2) in R&Di
2424 real(r8) rsqti ! Reciprocal of sqrt of path temperature
2425 real(r8) tpath ! Path temperature used in co2 band model
2426 real(r8) tmp3 ! Weak band factor see K&B
2427 real(r8) rdpnmsq ! Reciprocal of difference in press^2
2428 real(r8) rdpnm ! Reciprocal of difference in press
2429 real(r8) p1 ! Mean pressure factor
2430 real(r8) p2 ! Mean pressure factor
2431 real(r8) dtym10 ! T - 260 used in eq(9) and (10) table A3a
2432 real(r8) dplco2 ! Co2 path length
2433 real(r8) te ! A_0 T factor in ozone model table 1 of R&Di
2434 real(r8) denom ! Denominator in eq(r8) of table A3a of R&D
2435 real(r8) th2o(pcols) ! transmission due to H2O
2436 real(r8) tco2(pcols) ! transmission due to CO2
2437 real(r8) to3(pcols) ! transmission due to O3
2438 !
2439 ! Transmission terms for various spectral intervals:
2440 !
2441 real(r8) trab2(pcols) ! H2o 500 - 800 cm-1
2442 real(r8) absbnd ! Proportional to co2 band absorptance
2443 real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3
2444 real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3
2445 !
2446 ! Variables for Collins/Hackney/Edwards (C/H/E) &
2447 ! Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization
2449 !
2450 ! Notation:
2451 ! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
2452 ! P = atmospheric pressure
2453 ! P_0 = reference atmospheric pressure
2454 ! W = precipitable water path
2455 ! T_e = emission temperature
2456 ! T_p = path temperature
2457 ! RH = path relative humidity
2458 !
2459 real(r8) fa ! asymptotic value of abs. as U->infinity
2460 real(r8) a_star ! normalized absorptivity for non-window
2461 real(r8) l_star ! interpolated line transmission
2462 real(r8) c_star ! interpolated continuum transmission
2464 real(r8) te1 ! emission temperature
2465 real(r8) te2 ! te^2
2466 real(r8) te3 ! te^3
2467 real(r8) te4 ! te^4
2468 real(r8) te5 ! te^5
2470 real(r8) log_u ! log base 10 of U
2471 real(r8) log_uc ! log base 10 of H2O continuum path
2472 real(r8) log_p ! log base 10 of P
2473 real(r8) t_p ! T_p
2474 real(r8) t_e ! T_e (offset by T_p)
2476 integer iu ! index for log10(U)
2477 integer iu1 ! iu + 1
2478 integer iuc ! index for log10(H2O continuum path)
2479 integer iuc1 ! iuc + 1
2480 integer ip ! index for log10(P)
2481 integer ip1 ! ip + 1
2482 integer itp ! index for T_p
2483 integer itp1 ! itp + 1
2484 integer ite ! index for T_e
2485 integer ite1 ! ite + 1
2486 integer irh ! index for RH
2487 integer irh1 ! irh + 1
2489 real(r8) dvar ! normalized variation in T_p/T_e/P/U
2490 real(r8) uvar ! U * diffusivity factor
2491 real(r8) uscl ! factor for lineary scaling as U->0
2493 real(r8) wu ! weight for U
2494 real(r8) wu1 ! 1 - wu
2495 real(r8) wuc ! weight for H2O continuum path
2496 real(r8) wuc1 ! 1 - wuc
2497 real(r8) wp ! weight for P
2498 real(r8) wp1 ! 1 - wp
2499 real(r8) wtp ! weight for T_p
2500 real(r8) wtp1 ! 1 - wtp
2501 real(r8) wte ! weight for T_e
2502 real(r8) wte1 ! 1 - wte
2503 real(r8) wrh ! weight for RH
2504 real(r8) wrh1 ! 1 - wrh
2506 real(r8) w_0_0_ ! weight for Tp/Te combination
2507 real(r8) w_0_1_ ! weight for Tp/Te combination
2508 real(r8) w_1_0_ ! weight for Tp/Te combination
2509 real(r8) w_1_1_ ! weight for Tp/Te combination
2511 real(r8) w_0_00 ! weight for Tp/Te/RH combination
2512 real(r8) w_0_01 ! weight for Tp/Te/RH combination
2513 real(r8) w_0_10 ! weight for Tp/Te/RH combination
2514 real(r8) w_0_11 ! weight for Tp/Te/RH combination
2515 real(r8) w_1_00 ! weight for Tp/Te/RH combination
2516 real(r8) w_1_01 ! weight for Tp/Te/RH combination
2517 real(r8) w_1_10 ! weight for Tp/Te/RH combination
2518 real(r8) w_1_11 ! weight for Tp/Te/RH combination
2520 real(r8) w00_00 ! weight for P/Tp/Te/RH combination
2521 real(r8) w00_01 ! weight for P/Tp/Te/RH combination
2522 real(r8) w00_10 ! weight for P/Tp/Te/RH combination
2523 real(r8) w00_11 ! weight for P/Tp/Te/RH combination
2524 real(r8) w01_00 ! weight for P/Tp/Te/RH combination
2525 real(r8) w01_01 ! weight for P/Tp/Te/RH combination
2526 real(r8) w01_10 ! weight for P/Tp/Te/RH combination
2527 real(r8) w01_11 ! weight for P/Tp/Te/RH combination
2528 real(r8) w10_00 ! weight for P/Tp/Te/RH combination
2529 real(r8) w10_01 ! weight for P/Tp/Te/RH combination
2530 real(r8) w10_10 ! weight for P/Tp/Te/RH combination
2531 real(r8) w10_11 ! weight for P/Tp/Te/RH combination
2532 real(r8) w11_00 ! weight for P/Tp/Te/RH combination
2533 real(r8) w11_01 ! weight for P/Tp/Te/RH combination
2534 real(r8) w11_10 ! weight for P/Tp/Te/RH combination
2535 real(r8) w11_11 ! weight for P/Tp/Te/RH combination
2537 integer ib ! spectral interval:
2538 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
2539 ! 2 = 800-1200 cm^-1
2542 real(r8) pch2o ! H2O continuum path
2543 real(r8) fch2o ! temp. factor for continuum
2544 real(r8) uch2o ! U corresponding to H2O cont. path (window)
2546 real(r8) fdif ! secant(zenith angle) for diffusivity approx.
2548 real(r8) sslp_mks ! Sea-level pressure in MKS units
2549 real(r8) esx ! saturation vapor pressure returned by vqsatd
2550 real(r8) qsx ! saturation mixing ratio returned by vqsatd
2551 real(r8) pnew_mks ! pnew in MKS units
2552 real(r8) q_path ! effective specific humidity along path
2553 real(r8) rh_path ! effective relative humidity along path
2554 real(r8) omeps ! 1 - epsilo
2556 integer iest ! index in estblh2o
2558 integer bnd_idx ! LW band index
2559 real(r8) aer_pth_dlt ! [kg m-2] STRAER path between interface levels k1 and k2
2560 real(r8) aer_pth_ngh(pcols)
2561 ! [kg m-2] STRAER path between neighboring layers
2562 real(r8) odap_aer_ttl ! [fraction] Total path absorption optical depth
2563 real(r8) aer_trn_ngh(pcols,bnd_nbr_LW)
2564 ! [fraction] Total transmission between
2565 ! nearest neighbor sub-levels
2566 !
2567 !--------------------------Statement function---------------------------
2568 !
2569 real(r8) dbvt,t ! Planck fnctn tmp derivative for o3
2570 !
2571 dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
2572 (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
2573 !
2574 !
2575 !-----------------------------------------------------------------------
2576 !
2577 ! Initialize
2578 !
2579 do k2=1,ntoplw-1
2580 do k1=1,ntoplw-1
2581 abstot(:,k1,k2) = inf ! set unused portions for lf95 restart write
2582 end do
2583 end do
2584 do k2=1,4
2585 do k1=1,ntoplw-1
2586 absnxt(:,k1,k2) = inf ! set unused portions for lf95 restart write
2587 end do
2588 end do
2590 do k=ntoplw,pverp
2591 abstot(:,k,k) = inf ! set unused portions for lf95 restart write
2592 end do
2594 do k=ntoplw,pver
2595 do i=1,ncol
2596 dbvtly(i,k) = dbvt(tlayr(i,k+1))
2597 dbvtit(i,k) = dbvt(tint(i,k))
2598 end do
2599 end do
2600 do i=1,ncol
2601 dbvtit(i,pverp) = dbvt(tint(i,pverp))
2602 end do
2603 !
2604 r293 = 1./293.
2605 r250 = 1./250.
2606 r3205 = 1./.3205
2607 r300 = 1./300.
2608 rsslp = 1./sslp
2609 r2sslp = 1./(2.*sslp)
2610 !
2611 !Constants for computing U corresponding to H2O cont. path
2612 !
2613 fdif = 1.66
2614 sslp_mks = sslp / 10.0
2615 omeps = 1.0 - epsilo
2616 !
2617 ! Non-adjacent layer absorptivity:
2618 !
2619 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
2620 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
2621 ! abso(i,2) 800 - 1200 cm-1 h2o window
2622 !
2623 ! Separation between rotation and vibration-rotation dropped, so
2624 ! only 2 slots needed for H2O absorptivity
2625 !
2626 ! 500-800 cm^-1 H2o continuum/line overlap already included
2627 ! in abso(i,1). This used to be in abso(i,4)
2628 !
2629 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
2630 ! abso(i,4) co2 15 micrometer band system
2631 !
2632 do k=ntoplw,pverp
2633 do i=1,ncol
2634 pnmsq(i,k) = pnm(i,k)**2
2635 dtx(i) = tplnka(i,k) - 250.
2636 end do
2637 end do
2638 !
2639 ! Non-nearest layer level loops
2640 !
2641 do k1=pverp,ntoplw,-1
2642 do k2=pverp,ntoplw,-1
2643 if (k1 == k2) cycle
2644 do i=1,ncol
2645 dplh2o(i) = plh2o(i,k1) - plh2o(i,k2)
2646 u(i) = abs(dplh2o(i))
2647 sqrtu(i) = sqrt(u(i))
2648 ds2c = abs(s2c(i,k1) - s2c(i,k2))
2649 dw(i) = abs(w(i,k1) - w(i,k2))
2650 uc1(i) = (ds2c + 1.7e-3*u(i))*(1. + 2.*ds2c)/(1. + 15.*ds2c)
2651 pch2o = ds2c
2652 pnew(i) = u(i)/dw(i)
2653 pnew_mks = pnew(i) * sslp_mks
2654 !
2655 ! Changed effective path temperature to std. Curtis-Godson form
2656 !
2657 tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i)
2658 t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o)
2659 iest = floor(t_p) - min_tp_h2o
2660 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
2661 (t_p - min_tp_h2o - iest)
2662 qsx = epsilo * esx / (pnew_mks - omeps * esx)
2663 !
2664 ! Compute effective RH along path
2665 !
2666 q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga
2667 !
2668 ! Calculate effective u, pnew for each band using
2669 ! Hulst-Curtis-Godson approximation:
2670 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
2671 ! 2nd edition, Oxford University Press, 1989.
2672 ! Effective H2O path (w)
2673 ! eq. 6.24, p. 228
2674 ! Effective H2O path pressure (pnew = u/w):
2675 ! eq. 6.29, p. 228
2676 !
2677 ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1)
2678 ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2)
2680 pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1)
2681 pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2)
2683 dtx(i) = tplnka(i,k2) - 250.
2684 dty(i) = tpatha - 250.
2686 fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
2687 fwku(i) = fwk(i)*u(i)
2688 !
2689 ! Define variables for C/H/E (now C/LT/E) fit
2690 !
2691 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
2692 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
2693 ! abso(i,2) 800 - 1200 cm-1 h2o window
2694 !
2695 ! Separation between rotation and vibration-rotation dropped, so
2696 ! only 2 slots needed for H2O absorptivity
2697 !
2698 ! Notation:
2699 ! U = integral (P/P_0 dW)
2700 ! P = atmospheric pressure
2701 ! P_0 = reference atmospheric pressure
2702 ! W = precipitable water path
2703 ! T_e = emission temperature
2704 ! T_p = path temperature
2705 ! RH = path relative humidity
2706 !
2707 !
2708 ! Terms for asymptotic value of emissivity
2709 !
2710 te1 = tplnka(i,k2)
2711 te2 = te1 * te1
2712 te3 = te2 * te1
2713 te4 = te3 * te1
2714 te5 = te4 * te1
2716 !
2717 ! Band-independent indices for lines and continuum tables
2718 !
2719 dvar = (t_p - min_tp_h2o) / dtp_h2o
2720 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
2721 itp1 = itp + 1
2722 wtp = dvar - floor(dvar)
2723 wtp1 = 1.0 - wtp
2725 t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o)
2726 dvar = (t_e - min_te_h2o) / dte_h2o
2727 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
2728 ite1 = ite + 1
2729 wte = dvar - floor(dvar)
2730 wte1 = 1.0 - wte
2732 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
2733 dvar = (rh_path - min_rh_h2o) / drh_h2o
2734 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
2735 irh1 = irh + 1
2736 wrh = dvar - floor(dvar)
2737 wrh1 = 1.0 - wrh
2739 w_0_0_ = wtp * wte
2740 w_0_1_ = wtp * wte1
2741 w_1_0_ = wtp1 * wte
2742 w_1_1_ = wtp1 * wte1
2744 w_0_00 = w_0_0_ * wrh
2745 w_0_01 = w_0_0_ * wrh1
2746 w_0_10 = w_0_1_ * wrh
2747 w_0_11 = w_0_1_ * wrh1
2748 w_1_00 = w_1_0_ * wrh
2749 w_1_01 = w_1_0_ * wrh1
2750 w_1_10 = w_1_1_ * wrh
2751 w_1_11 = w_1_1_ * wrh1
2753 !
2754 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
2755 !
2756 ! Assume foreign continuum dominates total H2O continuum in these bands
2757 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
2758 ! Then the effective H2O path is just
2759 ! U_c = integral[ f(P) dW ]
2760 ! where
2761 ! W = water-vapor mass and
2762 ! f(P) = dependence of foreign continuum on pressure
2763 ! = P / sslp
2764 ! Then
2765 ! U_c = U (the same effective H2O path as for lines)
2766 !
2767 !
2768 ! Continuum terms for 800-1200 cm^-1
2769 !
2770 ! Assume self continuum dominates total H2O continuum for this band
2771 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
2772 ! Then the effective H2O self-continuum path is
2773 ! U_c = integral[ h(e,T) dW ] (*eq. 1*)
2774 ! where
2775 ! W = water-vapor mass and
2776 ! e = partial pressure of H2O along path
2777 ! T = temperature along path
2778 ! h(e,T) = dependence of foreign continuum on e,T
2779 ! = e / sslp * f(T)
2780 !
2781 ! Replacing
2782 ! e =~ q * P / epsilo
2783 ! q = mixing ratio of H2O
2784 ! epsilo = 0.622
2785 !
2786 ! and using the definition
2787 ! U = integral [ (P / sslp) dW ]
2788 ! = (P / sslp) W (homogeneous path)
2789 !
2790 ! the effective path length for the self continuum is
2791 ! U_c = (q / epsilo) f(T) U (*eq. 2*)
2792 !
2793 ! Once values of T, U, and q have been calculated for the inhomogeneous
2794 ! path, this sets U_c for the corresponding
2795 ! homogeneous atmosphere. However, this need not equal the
2796 ! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
2797 ! under consideration.
2798 !
2799 ! Solution: hold T and q constant, solve for U' that gives U_c' by
2800 ! inverting eq. (2):
2801 !
2802 ! U' = (U_c * epsilo) / (q * f(T))
2803 !
2804 fch2o = fh2oself(t_p)
2805 uch2o = (pch2o * epsilo) / (q_path * fch2o)
2807 !
2808 ! Band-dependent indices for non-window
2809 !
2810 ib = 1
2812 uvar = ub(ib) * fdif
2813 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
2814 dvar = (log_u - min_lu_h2o) / dlu_h2o
2815 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2816 iu1 = iu + 1
2817 wu = dvar - floor(dvar)
2818 wu1 = 1.0 - wu
2820 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
2821 dvar = (log_p - min_lp_h2o) / dlp_h2o
2822 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
2823 ip1 = ip + 1
2824 wp = dvar - floor(dvar)
2825 wp1 = 1.0 - wp
2827 w00_00 = wp * w_0_00
2828 w00_01 = wp * w_0_01
2829 w00_10 = wp * w_0_10
2830 w00_11 = wp * w_0_11
2831 w01_00 = wp * w_1_00
2832 w01_01 = wp * w_1_01
2833 w01_10 = wp * w_1_10
2834 w01_11 = wp * w_1_11
2835 w10_00 = wp1 * w_0_00
2836 w10_01 = wp1 * w_0_01
2837 w10_10 = wp1 * w_0_10
2838 w10_11 = wp1 * w_0_11
2839 w11_00 = wp1 * w_1_00
2840 w11_01 = wp1 * w_1_01
2841 w11_10 = wp1 * w_1_10
2842 w11_11 = wp1 * w_1_11
2843 !
2844 ! Asymptotic value of absorptivity as U->infinity
2845 !
2846 fa = fat(1,ib) + &
2847 fat(2,ib) * te1 + &
2848 fat(3,ib) * te2 + &
2849 fat(4,ib) * te3 + &
2850 fat(5,ib) * te4 + &
2851 fat(6,ib) * te5
2853 a_star = &
2854 ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
2855 ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
2856 ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
2857 ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
2858 ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
2859 ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
2860 ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
2861 ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
2862 ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
2863 ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
2864 ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
2865 ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
2866 ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
2867 ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
2868 ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
2869 ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
2870 ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
2871 ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
2872 ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
2873 ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
2874 ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
2875 ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
2876 ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
2877 ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
2878 ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
2879 ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
2880 ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
2881 ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
2882 ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
2883 ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
2884 ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
2885 ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
2886 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
2887 aer_trn_ttl(i,k1,k2,ib)), &
2888 0.0_r8), 1.0_r8)
2889 !
2890 ! Invoke linear limit for scaling wrt u below min_u_h2o
2891 !
2892 if (uvar < min_u_h2o) then
2893 uscl = uvar / min_u_h2o
2894 abso(i,ib) = abso(i,ib) * uscl
2895 endif
2897 !
2898 ! Band-dependent indices for window
2899 !
2900 ib = 2
2902 uvar = ub(ib) * fdif
2903 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
2904 dvar = (log_u - min_lu_h2o) / dlu_h2o
2905 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2906 iu1 = iu + 1
2907 wu = dvar - floor(dvar)
2908 wu1 = 1.0 - wu
2910 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
2911 dvar = (log_p - min_lp_h2o) / dlp_h2o
2912 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
2913 ip1 = ip + 1
2914 wp = dvar - floor(dvar)
2915 wp1 = 1.0 - wp
2917 w00_00 = wp * w_0_00
2918 w00_01 = wp * w_0_01
2919 w00_10 = wp * w_0_10
2920 w00_11 = wp * w_0_11
2921 w01_00 = wp * w_1_00
2922 w01_01 = wp * w_1_01
2923 w01_10 = wp * w_1_10
2924 w01_11 = wp * w_1_11
2925 w10_00 = wp1 * w_0_00
2926 w10_01 = wp1 * w_0_01
2927 w10_10 = wp1 * w_0_10
2928 w10_11 = wp1 * w_0_11
2929 w11_00 = wp1 * w_1_00
2930 w11_01 = wp1 * w_1_01
2931 w11_10 = wp1 * w_1_10
2932 w11_11 = wp1 * w_1_11
2934 log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
2935 dvar = (log_uc - min_lu_h2o) / dlu_h2o
2936 iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2937 iuc1 = iuc + 1
2938 wuc = dvar - floor(dvar)
2939 wuc1 = 1.0 - wuc
2940 !
2941 ! Asymptotic value of absorptivity as U->infinity
2942 !
2943 fa = fat(1,ib) + &
2944 fat(2,ib) * te1 + &
2945 fat(3,ib) * te2 + &
2946 fat(4,ib) * te3 + &
2947 fat(5,ib) * te4 + &
2948 fat(6,ib) * te5
2950 l_star = &
2951 ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
2952 ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
2953 ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
2954 ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
2955 ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
2956 ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
2957 ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
2958 ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
2959 ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
2960 ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
2961 ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
2962 ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
2963 ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
2964 ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
2965 ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
2966 ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
2967 ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
2968 ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
2969 ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
2970 ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
2971 ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
2972 ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
2973 ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
2974 ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
2975 ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
2976 ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
2977 ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
2978 ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
2979 ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
2980 ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
2981 ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
2982 ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
2984 c_star = &
2985 cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
2986 cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
2987 cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
2988 cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
2989 cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
2990 cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
2991 cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
2992 cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
2993 cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
2994 cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
2995 cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
2996 cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
2997 cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
2998 cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
2999 cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
3000 cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
3001 cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
3002 cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
3003 cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
3004 cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
3005 cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
3006 cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
3007 cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
3008 cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
3009 cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
3010 cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
3011 cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
3012 cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
3013 cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
3014 cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
3015 cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
3016 cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
3017 abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * &
3018 aer_trn_ttl(i,k1,k2,ib)), &
3019 0.0_r8), 1.0_r8)
3020 !
3021 ! Invoke linear limit for scaling wrt u below min_u_h2o
3022 !
3023 if (uvar < min_u_h2o) then
3024 uscl = uvar / min_u_h2o
3025 abso(i,ib) = abso(i,ib) * uscl
3026 endif
3028 end do
3029 !
3030 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
3031 !
3032 do i=1,ncol
3033 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
3034 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
3035 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
3036 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
3037 end do
3038 !
3039 ! 500 - 800 cm-1 h2o rotation band overlap with co2
3040 !
3041 do i=1,ncol
3042 k21 = term7(i,1) + term8(i,1)/ &
3043 (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i))
3044 k22 = term7(i,2) + term8(i,2)/ &
3045 (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i))
3046 tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
3047 tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
3048 tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)
3049 ! ! H2O line+STRAER trn 650--800 cm-1
3050 tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650)
3051 ! ! H2O line+STRAER trn 500--650 cm-1
3052 tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
3053 tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
3054 tr9(i) = tr1*tr5
3055 tr10(i) = tr2*tr6
3056 th2o(i) = tr10(i)
3057 trab2(i) = 0.65*tr9(i) + 0.35*tr10(i)
3058 end do
3059 if (k2 < k1) then
3060 do i=1,ncol
3061 to3h2o(i) = h2otr(i,k1)/h2otr(i,k2)
3062 end do
3063 else
3064 do i=1,ncol
3065 to3h2o(i) = h2otr(i,k2)/h2otr(i,k1)
3066 end do
3067 end if
3068 !
3069 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
3070 !
3071 do i=1,ncol
3072 dpnm(i) = pnm(i,k1) - pnm(i,k2)
3073 to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i)
3074 te = (to3co2(i)*r293)**.7
3075 dplos = plos(i,k1) - plos(i,k2)
3076 dplol = plol(i,k1) - plol(i,k2)
3077 u1 = 18.29*abs(dplos)/te
3078 u2 = .5649*abs(dplos)/te
3079 rphat = dplol/dplos
3080 tlocal = tint(i,k2)
3081 tcrfac = sqrt(tlocal*r250)*te
3082 beta = r3205*(rphat + dpfo3*tcrfac)
3083 realnu = te/beta
3084 tmp1 = u1/sqrt(4. + u1*(1. + realnu))
3085 tmp2 = u2/sqrt(4. + u2*(1. + realnu))
3086 o3bndi = 74.*te*log(1. + tmp1 + tmp2)
3087 abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2)
3088 to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
3089 end do
3090 !
3091 ! abso(i,4) co2 15 micrometer band system
3092 !
3093 do i=1,ncol
3094 sqwp = sqrt(abs(plco2(i,k1) - plco2(i,k2)))
3095 et = exp(-480./to3co2(i))
3096 sqti(i) = sqrt(to3co2(i))
3097 rsqti = 1./sqti(i)
3098 et2 = et*et
3099 et4 = et2*et2
3100 omet = 1. - 1.5*et2
3101 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
3102 f1sqwp(i) = f1co2*sqwp
3103 t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
3104 oneme = 1. - et2
3105 alphat = oneme**3*rsqti
3106 pi = abs(dpnm(i))
3107 wco2 = 2.5221*co2vmr*pi*rga
3108 u7(i) = 4.9411e4*alphat*et2*wco2
3109 u8 = 3.9744e4*alphat*et4*wco2
3110 u9 = 1.0447e5*alphat*et4*et2*wco2
3111 u13 = 2.8388e3*alphat*et4*wco2
3112 tpath = to3co2(i)
3113 tlocal = tint(i,k2)
3114 tcrfac = sqrt(tlocal*r250*tpath*r300)
3115 posqt = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti
3116 rbeta7(i) = 1./(5.3228*posqt)
3117 rbeta8 = 1./(10.6576*posqt)
3118 rbeta9 = rbeta7(i)
3119 rbeta13 = rbeta9
3120 f2co2(i) = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + &
3121 (u8 /sqrt(4. + u8*(1. + rbeta8))) + &
3122 (u9 /sqrt(4. + u9*(1. + rbeta9)))
3123 f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
3124 end do
3125 if (k2 >= k1) then
3126 do i=1,ncol
3127 sqti(i) = sqrt(tlayr(i,k2))
3128 end do
3129 end if
3130 !
3131 do i=1,ncol
3132 tmp1 = log(1. + f1sqwp(i))
3133 tmp2 = log(1. + f2co2(i))
3134 tmp3 = log(1. + f3co2(i))
3135 absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
3136 abso(i,4) = trab2(i)*co2em(i,k2)*absbnd
3137 tco2(i) = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))))
3138 end do
3139 !
3140 ! Calculate absorptivity due to trace gases, abstrc
3141 !
3142 call trcab( lchnk ,ncol ,pcols, pverp, &
3143 k1 ,k2 ,ucfc11 ,ucfc12 ,un2o0 , &
3144 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
3145 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
3146 bch4 ,to3co2 ,pnm ,dw ,pnew , &
3147 s2c ,uptype ,u ,abplnk1 ,tco2 , &
3148 th2o ,to3 ,abstrc , &
3149 aer_trn_ttl)
3150 !
3151 ! Sum total absorptivity
3152 !
3153 do i=1,ncol
3154 abstot(i,k1,k2) = abso(i,1) + abso(i,2) + &
3155 abso(i,3) + abso(i,4) + abstrc(i)
3156 end do
3157 end do ! do k2 =
3158 end do ! do k1 =
3159 !
3160 ! Adjacent layer absorptivity:
3161 !
3162 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
3163 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
3164 ! abso(i,2) 800 - 1200 cm-1 h2o window
3165 !
3166 ! Separation between rotation and vibration-rotation dropped, so
3167 ! only 2 slots needed for H2O absorptivity
3168 !
3169 ! 500-800 cm^-1 H2o continuum/line overlap already included
3170 ! in abso(i,1). This used to be in abso(i,4)
3171 !
3172 ! abso(i,3) o3 9.6 micrometer band (nu3 and nu1 bands)
3173 ! abso(i,4) co2 15 micrometer band system
3174 !
3175 ! Nearest layer level loop
3176 !
3177 do k2=pver,ntoplw,-1
3178 do i=1,ncol
3179 tbar(i,1) = 0.5*(tint(i,k2+1) + tlayr(i,k2+1))
3180 emm(i,1) = 0.5*(co2em(i,k2+1) + co2eml(i,k2))
3181 tbar(i,2) = 0.5*(tlayr(i,k2+1) + tint(i,k2))
3182 emm(i,2) = 0.5*(co2em(i,k2) + co2eml(i,k2))
3183 tbar(i,3) = 0.5*(tbar(i,2) + tbar(i,1))
3184 emm(i,3) = emm(i,1)
3185 tbar(i,4) = tbar(i,3)
3186 emm(i,4) = emm(i,2)
3187 o3emm(i,1) = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2))
3188 o3emm(i,2) = 0.5*(dbvtit(i,k2) + dbvtly(i,k2))
3189 o3emm(i,3) = o3emm(i,1)
3190 o3emm(i,4) = o3emm(i,2)
3191 temh2o(i,1) = tbar(i,1)
3192 temh2o(i,2) = tbar(i,2)
3193 temh2o(i,3) = tbar(i,1)
3194 temh2o(i,4) = tbar(i,2)
3195 dpnm(i) = pnm(i,k2+1) - pnm(i,k2)
3196 end do
3197 !
3198 ! Weighted Planck functions for trace gases
3199 !
3200 do wvl = 1,14
3201 do i = 1,ncol
3202 bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2))
3203 bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2))
3204 bplnk(wvl,i,3) = bplnk(wvl,i,1)
3205 bplnk(wvl,i,4) = bplnk(wvl,i,2)
3206 end do
3207 end do
3209 do i=1,ncol
3210 rdpnmsq = 1./(pnmsq(i,k2+1) - pnmsq(i,k2))
3211 rdpnm = 1./dpnm(i)
3212 p1 = .5*(pbr(i,k2) + pnm(i,k2+1))
3213 p2 = .5*(pbr(i,k2) + pnm(i,k2 ))
3214 uinpl(i,1) = (pnmsq(i,k2+1) - p1**2)*rdpnmsq
3215 uinpl(i,2) = -(pnmsq(i,k2 ) - p2**2)*rdpnmsq
3216 uinpl(i,3) = -(pnmsq(i,k2 ) - p1**2)*rdpnmsq
3217 uinpl(i,4) = (pnmsq(i,k2+1) - p2**2)*rdpnmsq
3218 winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm
3219 winpl(i,2) = (.5*(-pnm(i,k2 ) + pbr(i,k2)))*rdpnm
3220 winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2 ))*rdpnm
3221 winpl(i,4) = (.5*(-pnm(i,k2 ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm
3222 tmp1 = 1./(piln(i,k2+1) - piln(i,k2))
3223 tmp2 = piln(i,k2+1) - pmln(i,k2)
3224 tmp3 = piln(i,k2 ) - pmln(i,k2)
3225 zinpl(i,1) = (.5*tmp2 )*tmp1
3226 zinpl(i,2) = ( - .5*tmp3)*tmp1
3227 zinpl(i,3) = (.5*tmp2 - tmp3)*tmp1
3228 zinpl(i,4) = ( tmp2 - .5*tmp3)*tmp1
3229 pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1))
3230 pinpl(i,2) = 0.5*(p2 + pnm(i,k2 ))
3231 pinpl(i,3) = 0.5*(p1 + pnm(i,k2 ))
3232 pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1))
3233 if(strat_volcanic) then
3234 aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1))
3235 endif
3236 end do
3237 do kn=1,4
3238 do i=1,ncol
3239 u(i) = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1))
3240 sqrtu(i) = sqrt(u(i))
3241 dw(i) = abs(w(i,k2) - w(i,k2+1))
3242 pnew(i) = u(i)/(winpl(i,kn)*dw(i))
3243 pnew_mks = pnew(i) * sslp_mks
3244 t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o)
3245 iest = floor(t_p) - min_tp_h2o
3246 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
3247 (t_p - min_tp_h2o - iest)
3248 qsx = epsilo * esx / (pnew_mks - omeps * esx)
3249 q_path = dw(i) / ABS(dpnm(i)) / rga
3251 ds2c = abs(s2c(i,k2) - s2c(i,k2+1))
3252 uc1(i) = uinpl(i,kn)*ds2c
3253 pch2o = uc1(i)
3254 uc1(i) = (uc1(i) + 1.7e-3*u(i))*(1. + 2.*uc1(i))/(1. + 15.*uc1(i))
3255 dtx(i) = temh2o(i,kn) - 250.
3256 dty(i) = tbar(i,kn) - 250.
3258 fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i))
3259 fwku(i) = fwk(i)*u(i)
3261 if(strat_volcanic) then
3262 aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i)
3264 do bnd_idx=1,bnd_nbr_LW
3265 odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
3266 aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl)
3267 end do
3268 else
3269 aer_trn_ngh(i,:) = 1.0
3270 endif
3272 !
3273 ! Define variables for C/H/E (now C/LT/E) fit
3274 !
3275 ! abso(i,1) 0 - 800 cm-1 h2o rotation band
3276 ! abso(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
3277 ! abso(i,2) 800 - 1200 cm-1 h2o window
3278 !
3279 ! Separation between rotation and vibration-rotation dropped, so
3280 ! only 2 slots needed for H2O absorptivity
3281 !
3282 ! Notation:
3283 ! U = integral (P/P_0 dW)
3284 ! P = atmospheric pressure
3285 ! P_0 = reference atmospheric pressure
3286 ! W = precipitable water path
3287 ! T_e = emission temperature
3288 ! T_p = path temperature
3289 ! RH = path relative humidity
3290 !
3291 !
3292 ! Terms for asymptotic value of emissivity
3293 !
3294 te1 = temh2o(i,kn)
3295 te2 = te1 * te1
3296 te3 = te2 * te1
3297 te4 = te3 * te1
3298 te5 = te4 * te1
3300 !
3301 ! Indices for lines and continuum tables
3302 ! Note: because we are dealing with the nearest layer,
3303 ! the Hulst-Curtis-Godson corrections
3304 ! for inhomogeneous paths are not applied.
3305 !
3306 uvar = u(i)*fdif
3307 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
3308 dvar = (log_u - min_lu_h2o) / dlu_h2o
3309 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3310 iu1 = iu + 1
3311 wu = dvar - floor(dvar)
3312 wu1 = 1.0 - wu
3314 log_p = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o)
3315 dvar = (log_p - min_lp_h2o) / dlp_h2o
3316 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
3317 ip1 = ip + 1
3318 wp = dvar - floor(dvar)
3319 wp1 = 1.0 - wp
3321 dvar = (t_p - min_tp_h2o) / dtp_h2o
3322 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
3323 itp1 = itp + 1
3324 wtp = dvar - floor(dvar)
3325 wtp1 = 1.0 - wtp
3327 t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o)
3328 dvar = (t_e - min_te_h2o) / dte_h2o
3329 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
3330 ite1 = ite + 1
3331 wte = dvar - floor(dvar)
3332 wte1 = 1.0 - wte
3334 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
3335 dvar = (rh_path - min_rh_h2o) / drh_h2o
3336 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
3337 irh1 = irh + 1
3338 wrh = dvar - floor(dvar)
3339 wrh1 = 1.0 - wrh
3341 w_0_0_ = wtp * wte
3342 w_0_1_ = wtp * wte1
3343 w_1_0_ = wtp1 * wte
3344 w_1_1_ = wtp1 * wte1
3346 w_0_00 = w_0_0_ * wrh
3347 w_0_01 = w_0_0_ * wrh1
3348 w_0_10 = w_0_1_ * wrh
3349 w_0_11 = w_0_1_ * wrh1
3350 w_1_00 = w_1_0_ * wrh
3351 w_1_01 = w_1_0_ * wrh1
3352 w_1_10 = w_1_1_ * wrh
3353 w_1_11 = w_1_1_ * wrh1
3355 w00_00 = wp * w_0_00
3356 w00_01 = wp * w_0_01
3357 w00_10 = wp * w_0_10
3358 w00_11 = wp * w_0_11
3359 w01_00 = wp * w_1_00
3360 w01_01 = wp * w_1_01
3361 w01_10 = wp * w_1_10
3362 w01_11 = wp * w_1_11
3363 w10_00 = wp1 * w_0_00
3364 w10_01 = wp1 * w_0_01
3365 w10_10 = wp1 * w_0_10
3366 w10_11 = wp1 * w_0_11
3367 w11_00 = wp1 * w_1_00
3368 w11_01 = wp1 * w_1_01
3369 w11_10 = wp1 * w_1_10
3370 w11_11 = wp1 * w_1_11
3372 !
3373 ! Non-window absorptivity
3374 !
3375 ib = 1
3377 fa = fat(1,ib) + &
3378 fat(2,ib) * te1 + &
3379 fat(3,ib) * te2 + &
3380 fat(4,ib) * te3 + &
3381 fat(5,ib) * te4 + &
3382 fat(6,ib) * te5
3384 a_star = &
3385 ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3386 ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3387 ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3388 ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3389 ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
3390 ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
3391 ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
3392 ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
3393 ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3394 ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3395 ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3396 ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3397 ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
3398 ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
3399 ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
3400 ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
3401 ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3402 ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3403 ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3404 ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3405 ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
3406 ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
3407 ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
3408 ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
3409 ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3410 ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3411 ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3412 ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3413 ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
3414 ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
3415 ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
3416 ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3418 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
3419 aer_trn_ngh(i,ib)), &
3420 0.0_r8), 1.0_r8)
3422 !
3423 ! Invoke linear limit for scaling wrt u below min_u_h2o
3424 !
3425 if (uvar < min_u_h2o) then
3426 uscl = uvar / min_u_h2o
3427 abso(i,ib) = abso(i,ib) * uscl
3428 endif
3430 !
3431 ! Window absorptivity
3432 !
3433 ib = 2
3435 fa = fat(1,ib) + &
3436 fat(2,ib) * te1 + &
3437 fat(3,ib) * te2 + &
3438 fat(4,ib) * te3 + &
3439 fat(5,ib) * te4 + &
3440 fat(6,ib) * te5
3442 a_star = &
3443 ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3444 ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3445 ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3446 ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3447 ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
3448 ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
3449 ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
3450 ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
3451 ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3452 ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3453 ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3454 ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3455 ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
3456 ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
3457 ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
3458 ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
3459 ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3460 ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3461 ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3462 ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3463 ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
3464 ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
3465 ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
3466 ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
3467 ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3468 ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3469 ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3470 ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3471 ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
3472 ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
3473 ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
3474 ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3476 abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
3477 aer_trn_ngh(i,ib)), &
3478 0.0_r8), 1.0_r8)
3480 !
3481 ! Invoke linear limit for scaling wrt u below min_u_h2o
3482 !
3483 if (uvar < min_u_h2o) then
3484 uscl = uvar / min_u_h2o
3485 abso(i,ib) = abso(i,ib) * uscl
3486 endif
3488 end do
3489 !
3490 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
3491 !
3492 do i=1,ncol
3493 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
3494 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
3495 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
3496 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
3497 end do
3498 !
3499 ! 500 - 800 cm-1 h2o rotation band overlap with co2
3500 !
3501 do i=1,ncol
3502 dtym10 = dty(i) - 10.
3503 denom = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i)
3504 k21 = term7(i,1) + term8(i,1)/denom
3505 denom = 1. + (c28 + c29*dtym10 )*sqrtu(i)
3506 k22 = term7(i,2) + term8(i,2)/denom
3507 tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
3508 tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
3509 tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800)
3510 ! ! H2O line+STRAER trn 650--800 cm-1
3511 tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650)
3512 ! ! H2O line+STRAER trn 500--650 cm-1
3513 tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
3514 tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
3515 tr9(i) = tr1*tr5
3516 tr10(i) = tr2*tr6
3517 trab2(i)= 0.65*tr9(i) + 0.35*tr10(i)
3518 th2o(i) = tr10(i)
3519 end do
3520 !
3521 ! abso(i,3) o3 9.6 micrometer (nu3 and nu1 bands)
3522 !
3523 do i=1,ncol
3524 te = (tbar(i,kn)*r293)**.7
3525 dplos = abs(plos(i,k2+1) - plos(i,k2))
3526 u1 = zinpl(i,kn)*18.29*dplos/te
3527 u2 = zinpl(i,kn)*.5649*dplos/te
3528 tlocal = tbar(i,kn)
3529 tcrfac = sqrt(tlocal*r250)*te
3530 beta = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac)
3531 realnu = te/beta
3532 tmp1 = u1/sqrt(4. + u1*(1. + realnu))
3533 tmp2 = u2/sqrt(4. + u2*(1. + realnu))
3534 o3bndi = 74.*te*log(1. + tmp1 + tmp2)
3535 abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2))
3536 to3(i) = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
3537 end do
3538 !
3539 ! abso(i,4) co2 15 micrometer band system
3540 !
3541 do i=1,ncol
3542 dplco2 = plco2(i,k2+1) - plco2(i,k2)
3543 sqwp = sqrt(uinpl(i,kn)*dplco2)
3544 et = exp(-480./tbar(i,kn))
3545 sqti(i) = sqrt(tbar(i,kn))
3546 rsqti = 1./sqti(i)
3547 et2 = et*et
3548 et4 = et2*et2
3549 omet = (1. - 1.5*et2)
3550 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
3551 f1sqwp(i)= f1co2*sqwp
3552 t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
3553 oneme = 1. - et2
3554 alphat = oneme**3*rsqti
3555 pi = abs(dpnm(i))*winpl(i,kn)
3556 wco2 = 2.5221*co2vmr*pi*rga
3557 u7(i) = 4.9411e4*alphat*et2*wco2
3558 u8 = 3.9744e4*alphat*et4*wco2
3559 u9 = 1.0447e5*alphat*et4*et2*wco2
3560 u13 = 2.8388e3*alphat*et4*wco2
3561 tpath = tbar(i,kn)
3562 tlocal = tbar(i,kn)
3563 tcrfac = sqrt((tlocal*r250)*(tpath*r300))
3564 posqt = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti
3565 rbeta7(i)= 1./(5.3228*posqt)
3566 rbeta8 = 1./(10.6576*posqt)
3567 rbeta9 = rbeta7(i)
3568 rbeta13 = rbeta9
3569 f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + &
3570 u8 /sqrt(4. + u8*(1. + rbeta8)) + &
3571 u9 /sqrt(4. + u9*(1. + rbeta9))
3572 f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
3573 tmp1 = log(1. + f1sqwp(i))
3574 tmp2 = log(1. + f2co2(i))
3575 tmp3 = log(1. + f3co2(i))
3576 absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
3577 abso(i,4)= trab2(i)*emm(i,kn)*absbnd
3578 tco2(i) = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))
3579 end do ! do i =
3580 !
3581 ! Calculate trace gas absorptivity for nearest layer, abstrc
3582 !
3583 call trcabn(lchnk ,ncol ,pcols, pverp, &
3584 k2 ,kn ,ucfc11 ,ucfc12 ,un2o0 , &
3585 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
3586 uco221 ,uco222 ,uco223 ,tbar ,bplnk , &
3587 winpl ,pinpl ,tco2 ,th2o ,to3 , &
3588 uptype ,dw ,s2c ,u ,pnew , &
3589 abstrc ,uinpl , &
3590 aer_trn_ngh)
3591 !
3592 ! Total next layer absorptivity:
3593 !
3594 do i=1,ncol
3595 absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + &
3596 abso(i,3) + abso(i,4) + abstrc(i)
3597 end do
3598 end do ! do kn =
3599 end do ! do k2 =
3601 return
3602 end subroutine radabs
3606 subroutine radems(lchnk ,ncol ,pcols, pver, pverp, &
3607 s2c ,tcg ,w ,tplnke ,plh2o , &
3608 pnm ,plco2 ,tint ,tint4 ,tlayr , &
3609 tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
3610 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
3611 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
3612 bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
3613 co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
3614 plh2ob ,wb , &
3615 aer_trn_ttl)
3616 !-----------------------------------------------------------------------
3617 !
3618 ! Purpose:
3619 ! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12
3620 !
3621 ! Method:
3622 ! H2O .... Uses nonisothermal emissivity method for water vapor from
3623 ! Ramanathan, V. and P.Downey, 1986: A Nonisothermal
3624 ! Emissivity and Absorptivity Formulation for Water Vapor
3625 ! Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666
3626 !
3627 ! Implementation updated by Collins,Hackney, and Edwards 2001
3628 ! using line-by-line calculations based upon Hitran 1996 and
3629 ! CKD 2.1 for absorptivity and emissivity
3630 !
3631 ! Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
3632 ! using line-by-line calculations based upon Hitran 2000 and
3633 ! CKD 2.4 for absorptivity and emissivity
3634 !
3635 ! CO2 .... Uses absorptance parameterization of the 15 micro-meter
3636 ! (500 - 800 cm-1) band system of Carbon Dioxide, from
3637 ! Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
3638 ! of the Absorptance Due to the 15 micro-meter Band System
3639 ! of Carbon Dioxide Jouranl of Geophysical Research,
3640 ! vol. 96., D5, pp 9013-9019. Also includes the effects
3641 ! of the 9.4 and 10.4 micron bands of CO2.
3642 !
3643 ! O3 .... Uses absorptance parameterization of the 9.6 micro-meter
3644 ! band system of ozone, from Ramanathan, V. and R. Dickinson,
3645 ! 1979: The Role of stratospheric ozone in the zonal and
3646 ! seasonal radiative energy balance of the earth-troposphere
3647 ! system. Journal of the Atmospheric Sciences, Vol. 36,
3648 ! pp 1084-1104
3649 !
3650 ! ch4 .... Uses a broad band model for the 7.7 micron band of methane.
3651 !
3652 ! n20 .... Uses a broad band model for the 7.8, 8.6 and 17.0 micron
3653 ! bands of nitrous oxide
3654 !
3655 ! cfc11 ... Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
3656 ! micron bands of CFC11
3657 !
3658 ! cfc12 ... Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
3659 ! micron bands of CFC12
3660 !
3661 !
3662 ! Computes individual emissivities, accounting for band overlap, and
3663 ! sums to obtain the total.
3664 !
3665 ! Author: W. Collins (H2O emissivity) and J. Kiehl
3666 !
3667 !-----------------------------------------------------------------------
3668 !------------------------------Arguments--------------------------------
3669 !
3670 ! Input arguments
3671 !
3672 integer, intent(in) :: lchnk ! chunk identifier
3673 integer, intent(in) :: ncol ! number of atmospheric columns
3674 integer, intent(in) :: pcols, pver, pverp
3676 real(r8), intent(in) :: s2c(pcols,pverp) ! H2o continuum path length
3677 real(r8), intent(in) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
3678 real(r8), intent(in) :: w(pcols,pverp) ! H2o path length
3679 real(r8), intent(in) :: tplnke(pcols) ! Layer planck temperature
3680 real(r8), intent(in) :: plh2o(pcols,pverp) ! H2o prs wghted path length
3681 real(r8), intent(in) :: pnm(pcols,pverp) ! Model interface pressure
3682 real(r8), intent(in) :: plco2(pcols,pverp) ! Prs wghted path of co2
3683 real(r8), intent(in) :: tint(pcols,pverp) ! Model interface temperatures
3684 real(r8), intent(in) :: tint4(pcols,pverp) ! Tint to the 4th power
3685 real(r8), intent(in) :: tlayr(pcols,pverp) ! K-1 model layer temperature
3686 real(r8), intent(in) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
3687 real(r8), intent(in) :: plol(pcols,pverp) ! Pressure wghtd ozone path
3688 real(r8), intent(in) :: plos(pcols,pverp) ! Ozone path
3689 real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
3690 ! Hulst-Curtis-Godson temp. factor
3691 ! for H2O bands
3692 real(r8), intent(in) :: wb(nbands,pcols,pverp) ! H2o path length with
3693 ! Hulst-Curtis-Godson temp. factor
3694 ! for H2O bands
3696 real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW)
3697 ! ! [fraction] Total strat. aerosol
3698 ! ! transmission between interfaces k1 and k2
3700 !
3701 ! Trace gas variables
3702 !
3703 real(r8), intent(in) :: ucfc11(pcols,pverp) ! CFC11 path length
3704 real(r8), intent(in) :: ucfc12(pcols,pverp) ! CFC12 path length
3705 real(r8), intent(in) :: un2o0(pcols,pverp) ! N2O path length
3706 real(r8), intent(in) :: un2o1(pcols,pverp) ! N2O path length (hot band)
3707 real(r8), intent(in) :: uch4(pcols,pverp) ! CH4 path length
3708 real(r8), intent(in) :: uco211(pcols,pverp) ! CO2 9.4 micron band path length
3709 real(r8), intent(in) :: uco212(pcols,pverp) ! CO2 9.4 micron band path length
3710 real(r8), intent(in) :: uco213(pcols,pverp) ! CO2 9.4 micron band path length
3711 real(r8), intent(in) :: uco221(pcols,pverp) ! CO2 10.4 micron band path length
3712 real(r8), intent(in) :: uco222(pcols,pverp) ! CO2 10.4 micron band path length
3713 real(r8), intent(in) :: uco223(pcols,pverp) ! CO2 10.4 micron band path length
3714 real(r8), intent(in) :: bn2o0(pcols,pverp) ! pressure factor for n2o
3715 real(r8), intent(in) :: bn2o1(pcols,pverp) ! pressure factor for n2o
3716 real(r8), intent(in) :: bch4(pcols,pverp) ! pressure factor for ch4
3717 real(r8), intent(in) :: uptype(pcols,pverp) ! p-type continuum path length
3718 !
3719 ! Output arguments
3720 !
3721 real(r8), intent(out) :: emstot(pcols,pverp) ! Total emissivity
3722 real(r8), intent(out) :: co2em(pcols,pverp) ! Layer co2 normalzd plnck funct drvtv
3723 real(r8), intent(out) :: co2eml(pcols,pver) ! Intrfc co2 normalzd plnck func drvtv
3724 real(r8), intent(out) :: co2t(pcols,pverp) ! Tmp and prs weighted path length
3725 real(r8), intent(out) :: h2otr(pcols,pverp) ! H2o transmission over o3 band
3726 real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
3727 real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
3729 !
3730 !---------------------------Local variables-----------------------------
3731 !
3732 integer i ! Longitude index
3733 integer k ! Level index]
3734 integer k1 ! Level index
3735 !
3736 ! Local variables for H2O:
3737 !
3738 real(r8) h2oems(pcols,pverp) ! H2o emissivity
3739 real(r8) tpathe ! Used to compute h2o emissivity
3740 real(r8) dtx(pcols) ! Planck temperature minus 250 K
3741 real(r8) dty(pcols) ! Path temperature minus 250 K
3742 !
3743 ! The 500-800 cm^-1 emission in emis(i,4) has been combined
3744 ! into the 0-800 cm^-1 emission in emis(i,1)
3745 !
3746 real(r8) emis(pcols,2) ! H2O emissivity
3747 !
3748 !
3749 !
3750 real(r8) term7(pcols,2) ! Kl_inf(i) in eq(r8) of table A3a of R&D
3751 real(r8) term8(pcols,2) ! Delta kl_inf(i) in eq(r8)
3752 real(r8) tr1(pcols) ! Equation(6) in table A2 for 650-800
3753 real(r8) tr2(pcols) ! Equation(6) in table A2 for 500-650
3754 real(r8) tr3(pcols) ! Equation(4) in table A2 for 650-800
3755 real(r8) tr4(pcols) ! Equation(4),table A2 of R&D for 500-650
3756 real(r8) tr7(pcols) ! Equation (6) times eq(4) in table A2
3757 ! of R&D for 650-800 cm-1 region
3758 real(r8) tr8(pcols) ! Equation (6) times eq(4) in table A2
3759 ! of R&D for 500-650 cm-1 region
3760 real(r8) k21(pcols) ! Exponential coefficient used to calc
3761 ! rot band transmissivity in the 650-800
3762 ! cm-1 region (tr1)
3763 real(r8) k22(pcols) ! Exponential coefficient used to calc
3764 ! rot band transmissivity in the 500-650
3765 ! cm-1 region (tr2)
3766 real(r8) u(pcols) ! Pressure weighted H2O path length
3767 real(r8) ub(nbands) ! Pressure weighted H2O path length with
3768 ! Hulst-Curtis-Godson correction for
3769 ! each band
3770 real(r8) pnew ! Effective pressure for h2o linewidth
3771 real(r8) pnewb(nbands) ! Effective pressure for h2o linewidth w/
3772 ! Hulst-Curtis-Godson correction for
3773 ! each band
3774 real(r8) uc1(pcols) ! H2o continuum pathlength 500-800 cm-1
3775 real(r8) fwk ! Equation(33) in R&D far wing correction
3776 real(r8) troco2(pcols,pverp) ! H2o overlap factor for co2 absorption
3777 real(r8) emplnk(14,pcols) ! emissivity Planck factor
3778 real(r8) emstrc(pcols,pverp) ! total trace gas emissivity
3779 !
3780 ! Local variables for CO2:
3781 !
3782 real(r8) co2ems(pcols,pverp) ! Co2 emissivity
3783 real(r8) co2plk(pcols) ! Used to compute co2 emissivity
3784 real(r8) sum(pcols) ! Used to calculate path temperature
3785 real(r8) t1i ! Co2 hot band temperature factor
3786 real(r8) sqti ! Sqrt of temperature
3787 real(r8) pi ! Pressure used in co2 mean line width
3788 real(r8) et ! Co2 hot band factor
3789 real(r8) et2 ! Co2 hot band factor
3790 real(r8) et4 ! Co2 hot band factor
3791 real(r8) omet ! Co2 stimulated emission term
3792 real(r8) ex ! Part of co2 planck function
3793 real(r8) f1co2 ! Co2 weak band factor
3794 real(r8) f2co2 ! Co2 weak band factor
3795 real(r8) f3co2 ! Co2 weak band factor
3796 real(r8) t1co2 ! Overlap factor weak bands strong band
3797 real(r8) sqwp ! Sqrt of co2 pathlength
3798 real(r8) f1sqwp ! Main co2 band factor
3799 real(r8) oneme ! Co2 stimulated emission term
3800 real(r8) alphat ! Part of the co2 stimulated emiss term
3801 real(r8) wco2 ! Consts used to define co2 pathlength
3802 real(r8) posqt ! Effective pressure for co2 line width
3803 real(r8) rbeta7 ! Inverse of co2 hot band line width par
3804 real(r8) rbeta8 ! Inverse of co2 hot band line width par
3805 real(r8) rbeta9 ! Inverse of co2 hot band line width par
3806 real(r8) rbeta13 ! Inverse of co2 hot band line width par
3807 real(r8) tpath ! Path temp used in co2 band model
3808 real(r8) tmp1 ! Co2 band factor
3809 real(r8) tmp2 ! Co2 band factor
3810 real(r8) tmp3 ! Co2 band factor
3811 real(r8) tlayr5 ! Temperature factor in co2 Planck func
3812 real(r8) rsqti ! Reciprocal of sqrt of temperature
3813 real(r8) exm1sq ! Part of co2 Planck function
3814 real(r8) u7 ! Absorber amt for various co2 band systems
3815 real(r8) u8 ! Absorber amt for various co2 band systems
3816 real(r8) u9 ! Absorber amt for various co2 band systems
3817 real(r8) u13 ! Absorber amt for various co2 band systems
3818 real(r8) r250 ! Inverse 250K
3819 real(r8) r300 ! Inverse 300K
3820 real(r8) rsslp ! Inverse standard sea-level pressure
3821 !
3822 ! Local variables for O3:
3823 !
3824 real(r8) o3ems(pcols,pverp) ! Ozone emissivity
3825 real(r8) dbvtt(pcols) ! Tmp drvtv of planck fctn for tplnke
3826 real(r8) dbvt,fo3,t,ux,vx
3827 real(r8) te ! Temperature factor
3828 real(r8) u1 ! Path length factor
3829 real(r8) u2 ! Path length factor
3830 real(r8) phat ! Effecitive path length pressure
3831 real(r8) tlocal ! Local planck function temperature
3832 real(r8) tcrfac ! Scaled temperature factor
3833 real(r8) beta ! Absorption funct factor voigt effect
3834 real(r8) realnu ! Absorption function factor
3835 real(r8) o3bndi ! Band absorption factor
3836 !
3837 ! Transmission terms for various spectral intervals:
3838 !
3839 real(r8) absbnd ! Proportional to co2 band absorptance
3840 real(r8) tco2(pcols) ! co2 overlap factor
3841 real(r8) th2o(pcols) ! h2o overlap factor
3842 real(r8) to3(pcols) ! o3 overlap factor
3843 !
3844 ! Variables for new H2O parameterization
3845 !
3846 ! Notation:
3847 ! U = integral (P/P_0 dW) eq. 15 in Ramanathan/Downey 1986
3848 ! P = atmospheric pressure
3849 ! P_0 = reference atmospheric pressure
3850 ! W = precipitable water path
3851 ! T_e = emission temperature
3852 ! T_p = path temperature
3853 ! RH = path relative humidity
3854 !
3855 real(r8) fe ! asymptotic value of emis. as U->infinity
3856 real(r8) e_star ! normalized non-window emissivity
3857 real(r8) l_star ! interpolated line transmission
3858 real(r8) c_star ! interpolated continuum transmission
3860 real(r8) te1 ! emission temperature
3861 real(r8) te2 ! te^2
3862 real(r8) te3 ! te^3
3863 real(r8) te4 ! te^4
3864 real(r8) te5 ! te^5
3866 real(r8) log_u ! log base 10 of U
3867 real(r8) log_uc ! log base 10 of H2O continuum path
3868 real(r8) log_p ! log base 10 of P
3869 real(r8) t_p ! T_p
3870 real(r8) t_e ! T_e (offset by T_p)
3872 integer iu ! index for log10(U)
3873 integer iu1 ! iu + 1
3874 integer iuc ! index for log10(H2O continuum path)
3875 integer iuc1 ! iuc + 1
3876 integer ip ! index for log10(P)
3877 integer ip1 ! ip + 1
3878 integer itp ! index for T_p
3879 integer itp1 ! itp + 1
3880 integer ite ! index for T_e
3881 integer ite1 ! ite + 1
3882 integer irh ! index for RH
3883 integer irh1 ! irh + 1
3885 real(r8) dvar ! normalized variation in T_p/T_e/P/U
3886 real(r8) uvar ! U * diffusivity factor
3887 real(r8) uscl ! factor for lineary scaling as U->0
3889 real(r8) wu ! weight for U
3890 real(r8) wu1 ! 1 - wu
3891 real(r8) wuc ! weight for H2O continuum path
3892 real(r8) wuc1 ! 1 - wuc
3893 real(r8) wp ! weight for P
3894 real(r8) wp1 ! 1 - wp
3895 real(r8) wtp ! weight for T_p
3896 real(r8) wtp1 ! 1 - wtp
3897 real(r8) wte ! weight for T_e
3898 real(r8) wte1 ! 1 - wte
3899 real(r8) wrh ! weight for RH
3900 real(r8) wrh1 ! 1 - wrh
3902 real(r8) w_0_0_ ! weight for Tp/Te combination
3903 real(r8) w_0_1_ ! weight for Tp/Te combination
3904 real(r8) w_1_0_ ! weight for Tp/Te combination
3905 real(r8) w_1_1_ ! weight for Tp/Te combination
3907 real(r8) w_0_00 ! weight for Tp/Te/RH combination
3908 real(r8) w_0_01 ! weight for Tp/Te/RH combination
3909 real(r8) w_0_10 ! weight for Tp/Te/RH combination
3910 real(r8) w_0_11 ! weight for Tp/Te/RH combination
3911 real(r8) w_1_00 ! weight for Tp/Te/RH combination
3912 real(r8) w_1_01 ! weight for Tp/Te/RH combination
3913 real(r8) w_1_10 ! weight for Tp/Te/RH combination
3914 real(r8) w_1_11 ! weight for Tp/Te/RH combination
3916 real(r8) w00_00 ! weight for P/Tp/Te/RH combination
3917 real(r8) w00_01 ! weight for P/Tp/Te/RH combination
3918 real(r8) w00_10 ! weight for P/Tp/Te/RH combination
3919 real(r8) w00_11 ! weight for P/Tp/Te/RH combination
3920 real(r8) w01_00 ! weight for P/Tp/Te/RH combination
3921 real(r8) w01_01 ! weight for P/Tp/Te/RH combination
3922 real(r8) w01_10 ! weight for P/Tp/Te/RH combination
3923 real(r8) w01_11 ! weight for P/Tp/Te/RH combination
3924 real(r8) w10_00 ! weight for P/Tp/Te/RH combination
3925 real(r8) w10_01 ! weight for P/Tp/Te/RH combination
3926 real(r8) w10_10 ! weight for P/Tp/Te/RH combination
3927 real(r8) w10_11 ! weight for P/Tp/Te/RH combination
3928 real(r8) w11_00 ! weight for P/Tp/Te/RH combination
3929 real(r8) w11_01 ! weight for P/Tp/Te/RH combination
3930 real(r8) w11_10 ! weight for P/Tp/Te/RH combination
3931 real(r8) w11_11 ! weight for P/Tp/Te/RH combination
3933 integer ib ! spectral interval:
3934 ! 1 = 0-800 cm^-1 and 1200-2200 cm^-1
3935 ! 2 = 800-1200 cm^-1
3937 real(r8) pch2o ! H2O continuum path
3938 real(r8) fch2o ! temp. factor for continuum
3939 real(r8) uch2o ! U corresponding to H2O cont. path (window)
3941 real(r8) fdif ! secant(zenith angle) for diffusivity approx.
3943 real(r8) sslp_mks ! Sea-level pressure in MKS units
3944 real(r8) esx ! saturation vapor pressure returned by vqsatd
3945 real(r8) qsx ! saturation mixing ratio returned by vqsatd
3946 real(r8) pnew_mks ! pnew in MKS units
3947 real(r8) q_path ! effective specific humidity along path
3948 real(r8) rh_path ! effective relative humidity along path
3949 real(r8) omeps ! 1 - epsilo
3951 integer iest ! index in estblh2o
3953 !
3954 !---------------------------Statement functions-------------------------
3955 !
3956 ! Derivative of planck function at 9.6 micro-meter wavelength, and
3957 ! an absorption function factor:
3958 !
3959 !
3960 dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
3961 (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
3962 !
3963 fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx))
3964 !
3965 !
3966 !
3967 !-----------------------------------------------------------------------
3968 !
3969 ! Initialize
3970 !
3971 r250 = 1./250.
3972 r300 = 1./300.
3973 rsslp = 1./sslp
3974 !
3975 ! Constants for computing U corresponding to H2O cont. path
3976 !
3977 fdif = 1.66
3978 sslp_mks = sslp / 10.0
3979 omeps = 1.0 - epsilo
3980 !
3981 ! Planck function for co2
3982 !
3983 do i=1,ncol
3984 ex = exp(960./tplnke(i))
3985 co2plk(i) = 5.e8/((tplnke(i)**4)*(ex - 1.))
3986 co2t(i,ntoplw) = tplnke(i)
3987 sum(i) = co2t(i,ntoplw)*pnm(i,ntoplw)
3988 end do
3989 k = ntoplw
3990 do k1=pverp,ntoplw+1,-1
3991 k = k + 1
3992 do i=1,ncol
3993 sum(i) = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1))
3994 ex = exp(960./tlayr(i,k1))
3995 tlayr5 = tlayr(i,k1)*tlayr4(i,k1)
3996 co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2)
3997 co2t(i,k) = sum(i)/pnm(i,k)
3998 end do
3999 end do
4000 !
4001 ! Initialize planck function derivative for O3
4002 !
4003 do i=1,ncol
4004 dbvtt(i) = dbvt(tplnke(i))
4005 end do
4006 !
4007 ! Calculate trace gas Planck functions
4008 !
4009 call trcplk(lchnk ,ncol ,pcols, pver, pverp, &
4010 tint ,tlayr ,tplnke ,emplnk ,abplnk1 , &
4011 abplnk2 )
4012 !
4013 ! Interface loop
4014 !
4015 do k1=ntoplw,pverp
4016 !
4017 ! H2O emissivity
4018 !
4019 ! emis(i,1) 0 - 800 cm-1 h2o rotation band
4020 ! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
4021 ! emis(i,2) 800 - 1200 cm-1 h2o window
4022 !
4023 ! Separation between rotation and vibration-rotation dropped, so
4024 ! only 2 slots needed for H2O emissivity
4025 !
4026 ! emis(i,3) = 0.0
4027 !
4028 ! For the p type continuum
4029 !
4030 do i=1,ncol
4031 u(i) = plh2o(i,k1)
4032 pnew = u(i)/w(i,k1)
4033 pnew_mks = pnew * sslp_mks
4034 !
4035 ! Apply scaling factor for 500-800 continuum
4036 !
4037 uc1(i) = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ &
4038 (1. + 15.*s2c(i,k1))
4039 pch2o = s2c(i,k1)
4040 !
4041 ! Changed effective path temperature to std. Curtis-Godson form
4042 !
4043 tpathe = tcg(i,k1)/w(i,k1)
4044 t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o)
4045 iest = floor(t_p) - min_tp_h2o
4046 esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
4047 (t_p - min_tp_h2o - iest)
4048 qsx = epsilo * esx / (pnew_mks - omeps * esx)
4049 !
4050 ! Compute effective RH along path
4051 !
4052 q_path = w(i,k1) / pnm(i,k1) / rga
4053 !
4054 ! Calculate effective u, pnew for each band using
4055 ! Hulst-Curtis-Godson approximation:
4056 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
4057 ! 2nd edition, Oxford University Press, 1989.
4058 ! Effective H2O path (w)
4059 ! eq. 6.24, p. 228
4060 ! Effective H2O path pressure (pnew = u/w):
4061 ! eq. 6.29, p. 228
4062 !
4063 ub(1) = plh2ob(1,i,k1) / psi(t_p,1)
4064 ub(2) = plh2ob(2,i,k1) / psi(t_p,2)
4066 pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1)
4067 pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2)
4068 !
4069 !
4070 !
4071 dtx(i) = tplnke(i) - 250.
4072 dty(i) = tpathe - 250.
4073 !
4074 ! Define variables for C/H/E (now C/LT/E) fit
4075 !
4076 ! emis(i,1) 0 - 800 cm-1 h2o rotation band
4077 ! emis(i,1) 1200 - 2200 cm-1 h2o vibration-rotation band
4078 ! emis(i,2) 800 - 1200 cm-1 h2o window
4079 !
4080 ! Separation between rotation and vibration-rotation dropped, so
4081 ! only 2 slots needed for H2O emissivity
4082 !
4083 ! emis(i,3) = 0.0
4084 !
4085 ! Notation:
4086 ! U = integral (P/P_0 dW)
4087 ! P = atmospheric pressure
4088 ! P_0 = reference atmospheric pressure
4089 ! W = precipitable water path
4090 ! T_e = emission temperature
4091 ! T_p = path temperature
4092 ! RH = path relative humidity
4093 !
4094 ! Terms for asymptotic value of emissivity
4095 !
4096 te1 = tplnke(i)
4097 te2 = te1 * te1
4098 te3 = te2 * te1
4099 te4 = te3 * te1
4100 te5 = te4 * te1
4101 !
4102 ! Band-independent indices for lines and continuum tables
4103 !
4104 dvar = (t_p - min_tp_h2o) / dtp_h2o
4105 itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
4106 itp1 = itp + 1
4107 wtp = dvar - floor(dvar)
4108 wtp1 = 1.0 - wtp
4110 t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o)
4111 dvar = (t_e - min_te_h2o) / dte_h2o
4112 ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
4113 ite1 = ite + 1
4114 wte = dvar - floor(dvar)
4115 wte1 = 1.0 - wte
4117 rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
4118 dvar = (rh_path - min_rh_h2o) / drh_h2o
4119 irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
4120 irh1 = irh + 1
4121 wrh = dvar - floor(dvar)
4122 wrh1 = 1.0 - wrh
4124 w_0_0_ = wtp * wte
4125 w_0_1_ = wtp * wte1
4126 w_1_0_ = wtp1 * wte
4127 w_1_1_ = wtp1 * wte1
4129 w_0_00 = w_0_0_ * wrh
4130 w_0_01 = w_0_0_ * wrh1
4131 w_0_10 = w_0_1_ * wrh
4132 w_0_11 = w_0_1_ * wrh1
4133 w_1_00 = w_1_0_ * wrh
4134 w_1_01 = w_1_0_ * wrh1
4135 w_1_10 = w_1_1_ * wrh
4136 w_1_11 = w_1_1_ * wrh1
4137 !
4138 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
4139 !
4140 ! Assume foreign continuum dominates total H2O continuum in these bands
4141 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
4142 ! Then the effective H2O path is just
4143 ! U_c = integral[ f(P) dW ]
4144 ! where
4145 ! W = water-vapor mass and
4146 ! f(P) = dependence of foreign continuum on pressure
4147 ! = P / sslp
4148 ! Then
4149 ! U_c = U (the same effective H2O path as for lines)
4150 !
4151 !
4152 ! Continuum terms for 800-1200 cm^-1
4153 !
4154 ! Assume self continuum dominates total H2O continuum for this band
4155 ! per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
4156 ! Then the effective H2O self-continuum path is
4157 ! U_c = integral[ h(e,T) dW ] (*eq. 1*)
4158 ! where
4159 ! W = water-vapor mass and
4160 ! e = partial pressure of H2O along path
4161 ! T = temperature along path
4162 ! h(e,T) = dependence of foreign continuum on e,T
4163 ! = e / sslp * f(T)
4164 !
4165 ! Replacing
4166 ! e =~ q * P / epsilo
4167 ! q = mixing ratio of H2O
4168 ! epsilo = 0.622
4169 !
4170 ! and using the definition
4171 ! U = integral [ (P / sslp) dW ]
4172 ! = (P / sslp) W (homogeneous path)
4173 !
4174 ! the effective path length for the self continuum is
4175 ! U_c = (q / epsilo) f(T) U (*eq. 2*)
4176 !
4177 ! Once values of T, U, and q have been calculated for the inhomogeneous
4178 ! path, this sets U_c for the corresponding
4179 ! homogeneous atmosphere. However, this need not equal the
4180 ! value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
4181 ! under consideration.
4182 !
4183 ! Solution: hold T and q constant, solve for U' that gives U_c' by
4184 ! inverting eq. (2):
4185 !
4186 ! U' = (U_c * epsilo) / (q * f(T))
4187 !
4188 fch2o = fh2oself(t_p)
4189 uch2o = (pch2o * epsilo) / (q_path * fch2o)
4191 !
4192 ! Band-dependent indices for non-window
4193 !
4194 ib = 1
4196 uvar = ub(ib) * fdif
4197 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
4198 dvar = (log_u - min_lu_h2o) / dlu_h2o
4199 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
4200 iu1 = iu + 1
4201 wu = dvar - floor(dvar)
4202 wu1 = 1.0 - wu
4204 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
4205 dvar = (log_p - min_lp_h2o) / dlp_h2o
4206 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
4207 ip1 = ip + 1
4208 wp = dvar - floor(dvar)
4209 wp1 = 1.0 - wp
4211 w00_00 = wp * w_0_00
4212 w00_01 = wp * w_0_01
4213 w00_10 = wp * w_0_10
4214 w00_11 = wp * w_0_11
4215 w01_00 = wp * w_1_00
4216 w01_01 = wp * w_1_01
4217 w01_10 = wp * w_1_10
4218 w01_11 = wp * w_1_11
4219 w10_00 = wp1 * w_0_00
4220 w10_01 = wp1 * w_0_01
4221 w10_10 = wp1 * w_0_10
4222 w10_11 = wp1 * w_0_11
4223 w11_00 = wp1 * w_1_00
4224 w11_01 = wp1 * w_1_01
4225 w11_10 = wp1 * w_1_10
4226 w11_11 = wp1 * w_1_11
4228 !
4229 ! Asymptotic value of emissivity as U->infinity
4230 !
4231 fe = fet(1,ib) + &
4232 fet(2,ib) * te1 + &
4233 fet(3,ib) * te2 + &
4234 fet(4,ib) * te3 + &
4235 fet(5,ib) * te4 + &
4236 fet(6,ib) * te5
4238 e_star = &
4239 eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
4240 eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
4241 eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
4242 eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
4243 eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
4244 eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
4245 eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
4246 eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
4247 eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
4248 eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
4249 eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
4250 eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
4251 eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
4252 eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
4253 eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
4254 eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
4255 eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
4256 eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
4257 eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
4258 eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
4259 eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
4260 eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
4261 eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
4262 eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
4263 eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
4264 eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
4265 eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
4266 eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
4267 eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
4268 eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
4269 eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
4270 eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
4271 emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * &
4272 aer_trn_ttl(i,k1,1,ib)), &
4273 0.0_r8), 1.0_r8)
4274 !
4275 ! Invoke linear limit for scaling wrt u below min_u_h2o
4276 !
4277 if (uvar < min_u_h2o) then
4278 uscl = uvar / min_u_h2o
4279 emis(i,ib) = emis(i,ib) * uscl
4280 endif
4284 !
4285 ! Band-dependent indices for window
4286 !
4287 ib = 2
4289 uvar = ub(ib) * fdif
4290 log_u = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
4291 dvar = (log_u - min_lu_h2o) / dlu_h2o
4292 iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
4293 iu1 = iu + 1
4294 wu = dvar - floor(dvar)
4295 wu1 = 1.0 - wu
4297 log_p = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
4298 dvar = (log_p - min_lp_h2o) / dlp_h2o
4299 ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
4300 ip1 = ip + 1
4301 wp = dvar - floor(dvar)
4302 wp1 = 1.0 - wp
4304 w00_00 = wp * w_0_00
4305 w00_01 = wp * w_0_01
4306 w00_10 = wp * w_0_10
4307 w00_11 = wp * w_0_11
4308 w01_00 = wp * w_1_00
4309 w01_01 = wp * w_1_01
4310 w01_10 = wp * w_1_10
4311 w01_11 = wp * w_1_11
4312 w10_00 = wp1 * w_0_00
4313 w10_01 = wp1 * w_0_01
4314 w10_10 = wp1 * w_0_10
4315 w10_11 = wp1 * w_0_11
4316 w11_00 = wp1 * w_1_00
4317 w11_01 = wp1 * w_1_01
4318 w11_10 = wp1 * w_1_10
4319 w11_11 = wp1 * w_1_11
4321 log_uc = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
4322 dvar = (log_uc - min_lu_h2o) / dlu_h2o
4323 iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
4324 iuc1 = iuc + 1
4325 wuc = dvar - floor(dvar)
4326 wuc1 = 1.0 - wuc
4327 !
4328 ! Asymptotic value of emissivity as U->infinity
4329 !
4330 fe = fet(1,ib) + &
4331 fet(2,ib) * te1 + &
4332 fet(3,ib) * te2 + &
4333 fet(4,ib) * te3 + &
4334 fet(5,ib) * te4 + &
4335 fet(6,ib) * te5
4337 l_star = &
4338 ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
4339 ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
4340 ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
4341 ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
4342 ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu + &
4343 ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu + &
4344 ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu + &
4345 ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu + &
4346 ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
4347 ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
4348 ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
4349 ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
4350 ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu + &
4351 ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu + &
4352 ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu + &
4353 ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu + &
4354 ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
4355 ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
4356 ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
4357 ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
4358 ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu + &
4359 ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu + &
4360 ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu + &
4361 ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu + &
4362 ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
4363 ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
4364 ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
4365 ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
4366 ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu + &
4367 ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu + &
4368 ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu + &
4369 ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
4371 c_star = &
4372 cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
4373 cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
4374 cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
4375 cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
4376 cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc + &
4377 cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc + &
4378 cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc + &
4379 cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc + &
4380 cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
4381 cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
4382 cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
4383 cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
4384 cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc + &
4385 cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc + &
4386 cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc + &
4387 cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc + &
4388 cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
4389 cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
4390 cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
4391 cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
4392 cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc + &
4393 cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc + &
4394 cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc + &
4395 cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc + &
4396 cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
4397 cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
4398 cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
4399 cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
4400 cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc + &
4401 cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc + &
4402 cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc + &
4403 cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
4404 emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * &
4405 aer_trn_ttl(i,k1,1,ib)), &
4406 0.0_r8), 1.0_r8)
4407 !
4408 ! Invoke linear limit for scaling wrt u below min_u_h2o
4409 !
4410 if (uvar < min_u_h2o) then
4411 uscl = uvar / min_u_h2o
4412 emis(i,ib) = emis(i,ib) * uscl
4413 endif
4416 !
4417 ! Compute total emissivity for H2O
4418 !
4419 h2oems(i,k1) = emis(i,1)+emis(i,2)
4421 end do
4422 !
4423 !
4424 !
4426 do i=1,ncol
4427 term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i))
4428 term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i))
4429 term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i))
4430 term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i))
4431 end do
4432 do i=1,ncol
4433 !
4434 ! 500 - 800 cm-1 rotation band overlap with co2
4435 !
4436 k21(i) = term7(i,1) + term8(i,1)/ &
4437 (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i)))
4438 k22(i) = term7(i,2) + term8(i,2)/ &
4439 (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i)))
4440 fwk = fwcoef + fwc1/(1.+fwc2*u(i))
4441 tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
4442 tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
4443 tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800)
4444 ! ! H2O line+aer trn 650--800 cm-1
4445 tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650)
4446 ! ! H2O line+aer trn 500--650 cm-1
4447 tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i)))
4448 tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i)))
4449 tr7(i) = tr1(i)*tr3(i)
4450 tr8(i) = tr2(i)*tr4(i)
4451 troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i)
4452 th2o(i) = tr8(i)
4453 end do
4454 !
4455 ! CO2 emissivity for 15 micron band system
4456 !
4457 do i=1,ncol
4458 t1i = exp(-480./co2t(i,k1))
4459 sqti = sqrt(co2t(i,k1))
4460 rsqti = 1./sqti
4461 et = t1i
4462 et2 = et*et
4463 et4 = et2*et2
4464 omet = 1. - 1.5*et2
4465 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
4466 sqwp = sqrt(plco2(i,k1))
4467 f1sqwp = f1co2*sqwp
4468 t1co2 = 1./(1. + 245.18*omet*sqwp*rsqti)
4469 oneme = 1. - et2
4470 alphat = oneme**3*rsqti
4471 wco2 = 2.5221*co2vmr*pnm(i,k1)*rga
4472 u7 = 4.9411e4*alphat*et2*wco2
4473 u8 = 3.9744e4*alphat*et4*wco2
4474 u9 = 1.0447e5*alphat*et4*et2*wco2
4475 u13 = 2.8388e3*alphat*et4*wco2
4476 !
4477 tpath = co2t(i,k1)
4478 tlocal = tplnke(i)
4479 tcrfac = sqrt((tlocal*r250)*(tpath*r300))
4480 pi = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac
4481 posqt = pi/(2.*sqti)
4482 rbeta7 = 1./( 5.3288*posqt)
4483 rbeta8 = 1./ (10.6576*posqt)
4484 rbeta9 = rbeta7
4485 rbeta13= rbeta9
4486 f2co2 = (u7/sqrt(4. + u7*(1. + rbeta7))) + &
4487 (u8/sqrt(4. + u8*(1. + rbeta8))) + &
4488 (u9/sqrt(4. + u9*(1. + rbeta9)))
4489 f3co2 = u13/sqrt(4. + u13*(1. + rbeta13))
4490 tmp1 = log(1. + f1sqwp)
4491 tmp2 = log(1. + f2co2)
4492 tmp3 = log(1. + f3co2)
4493 absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti
4494 tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7))))
4495 co2ems(i,k1) = troco2(i,k1)*absbnd*co2plk(i)
4496 ex = exp(960./tint(i,k1))
4497 exm1sq = (ex - 1.)**2
4498 co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq)
4499 end do
4500 !
4501 ! O3 emissivity
4502 !
4503 do i=1,ncol
4504 h2otr(i,k1) = exp(-12.*s2c(i,k1))
4505 h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200)
4506 te = (co2t(i,k1)/293.)**.7
4507 u1 = 18.29*plos(i,k1)/te
4508 u2 = .5649*plos(i,k1)/te
4509 phat = plos(i,k1)/plol(i,k1)
4510 tlocal = tplnke(i)
4511 tcrfac = sqrt(tlocal*r250)*te
4512 beta = (1./.3205)*((1./phat) + (dpfo3*tcrfac))
4513 realnu = (1./beta)*te
4514 o3bndi = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu))
4515 o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi
4516 to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu))
4517 end do
4518 !
4519 ! Calculate trace gas emissivities
4520 !
4521 call trcems(lchnk ,ncol ,pcols, pverp, &
4522 k1 ,co2t ,pnm ,ucfc11 ,ucfc12 , &
4523 un2o0 ,un2o1 ,bn2o0 ,bn2o1 ,uch4 , &
4524 bch4 ,uco211 ,uco212 ,uco213 ,uco221 , &
4525 uco222 ,uco223 ,uptype ,w ,s2c , &
4526 u ,emplnk ,th2o ,tco2 ,to3 , &
4527 emstrc , &
4528 aer_trn_ttl)
4529 !
4530 ! Total emissivity:
4531 !
4532 do i=1,ncol
4533 emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1) &
4534 + emstrc(i,k1)
4535 end do
4536 end do ! End of interface loop
4538 return
4539 end subroutine radems
4541 subroutine radtpl(lchnk ,ncol ,pcols, pver, pverp, &
4542 tnm ,lwupcgs ,qnm ,pnm ,plco2 ,plh2o , &
4543 tplnka ,s2c ,tcg ,w ,tplnke , &
4544 tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
4545 piln ,plh2ob ,wb )
4546 !--------------------------------------------------------------------
4547 !
4548 ! Purpose:
4549 ! Compute temperatures and path lengths for longwave radiation
4550 !
4551 ! Method:
4552 ! <Describe the algorithm(s) used in the routine.>
4553 ! <Also include any applicable external references.>
4554 !
4555 ! Author: CCM1
4556 !
4557 !--------------------------------------------------------------------
4559 !------------------------------Arguments-----------------------------
4560 !
4561 ! Input arguments
4562 !
4563 integer, intent(in) :: lchnk ! chunk identifier
4564 integer, intent(in) :: ncol ! number of atmospheric columns
4565 integer, intent(in) :: pcols, pver, pverp
4567 real(r8), intent(in) :: tnm(pcols,pver) ! Model level temperatures
4568 real(r8), intent(in) :: lwupcgs(pcols) ! Surface longwave up flux
4569 real(r8), intent(in) :: qnm(pcols,pver) ! Model level specific humidity
4570 real(r8), intent(in) :: pnm(pcols,pverp) ! Pressure at model interfaces (dynes/cm2)
4571 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmidm1)
4572 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pintm1)
4573 !
4574 ! Output arguments
4575 !
4576 real(r8), intent(out) :: plco2(pcols,pverp) ! Pressure weighted co2 path
4577 real(r8), intent(out) :: plh2o(pcols,pverp) ! Pressure weighted h2o path
4578 real(r8), intent(out) :: tplnka(pcols,pverp) ! Level temperature from interface temperatures
4579 real(r8), intent(out) :: s2c(pcols,pverp) ! H2o continuum path length
4580 real(r8), intent(out) :: tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
4581 real(r8), intent(out) :: w(pcols,pverp) ! H2o path length
4582 real(r8), intent(out) :: tplnke(pcols) ! Equal to tplnka
4583 real(r8), intent(out) :: tint(pcols,pverp) ! Layer interface temperature
4584 real(r8), intent(out) :: tint4(pcols,pverp) ! Tint to the 4th power
4585 real(r8), intent(out) :: tlayr(pcols,pverp) ! K-1 level temperature
4586 real(r8), intent(out) :: tlayr4(pcols,pverp) ! Tlayr to the 4th power
4587 real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
4588 ! Hulst-Curtis-Godson temp. factor
4589 ! for H2O bands
4590 real(r8), intent(out) :: wb(nbands,pcols,pverp) ! H2o path length with
4591 ! Hulst-Curtis-Godson temp. factor
4592 ! for H2O bands
4594 !
4595 !---------------------------Local variables--------------------------
4596 !
4597 integer i ! Longitude index
4598 integer k ! Level index
4599 integer kp1 ! Level index + 1
4601 real(r8) repsil ! Inver ratio mol weight h2o to dry air
4602 real(r8) dy ! Thickness of layer for tmp interp
4603 real(r8) dpnm ! Pressure thickness of layer
4604 real(r8) dpnmsq ! Prs squared difference across layer
4605 real(r8) dw ! Increment in H2O path length
4606 real(r8) dplh2o ! Increment in plh2o
4607 real(r8) cpwpl ! Const in co2 mix ratio to path length conversn
4609 !--------------------------------------------------------------------
4610 !
4611 repsil = 1./epsilo
4612 !
4613 ! Compute co2 and h2o paths
4614 !
4615 cpwpl = amco2/amd * 0.5/(gravit*p0)
4616 do i=1,ncol
4617 plh2o(i,ntoplw) = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw)
4618 plco2(i,ntoplw) = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw)
4619 end do
4620 do k=ntoplw,pver
4621 do i=1,ncol
4622 plh2o(i,k+1) = plh2o(i,k) + rgsslp* &
4623 (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k)
4624 plco2(i,k+1) = co2vmr*cpwpl*pnm(i,k+1)**2
4625 end do
4626 end do
4627 !
4628 ! Set the top and bottom intermediate level temperatures,
4629 ! top level planck temperature and top layer temp**4.
4630 !
4631 ! Tint is lower interface temperature
4632 ! (not available for bottom layer, so use ground temperature)
4633 !
4634 do i=1,ncol
4635 tint4(i,pverp) = lwupcgs(i)/stebol
4636 tint(i,pverp) = sqrt(sqrt(tint4(i,pverp)))
4637 tplnka(i,ntoplw) = tnm(i,ntoplw)
4638 tint(i,ntoplw) = tplnka(i,ntoplw)
4639 tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4
4640 tint4(i,ntoplw) = tlayr4(i,ntoplw)
4641 end do
4642 !
4643 ! Intermediate level temperatures are computed using temperature
4644 ! at the full level below less dy*delta t,between the full level
4645 !
4646 do k=ntoplw+1,pver
4647 do i=1,ncol
4648 dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k))
4649 tint(i,k) = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1))
4650 tint4(i,k) = tint(i,k)**4
4651 end do
4652 end do
4653 !
4654 ! Now set the layer temp=full level temperatures and establish a
4655 ! planck temperature for absorption (tplnka) which is the average
4656 ! the intermediate level temperatures. Note that tplnka is not
4657 ! equal to the full level temperatures.
4658 !
4659 do k=ntoplw+1,pverp
4660 do i=1,ncol
4661 tlayr(i,k) = tnm(i,k-1)
4662 tlayr4(i,k) = tlayr(i,k)**4
4663 tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1))
4664 end do
4665 end do
4666 !
4667 ! Calculate tplank for emissivity calculation.
4668 ! Assume isothermal tplnke i.e. all levels=ttop.
4669 !
4670 do i=1,ncol
4671 tplnke(i) = tplnka(i,ntoplw)
4672 tlayr(i,ntoplw) = tint(i,ntoplw)
4673 end do
4674 !
4675 ! Now compute h2o path fields:
4676 !
4677 do i=1,ncol
4678 !
4679 ! Changed effective path temperature to std. Curtis-Godson form
4680 !
4681 tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw)
4682 w(i,ntoplw) = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw)
4683 !
4684 ! Hulst-Curtis-Godson scaling for H2O path
4685 !
4686 wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1)
4687 wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2)
4688 !
4689 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
4690 !
4691 plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1)
4692 plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2)
4694 s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil
4695 end do
4697 do k=ntoplw,pver
4698 do i=1,ncol
4699 dpnm = pnm(i,k+1) - pnm(i,k)
4700 dpnmsq = pnm(i,k+1)**2 - pnm(i,k)**2
4701 dw = rga*qnm(i,k)*dpnm
4702 kp1 = k+1
4703 w(i,kp1) = w(i,k) + dw
4704 !
4705 ! Hulst-Curtis-Godson scaling for H2O path
4706 !
4707 wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1)
4708 wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2)
4709 !
4710 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
4711 !
4712 dplh2o = plh2o(i,kp1) - plh2o(i,k)
4714 plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1)
4715 plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2)
4716 !
4717 ! Changed effective path temperature to std. Curtis-Godson form
4718 !
4719 tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k)
4720 s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* &
4721 fh2oself(tnm(i,k))*qnm(i,k)*repsil
4722 end do
4723 end do
4724 !
4725 return
4726 end subroutine radtpl
4729 subroutine radclwmx(lchnk ,ncol ,pcols, pver, pverp, &
4730 lwupcgs ,tnm ,qnm ,o3vmr , &
4731 pmid ,pint ,pmln ,piln , &
4732 n2o ,ch4 ,cfc11 ,cfc12 , &
4733 cld ,emis ,pmxrgn ,nmxrgn ,qrl , &
4734 qrlcs, doabsems, abstot, absnxt, emstot, &
4735 flns ,flnt ,flnsc ,flntc ,flwds , &
4736 flut ,flutc , &
4737 flup ,flupc ,fldn ,fldnc , &
4738 aer_mass)
4739 !-----------------------------------------------------------------------
4740 !
4741 ! Purpose:
4742 ! Compute longwave radiation heating rates and boundary fluxes
4743 !
4744 ! Method:
4745 ! Uses broad band absorptivity/emissivity method to compute clear sky;
4746 ! assumes randomly overlapped clouds with variable cloud emissivity to
4747 ! include effects of clouds.
4748 !
4749 ! Computes clear sky absorptivity/emissivity at lower frequency (in
4750 ! general) than the model radiation frequency; uses previously computed
4751 ! and stored values for efficiency
4752 !
4753 ! Note: This subroutine contains vertical indexing which proceeds
4754 ! from bottom to top rather than the top to bottom indexing
4755 ! used in the rest of the model.
4756 !
4757 ! Author: B. Collins
4758 !
4759 !-----------------------------------------------------------------------
4760 ! use shr_kind_mod, only: r8 => shr_kind_r8
4761 ! use ppgrid
4762 ! use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d
4763 ! use volcrad
4765 implicit none
4767 integer pverp2,pverp3,pverp4
4768 ! parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4)
4770 real(r8) cldmin
4771 parameter (cldmin = 1.0d-80)
4772 !------------------------------Commons----------------------------------
4773 !-----------------------------------------------------------------------
4774 !------------------------------Arguments--------------------------------
4775 !
4776 ! Input arguments
4777 !
4778 integer, intent(in) :: lchnk ! chunk identifier
4779 integer, intent(in) :: pcols, pver, pverp
4780 integer, intent(in) :: ncol ! number of atmospheric columns
4781 ! maximally overlapped region.
4782 ! 0->pmxrgn(i,1) is range of pmid for
4783 ! 1st region, pmxrgn(i,1)->pmxrgn(i,2) for
4784 ! 2nd region, etc
4785 integer, intent(in) :: nmxrgn(pcols) ! Number of maximally overlapped regions
4786 logical, intent(in) :: doabsems
4788 real(r8), intent(in) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
4789 real(r8), intent(in) :: lwupcgs(pcols) ! Longwave up flux in CGS units
4790 !
4791 ! Input arguments which are only passed to other routines
4792 !
4793 real(r8), intent(in) :: tnm(pcols,pver) ! Level temperature
4794 real(r8), intent(in) :: qnm(pcols,pver) ! Level moisture field
4795 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
4796 real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
4797 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressure
4798 real(r8), intent(in) :: pmln(pcols,pver) ! Ln(pmid)
4799 real(r8), intent(in) :: piln(pcols,pverp) ! Ln(pint)
4800 real(r8), intent(in) :: n2o(pcols,pver) ! nitrous oxide mass mixing ratio
4801 real(r8), intent(in) :: ch4(pcols,pver) ! methane mass mixing ratio
4802 real(r8), intent(in) :: cfc11(pcols,pver) ! cfc11 mass mixing ratio
4803 real(r8), intent(in) :: cfc12(pcols,pver) ! cfc12 mass mixing ratio
4804 real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover
4805 real(r8), intent(in) :: emis(pcols,pver) ! Cloud emissivity
4806 real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer
4808 !
4809 ! Output arguments
4810 !
4811 real(r8), intent(out) :: qrl(pcols,pver) ! Longwave heating rate
4812 real(r8), intent(out) :: qrlcs(pcols,pver) ! Clear sky longwave heating rate
4813 real(r8), intent(out) :: flns(pcols) ! Surface cooling flux
4814 real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux
4815 real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model
4816 real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing
4817 real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux
4818 real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model
4819 real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface
4820 ! Added downward/upward total and clear sky fluxes
4821 real(r8), intent(out) :: flup(pcols,pverp) ! Total sky upward longwave flux
4822 real(r8), intent(out) :: flupc(pcols,pverp) ! Clear sky upward longwave flux
4823 real(r8), intent(out) :: fldn(pcols,pverp) ! Total sky downward longwave flux
4824 real(r8), intent(out) :: fldnc(pcols,pverp) ! Clear sky downward longwave flux
4825 !
4826 real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
4827 real(r8), intent(inout) :: absnxt(pcols,pver,4) ! Total nearest layer absorptivity
4828 real(r8), intent(inout) :: emstot(pcols,pverp) ! Total emissivity
4830 !---------------------------Local variables-----------------------------
4831 !
4832 integer i ! Longitude index
4833 integer ilon ! Longitude index
4834 integer ii ! Longitude index
4835 integer iimx ! Longitude index (max overlap)
4836 integer k ! Level index
4837 integer k1 ! Level index
4838 integer k2 ! Level index
4839 integer k3 ! Level index
4840 integer km ! Level index
4841 integer km1 ! Level index
4842 integer km3 ! Level index
4843 integer km4 ! Level index
4844 integer irgn ! Index for max-overlap regions
4845 integer l ! Index for clouds to overlap
4846 integer l1 ! Index for clouds to overlap
4847 integer n ! Counter
4849 !
4850 real(r8) :: plco2(pcols,pverp) ! Path length co2
4851 real(r8) :: plh2o(pcols,pverp) ! Path length h2o
4852 real(r8) tmp(pcols) ! Temporary workspace
4853 real(r8) tmp2(pcols) ! Temporary workspace
4854 real(r8) absbt(pcols) ! Downward emission at model top
4855 real(r8) plol(pcols,pverp) ! O3 pressure wghted path length
4856 real(r8) plos(pcols,pverp) ! O3 path length
4857 real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level
4858 real(r8) co2em(pcols,pverp) ! Layer co2 normalized planck funct. derivative
4859 real(r8) co2eml(pcols,pver) ! Interface co2 normalized planck funct. deriv.
4860 real(r8) delt(pcols) ! Diff t**4 mid layer to top interface
4861 real(r8) delt1(pcols) ! Diff t**4 lower intrfc to mid layer
4862 real(r8) bk1(pcols) ! Absrptvty for vertical quadrature
4863 real(r8) bk2(pcols) ! Absrptvty for vertical quadrature
4864 real(r8) cldp(pcols,pverp) ! Cloud cover with extra layer
4865 real(r8) ful(pcols,pverp) ! Total upwards longwave flux
4866 real(r8) fsul(pcols,pverp) ! Clear sky upwards longwave flux
4867 real(r8) fdl(pcols,pverp) ! Total downwards longwave flux
4868 real(r8) fsdl(pcols,pverp) ! Clear sky downwards longwv flux
4869 real(r8) fclb4(pcols,-1:pver) ! Sig t**4 for cld bottom interfc
4870 real(r8) fclt4(pcols,0:pver) ! Sig t**4 for cloud top interfc
4871 real(r8) s(pcols,pverp,pverp) ! Flx integral sum
4872 real(r8) tplnka(pcols,pverp) ! Planck fnctn temperature
4873 real(r8) s2c(pcols,pverp) ! H2o cont amount
4874 real(r8) tcg(pcols,pverp) ! H2o-mass-wgted temp. (Curtis-Godson approx.)
4875 real(r8) w(pcols,pverp) ! H2o path
4876 real(r8) tplnke(pcols) ! Planck fnctn temperature
4877 real(r8) h2otr(pcols,pverp) ! H2o trnmsn for o3 overlap
4878 real(r8) co2t(pcols,pverp) ! Prs wghted temperature path
4879 real(r8) tint(pcols,pverp) ! Interface temperature
4880 real(r8) tint4(pcols,pverp) ! Interface temperature**4
4881 real(r8) tlayr(pcols,pverp) ! Level temperature
4882 real(r8) tlayr4(pcols,pverp) ! Level temperature**4
4883 real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
4884 ! Hulst-Curtis-Godson temp. factor
4885 ! for H2O bands
4886 real(r8) wb(nbands,pcols,pverp) ! H2o path length with
4887 ! Hulst-Curtis-Godson temp. factor
4888 ! for H2O bands
4890 real(r8) cld0 ! previous cloud amt (for max overlap)
4891 real(r8) cld1 ! next cloud amt (for max overlap)
4892 real(r8) emx(0:pverp) ! Emissivity factors (max overlap)
4893 real(r8) emx0 ! Emissivity factors for BCs (max overlap)
4894 real(r8) trans ! 1 - emis
4895 real(r8) asort(pver) ! 1 - cloud amounts to be sorted for max ovrlp.
4896 real(r8) atmp ! Temporary storage for sort when nxs = 2
4897 real(r8) maxcld(pcols) ! Maximum cloud at any layer
4899 integer indx(pcols) ! index vector of gathered array values
4900 !!$ integer indxmx(pcols+1,pverp)! index vector of gathered array values
4901 integer indxmx(pcols,pverp)! index vector of gathered array values
4902 ! (max overlap)
4903 integer nrgn(pcols) ! Number of max overlap regions at longitude
4904 integer npts ! number of values satisfying some criterion
4905 integer ncolmx(pverp) ! number of columns with clds in region
4906 integer kx1(pcols,pverp) ! Level index for top of max-overlap region
4907 integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region
4908 integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld()
4909 ! in descending order
4910 integer nxs(pcols,pverp) ! Number of cloudy layers between kx1 and kx2
4911 integer nxsk ! Number of cloudy layers between (kx1/kx2)&k
4912 integer ksort(0:pverp) ! Level indices of cloud amounts to be sorted
4913 ! for max ovrlp. calculation
4914 integer ktmp ! Temporary storage for sort when nxs = 2
4916 ! real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
4917 real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
4918 ! ! transmission between interfaces k1 and k2
4919 !
4920 ! Pointer variables to 3d structures
4921 !
4922 ! real(r8), pointer :: abstot(:,:,:)
4923 ! real(r8), pointer :: absnxt(:,:,:)
4924 ! real(r8), pointer :: emstot(:,:)
4926 !
4927 ! Trace gas variables
4928 !
4929 real(r8) ucfc11(pcols,pverp) ! CFC11 path length
4930 real(r8) ucfc12(pcols,pverp) ! CFC12 path length
4931 real(r8) un2o0(pcols,pverp) ! N2O path length
4932 real(r8) un2o1(pcols,pverp) ! N2O path length (hot band)
4933 real(r8) uch4(pcols,pverp) ! CH4 path length
4934 real(r8) uco211(pcols,pverp) ! CO2 9.4 micron band path length
4935 real(r8) uco212(pcols,pverp) ! CO2 9.4 micron band path length
4936 real(r8) uco213(pcols,pverp) ! CO2 9.4 micron band path length
4937 real(r8) uco221(pcols,pverp) ! CO2 10.4 micron band path length
4938 real(r8) uco222(pcols,pverp) ! CO2 10.4 micron band path length
4939 real(r8) uco223(pcols,pverp) ! CO2 10.4 micron band path length
4940 real(r8) bn2o0(pcols,pverp) ! pressure factor for n2o
4941 real(r8) bn2o1(pcols,pverp) ! pressure factor for n2o
4942 real(r8) bch4(pcols,pverp) ! pressure factor for ch4
4943 real(r8) uptype(pcols,pverp) ! p-type continuum path length
4944 real(r8) abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
4945 real(r8) abplnk2(14,pcols,pverp) ! nearest layer factor
4946 !
4947 !
4948 !-----------------------------------------------------------------------
4949 !
4950 !
4951 pverp2=pver+2
4952 pverp3=pver+3
4953 pverp4=pver+4
4954 !
4955 ! Set pointer variables
4956 !
4957 ! abstot => abstot_3d(:,:,:,lchnk)
4958 ! absnxt => absnxt_3d(:,:,:,lchnk)
4959 ! emstot => emstot_3d(:,:,lchnk)
4960 !
4961 ! accumulate mass path from top of atmosphere
4962 !
4963 call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp)
4965 !
4966 ! Calculate some temperatures needed to derive absorptivity and
4967 ! emissivity, as well as some h2o path lengths
4968 !
4969 call radtpl(lchnk ,ncol ,pcols, pver, pverp, &
4970 tnm ,lwupcgs ,qnm ,pint ,plco2 ,plh2o , &
4971 tplnka ,s2c ,tcg ,w ,tplnke , &
4972 tint ,tint4 ,tlayr ,tlayr4 ,pmln , &
4973 piln ,plh2ob ,wb )
4974 if (doabsems) then
4975 !
4976 ! Compute ozone path lengths at frequency of a/e calculation.
4977 !
4978 call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
4979 !
4980 ! Compute trace gas path lengths
4981 !
4982 call trcpth(lchnk ,ncol ,pcols, pver, pverp, &
4983 tnm ,pint ,cfc11 ,cfc12 ,n2o , &
4984 ch4 ,qnm ,ucfc11 ,ucfc12 ,un2o0 , &
4985 un2o1 ,uch4 ,uco211 ,uco212 ,uco213 , &
4986 uco221 ,uco222 ,uco223 ,bn2o0 ,bn2o1 , &
4987 bch4 ,uptype )
4989 ! Compute transmission through STRAER absorption continuum
4990 call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp)
4992 !
4993 !
4994 ! Compute total emissivity:
4995 !
4996 call radems(lchnk ,ncol ,pcols, pver, pverp, &
4997 s2c ,tcg ,w ,tplnke ,plh2o , &
4998 pint ,plco2 ,tint ,tint4 ,tlayr , &
4999 tlayr4 ,plol ,plos ,ucfc11 ,ucfc12 , &
5000 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
5001 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
5002 bn2o0 ,bn2o1 ,bch4 ,co2em ,co2eml , &
5003 co2t ,h2otr ,abplnk1 ,abplnk2 ,emstot , &
5004 plh2ob ,wb , &
5005 aer_trn_ttl)
5006 !
5007 ! Compute total absorptivity:
5008 !
5009 call radabs(lchnk ,ncol ,pcols, pver, pverp, &
5010 pmid ,pint ,co2em ,co2eml ,tplnka , &
5011 s2c ,tcg ,w ,h2otr ,plco2 , &
5012 plh2o ,co2t ,tint ,tlayr ,plol , &
5013 plos ,pmln ,piln ,ucfc11 ,ucfc12 , &
5014 un2o0 ,un2o1 ,uch4 ,uco211 ,uco212 , &
5015 uco213 ,uco221 ,uco222 ,uco223 ,uptype , &
5016 bn2o0 ,bn2o1 ,bch4 ,abplnk1 ,abplnk2 , &
5017 abstot ,absnxt ,plh2ob ,wb , &
5018 aer_mpp ,aer_trn_ttl)
5019 end if
5020 !
5021 ! Compute sums used in integrals (all longitude points)
5022 !
5023 ! Definition of bk1 & bk2 depends on finite differencing. for
5024 ! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent
5025 ! layers only.
5026 !
5027 ! delt=t**4 in layer above current sigma level km.
5028 ! delt1=t**4 in layer below current sigma level km.
5029 !
5030 do i=1,ncol
5031 delt(i) = tint4(i,pver) - tlayr4(i,pverp)
5032 delt1(i) = tlayr4(i,pverp) - tint4(i,pverp)
5033 s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4))
5034 s(i,pver,pverp) = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3))
5035 end do
5036 do k=ntoplw,pver-1
5037 do i=1,ncol
5038 bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5
5039 bk1(i) = bk2(i)
5040 s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
5041 end do
5042 end do
5043 !
5044 ! All k, km>1
5045 !
5046 do km=pver,ntoplw+1,-1
5047 do i=1,ncol
5048 delt(i) = tint4(i,km-1) - tlayr4(i,km)
5049 delt1(i) = tlayr4(i,km) - tint4(i,km)
5050 end do
5051 do k=pverp,ntoplw,-1
5052 if (k == km) then
5053 do i=1,ncol
5054 bk2(i) = absnxt(i,km-1,4)
5055 bk1(i) = absnxt(i,km-1,1)
5056 end do
5057 else if (k == km-1) then
5058 do i=1,ncol
5059 bk2(i) = absnxt(i,km-1,2)
5060 bk1(i) = absnxt(i,km-1,3)
5061 end do
5062 else
5063 do i=1,ncol
5064 bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5
5065 bk1(i) = bk2(i)
5066 end do
5067 end if
5068 do i=1,ncol
5069 s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
5070 end do
5071 end do
5072 end do
5073 !
5074 ! Computation of clear sky fluxes always set first level of fsul
5075 !
5076 do i=1,ncol
5077 fsul(i,pverp) = lwupcgs(i)
5078 end do
5079 !
5080 ! Downward clear sky fluxes store intermediate quantities in down flux
5081 ! Initialize fluxes to clear sky values.
5082 !
5083 do i=1,ncol
5084 tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp)
5085 fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1)
5086 fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw)
5087 end do
5088 !
5089 ! fsdl(i,pverp) assumes isothermal layer
5090 !
5091 do k=ntoplw+1,pver
5092 do i=1,ncol
5093 fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1)
5094 fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1))
5095 end do
5096 end do
5097 !
5098 ! Store the downward emission from level 1 = total gas emission * sigma
5099 ! t**4. fsdl does not yet include all terms
5100 !
5101 do i=1,ncol
5102 absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp)
5103 fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1)
5104 end do
5105 !
5106 !----------------------------------------------------------------------
5107 ! Modifications for clouds -- max/random overlap assumption
5108 !
5109 ! The column is divided into sets of adjacent layers, called regions,
5110 ! in which the clouds are maximally overlapped. The clouds are
5111 ! randomly overlapped between different regions. The number of
5112 ! regions in a column is set by nmxrgn, and the range of pressures
5113 ! included in each region is set by pmxrgn. The max/random overlap
5114 ! can be written in terms of the solutions of random overlap with
5115 ! cloud amounts = 1. The random overlap assumption is equivalent to
5116 ! setting the flux boundary conditions (BCs) at the edges of each region
5117 ! equal to the mean all-sky flux at those boundaries. Since the
5118 ! emissivity array for propogating BCs is only computed for the
5119 ! TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated
5120 ! in terms of solutions to the random overlap equations. This is done
5121 ! by writing the flux BCs as the sum of a clear-sky flux and emission
5122 ! from a cloud outside the region weighted by an emissivity. This
5123 ! emissivity is determined from the location of the cloud and the
5124 ! flux BC.
5125 !
5126 ! Copy cloud amounts to buffer with extra layer (needed for overlap logic)
5127 !
5128 cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver)
5129 cldp(:ncol,pverp) = 0.0
5130 !
5131 !
5132 ! Select only those locations where there are no clouds
5133 ! (maximum cloud fraction <= 1.e-3 treated as clear)
5134 ! Set all-sky fluxes to clear-sky values.
5135 !
5136 maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2)
5138 npts = 0
5139 do i=1,ncol
5140 if (maxcld(i) < cldmin) then
5141 npts = npts + 1
5142 indx(npts) = i
5143 end if
5144 end do
5146 do ii = 1, npts
5147 i = indx(ii)
5148 do k = ntoplw, pverp
5149 fdl(i,k) = fsdl(i,k)
5150 ful(i,k) = fsul(i,k)
5151 end do
5152 end do
5153 !
5154 ! Select only those locations where there are clouds
5155 !
5156 npts = 0
5157 do i=1,ncol
5158 if (maxcld(i) >= cldmin) then
5159 npts = npts + 1
5160 indx(npts) = i
5161 end if
5162 end do
5164 !
5165 ! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions
5166 !
5167 do ii = 1, npts
5168 i = indx(ii)
5169 fdl(i,ntoplw) = fsdl(i,ntoplw)
5170 fdl(i,pverp) = 0.0
5171 ful(i,ntoplw) = 0.0
5172 ful(i,pverp) = fsul(i,pverp)
5173 do k = ntoplw+1, pver
5174 fdl(i,k) = 0.0
5175 ful(i,k) = 0.0
5176 end do
5177 !
5178 ! Initialize Planck emission from layer boundaries
5179 !
5180 do k = ntoplw, pver
5181 fclt4(i,k-1) = stebol*tint4(i,k)
5182 fclb4(i,k-1) = stebol*tint4(i,k+1)
5183 enddo
5184 fclb4(i,ntoplw-2) = stebol*tint4(i,ntoplw)
5185 fclt4(i,pver) = stebol*tint4(i,pverp)
5186 !
5187 ! Initialize indices for layers to be max-overlapped
5188 !
5189 do irgn = 0, nmxrgn(i)
5190 kx2(i,irgn) = ntoplw-1
5191 end do
5192 nrgn(i) = 0
5193 end do
5195 !----------------------------------------------------------------------
5196 ! INDEX CALCULATIONS FOR MAX OVERLAP
5198 do ii = 1, npts
5199 ilon = indx(ii)
5201 !
5202 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
5203 !
5204 do irgn = 1, nmxrgn(ilon)
5205 !
5206 ! Calculate min/max layer indices inside region.
5207 !
5208 n = 0
5209 if (kx2(ilon,irgn-1) < pver) then
5210 nrgn(ilon) = irgn
5211 k1 = kx2(ilon,irgn-1)+1
5212 kx1(ilon,irgn) = k1
5213 kx2(ilon,irgn) = 0
5214 do k2 = pver, k1, -1
5215 if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then
5216 kx2(ilon,irgn) = k2
5217 exit
5218 end if
5219 end do
5220 !
5221 ! Identify columns with clouds in the given region.
5222 !
5223 do k = k1, k2
5224 if (cldp(ilon,k) >= cldmin) then
5225 n = n+1
5226 indxmx(n,irgn) = ilon
5227 exit
5228 endif
5229 end do
5230 endif
5231 ncolmx(irgn) = n
5232 !
5233 ! Dummy value for handling clear-sky regions
5234 !
5235 !!$ indxmx(ncolmx(irgn)+1,irgn) = ncol+1
5236 !
5237 ! Outer loop over columns with clouds in the max-overlap region
5238 !
5239 do iimx = 1, ncolmx(irgn)
5240 i = indxmx(iimx,irgn)
5241 !
5242 ! Sort cloud areas and corresponding level indices.
5243 !
5244 n = 0
5245 do k = kx1(i,irgn),kx2(i,irgn)
5246 if (cldp(i,k) >= cldmin) then
5247 n = n+1
5248 ksort(n) = k
5249 !
5250 ! We need indices for clouds in order of largest to smallest, so
5251 ! sort 1-cld in ascending order
5252 !
5253 asort(n) = 1.0-cldp(i,k)
5254 end if
5255 end do
5256 nxs(i,irgn) = n
5257 !
5258 ! If nxs(i,irgn) eq 1, no need to sort.
5259 ! If nxs(i,irgn) eq 2, sort by swapping if necessary
5260 ! If nxs(i,irgn) ge 3, sort using local sort routine
5261 !
5262 if (nxs(i,irgn) == 2) then
5263 if (asort(2) < asort(1)) then
5264 ktmp = ksort(1)
5265 ksort(1) = ksort(2)
5266 ksort(2) = ktmp
5268 atmp = asort(1)
5269 asort(1) = asort(2)
5270 asort(2) = atmp
5271 endif
5272 else if (nxs(i,irgn) >= 3) then
5273 call sortarray(nxs(i,irgn),asort,ksort(1:))
5274 endif
5276 do l = 1, nxs(i,irgn)
5277 kxs(l,i,irgn) = ksort(l)
5278 end do
5279 !
5280 ! End loop over longitude i for fluxes
5281 !
5282 end do
5283 !
5284 ! End loop over regions irgn for max-overlap
5285 !
5286 end do
5287 !
5288 !----------------------------------------------------------------------
5289 ! DOWNWARD FLUXES:
5290 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
5291 !
5292 do irgn = 1, nmxrgn(ilon)
5293 !
5294 ! Compute clear-sky fluxes for regions without clouds
5295 !
5296 iimx = 1
5297 if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
5298 !
5299 ! Calculate emissivity so that downward flux at upper boundary of region
5300 ! can be cast in form of solution for downward flux from cloud above
5301 ! that boundary. Then solutions for fluxes at other levels take form of
5302 ! random overlap expressions. Try to locate "cloud" as close as possible
5303 ! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
5304 !
5305 k1 = kx1(ilon,irgn)
5306 do km1 = ntoplw-2, k1-2
5307 km4 = km1+3
5308 k2 = k1
5309 k3 = k2+1
5310 tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
5311 emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ &
5312 ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1))
5313 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5314 end do
5315 km1 = min(km1,k1-2)
5316 do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1
5317 k3 = k2+1
5318 tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
5319 fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + &
5320 emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))
5321 end do
5322 else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
5323 iimx = iimx+1
5324 end if
5325 !
5326 ! Outer loop over columns with clouds in the max-overlap region
5327 !
5328 do iimx = 1, ncolmx(irgn)
5329 i = indxmx(iimx,irgn)
5331 !
5332 ! Calculate emissivity so that downward flux at upper boundary of region
5333 ! can be cast in form of solution for downward flux from cloud above that
5334 ! boundary. Then solutions for fluxes at other levels take form of
5335 ! random overlap expressions. Try to locate "cloud" as close as possible
5336 ! to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
5337 !
5338 k1 = kx1(i,irgn)
5339 do km1 = ntoplw-2,k1-2
5340 km4 = km1+3
5341 k2 = k1
5342 k3 = k2 + 1
5343 tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
5344 tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4)
5345 emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1))
5346 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5347 end do
5348 km1 = min(km1,k1-2)
5349 ksort(0) = km1 + 1
5350 !
5351 ! Loop to calculate fluxes at level k
5352 !
5353 nxsk = 0
5354 do k = kx1(i,irgn), kx2(i,irgn)
5355 !
5356 ! Identify clouds (largest to smallest area) between kx1 and k
5357 ! Since nxsk will increase with increasing k up to nxs(i,irgn), once
5358 ! nxsk == nxs(i,irgn) then use the list constructed for previous k
5359 !
5360 if (nxsk < nxs(i,irgn)) then
5361 nxsk = 0
5362 do l = 1, nxs(i,irgn)
5363 k1 = kxs(l,i,irgn)
5364 if (k >= k1) then
5365 nxsk = nxsk + 1
5366 ksort(nxsk) = k1
5367 endif
5368 end do
5369 endif
5370 !
5371 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
5372 !
5373 ksort(nxsk+1) = pverp
5374 !
5375 ! Initialize iterated emissivity factors
5376 !
5377 do l = 1, nxsk
5378 emx(l) = emis(i,ksort(l))
5379 end do
5380 !
5381 ! Initialize iterated emissivity factor for bnd. condition at upper interface
5382 !
5383 emx(0) = emx0
5384 !
5385 ! Initialize previous cloud amounts
5386 !
5387 cld0 = 1.0
5388 !
5389 ! Indices for flux calculations
5390 !
5391 k2 = k+1
5392 k3 = k2+1
5393 tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
5394 !
5395 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
5396 !
5397 do l = 1, nxsk+1
5398 !
5399 ! Calculate downward fluxes
5400 !
5401 cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
5402 if (cld0 /= cld1) then
5403 fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2)
5404 do l1 = 0, l - 1
5405 km1 = ksort(l1)-1
5406 km4 = km1+3
5407 tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4)
5408 fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- &
5409 fsdl(i,k2))
5410 end do
5411 endif
5412 cld0 = cld1
5413 !
5414 ! Multiply emissivity factors by current cloud transmissivity
5415 !
5416 if (l <= nxsk) then
5417 k1 = ksort(l)
5418 trans = 1.0-emis(i,k1)
5419 !
5420 ! Ideally the upper bound on l1 would be l-1, but the sort routine
5421 ! scrambles the order of layers with identical cloud amounts
5422 !
5423 do l1 = 0, nxsk
5424 if (ksort(l1) < k1) then
5425 emx(l1) = emx(l1)*trans
5426 endif
5427 end do
5428 end if
5429 !
5430 ! End loop over number l of cloud levels
5431 !
5432 end do
5433 !
5434 ! End loop over level k for fluxes
5435 !
5436 end do
5437 !
5438 ! End loop over longitude i for fluxes
5439 !
5440 end do
5441 !
5442 ! End loop over regions irgn for max-overlap
5443 !
5444 end do
5446 !
5447 !----------------------------------------------------------------------
5448 ! UPWARD FLUXES:
5449 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
5450 !
5451 do irgn = nmxrgn(ilon), 1, -1
5452 !
5453 ! Compute clear-sky fluxes for regions without clouds
5454 !
5455 iimx = 1
5456 if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
5457 !
5458 ! Calculate emissivity so that upward flux at lower boundary of region
5459 ! can be cast in form of solution for upward flux from cloud below that
5460 ! boundary. Then solutions for fluxes at other levels take form of
5461 ! random overlap expressions. Try to locate "cloud" as close as possible
5462 ! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
5463 ! Include allowance for surface emissivity (both numerator and denominator
5464 ! equal 1)
5465 !
5466 k1 = kx2(ilon,irgn)+1
5467 if (k1 < pverp) then
5468 do km1 = pver-1,kx2(ilon,irgn),-1
5469 km3 = km1+2
5470 k2 = k1
5471 k3 = k2+1
5472 tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
5473 emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ &
5474 ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1))
5475 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5476 end do
5477 km1 = max(km1,kx2(ilon,irgn))
5478 else
5479 km1 = k1-1
5480 km3 = km1+2
5481 emx0 = 1.0
5482 endif
5484 do k2 = kx1(ilon,irgn), kx2(ilon,irgn)
5485 k3 = k2+1
5486 !
5487 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
5488 !
5489 tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
5490 ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* &
5491 (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))
5492 end do
5493 else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
5494 iimx = iimx+1
5495 end if
5496 !
5497 ! Outer loop over columns with clouds in the max-overlap region
5498 !
5499 do iimx = 1, ncolmx(irgn)
5500 i = indxmx(iimx,irgn)
5502 !
5503 ! Calculate emissivity so that upward flux at lower boundary of region
5504 ! can be cast in form of solution for upward flux from cloud at that
5505 ! boundary. Then solutions for fluxes at other levels take form of
5506 ! random overlap expressions. Try to locate "cloud" as close as possible
5507 ! to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
5508 ! Include allowance for surface emissivity (both numerator and denominator
5509 ! equal 1)
5510 !
5511 k1 = kx2(i,irgn)+1
5512 if (k1 < pverp) then
5513 do km1 = pver-1,kx2(i,irgn),-1
5514 km3 = km1+2
5515 k2 = k1
5516 k3 = k2+1
5517 tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3)
5518 emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1))
5519 if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5520 end do
5521 km1 = max(km1,kx2(i,irgn))
5522 else
5523 emx0 = 1.0
5524 km1 = k1-1
5525 endif
5526 ksort(0) = km1 + 1
5528 !
5529 ! Loop to calculate fluxes at level k
5530 !
5531 nxsk = 0
5532 do k = kx2(i,irgn), kx1(i,irgn), -1
5533 !
5534 ! Identify clouds (largest to smallest area) between k and kx2
5535 ! Since nxsk will increase with decreasing k up to nxs(i,irgn), once
5536 ! nxsk == nxs(i,irgn) then use the list constructed for previous k
5537 !
5538 if (nxsk < nxs(i,irgn)) then
5539 nxsk = 0
5540 do l = 1, nxs(i,irgn)
5541 k1 = kxs(l,i,irgn)
5542 if (k <= k1) then
5543 nxsk = nxsk + 1
5544 ksort(nxsk) = k1
5545 endif
5546 end do
5547 endif
5548 !
5549 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
5550 !
5551 ksort(nxsk+1) = pverp
5552 !
5553 ! Initialize iterated emissivity factors
5554 !
5555 do l = 1, nxsk
5556 emx(l) = emis(i,ksort(l))
5557 end do
5558 !
5559 ! Initialize iterated emissivity factor for bnd. condition at lower interface
5560 !
5561 emx(0) = emx0
5562 !
5563 ! Initialize previous cloud amounts
5564 !
5565 cld0 = 1.0
5566 !
5567 ! Indices for flux calculations
5568 !
5569 k2 = k
5570 k3 = k2+1
5571 !
5572 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
5573 !
5574 do l = 1, nxsk+1
5575 !
5576 ! Calculate upward fluxes
5577 !
5578 cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
5579 if (cld0 /= cld1) then
5580 ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2)
5581 do l1 = 0, l - 1
5582 km1 = ksort(l1)-1
5583 km3 = km1+2
5584 !
5585 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
5586 !
5587 tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3)
5588 ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* &
5589 (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2))
5590 end do
5591 endif
5592 cld0 = cld1
5593 !
5594 ! Multiply emissivity factors by current cloud transmissivity
5595 !
5596 if (l <= nxsk) then
5597 k1 = ksort(l)
5598 trans = 1.0-emis(i,k1)
5599 !
5600 ! Ideally the upper bound on l1 would be l-1, but the sort routine
5601 ! scrambles the order of layers with identical cloud amounts
5602 !
5603 do l1 = 0, nxsk
5604 if (ksort(l1) > k1) then
5605 emx(l1) = emx(l1)*trans
5606 endif
5607 end do
5608 end if
5609 !
5610 ! End loop over number l of cloud levels
5611 !
5612 end do
5613 !
5614 ! End loop over level k for fluxes
5615 !
5616 end do
5617 !
5618 ! End loop over longitude i for fluxes
5619 !
5620 end do
5621 !
5622 ! End loop over regions irgn for max-overlap
5623 !
5624 end do
5625 !
5626 ! End outermost longitude loop
5627 !
5628 end do
5629 !
5630 ! End cloud modification loops
5631 !
5632 !----------------------------------------------------------------------
5633 ! All longitudes: store history tape quantities
5634 !
5635 do i=1,ncol
5636 flwds(i) = fdl (i,pverp )
5637 flns(i) = ful (i,pverp ) - fdl (i,pverp )
5638 flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp )
5639 flnt(i) = ful (i,ntoplw) - fdl (i,ntoplw)
5640 flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw)
5641 flut(i) = ful (i,ntoplw)
5642 flutc(i) = fsul(i,ntoplw)
5643 end do
5644 !
5645 ! Computation of longwave heating (J/kg/s)
5646 !
5647 do k=ntoplw,pver
5648 do i=1,ncol
5649 qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* &
5650 1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
5651 end do
5652 end do
5653 ! Repeat for clear sky
5654 do k=ntoplw,pver
5655 do i=1,ncol
5656 qrlcs(i,k) = (fsul(i,k) - fsdl(i,k) - fsul(i,k+1) + fsdl(i,k+1))* &
5657 1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
5658 end do
5659 end do
5660 ! Return 0 above solution domain
5661 if ( ntoplw > 1 )then
5662 qrl(:ncol,:ntoplw-1) = 0.
5663 qrlcs(:ncol,:ntoplw-1) = 0.
5664 end if
5666 ! Added downward/upward total and clear sky fluxes
5667 !
5668 do k=ntoplw,pverp
5669 do i=1,ncol
5670 flup(i,k) = ful(i,k)
5671 flupc(i,k) = fsul(i,k)
5672 fldn(i,k) = fdl(i,k)
5673 fldnc(i,k) = fsdl(i,k)
5674 end do
5675 end do
5676 ! Return 0 above solution domain
5677 if ( ntoplw > 1 )then
5678 flup(:ncol,:ntoplw-1) = 0.
5679 flupc(:ncol,:ntoplw-1) = 0.
5680 fldn(:ncol,:ntoplw-1) = 0.
5681 fldnc(:ncol,:ntoplw-1) = 0.
5682 end if
5683 !
5684 return
5685 end subroutine radclwmx
5687 subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, &
5688 pint ,pmid ,h2ommr ,rh ,o3mmr , &
5689 aermmr ,cld ,cicewp ,cliqwp ,rel , &
5690 ! rei ,eccf ,coszrs ,scon ,solin ,solcon, &
5691 rei ,tauxcl ,tauxci ,eccf ,coszrs ,scon ,solin ,solcon, &
5692 asdir ,asdif ,aldir ,aldif ,nmxrgn , &
5693 pmxrgn ,qrs ,qrscs ,fsnt ,fsntc ,fsntoa , &
5694 fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns , &
5695 fsnsc ,fsdsc ,fsds ,sols ,soll , &
5696 solsd ,solld ,frc_day , &
5697 fsup ,fsupc ,fsdn ,fsdnc , &
5698 fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profiles
5699 fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc
5700 aertau ,aerssa ,aerasm ,aerfwd )
5701 !-----------------------------------------------------------------------
5702 !
5703 ! Purpose:
5704 ! Solar radiation code
5705 !
5706 ! Method:
5707 ! Basic method is Delta-Eddington as described in:
5708 !
5709 ! Briegleb, Bruce P., 1992: Delta-Eddington
5710 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
5711 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
5712 !
5713 ! Five changes to the basic method described above are:
5714 ! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993)
5715 ! (2) the distinction between liquid and ice particle clouds
5716 ! (Kiehl et al, 1996);
5717 ! (3) provision for calculating TOA fluxes with spectral response to
5718 ! match Nimbus-7 visible/near-IR radiometers (Collins, 1998);
5719 ! (4) max-random overlap (Collins, 2001)
5720 ! (5) The near-IR absorption by H2O was updated in 2003 by Collins,
5721 ! Lee-Taylor, and Edwards for consistency with the new line data in
5722 ! Hitran 2000 and the H2O continuum version CKD 2.4. Modifications
5723 ! were optimized by reducing RMS errors in heating rates relative
5724 ! to a series of benchmark calculations for the 5 standard AFGL
5725 ! atmospheres. The benchmarks were performed using DISORT2 combined
5726 ! with GENLN3. The near-IR scattering optical depths for Rayleigh
5727 ! scattering were also adjusted, as well as the correction for
5728 ! stratospheric heating by H2O.
5729 !
5730 ! The treatment of maximum-random overlap is described in the
5731 ! comment block "INDEX CALCULATIONS FOR MAX OVERLAP".
5732 !
5733 ! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters.
5734 ! solar flux fractions specified for each interval. allows for
5735 ! seasonally and diurnally varying solar input. Includes molecular,
5736 ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud,
5737 ! and surface absorption. Computes delta-eddington reflections and
5738 ! transmissions assuming homogeneously mixed layers. Adds the layers
5739 ! assuming scattering between layers to be isotropic, and distinguishes
5740 ! direct solar beam from scattered radiation.
5741 !
5742 ! Longitude loops are broken into 1 or 2 sections, so that only daylight
5743 ! (i.e. coszrs > 0) computations are done.
5744 !
5745 ! Note that an extra layer above the model top layer is added.
5746 !
5747 ! cgs units are used.
5748 !
5749 ! Special diagnostic calculation of the clear sky surface and total column
5750 ! absorbed flux is also done for cloud forcing diagnostics.
5751 !
5752 !-----------------------------------------------------------------------
5753 ! use shr_kind_mod, only: r8 => shr_kind_r8
5754 ! use ppgrid
5755 ! use ghg_surfvals, only: co2mmr
5756 ! use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, &
5757 ! idxDUSTfirst, numDUST, idxVOLC, naer_all
5758 ! use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, &
5759 ! ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, &
5760 ! kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc
5761 ! use abortutils, only: endrun
5763 implicit none
5765 integer nspint ! Num of spctrl intervals across solar spectrum
5766 integer naer_groups ! Num of aerosol groups for optical diagnostics
5768 parameter ( nspint = 19 )
5769 parameter ( naer_groups = 7 ) ! current groupings are sul, sslt, all carbons, all dust, and all aerosols
5770 !-----------------------Constants for new band (640-700 nm)-------------
5772 !-------------Parameters for accelerating max-random solution-------------
5773 !
5774 ! The solution time scales like prod(j:1->N) (1 + n_j) where
5775 ! N = number of max-overlap regions (nmxrgn)
5776 ! n_j = number of unique cloud amounts in region j
5777 !
5778 ! Therefore the solution cost can be reduced by decreasing n_j.
5779 ! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky.
5780 ! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps)
5781 ! decimal places as identical
5782 !
5783 ! areamin reduces the cost by dropping configurations that occupy
5784 ! a surface area < areamin of the model grid box. The surface area
5785 ! for a configuration C(j,k_j), where j is the region number and k_j is the
5786 ! index for a unique cloud amount (in descending order from biggest to
5787 ! smallest clouds) in region j, is
5788 !
5789 ! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)]
5790 !
5791 ! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0.
5792 !
5793 ! nconfgmax reduces the cost and improves load balancing by setting an upper
5794 ! bound on the number of cloud configurations in the solution. If the number
5795 ! of configurations exceeds nconfgmax, the nconfgmax configurations with the
5796 ! largest area are retained, and the fluxes are normalized by the total area
5797 ! of these nconfgmax configurations. For the current max/random overlap
5798 ! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount
5799 ! parameterization, the mean and RMS number of configurations are
5800 ! both roughly 5. nconfgmax has been set to the mean+2*RMS number, or 15.
5801 !
5802 ! Minimum cloud amount (as a fraction of the grid-box area) to
5803 ! distinguish from clear sky
5804 !
5805 real(r8) cldmin
5806 parameter (cldmin = 1.0e-80_r8)
5807 !
5808 ! Minimimum horizontal area (as a fraction of the grid-box area) to retain
5809 ! for a unique cloud configuration in the max-random solution
5810 !
5811 real(r8) areamin
5812 parameter (areamin = 0.01_r8)
5813 !
5814 ! Decimal precision of cloud amount (0 -> preserve full resolution;
5815 ! 10^-n -> preserve n digits of cloud amount)
5816 !
5817 real(r8) cldeps
5818 parameter (cldeps = 0.0_r8)
5819 !
5820 ! Maximum number of configurations to include in solution
5821 !
5822 integer nconfgmax
5823 parameter (nconfgmax = 15)
5824 !------------------------------Commons----------------------------------
5825 !
5826 ! Input arguments
5827 !
5828 integer, intent(in) :: lchnk,jj ! chunk identifier
5829 integer, intent(in) :: pcols, pver, pverp
5830 integer, intent(in) :: ncol ! number of atmospheric columns
5832 real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
5833 real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
5834 real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio)
5835 real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
5836 real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio
5837 real(r8), intent(in) :: rh(pcols,pver) ! Relative humidity (fraction)
5838 !
5839 real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
5840 real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
5841 real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
5842 real(r8), intent(in) :: rel(pcols,pver) ! Liquid effective drop size (microns)
5843 real(r8), intent(in) :: rei(pcols,pver) ! Ice effective drop size (microns)
5844 !
5845 real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2)
5846 real, intent(in) :: solcon ! solar constant with eccentricity factor
5847 real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle
5848 real(r8), intent(in) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad
5849 real(r8), intent(in) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad
5850 real(r8), intent(in) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad
5851 real(r8), intent(in) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad
5853 real(r8), intent(in) :: scon ! solar constant
5854 !
5855 ! IN/OUT arguments
5856 !
5857 real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each
5858 ! ! maximally overlapped region.
5859 ! ! 0->pmxrgn(i,1) is range of pressure for
5860 ! ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
5861 ! ! 2nd region, etc
5862 integer, intent(inout) :: nmxrgn(pcols) ! Number of maximally overlapped regions
5863 !
5864 ! Output arguments
5865 !
5867 real(r8), intent(out) :: solin(pcols) ! Incident solar flux
5868 real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate
5869 real(r8), intent(out) :: qrscs(pcols,pver)! Clear sky solar heating rate
5870 real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
5871 real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux
5872 real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA
5873 real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface
5874 !
5875 real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux
5876 real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux
5878 real(r8), intent(out) :: fsdscdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20)
5879 real(r8), intent(out) :: fsdscdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20)
5880 real(r8), intent(out) :: fsdsdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20)
5881 real(r8), intent(out) :: fsdsdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20)
5883 real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx
5884 real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA
5885 real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7)
5886 real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7)
5887 real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7)
5888 real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7)
5889 real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa
5890 real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa
5891 real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns
5892 real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
5893 real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
5895 ! Added downward/upward total and clear sky fluxes
5896 real(r8), intent(out) :: fsup(pcols,pverp) ! Total sky upward solar flux (spectrally summed)
5897 real(r8), intent(out) :: fsupc(pcols,pverp) ! Clear sky upward solar flux (spectrally summed)
5898 real(r8), intent(out) :: fsdn(pcols,pverp) ! Total sky downward solar flux (spectrally summed)
5899 real(r8), intent(out) :: fsdnc(pcols,pverp) ! Clear sky downward solar flux (spectrally summed)
5900 real(r8), intent(out) :: fsdndir(pcols,pverp) ! Total sky direct downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20)
5901 real(r8), intent(out) :: fsdncdir(pcols,pverp) ! Clear sky direct downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20)
5902 real(r8), intent(out) :: fsdndif(pcols,pverp) ! Total sky diffuse downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20)
5903 real(r8), intent(out) :: fsdncdif(pcols,pverp) ! Clear sky diffuse downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20)
5904 !
5905 real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns
5906 real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
5907 real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
5908 real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
5909 real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
5910 ! real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
5911 ! real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
5912 ! real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
5913 ! real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
5914 !
5915 !---------------------------Local variables-----------------------------
5916 !
5917 ! Max/random overlap variables
5918 !
5919 real(r8) asort(pverp) ! 1 - cloud amounts to be sorted for max ovrlp.
5920 real(r8) atmp ! Temporary storage for sort when nxs = 2
5921 real(r8) cld0 ! 1 - (cld amt) used to make wstr, cstr, nstr
5922 real(r8) totwgt ! Total of xwgts = total fractional area of
5923 ! grid-box covered by cloud configurations
5924 ! included in solution to fluxes
5926 real(r8) wgtv(nconfgmax) ! Weights for fluxes
5927 ! 1st index is configuration number
5928 real(r8) wstr(pverp,pverp) ! area weighting factors for streams
5929 ! 1st index is for stream #,
5930 ! 2nd index is for region #
5932 real(r8) xexpt ! solar direct beam trans. for layer above
5933 real(r8) xrdnd ! diffuse reflectivity for layer above
5934 real(r8) xrupd ! diffuse reflectivity for layer below
5935 real(r8) xrups ! direct-beam reflectivity for layer below
5936 real(r8) xtdnt ! total trans for layers above
5938 real(r8) xwgt ! product of cloud amounts
5940 real(r8) yexpt ! solar direct beam trans. for layer above
5941 real(r8) yrdnd ! diffuse reflectivity for layer above
5942 real(r8) yrupd ! diffuse reflectivity for layer below
5943 real(r8) ytdnd ! dif-beam transmission for layers above
5944 real(r8) ytupd ! dif-beam transmission for layers below
5946 real(r8) zexpt ! solar direct beam trans. for layer above
5947 real(r8) zrdnd ! diffuse reflectivity for layer above
5948 real(r8) zrupd ! diffuse reflectivity for layer below
5949 real(r8) zrups ! direct-beam reflectivity for layer below
5950 real(r8) ztdnt ! total trans for layers above
5952 logical new_term ! Flag for configurations to include in fluxes
5953 logical region_found ! flag for identifying regions
5955 integer ccon(0:pverp,nconfgmax)
5956 ! flags for presence of clouds
5957 ! 1st index is for level # (including
5958 ! layer above top of model and at surface)
5959 ! 2nd index is for configuration #
5960 integer cstr(0:pverp,pverp)
5961 ! flags for presence of clouds
5962 ! 1st index is for level # (including
5963 ! layer above top of model and at surface)
5964 ! 2nd index is for stream #
5965 integer icond(0:pverp,nconfgmax)
5966 ! Indices for copying rad. properties from
5967 ! one identical downward cld config.
5968 ! to another in adding method (step 2)
5969 ! 1st index is for interface # (including
5970 ! layer above top of model and at surface)
5971 ! 2nd index is for configuration # range
5972 integer iconu(0:pverp,nconfgmax)
5973 ! Indices for copying rad. properties from
5974 ! one identical upward configuration
5975 ! to another in adding method (step 2)
5976 ! 1st index is for interface # (including
5977 ! layer above top of model and at surface)
5978 ! 2nd index is for configuration # range
5979 integer iconfig ! Counter for random-ovrlap configurations
5980 integer irgn ! Index for max-overlap regions
5981 integer is0 ! Lower end of stream index range
5982 integer is1 ! Upper end of stream index range
5983 integer isn ! Stream index
5984 integer istr(pverp+1) ! index for stream #s during flux calculation
5985 integer istrtd(0:pverp,0:nconfgmax+1)
5986 ! indices into icond
5987 ! 1st index is for interface # (including
5988 ! layer above top of model and at surface)
5989 ! 2nd index is for configuration # range
5990 integer istrtu(0:pverp,0:nconfgmax+1)
5991 ! indices into iconu
5992 ! 1st index is for interface # (including
5993 ! layer above top of model and at surface)
5994 ! 2nd index is for configuration # range
5995 integer j ! Configuration index
5996 integer k1 ! Level index
5997 integer k2 ! Level index
5998 integer ksort(pverp) ! Level indices of cloud amounts to be sorted
5999 integer ktmp ! Temporary storage for sort when nxs = 2
6000 integer kx1(0:pverp) ! Level index for top of max-overlap region
6001 integer kx2(0:pverp) ! Level index for bottom of max-overlap region
6002 integer l ! Index
6003 integer l0 ! Index
6004 integer mrgn ! Counter for nrgn
6005 integer mstr ! Counter for nstr
6006 integer n0 ! Number of configurations with ccon(k,:)==0
6007 integer n1 ! Number of configurations with ccon(k,:)==1
6008 integer nconfig ! Number of random-ovrlap configurations
6009 integer nconfigm ! Value of config before testing for areamin,
6010 ! nconfgmax
6011 integer npasses ! number of passes over the indexing loop
6012 integer nrgn ! Number of max overlap regions at current
6013 ! longitude
6014 integer nstr(pverp) ! Number of unique cloud configurations
6015 ! ("streams") in a max-overlapped region
6016 ! 1st index is for region #
6017 integer nuniq ! # of unique cloud configurations
6018 integer nuniqd(0:pverp) ! # of unique cloud configurations: TOA
6019 ! to level k
6020 integer nuniqu(0:pverp) ! # of unique cloud configurations: surface
6021 ! to level k
6022 integer nxs ! Number of cloudy layers between k1 and k2
6023 integer ptr0(nconfgmax) ! Indices of configurations with ccon(k,:)==0
6024 integer ptr1(nconfgmax) ! Indices of configurations with ccon(k,:)==1
6025 integer ptrc(nconfgmax) ! Pointer for configurations sorted by wgtv
6026 ! integer findvalue ! Function for finding kth smallest element
6027 ! in a vector
6028 ! external findvalue
6030 !
6031 ! Other
6032 !
6033 integer ns ! Spectral loop index
6034 integer i ! Longitude loop index
6035 integer k ! Level loop index
6036 integer km1 ! k - 1
6037 integer kp1 ! k + 1
6038 integer n ! Loop index for daylight
6039 integer ndayc ! Number of daylight columns
6040 integer idayc(pcols) ! Daytime column indices
6041 integer indxsl ! Index for cloud particle properties
6042 integer ksz ! dust size bin index
6043 integer krh ! relative humidity bin index
6044 integer kaer ! aerosol group index
6045 real(r8) wrh ! weight for linear interpolation between lut points
6046 real(r8) :: rhtrunc ! rh, truncated for the purposes of extrapolating
6047 ! aerosol optical properties
6048 real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad
6049 real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad
6050 !
6051 real(r8) wgtint ! Weight for specific spectral interval
6053 !
6054 ! Diagnostic and accumulation arrays; note that sfltot, fswup, and
6055 ! fswdn are not used in the computation,but are retained for future use.
6056 !
6057 real(r8) solflx ! Solar flux in current interval
6058 real(r8) sfltot ! Spectrally summed total solar flux
6059 real(r8) totfld(0:pver) ! Spectrally summed flux divergence
6060 real(r8) totfldc(0:pver) ! Spectrally summed clear sky flux divergence
6061 real(r8) fswup(0:pverp) ! Spectrally summed up flux
6062 real(r8) fswdn(0:pverp) ! Spectrally summed down flux
6063 real(r8) fswupc(0:pverp) ! Spectrally summed up clear sky flux
6064 real(r8) fswdnc(0:pverp) ! Spectrally summed down clear sky flux
6065 real(r8) fswdndir(0:pverp) ! Spectrally summed direct flux in all sky (amontornes-bcodina 2014-04-20)
6066 real(r8) fswdncdir(0:pverp)! Spectrally summed direct flux in clear sky (amontornes-bcodina 2014-04-20)
6067 !
6068 ! Cloud radiative property arrays
6069 !
6070 ! real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth
6071 ! real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth
6072 real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo
6073 real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
6074 real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
6075 real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo
6076 real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter
6077 real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction
6078 !
6079 ! Aerosol mass paths by species
6080 !
6081 real(r8) usul(pcols,pver) ! sulfate (SO4)
6082 real(r8) ubg(pcols,pver) ! background aerosol
6083 real(r8) usslt(pcols,pver) ! sea-salt (SSLT)
6084 real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI)
6085 real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO)
6086 real(r8) ucb(pcols,pver) ! black carbon (BCPHI + BCPHO)
6087 real(r8) uvolc(pcols,pver) ! volcanic mass
6088 real(r8) udst(ndstsz,pcols,pver) ! dust
6090 !
6091 ! local variables used for the external mixing of aerosol species
6092 !
6093 real(r8) tau_sul ! optical depth, sulfate
6094 real(r8) tau_bg ! optical depth, background aerosol
6095 real(r8) tau_sslt ! optical depth, sea-salt
6096 real(r8) tau_cphil ! optical depth, hydrophilic carbon
6097 real(r8) tau_cphob ! optical depth, hydrophobic carbon
6098 real(r8) tau_cb ! optical depth, black carbon
6099 real(r8) tau_volc ! optical depth, volcanic
6100 real(r8) tau_dst(ndstsz) ! optical depth, dust, by size category
6101 real(r8) tau_dst_tot ! optical depth, total dust
6102 real(r8) tau_tot ! optical depth, total aerosol
6104 real(r8) tau_w_sul ! optical depth * single scattering albedo, sulfate
6105 real(r8) tau_w_bg ! optical depth * single scattering albedo, background aerosol
6106 real(r8) tau_w_sslt ! optical depth * single scattering albedo, sea-salt
6107 real(r8) tau_w_cphil ! optical depth * single scattering albedo, hydrophilic carbon
6108 real(r8) tau_w_cphob ! optical depth * single scattering albedo, hydrophobic carbon
6109 real(r8) tau_w_cb ! optical depth * single scattering albedo, black carbon
6110 real(r8) tau_w_volc ! optical depth * single scattering albedo, volcanic
6111 real(r8) tau_w_dst(ndstsz) ! optical depth * single scattering albedo, dust, by size
6112 real(r8) tau_w_dst_tot ! optical depth * single scattering albedo, total dust
6113 real(r8) tau_w_tot ! optical depth * single scattering albedo, total aerosol
6115 real(r8) tau_w_g_sul ! optical depth * single scattering albedo * asymmetry parameter, sulfate
6116 real(r8) tau_w_g_bg ! optical depth * single scattering albedo * asymmetry parameter, background aerosol
6117 real(r8) tau_w_g_sslt ! optical depth * single scattering albedo * asymmetry parameter, sea-salt
6118 real(r8) tau_w_g_cphil ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon
6119 real(r8) tau_w_g_cphob ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon
6120 real(r8) tau_w_g_cb ! optical depth * single scattering albedo * asymmetry parameter, black carbon
6121 real(r8) tau_w_g_volc ! optical depth * single scattering albedo * asymmetry parameter, volcanic
6122 real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size
6123 real(r8) tau_w_g_dst_tot ! optical depth * single scattering albedo * asymmetry parameter, total dust
6124 real(r8) tau_w_g_tot ! optical depth * single scattering albedo * asymmetry parameter, total aerosol
6126 real(r8) f_sul ! forward scattering fraction, sulfate
6127 real(r8) f_bg ! forward scattering fraction, background aerosol
6128 real(r8) f_sslt ! forward scattering fraction, sea-salt
6129 real(r8) f_cphil ! forward scattering fraction, hydrophilic carbon
6130 real(r8) f_cphob ! forward scattering fraction, hydrophobic carbon
6131 real(r8) f_cb ! forward scattering fraction, black carbon
6132 real(r8) f_volc ! forward scattering fraction, volcanic
6133 real(r8) f_dst(ndstsz) ! forward scattering fraction, dust, by size
6134 real(r8) f_dst_tot ! forward scattering fraction, total dust
6135 real(r8) f_tot ! forward scattering fraction, total aerosol
6137 real(r8) tau_w_f_sul ! optical depth * forward scattering fraction * single scattering albedo, sulfate
6138 real(r8) tau_w_f_bg ! optical depth * forward scattering fraction * single scattering albedo, background
6139 real(r8) tau_w_f_sslt ! optical depth * forward scattering fraction * single scattering albedo, sea-salt
6140 real(r8) tau_w_f_cphil ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C
6141 real(r8) tau_w_f_cphob ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C
6142 real(r8) tau_w_f_cb ! optical depth * forward scattering fraction * single scattering albedo, black C
6143 real(r8) tau_w_f_volc ! optical depth * forward scattering fraction * single scattering albedo, volcanic
6144 real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size
6145 real(r8) tau_w_f_dst_tot ! optical depth * forward scattering fraction * single scattering albedo, total dust
6146 real(r8) tau_w_f_tot ! optical depth * forward scattering fraction * single scattering albedo, total aerosol
6147 real(r8) w_dst_tot ! single scattering albedo, total dust
6148 real(r8) w_tot ! single scattering albedo, total aerosol
6149 real(r8) g_dst_tot ! asymmetry parameter, total dust
6150 real(r8) g_tot ! asymmetry parameter, total aerosol
6151 real(r8) ksuli ! specific extinction interpolated between rh look-up-table points, sulfate
6152 real(r8) ksslti ! specific extinction interpolated between rh look-up-table points, sea-salt
6153 real(r8) kcphili ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon
6154 real(r8) wsuli ! single scattering albedo interpolated between rh look-up-table points, sulfate
6155 real(r8) wsslti ! single scattering albedo interpolated between rh look-up-table points, sea-salt
6156 real(r8) wcphili ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon
6157 real(r8) gsuli ! asymmetry parameter interpolated between rh look-up-table points, sulfate
6158 real(r8) gsslti ! asymmetry parameter interpolated between rh look-up-table points, sea-salt
6159 real(r8) gcphili ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon
6160 !
6161 ! Aerosol radiative property arrays
6162 !
6163 real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth
6164 real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo
6165 real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter
6166 real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction
6168 !
6169 ! Various arrays and other constants:
6170 !
6171 real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer
6172 real(r8) zenfac(pcols) ! Square root of cos solar zenith angle
6173 real(r8) sqrco2 ! Square root of the co2 mass mixg ratio
6174 real(r8) tmp1 ! Temporary constant array
6175 real(r8) tmp2 ! Temporary constant array
6176 real(r8) pdel ! Pressure difference across layer
6177 real(r8) path ! Mass path of layer
6178 real(r8) ptop ! Lower interface pressure of extra layer
6179 real(r8) ptho2 ! Used to compute mass path of o2
6180 real(r8) ptho3 ! Used to compute mass path of o3
6181 real(r8) pthco2 ! Used to compute mass path of co2
6182 real(r8) pthh2o ! Used to compute mass path of h2o
6183 real(r8) h2ostr ! Inverse sq. root h2o mass mixing ratio
6184 real(r8) wavmid(nspint) ! Spectral interval middle wavelength
6185 real(r8) trayoslp ! Rayleigh optical depth/standard pressure
6186 real(r8) tmp1l ! Temporary constant array
6187 real(r8) tmp2l ! Temporary constant array
6188 real(r8) tmp3l ! Temporary constant array
6189 real(r8) tmp1i ! Temporary constant array
6190 real(r8) tmp2i ! Temporary constant array
6191 real(r8) tmp3i ! Temporary constant array
6192 real(r8) rdenom ! Multiple scattering term
6193 real(r8) rdirexp ! layer direct ref times exp transmission
6194 real(r8) tdnmexp ! total transmission - exp transmission
6195 real(r8) psf(nspint) ! Frac of solar flux in spect interval
6196 !
6197 ! Layer absorber amounts; note that 0 refers to the extra layer added
6198 ! above the top model layer
6199 !
6200 real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o
6201 real(r8) uo3(pcols,0:pver) ! Layer absorber amount of o3
6202 real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2
6203 real(r8) uo2(pcols,0:pver) ! Layer absorber amount of o2
6204 real(r8) uaer(pcols,0:pver) ! Layer aerosol amount
6205 !
6206 ! Total column absorber amounts:
6207 !
6208 real(r8) uth2o(pcols) ! Total column absorber amount of h2o
6209 real(r8) uto3(pcols) ! Total column absorber amount of o3
6210 real(r8) utco2(pcols) ! Total column absorber amount of co2
6211 real(r8) uto2(pcols) ! Total column absorber amount of o2
6212 !
6213 ! These arrays are defined for pver model layers; 0 refers to the extra
6214 ! layer on top:
6215 !
6216 real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
6217 real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
6218 real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
6219 real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
6220 real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer
6222 real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad
6223 real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad
6224 real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad
6225 real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad
6226 real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer
6228 real(r8) flxdiv ! Flux divergence for layer
6229 !
6230 !
6231 ! Radiative Properties:
6232 !
6233 ! There are 1 classes of properties:
6234 ! (1. All-sky bulk properties
6235 ! (2. Clear-sky properties
6236 !
6237 ! The first set of properties are generated during step 2 of the solution.
6238 !
6239 ! These arrays are defined at model interfaces; in 1st index (for level #),
6240 ! 0 is the top of the extra layer above the model top, and
6241 ! pverp is the earth surface. 2nd index is for cloud configuration
6242 ! defined over a whole column.
6243 !
6244 real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above
6245 real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above
6246 real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below
6247 real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below
6248 real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above
6249 !
6250 ! Bulk properties used during the clear-sky calculation.
6251 !
6252 real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above
6253 real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above
6254 real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below
6255 real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below
6256 real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above
6258 real(r8) fluxup(0:pverp) ! Up flux at model interface
6259 real(r8) fluxdn(0:pverp) ! Down flux at model interface
6260 real(r8) fluxdndir(0:pverp) ! Direct Down flux at model interface (amontornes-bcodina 2014-04-20)
6261 real(r8) wexptdn ! Direct solar beam trans. to surface
6263 ! moved to here from the module storage above, because these have to be thread-private. JM 20100217
6264 real(r8) abarli ! A coefficient for current spectral band
6265 real(r8) bbarli ! B coefficient for current spectral band
6266 real(r8) cbarli ! C coefficient for current spectral band
6267 real(r8) dbarli ! D coefficient for current spectral band
6268 real(r8) ebarli ! E coefficient for current spectral band
6269 real(r8) fbarli ! F coefficient for current spectral band
6271 real(r8) abarii ! A coefficient for current spectral band
6272 real(r8) bbarii ! B coefficient for current spectral band
6273 real(r8) cbarii ! C coefficient for current spectral band
6274 real(r8) dbarii ! D coefficient for current spectral band
6275 real(r8) ebarii ! E coefficient for current spectral band
6276 real(r8) fbarii ! F coefficient for current spectral band
6277 ! JM 20100217
6279 !
6280 !-----------------------------------------------------------------------
6281 ! START OF CALCULATION
6282 !-----------------------------------------------------------------------
6283 !
6284 ! write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk
6286 do i=1, ncol
6287 !
6288 ! Initialize output fields:
6289 !
6290 fsds(i) = 0.0_r8
6292 fsnirtoa(i) = 0.0_r8
6293 fsnrtoac(i) = 0.0_r8
6294 fsnrtoaq(i) = 0.0_r8
6296 fsns(i) = 0.0_r8
6297 fsnsc(i) = 0.0_r8
6298 fsdsc(i) = 0.0_r8
6300 fsdscdir(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6301 fsdscdif(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6302 fsdsdir(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6303 fsdsdif(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6305 fsnt(i) = 0.0_r8
6306 fsntc(i) = 0.0_r8
6307 fsntoa(i) = 0.0_r8
6308 fsntoac(i) = 0.0_r8
6310 solin(i) = 0.0_r8
6312 sols(i) = 0.0_r8
6313 soll(i) = 0.0_r8
6314 solsd(i) = 0.0_r8
6315 solld(i) = 0.0_r8
6317 ! initialize added downward/upward total and clear sky fluxes
6319 do k=1,pverp
6320 fsup(i,k) = 0.0_r8
6321 fsupc(i,k) = 0.0_r8
6322 fsdn(i,k) = 0.0_r8
6323 fsdnc(i,k) = 0.0_r8
6324 fsdndir(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6325 fsdncdir(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6326 fsdndif(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6327 fsdncdif(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
6328 tauxcl(i,k-1) = 0.0_r8
6329 tauxci(i,k-1) = 0.0_r8
6330 end do
6332 do k=1, pver
6333 qrs(i,k) = 0.0_r8
6334 qrscs(i,k) = 0.0_r8
6335 end do
6337 ! initialize aerosol diagnostic fields to 0.0
6338 ! Average can be obtained by dividing <aerod>/<frc_day>
6339 do kaer = 1, naer_groups
6340 do ns = 1, nspint
6341 frc_day(i) = 0.0_r8
6342 aertau(i,ns,kaer) = 0.0_r8
6343 aerssa(i,ns,kaer) = 0.0_r8
6344 aerasm(i,ns,kaer) = 0.0_r8
6345 aerfwd(i,ns,kaer) = 0.0_r8
6346 end do
6347 end do
6349 end do
6350 !
6351 ! Compute starting, ending daytime loop indices:
6352 ! *** Note this logic assumes day and night points are contiguous so
6353 ! *** will not work in general with chunked data structure.
6354 !
6355 ndayc = 0
6356 do i=1,ncol
6357 if (coszrs(i) > 0.0_r8) then
6358 ndayc = ndayc + 1
6359 idayc(ndayc) = i
6360 end if
6361 end do
6362 !
6363 ! If night everywhere, return:
6364 !
6365 if (ndayc == 0) return
6366 !
6367 ! Perform other initializations
6368 !
6369 tmp1 = 0.5_r8/(gravit*sslp)
6370 tmp2 = delta/gravit
6371 sqrco2 = sqrt(co2mmr)
6373 do n=1,ndayc
6374 i=idayc(n)
6375 !
6376 ! Define solar incident radiation and interface pressures:
6377 !
6378 ! solin(i) = scon*eccf*coszrs(i)
6379 !WRF use SOLCON (MKS) calculated outside
6380 solin(i) = solcon*coszrs(i)*1000.
6381 pflx(i,0) = 0._r8
6382 do k=1,pverp
6383 pflx(i,k) = pint(i,k)
6384 end do
6385 !
6386 ! Compute optical paths:
6387 !
6388 ptop = pflx(i,1)
6389 ptho2 = o2mmr * ptop / gravit
6390 ptho3 = o3mmr(i,1) * ptop / gravit
6391 pthco2 = sqrco2 * (ptop / gravit)
6392 h2ostr = sqrt( 1._r8 / h2ommr(i,1) )
6393 zenfac(i) = sqrt(coszrs(i))
6394 pthh2o = ptop**2*tmp1 + (ptop*rga)* &
6395 (h2ostr*zenfac(i)*delta)
6396 uh2o(i,0) = h2ommr(i,1)*pthh2o
6397 uco2(i,0) = zenfac(i)*pthco2
6398 uo2 (i,0) = zenfac(i)*ptho2
6399 uo3 (i,0) = ptho3
6400 uaer(i,0) = 0.0_r8
6401 do k=1,pver
6402 pdel = pflx(i,k+1) - pflx(i,k)
6403 path = pdel / gravit
6404 ptho2 = o2mmr * path
6405 ptho3 = o3mmr(i,k) * path
6406 pthco2 = sqrco2 * path
6407 h2ostr = sqrt(1.0_r8/h2ommr(i,k))
6408 pthh2o = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2
6409 uh2o(i,k) = h2ommr(i,k)*pthh2o
6410 uco2(i,k) = zenfac(i)*pthco2
6411 uo2 (i,k) = zenfac(i)*ptho2
6412 uo3 (i,k) = ptho3
6413 usul(i,k) = aermmr(i,k,idxSUL) * path
6414 ubg(i,k) = aermmr(i,k,idxBG) * path
6415 usslt(i,k) = aermmr(i,k,idxSSLT) * path
6416 if (usslt(i,k) .lt. 0.0) then ! usslt is sometimes small and negative, will be fixed
6417 usslt(i,k) = 0.0
6418 end if
6419 ucphil(i,k) = aermmr(i,k,idxOCPHI) * path
6420 ucphob(i,k) = aermmr(i,k,idxOCPHO) * path
6421 ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path
6422 uvolc(i,k) = aermmr(i,k,idxVOLC)
6423 do ksz = 1, ndstsz
6424 udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path
6425 end do
6426 end do
6427 !
6428 ! Compute column absorber amounts for the clear sky computation:
6429 !
6430 uth2o(i) = 0.0_r8
6431 uto3(i) = 0.0_r8
6432 utco2(i) = 0.0_r8
6433 uto2(i) = 0.0_r8
6435 do k=1,pver
6436 uth2o(i) = uth2o(i) + uh2o(i,k)
6437 uto3(i) = uto3(i) + uo3(i,k)
6438 utco2(i) = utco2(i) + uco2(i,k)
6439 uto2(i) = uto2(i) + uo2(i,k)
6440 end do
6441 !
6442 ! Set cloud properties for top (0) layer; so long as tauxcl is zero,
6443 ! there is no cloud above top of model; the other cloud properties
6444 ! are arbitrary:
6445 !
6446 tauxcl(i,0) = 0._r8
6447 wcl(i,0) = 0.999999_r8
6448 gcl(i,0) = 0.85_r8
6449 fcl(i,0) = 0.725_r8
6450 tauxci(i,0) = 0._r8
6451 wci(i,0) = 0.999999_r8
6452 gci(i,0) = 0.85_r8
6453 fci(i,0) = 0.725_r8
6454 !
6455 ! Aerosol
6456 !
6457 tauxar(i,0) = 0._r8
6458 wa(i,0) = 0.925_r8
6459 ga(i,0) = 0.850_r8
6460 fa(i,0) = 0.7225_r8
6461 !
6462 ! End do n=1,ndayc
6463 !
6464 end do
6465 !
6466 ! Begin spectral loop
6467 !
6468 do ns=1,nspint
6469 !
6470 ! Set index for cloud particle properties based on the wavelength,
6471 ! according to A. Slingo (1989) equations 1-3:
6472 ! Use index 1 (0.25 to 0.69 micrometers) for visible
6473 ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared
6474 ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared
6475 ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared
6476 !
6477 ! Note that the minimum wavelength is encoded (with .001, .002, .003)
6478 ! in order to specify the index appropriate for the near-infrared
6479 ! cloud absorption properties
6480 !
6481 if(wavmax(ns) <= 0.7_r8) then
6482 indxsl = 1
6483 else if(wavmin(ns) == 0.700_r8) then
6484 indxsl = 2
6485 else if(wavmin(ns) == 0.701_r8) then
6486 indxsl = 3
6487 else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then
6488 indxsl = 4
6489 end if
6490 !
6491 ! Set cloud extinction optical depth, single scatter albedo,
6492 ! asymmetry parameter, and forward scattered fraction:
6493 !
6494 abarli = abarl(indxsl)
6495 bbarli = bbarl(indxsl)
6496 cbarli = cbarl(indxsl)
6497 dbarli = dbarl(indxsl)
6498 ebarli = ebarl(indxsl)
6499 fbarli = fbarl(indxsl)
6500 !
6501 abarii = abari(indxsl)
6502 bbarii = bbari(indxsl)
6503 cbarii = cbari(indxsl)
6504 dbarii = dbari(indxsl)
6505 ebarii = ebari(indxsl)
6506 fbarii = fbari(indxsl)
6507 !
6508 ! adjustfraction within spectral interval to allow for the possibility of
6509 ! sub-divisions within a particular interval:
6510 !
6511 psf(ns) = 1.0_r8
6512 if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns)
6513 if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns)
6514 if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns)
6516 do n=1,ndayc
6517 i=idayc(n)
6519 frc_day(i) = 1.0_r8
6520 do kaer = 1, naer_groups
6521 aertau(i,ns,kaer) = 0.0
6522 aerssa(i,ns,kaer) = 0.0
6523 aerasm(i,ns,kaer) = 0.0
6524 aerfwd(i,ns,kaer) = 0.0
6525 end do
6527 do k=1,pver
6528 !
6529 ! liquid
6530 !
6531 tmp1l = abarli + bbarli/rel(i,k)
6532 tmp2l = 1._r8 - cbarli - dbarli*rel(i,k)
6533 tmp3l = fbarli*rel(i,k)
6534 !
6535 ! ice
6536 !
6537 tmp1i = abarii + bbarii/rei(i,k)
6538 tmp2i = 1._r8 - cbarii - dbarii*rei(i,k)
6539 tmp3i = fbarii*rei(i,k)
6541 if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
6542 tauxcl(i,k) = cliqwp(i,k)*tmp1l
6543 tauxci(i,k) = cicewp(i,k)*tmp1i
6544 else
6545 tauxcl(i,k) = 0.0
6546 tauxci(i,k) = 0.0
6547 endif
6548 !
6549 ! Do not let single scatter albedo be 1. Delta-eddington solution
6550 ! for non-conservative case has different analytic form from solution
6551 ! for conservative case, and raddedmx is written for non-conservative case.
6552 !
6553 wcl(i,k) = min(tmp2l,.999999_r8)
6554 gcl(i,k) = ebarli + tmp3l
6555 fcl(i,k) = gcl(i,k)*gcl(i,k)
6556 !
6557 wci(i,k) = min(tmp2i,.999999_r8)
6558 gci(i,k) = ebarii + tmp3i
6559 fci(i,k) = gci(i,k)*gci(i,k)
6560 !
6561 ! Set aerosol properties
6562 ! Conversion factor to adjust aerosol extinction (m2/g)
6563 !
6564 rhtrunc = rh(i,k)
6565 rhtrunc = min(rh(i,k),1._r8)
6566 ! if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX')
6567 krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1)
6568 wrh = rhtrunc * nrh - krh
6570 ! linear interpolation of optical properties between rh table points
6571 ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh
6572 ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh
6573 kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh
6574 wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh
6575 wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh
6576 wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh
6577 gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh
6578 gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh
6579 gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh
6581 tau_sul = 1.e4 * ksuli * usul(i,k)
6582 tau_sslt = 1.e4 * ksslti * usslt(i,k)
6583 tau_cphil = 1.e4 * kcphili * ucphil(i,k)
6584 tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k)
6585 tau_cb = 1.e4 * kcb(ns) * ucb(i,k)
6586 tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k)
6587 tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k)
6588 tau_bg = 1.e4 * kbg(ns) * ubg(i,k)
6590 tau_w_sul = tau_sul * wsuli
6591 tau_w_sslt = tau_sslt * wsslti
6592 tau_w_cphil = tau_cphil * wcphili
6593 tau_w_cphob = tau_cphob * wcphob(ns)
6594 tau_w_cb = tau_cb * wcb(ns)
6595 tau_w_volc = tau_volc * wvolc(ns)
6596 tau_w_dst(:) = tau_dst(:) * wdst(:,ns)
6597 tau_w_bg = tau_bg * wbg(ns)
6599 tau_w_g_sul = tau_w_sul * gsuli
6600 tau_w_g_sslt = tau_w_sslt * gsslti
6601 tau_w_g_cphil = tau_w_cphil * gcphili
6602 tau_w_g_cphob = tau_w_cphob * gcphob(ns)
6603 tau_w_g_cb = tau_w_cb * gcb(ns)
6604 tau_w_g_volc = tau_w_volc * gvolc(ns)
6605 tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns)
6606 tau_w_g_bg = tau_w_bg * gbg(ns)
6608 f_sul = gsuli * gsuli
6609 f_sslt = gsslti * gsslti
6610 f_cphil = gcphili * gcphili
6611 f_cphob = gcphob(ns) * gcphob(ns)
6612 f_cb = gcb(ns) * gcb(ns)
6613 f_volc = gvolc(ns) * gvolc(ns)
6614 f_dst(:) = gdst(:,ns) * gdst(:,ns)
6615 f_bg = gbg(ns) * gbg(ns)
6617 tau_w_f_sul = tau_w_sul * f_sul
6618 tau_w_f_bg = tau_w_bg * f_bg
6619 tau_w_f_sslt = tau_w_sslt * f_sslt
6620 tau_w_f_cphil = tau_w_cphil * f_cphil
6621 tau_w_f_cphob = tau_w_cphob * f_cphob
6622 tau_w_f_cb = tau_w_cb * f_cb
6623 tau_w_f_volc = tau_w_volc * f_volc
6624 tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:)
6625 !
6626 ! mix dust aerosol size bins
6627 ! w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere
6628 ! but calculate them anyway for future use
6629 !
6630 tau_dst_tot = sum(tau_dst)
6631 tau_w_dst_tot = sum(tau_w_dst)
6632 tau_w_g_dst_tot = sum(tau_w_g_dst)
6633 tau_w_f_dst_tot = sum(tau_w_f_dst)
6635 if (tau_dst_tot .gt. 0.0) then
6636 w_dst_tot = tau_w_dst_tot / tau_dst_tot
6637 else
6638 w_dst_tot = 0.0
6639 endif
6641 if (tau_w_dst_tot .gt. 0.0) then
6642 g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot
6643 f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot
6644 else
6645 g_dst_tot = 0.0
6646 f_dst_tot = 0.0
6647 endif
6648 !
6649 ! mix aerosols
6650 !
6651 tau_tot = tau_sul + tau_sslt &
6652 + tau_cphil + tau_cphob + tau_cb + tau_dst_tot
6653 tau_tot = tau_tot + tau_bg + tau_volc
6655 tau_w_tot = tau_w_sul + tau_w_sslt &
6656 + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot
6657 tau_w_tot = tau_w_tot + tau_w_bg + tau_w_volc
6659 tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt &
6660 + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot
6661 tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc
6663 tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt &
6664 + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot
6665 tau_w_f_tot = tau_w_f_tot + tau_w_f_bg + tau_w_f_volc
6667 if (tau_tot .gt. 0.0) then
6668 w_tot = tau_w_tot / tau_tot
6669 else
6670 w_tot = 0.0
6671 endif
6673 if (tau_w_tot .gt. 0.0) then
6674 g_tot = tau_w_g_tot / tau_w_tot
6675 f_tot = tau_w_f_tot / tau_w_tot
6676 else
6677 g_tot = 0.0
6678 f_tot = 0.0
6679 endif
6681 tauxar(i,k) = tau_tot
6682 wa(i,k) = min(w_tot, 0.999999_r8)
6683 if (g_tot.gt.1._r8) write(6,*) "g_tot > 1"
6684 if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1"
6685 ! if (g_tot.gt.1._r8) call endrun ('RADCSWMX')
6686 ! if (g_tot.lt.-1._r8) call endrun ('RADCSWMX')
6687 ga(i,k) = g_tot
6688 if (f_tot.gt.1._r8) write(6,*)"f_tot > 1"
6689 if (f_tot.lt.0._r8) write(6,*)"f_tot < 0"
6690 ! if (f_tot.gt.1._r8) call endrun ('RADCSWMX')
6691 ! if (f_tot.lt.0._r8) call endrun ('RADCSWMX')
6692 fa(i,k) = f_tot
6694 aertau(i,ns,1) = aertau(i,ns,1) + tau_sul
6695 aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt
6696 aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb
6697 aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot
6698 aertau(i,ns,5) = aertau(i,ns,5) + tau_bg
6699 aertau(i,ns,6) = aertau(i,ns,6) + tau_volc
6700 aertau(i,ns,7) = aertau(i,ns,7) + tau_tot
6702 aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul
6703 aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt
6704 aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb
6705 aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot
6706 aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg
6707 aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc
6708 aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot
6710 aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul
6711 aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt
6712 aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb
6713 aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot
6714 aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg
6715 aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc
6716 aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot
6718 aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul
6719 aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt
6720 aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb
6721 aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot
6722 aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg
6723 aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc
6724 aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot
6726 !
6727 ! End do k=1,pver
6728 !
6729 end do
6731 ! normalize aerosol optical diagnostic fields
6732 do kaer = 1, naer_groups
6734 if (aerssa(i,ns,kaer) .gt. 0.0) then ! aerssa currently holds product of tau and ssa
6735 aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer)
6736 aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer)
6737 else
6738 aerasm(i,ns,kaer) = 0.0_r8
6739 aerfwd(i,ns,kaer) = 0.0_r8
6740 end if
6742 if (aertau(i,ns,kaer) .gt. 0.0) then
6743 aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer)
6744 else
6745 aerssa(i,ns,kaer) = 0.0_r8
6746 end if
6748 end do
6751 !
6752 ! End do n=1,ndayc
6753 !
6754 end do
6756 !
6757 ! Set reflectivities for surface based on mid-point wavelength
6758 !
6759 wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns))
6760 !
6761 ! Wavelength less than 0.7 micro-meter
6762 !
6763 if (wavmid(ns) < 0.7_r8 ) then
6764 do n=1,ndayc
6765 i=idayc(n)
6766 albdir(i,ns) = asdir(i)
6767 albdif(i,ns) = asdif(i)
6768 end do
6769 !
6770 ! Wavelength greater than 0.7 micro-meter
6771 !
6772 else
6773 do n=1,ndayc
6774 i=idayc(n)
6775 albdir(i,ns) = aldir(i)
6776 albdif(i,ns) = aldif(i)
6777 end do
6778 end if
6779 trayoslp = raytau(ns)/sslp
6780 !
6781 ! Layer input properties now completely specified; compute the
6782 ! delta-Eddington solution reflectivities and transmissivities
6783 ! for each layer
6784 !
6785 call raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc , &
6786 abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , &
6787 uh2o ,uo3 ,uco2 ,uo2 , &
6788 trayoslp ,pflx ,ns , &
6789 tauxcl ,wcl ,gcl ,fcl , &
6790 tauxci ,wci ,gci ,fci , &
6791 tauxar ,wa ,ga ,fa , &
6792 rdir ,rdif ,tdir ,tdif ,explay , &
6793 rdirc ,rdifc ,tdirc ,tdifc ,explayc )
6794 !
6795 ! End spectral loop
6796 !
6797 end do
6798 !
6799 !----------------------------------------------------------------------
6800 !
6801 ! Solution for max/random cloud overlap.
6802 !
6803 ! Steps:
6804 ! (1. delta-Eddington solution for each layer (called above)
6805 !
6806 ! (2. The adding method is used to
6807 ! compute the reflectivity and transmissivity to direct and diffuse
6808 ! radiation from the top and bottom of the atmosphere for each
6809 ! cloud configuration. This calculation is based upon the
6810 ! max-random overlap assumption.
6811 !
6812 ! (3. to solve for the fluxes, combine the
6813 ! bulk properties of the atmosphere above/below the region.
6814 !
6815 ! Index calculations for steps 2-3 are performed outside spectral
6816 ! loop to avoid redundant calculations. Index calculations (with
6817 ! application of areamin & nconfgmax conditions) are performed
6818 ! first to identify the minimum subset of terms for the configurations
6819 ! satisfying the areamin & nconfgmax conditions. This minimum set is
6820 ! used to identify the corresponding minimum subset of terms in
6821 ! steps 2 and 3.
6822 !
6824 do n=1,ndayc
6825 i=idayc(n)
6827 !----------------------------------------------------------------------
6828 ! INDEX CALCULATIONS FOR MAX OVERLAP
6829 !
6830 ! The column is divided into sets of adjacent layers, called regions,
6831 ! in which the clouds are maximally overlapped. The clouds are
6832 ! randomly overlapped between different regions. The number of
6833 ! regions in a column is set by nmxrgn, and the range of pressures
6834 ! included in each region is set by pmxrgn.
6835 !
6836 ! The following calculations determine the number of unique cloud
6837 ! configurations (assuming maximum overlap), called "streams",
6838 ! within each region. Each stream consists of a vector of binary
6839 ! clouds (either 0 or 100% cloud cover). Over the depth of the region,
6840 ! each stream requires a separate calculation of radiative properties. These
6841 ! properties are generated using the adding method from
6842 ! the radiative properties for each layer calculated by raddedmx.
6843 !
6844 ! The upward and downward-propagating streams are treated
6845 ! separately.
6846 !
6847 ! We will refer to a particular configuration of binary clouds
6848 ! within a single max-overlapped region as a "stream". We will
6849 ! refer to a particular arrangement of binary clouds over the entire column
6850 ! as a "configuration".
6851 !
6852 ! This section of the code generates the following information:
6853 ! (1. nrgn : the true number of max-overlap regions (need not = nmxrgn)
6854 ! (2. nstr : the number of streams in a region (>=1)
6855 ! (3. cstr : flags for presence of clouds at each layer in each stream
6856 ! (4. wstr : the fractional horizontal area of a grid box covered
6857 ! by each stream
6858 ! (5. kx1,2 : level indices for top/bottom of each region
6859 !
6860 ! The max-overlap calculation proceeds in 3 stages:
6861 ! (1. compute layer radiative properties in raddedmx.
6862 ! (2. combine these properties between layers
6863 ! (3. combine properties to compute fluxes at each interface.
6864 !
6865 ! Most of the indexing information calculated here is used in steps 2-3
6866 ! after the call to raddedmx.
6867 !
6868 ! Initialize indices for layers to be max-overlapped
6869 !
6870 ! Loop to handle fix in totwgt=0. For original overlap config
6871 ! from npasses = 0.
6872 !
6873 npasses = 0
6874 do
6875 do irgn = 0, nmxrgn(i)
6876 kx2(irgn) = 0
6877 end do
6878 mrgn = 0
6879 !
6880 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
6881 !
6882 do irgn = 1, nmxrgn(i)
6883 !
6884 ! Calculate min/max layer indices inside region.
6885 !
6886 region_found = .false.
6887 if (kx2(irgn-1) < pver) then
6888 k1 = kx2(irgn-1)+1
6889 kx1(irgn) = k1
6890 kx2(irgn) = k1-1
6891 do k2 = pver, k1, -1
6892 if (pmid(i,k2) <= pmxrgn(i,irgn)) then
6893 kx2(irgn) = k2
6894 mrgn = mrgn+1
6895 region_found = .true.
6896 exit
6897 end if
6898 end do
6899 else
6900 exit
6901 endif
6903 if (region_found) then
6904 !
6905 ! Sort cloud areas and corresponding level indices.
6906 !
6907 nxs = 0
6908 if (cldeps > 0) then
6909 do k = k1,k2
6910 if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
6911 nxs = nxs+1
6912 ksort(nxs) = k
6913 !
6914 ! We need indices for clouds in order of largest to smallest, so
6915 ! sort 1-cld in ascending order
6916 !
6917 asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps)
6918 end if
6919 end do
6920 else
6921 do k = k1,k2
6922 if (cld(i,k) >= cldmin) then
6923 nxs = nxs+1
6924 ksort(nxs) = k
6925 !
6926 ! We need indices for clouds in order of largest to smallest, so
6927 ! sort 1-cld in ascending order
6928 !
6929 asort(nxs) = 1.0_r8-cld(i,k)
6930 end if
6931 end do
6932 endif
6933 !
6934 ! If nxs eq 1, no need to sort.
6935 ! If nxs eq 2, sort by swapping if necessary
6936 ! If nxs ge 3, sort using local sort routine
6937 !
6938 if (nxs == 2) then
6939 if (asort(2) < asort(1)) then
6940 ktmp = ksort(1)
6941 ksort(1) = ksort(2)
6942 ksort(2) = ktmp
6944 atmp = asort(1)
6945 asort(1) = asort(2)
6946 asort(2) = atmp
6947 endif
6948 else if (nxs >= 3) then
6949 call sortarray(nxs,asort,ksort)
6950 endif
6951 !
6952 ! Construct wstr, cstr, nstr for this region
6953 !
6954 cstr(k1:k2,1:nxs+1) = 0
6955 mstr = 1
6956 cld0 = 0.0_r8
6957 do l = 1, nxs
6958 if (asort(l) /= cld0) then
6959 wstr(mstr,mrgn) = asort(l) - cld0
6960 cld0 = asort(l)
6961 mstr = mstr + 1
6962 endif
6963 cstr(ksort(l),mstr:nxs+1) = 1
6964 end do
6965 nstr(mrgn) = mstr
6966 wstr(mstr,mrgn) = 1.0_r8 - cld0
6967 !
6968 ! End test of region_found = true
6969 !
6970 endif
6971 !
6972 ! End loop over regions irgn for max-overlap
6973 !
6974 end do
6975 nrgn = mrgn
6976 !
6977 ! Finish construction of cstr for additional top layer
6978 !
6979 cstr(0,1:nstr(1)) = 0
6980 !
6981 ! INDEX COMPUTATIONS FOR STEP 2-3
6982 ! This section of the code generates the following information:
6983 ! (1. totwgt step 3 total frac. area of configurations satisfying
6984 ! areamin & nconfgmax criteria
6985 ! (2. wgtv step 3 frac. area of configurations
6986 ! (3. ccon step 2 binary flag for clouds in each configuration
6987 ! (4. nconfig steps 2-3 number of configurations
6988 ! (5. nuniqu/d step 2 Number of unique cloud configurations for
6989 ! up/downwelling rad. between surface/TOA
6990 ! and level k
6991 ! (6. istrtu/d step 2 Indices into iconu/d
6992 ! (7. iconu/d step 2 Cloud configurations which are identical
6993 ! for up/downwelling rad. between surface/TOA
6994 ! and level k
6995 !
6996 ! Number of configurations (all permutations of streams in each region)
6997 !
6998 nconfigm = product(nstr(1: nrgn))
6999 !
7000 ! Construction of totwgt, wgtv, ccon, nconfig
7001 !
7002 istr(1: nrgn) = 1
7003 nconfig = 0
7004 totwgt = 0.0_r8
7005 new_term = .true.
7006 do iconfig = 1, nconfigm
7007 xwgt = 1.0_r8
7008 do mrgn = 1, nrgn
7009 xwgt = xwgt * wstr(istr(mrgn),mrgn)
7010 end do
7011 if (xwgt >= areamin) then
7012 nconfig = nconfig + 1
7013 if (nconfig <= nconfgmax) then
7014 j = nconfig
7015 ptrc(nconfig) = nconfig
7016 else
7017 nconfig = nconfgmax
7018 if (new_term) then
7019 j = findvalue(1,nconfig,wgtv,ptrc)
7020 endif
7021 if (wgtv(j) < xwgt) then
7022 totwgt = totwgt - wgtv(j)
7023 new_term = .true.
7024 else
7025 new_term = .false.
7026 endif
7027 endif
7028 if (new_term) then
7029 wgtv(j) = xwgt
7030 totwgt = totwgt + xwgt
7031 do mrgn = 1, nrgn
7032 ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn))
7033 end do
7034 endif
7035 endif
7037 mrgn = nrgn
7038 istr(mrgn) = istr(mrgn) + 1
7039 do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1)
7040 istr(mrgn) = 1
7041 mrgn = mrgn - 1
7042 istr(mrgn) = istr(mrgn) + 1
7043 end do
7044 !
7045 ! End do iconfig = 1, nconfigm
7046 !
7047 end do
7048 !
7049 ! If totwgt = 0 implement maximum overlap and make another pass
7050 ! if totwgt = 0 on this second pass then terminate.
7051 !
7052 if (totwgt > 0.) then
7053 exit
7054 else
7055 npasses = npasses + 1
7056 if (npasses >= 2 ) then
7057 write(6,*)'RADCSWMX: Maximum overlap of column ','failed'
7058 call endrun
7059 endif
7060 nmxrgn(i)=1
7061 pmxrgn(i,1)=1.0e30
7062 end if
7063 !
7064 ! End npasses = 0, do
7065 !
7066 end do
7067 !
7068 !
7069 ! Finish construction of ccon
7070 !
7071 ccon(0,:) = 0
7072 ccon(pverp,:) = 0
7073 !
7074 ! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree
7075 !
7076 nuniqd(0) = 1
7077 nuniqu(pverp) = 1
7079 istrtd(0,1) = 1
7080 istrtu(pverp,1) = 1
7082 do j = 1, nconfig
7083 icond(0,j)=j
7084 iconu(pverp,j)=j
7085 end do
7087 istrtd(0,2) = nconfig+1
7088 istrtu(pverp,2) = nconfig+1
7090 do k = 1, pverp
7091 km1 = k-1
7092 nuniq = 0
7093 istrtd(k,1) = 1
7094 do l0 = 1, nuniqd(km1)
7095 is0 = istrtd(km1,l0)
7096 is1 = istrtd(km1,l0+1)-1
7097 n0 = 0
7098 n1 = 0
7099 do isn = is0, is1
7100 j = icond(km1,isn)
7101 if (ccon(k,j) == 0) then
7102 n0 = n0 + 1
7103 ptr0(n0) = j
7104 endif
7105 if (ccon(k,j) == 1) then
7106 n1 = n1 + 1
7107 ptr1(n1) = j
7108 endif
7109 end do
7110 if (n0 > 0) then
7111 nuniq = nuniq + 1
7112 istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0
7113 icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr0(1:n0)
7114 endif
7115 if (n1 > 0) then
7116 nuniq = nuniq + 1
7117 istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1
7118 icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) = ptr1(1:n1)
7119 endif
7120 end do
7121 nuniqd(k) = nuniq
7122 end do
7124 do k = pver, 0, -1
7125 kp1 = k+1
7126 nuniq = 0
7127 istrtu(k,1) = 1
7128 do l0 = 1, nuniqu(kp1)
7129 is0 = istrtu(kp1,l0)
7130 is1 = istrtu(kp1,l0+1)-1
7131 n0 = 0
7132 n1 = 0
7133 do isn = is0, is1
7134 j = iconu(kp1,isn)
7135 if (ccon(k,j) == 0) then
7136 n0 = n0 + 1
7137 ptr0(n0) = j
7138 endif
7139 if (ccon(k,j) == 1) then
7140 n1 = n1 + 1
7141 ptr1(n1) = j
7142 endif
7143 end do
7144 if (n0 > 0) then
7145 nuniq = nuniq + 1
7146 istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0
7147 iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr0(1:n0)
7148 endif
7149 if (n1 > 0) then
7150 nuniq = nuniq + 1
7151 istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1
7152 iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1)
7153 endif
7154 end do
7155 nuniqu(k) = nuniq
7156 end do
7157 !
7158 !----------------------------------------------------------------------
7159 ! End of index calculations
7160 !----------------------------------------------------------------------
7163 !----------------------------------------------------------------------
7164 ! Start of flux calculations
7165 !----------------------------------------------------------------------
7166 !
7167 ! Initialize spectrally integrated totals:
7168 !
7169 do k=0,pver
7170 totfld(k) = 0.0_r8
7171 totfldc(k) = 0.0_r8
7172 fswup (k) = 0.0_r8
7173 fswdn (k) = 0.0_r8
7174 fswupc (k) = 0.0_r8
7175 fswdnc (k) = 0.0_r8
7176 fswdndir(k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
7177 fswdncdir(k)= 0.0_r8 ! amontornes-bcodina (2014-04-20)
7178 end do
7180 sfltot = 0.0_r8
7181 fswup (pverp) = 0.0_r8
7182 fswdn (pverp) = 0.0_r8
7183 fswupc (pverp) = 0.0_r8
7184 fswdnc (pverp) = 0.0_r8
7185 fswdndir(pverp) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
7186 fswdncdir(pverp)= 0.0_r8 ! amontornes-bcodina (2014-04-20)
7188 !
7189 ! Start spectral interval
7190 !
7191 do ns = 1,nspint
7192 wgtint = nirwgt(ns)
7193 !----------------------------------------------------------------------
7194 ! STEP 2
7195 !
7196 !
7197 ! Apply adding method to solve for radiative properties
7198 !
7199 ! First initialize the bulk properties at TOA
7200 !
7201 rdndif(0,1:nconfig) = 0.0_r8
7202 exptdn(0,1:nconfig) = 1.0_r8
7203 tdntot(0,1:nconfig) = 1.0_r8
7204 !
7205 ! Solve for properties involving downward propagation of radiation.
7206 ! The bulk properties are:
7207 !
7208 ! (1. exptdn Sol. beam dwn. trans from layers above
7209 ! (2. rdndif Ref to dif rad for layers above
7210 ! (3. tdntot Total trans for layers above
7211 !
7212 do k = 1, pverp
7213 km1 = k - 1
7214 do l0 = 1, nuniqd(km1)
7215 is0 = istrtd(km1,l0)
7216 is1 = istrtd(km1,l0+1)-1
7218 j = icond(km1,is0)
7220 xexpt = exptdn(km1,j)
7221 xrdnd = rdndif(km1,j)
7222 tdnmexp = tdntot(km1,j) - xexpt
7224 if (ccon(km1,j) == 1) then
7225 !
7226 ! If cloud in layer, use cloudy layer radiative properties
7227 !
7228 ytdnd = tdif(ns,i,km1)
7229 yrdnd = rdif(ns,i,km1)
7231 rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
7232 rdirexp = rdir(ns,i,km1)*xexpt
7234 zexpt = xexpt * explay(ns,i,km1)
7235 zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
7236 ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom
7237 else
7238 !
7239 ! If clear layer, use clear-sky layer radiative properties
7240 !
7241 ytdnd = tdifc(ns,i,km1)
7242 yrdnd = rdifc(ns,i,km1)
7244 rdenom = 1._r8/(1._r8-yrdnd*xrdnd)
7245 rdirexp = rdirc(ns,i,km1)*xexpt
7247 zexpt = xexpt * explayc(ns,i,km1)
7248 zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
7249 ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* &
7250 (tdnmexp + xrdnd*rdirexp)*rdenom
7251 endif
7253 !
7254 ! If 2 or more configurations share identical properties at a given level k,
7255 ! the properties (at level k) are computed once and copied to
7256 ! all the configurations for efficiency.
7257 !
7258 do isn = is0, is1
7259 j = icond(km1,isn)
7260 exptdn(k,j) = zexpt
7261 rdndif(k,j) = zrdnd
7262 tdntot(k,j) = ztdnt
7263 end do
7264 !
7265 ! end do l0 = 1, nuniqd(k)
7266 !
7267 end do
7268 !
7269 ! end do k = 1, pverp
7270 !
7271 end do
7272 !
7273 ! Solve for properties involving upward propagation of radiation.
7274 ! The bulk properties are:
7275 !
7276 ! (1. rupdif Ref to dif rad for layers below
7277 ! (2. rupdir Ref to dir rad for layers below
7278 !
7279 ! Specify surface boundary conditions (surface albedos)
7280 !
7281 rupdir(pverp,1:nconfig) = albdir(i,ns)
7282 rupdif(pverp,1:nconfig) = albdif(i,ns)
7284 do k = pver, 0, -1
7285 do l0 = 1, nuniqu(k)
7286 is0 = istrtu(k,l0)
7287 is1 = istrtu(k,l0+1)-1
7289 j = iconu(k,is0)
7291 xrupd = rupdif(k+1,j)
7292 xrups = rupdir(k+1,j)
7294 if (ccon(k,j) == 1) then
7295 !
7296 ! If cloud in layer, use cloudy layer radiative properties
7297 !
7298 yexpt = explay(ns,i,k)
7299 yrupd = rdif(ns,i,k)
7300 ytupd = tdif(ns,i,k)
7302 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
7303 tdnmexp = (tdir(ns,i,k)-yexpt)
7304 rdirexp = xrups*yexpt
7306 zrupd = yrupd + xrupd*(ytupd**2)*rdenom
7307 zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
7308 else
7309 !
7310 ! If clear layer, use clear-sky layer radiative properties
7311 !
7312 yexpt = explayc(ns,i,k)
7313 yrupd = rdifc(ns,i,k)
7314 ytupd = tdifc(ns,i,k)
7316 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
7317 tdnmexp = (tdirc(ns,i,k)-yexpt)
7318 rdirexp = xrups*yexpt
7320 zrupd = yrupd + xrupd*(ytupd**2)*rdenom
7321 zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
7322 endif
7324 !
7325 ! If 2 or more configurations share identical properties at a given level k,
7326 ! the properties (at level k) are computed once and copied to
7327 ! all the configurations for efficiency.
7328 !
7329 do isn = is0, is1
7330 j = iconu(k,isn)
7331 rupdif(k,j) = zrupd
7332 rupdir(k,j) = zrups
7333 end do
7334 !
7335 ! end do l0 = 1, nuniqu(k)
7336 !
7337 end do
7338 !
7339 ! end do k = pver,0,-1
7340 !
7341 end do
7342 !
7343 !----------------------------------------------------------------------
7344 !
7345 ! STEP 3
7346 !
7347 ! Compute up and down fluxes for each interface k. This requires
7348 ! adding up the contributions from all possible permutations
7349 ! of streams in all max-overlap regions, weighted by the
7350 ! product of the fractional areas of the streams in each region
7351 ! (the random overlap assumption). The adding principle has been
7352 ! used in step 2 to combine the bulk radiative properties
7353 ! above and below the interface.
7354 !
7355 do k = 0,pverp
7356 !
7357 ! Initialize the fluxes
7358 !
7359 fluxup(k)=0.0_r8
7360 fluxdn(k)=0.0_r8
7361 fluxdndir(k) = 0.0_r8 ! amontornes-bcodina (2014-04-20)
7363 do iconfig = 1, nconfig
7364 xwgt = wgtv(iconfig)
7365 xexpt = exptdn(k,iconfig)
7366 xtdnt = tdntot(k,iconfig)
7367 xrdnd = rdndif(k,iconfig)
7368 xrupd = rupdif(k,iconfig)
7369 xrups = rupdir(k,iconfig)
7370 !
7371 ! Flux computation
7372 !
7373 rdenom = 1._r8/(1._r8 - xrdnd * xrupd)
7375 fluxup(k) = fluxup(k) + xwgt * &
7376 ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom)
7377 fluxdn(k) = fluxdn(k) + xwgt * &
7378 (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom)
7379 fluxdndir(k) = fluxdndir(k) + xwgt * xexpt ! Beer's Law amontornes-bcodina (2014-04-20)
7381 !
7382 ! End do iconfig = 1, nconfig
7383 !
7384 end do
7385 !
7386 ! Normalize by total area covered by cloud configurations included
7387 ! in solution
7388 !
7389 fluxup(k)=fluxup(k) / totwgt
7390 fluxdn(k)=fluxdn(k) / totwgt
7391 fluxdndir(k)=fluxdndir(k) / totwgt ! amontornes-bcodina (2014-04-20)
7392 !
7393 ! End do k = 0,pverp
7394 !
7395 end do
7396 !
7397 ! Initialize the direct-beam flux at surface
7398 !
7399 wexptdn = 0.0_r8
7401 do iconfig = 1, nconfig
7402 wexptdn = wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig)
7403 end do
7405 wexptdn = wexptdn / totwgt
7406 !
7407 ! Monochromatic computation completed; accumulate in totals
7408 !
7409 solflx = solin(i)*frcsol(ns)*psf(ns)
7410 fsnt(i) = fsnt(i) + solflx*(fluxdn(1) - fluxup(1))
7411 fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0))
7412 fsns(i) = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp))
7413 sfltot = sfltot + solflx
7414 fswup(0) = fswup(0) + solflx*fluxup(0)
7415 fswdn(0) = fswdn(0) + solflx*fluxdn(0)
7416 fswdndir(0) = fswdndir(0) + solflx*fluxdndir(0) ! amontornes-bcodina (2014-04-20)
7417 !
7418 ! Down spectral fluxes need to be in mks; thus the .001 conversion factors
7419 !
7420 if (wavmid(ns) < 0.7_r8) then
7421 sols(i) = sols(i) + wexptdn*solflx*0.001_r8
7422 solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
7423 else
7424 soll(i) = soll(i) + wexptdn*solflx*0.001_r8
7425 solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
7426 fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0))
7427 end if
7428 fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0))
7430 do k=0,pver
7431 !
7432 ! Compute flux divergence in each layer using the interface up and down
7433 ! fluxes:
7434 !
7435 kp1 = k+1
7436 flxdiv = (fluxdn(k ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k ))
7437 totfld(k) = totfld(k) + solflx*flxdiv
7438 fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1)
7439 fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1)
7440 fswdndir(kp1) = fswdndir(kp1) + solflx*fluxdndir(kp1) ! amontornes-bcodina (2014-04-20)
7441 end do
7442 !
7443 ! Perform clear-sky calculation
7444 !
7445 exptdnc(0) = 1.0_r8
7446 rdndifc(0) = 0.0_r8
7447 tdntotc(0) = 1.0_r8
7448 rupdirc(pverp) = albdir(i,ns)
7449 rupdifc(pverp) = albdif(i,ns)
7451 do k = 1, pverp
7452 km1 = k - 1
7453 xexpt = exptdnc(km1)
7454 xrdnd = rdndifc(km1)
7455 yrdnd = rdifc(ns,i,km1)
7456 ytdnd = tdifc(ns,i,km1)
7458 exptdnc(k) = xexpt*explayc(ns,i,km1)
7460 rdenom = 1._r8/(1._r8 - yrdnd*xrdnd)
7461 rdirexp = rdirc(ns,i,km1)*xexpt
7462 tdnmexp = tdntotc(km1) - xexpt
7464 tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* &
7465 rdenom
7466 rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom
7467 end do
7469 do k=pver,0,-1
7470 xrupd = rupdifc(k+1)
7471 yexpt = explayc(ns,i,k)
7472 yrupd = rdifc(ns,i,k)
7473 ytupd = tdifc(ns,i,k)
7475 rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
7477 rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + &
7478 xrupd*(tdirc(ns,i,k)-yexpt))*rdenom
7479 rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom
7480 end do
7482 do k=0,1
7483 rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
7484 fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
7485 rdenom
7486 fluxdn(k) = exptdnc(k) + &
7487 (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* &
7488 rdenom
7489 fswupc(k) = fswupc(k) + solflx*fluxup(k)
7490 fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
7491 fswdncdir(k) = fswdncdir(k) + solflx*exptdnc(k) ! Beer's Law amontornes-bcodina (2014-04-20)
7492 end do
7493 ! k = pverp
7494 do k=2,pverp
7495 rdenom = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
7496 fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
7497 rdenom
7498 fluxdn(k) = exptdnc(k) + (tdntotc(k) - exptdnc(k) + &
7499 exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom
7500 fswupc(k) = fswupc(k) + solflx*fluxup(k)
7501 fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
7502 fswdncdir(k) = fswdncdir(k) + solflx*exptdnc(k) ! Beer's Law amontornes-bcodina (2014-04-20)
7503 end do
7505 ! For clear sky heating rate
7506 do k=0,pver
7507 kp1 = k+1
7508 flxdiv = (fluxdn(k ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k))
7509 totfldc(k) = totfldc(k) + solflx*flxdiv
7510 end do
7512 fsntc(i) = fsntc(i)+solflx*(fluxdn(1)-fluxup(1))
7513 fsntoac(i) = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0))
7514 fsnsc(i) = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp))
7515 fsdsc(i) = fsdsc(i)+solflx*(fluxdn(pverp))
7516 fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0))
7517 !
7518 ! End of clear sky calculation
7519 !
7521 !
7522 ! End of spectral interval loop
7523 !
7524 end do
7525 !
7526 ! Compute solar heating rate (J/kg/s)
7527 !
7528 do k=1,pver
7529 qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1))
7530 qrscs(i,k) = -1.E-4*gravit*totfldc(k)/(pint(i,k) - pint(i,k+1))
7531 end do
7533 ! Added downward/upward total and clear sky fluxes
7535 do k=1,pverp
7536 fsup(i,k) = fswup(k)
7537 fsupc(i,k) = fswupc(k)
7538 fsdn(i,k) = fswdn(k)
7539 fsdnc(i,k) = fswdnc(k)
7540 fsdndir(i,k) = fswdndir(k) ! amontornes-bcodina (2014-04-20)
7541 fsdncdir(i,k) = fswdncdir(k) ! amontornes-bcodina (2014-04-20)
7542 fsdndif(i,k) = fswdn(k)-fswdndir(k) ! amontornes-bcodina (2014-04-20)
7543 fsdncdif(i,k) = fswdnc(k)-fswdncdir(k) ! amontornes-bcodina (2014-04-20)
7544 end do
7546 !
7547 ! Set the downwelling flux at the surface
7548 !
7549 fsds(i) = fswdn(pverp)
7550 ! amontornes-bcodina (2014-04-20) :: Save surface direct/difuse fluxes
7551 fsdscdir(i) = fsdncdir(i,pverp) ! amontornes-bcodina (2014-04-20)
7552 fsdscdif(i) = fsdncdif(i,pverp) ! amontornes-bcodina (2014-04-20)
7553 fsdsdir(i) = fsdndir(i,pverp) ! amontornes-bcodina (2014-04-20)
7554 fsdsdif(i) = fsdndif(i,pverp) ! amontornes-bcodina (2014-04-20)
7555 !
7556 ! End do n=1,ndayc
7557 !
7558 end do
7560 ! write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk
7562 return
7563 end subroutine radcswmx
7565 subroutine raddedmx(pver, pverp, pcols, coszrs ,ndayc ,idayc ,abh2o , &
7566 abo3 ,abco2 ,abo2 ,uh2o ,uo3 , &
7567 uco2 ,uo2 ,trayoslp,pflx ,ns , &
7568 tauxcl ,wcl ,gcl ,fcl ,tauxci , &
7569 wci ,gci ,fci ,tauxar ,wa , &
7570 ga ,fa ,rdir ,rdif ,tdir , &
7571 tdif ,explay ,rdirc ,rdifc ,tdirc , &
7572 tdifc ,explayc )
7573 !-----------------------------------------------------------------------
7574 !
7575 ! Purpose:
7576 ! Computes layer reflectivities and transmissivities, from the top down
7577 ! to the surface using the delta-Eddington solutions for each layer
7578 !
7579 ! Method:
7580 ! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington
7581 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
7582 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
7583 !
7584 ! Modified for maximum/random cloud overlap by Bill Collins and John
7585 ! Truesdale
7586 !
7587 ! Author: Bill Collins
7588 !
7589 !-----------------------------------------------------------------------
7590 ! use shr_kind_mod, only: r8 => shr_kind_r8
7591 ! use ppgrid
7593 implicit none
7595 integer nspint ! Num of spctrl intervals across solar spectrum
7597 parameter ( nspint = 19 )
7598 !
7599 ! Minimum total transmission below which no layer computation are done:
7600 !
7601 real(r8) trmin ! Minimum total transmission allowed
7602 real(r8) wray ! Rayleigh single scatter albedo
7603 real(r8) gray ! Rayleigh asymetry parameter
7604 real(r8) fray ! Rayleigh forward scattered fraction
7606 parameter (trmin = 1.e-3)
7607 parameter (wray = 0.999999)
7608 parameter (gray = 0.0)
7609 parameter (fray = 0.1)
7610 !
7611 !------------------------------Arguments--------------------------------
7612 !
7613 ! Input arguments
7614 !
7615 integer, intent(in) :: pver, pverp, pcols
7616 real(r8), intent(in) :: coszrs(pcols) ! Cosine zenith angle
7617 real(r8), intent(in) :: trayoslp ! Tray/sslp
7618 real(r8), intent(in) :: pflx(pcols,0:pverp) ! Interface pressure
7619 real(r8), intent(in) :: abh2o ! Absorption coefficiant for h2o
7620 real(r8), intent(in) :: abo3 ! Absorption coefficiant for o3
7621 real(r8), intent(in) :: abco2 ! Absorption coefficiant for co2
7622 real(r8), intent(in) :: abo2 ! Absorption coefficiant for o2
7623 real(r8), intent(in) :: uh2o(pcols,0:pver) ! Layer absorber amount of h2o
7624 real(r8), intent(in) :: uo3(pcols,0:pver) ! Layer absorber amount of o3
7625 real(r8), intent(in) :: uco2(pcols,0:pver) ! Layer absorber amount of co2
7626 real(r8), intent(in) :: uo2(pcols,0:pver) ! Layer absorber amount of o2
7627 real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid)
7628 real(r8), intent(in) :: wcl(pcols,0:pver) ! Cloud single scattering albedo (liquid)
7629 real(r8), intent(in) :: gcl(pcols,0:pver) ! Cloud asymmetry parameter (liquid)
7630 real(r8), intent(in) :: fcl(pcols,0:pver) ! Cloud forward scattered fraction (liquid)
7631 real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice)
7632 real(r8), intent(in) :: wci(pcols,0:pver) ! Cloud single scattering albedo (ice)
7633 real(r8), intent(in) :: gci(pcols,0:pver) ! Cloud asymmetry parameter (ice)
7634 real(r8), intent(in) :: fci(pcols,0:pver) ! Cloud forward scattered fraction (ice)
7635 real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth
7636 real(r8), intent(in) :: wa(pcols,0:pver) ! Aerosol single scattering albedo
7637 real(r8), intent(in) :: ga(pcols,0:pver) ! Aerosol asymmetry parameter
7638 real(r8), intent(in) :: fa(pcols,0:pver) ! Aerosol forward scattered fraction
7640 integer, intent(in) :: ndayc ! Number of daylight columns
7641 integer, intent(in) :: idayc(pcols) ! Daylight column indices
7642 integer, intent(in) :: ns ! Index of spectral interval
7643 !
7644 ! Input/Output arguments
7645 !
7646 ! Following variables are defined for each layer; 0 refers to extra
7647 ! layer above top of model:
7648 !
7649 real(r8), intent(inout) :: rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
7650 real(r8), intent(inout) :: rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
7651 real(r8), intent(inout) :: tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
7652 real(r8), intent(inout) :: tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
7653 real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer
7654 !
7655 ! Corresponding quantities for clear-skies
7656 !
7657 real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver) ! Clear layer reflec. to direct rad
7658 real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver) ! Clear layer reflec. to diffuse rad
7659 real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver) ! Clear layer trans. to direct rad
7660 real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver) ! Clear layer trans. to diffuse rad
7661 real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer
7662 !
7663 !---------------------------Local variables-----------------------------
7664 !
7665 integer i ! Column indices
7666 integer k ! Level index
7667 integer nn ! Index of column loops (max=ndayc)
7669 real(r8) taugab(pcols) ! Layer total gas absorption optical depth
7670 real(r8) tauray(pcols) ! Layer rayleigh optical depth
7671 real(r8) taucsc ! Layer cloud scattering optical depth
7672 real(r8) tautot ! Total layer optical depth
7673 real(r8) wtot ! Total layer single scatter albedo
7674 real(r8) gtot ! Total layer asymmetry parameter
7675 real(r8) ftot ! Total layer forward scatter fraction
7676 real(r8) wtau ! rayleigh layer scattering optical depth
7677 real(r8) wt ! layer total single scattering albedo
7678 real(r8) ts ! layer scaled extinction optical depth
7679 real(r8) ws ! layer scaled single scattering albedo
7680 real(r8) gs ! layer scaled asymmetry parameter
7681 !
7682 !---------------------------Statement functions-------------------------
7683 !
7684 ! Statement functions and other local variables
7685 !
7686 real(r8) alpha ! Term in direct reflect and transmissivity
7687 real(r8) gamma ! Term in direct reflect and transmissivity
7688 real(r8) el ! Term in alpha,gamma,n,u
7689 real(r8) taus ! Scaled extinction optical depth
7690 real(r8) omgs ! Scaled single particle scattering albedo
7691 real(r8) asys ! Scaled asymmetry parameter
7692 real(r8) u ! Term in diffuse reflect and
7693 ! transmissivity
7694 real(r8) n ! Term in diffuse reflect and
7695 ! transmissivity
7696 real(r8) lm ! Temporary for el
7697 real(r8) ne ! Temporary for n
7698 real(r8) w ! Dummy argument for statement function
7699 real(r8) uu ! Dummy argument for statement function
7700 real(r8) g ! Dummy argument for statement function
7701 real(r8) e ! Dummy argument for statement function
7702 real(r8) f ! Dummy argument for statement function
7703 real(r8) t ! Dummy argument for statement function
7704 real(r8) et ! Dummy argument for statement function
7705 !
7706 ! Intermediate terms for delta-eddington solution
7707 !
7708 real(r8) alp ! Temporary for alpha
7709 real(r8) gam ! Temporary for gamma
7710 real(r8) ue ! Temporary for u
7711 real(r8) arg ! Exponential argument
7712 real(r8) extins ! Extinction
7713 real(r8) amg ! Alp - gam
7714 real(r8) apg ! Alp + gam
7715 !
7716 alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu))
7717 gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu))
7718 el(w,g) = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g))
7719 taus(w,f,t) = (1._r8 - w*f)*t
7720 omgs(w,f) = (1._r8 - f)*w/(1._r8 - w*f)
7721 asys(g,f) = (g - f)/(1._r8 - f)
7722 u(w,g,e) = 1.5_r8*(1._r8 - w*g)/e
7723 n(uu,et) = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et)
7724 !
7725 !-----------------------------------------------------------------------
7726 !
7727 ! Compute layer radiative properties
7728 !
7729 ! Compute radiative properties (reflectivity and transmissivity for
7730 ! direct and diffuse radiation incident from above, under clear
7731 ! and cloudy conditions) and transmission of direct radiation
7732 ! (under clear and cloudy conditions) for each layer.
7733 !
7734 do k=0,pver
7735 do nn=1,ndayc
7736 i=idayc(nn)
7737 tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k))
7738 taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k)
7739 tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k)
7740 taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k)
7741 wtau = wray*tauray(i)
7742 wt = wtau + taucsc
7743 wtot = wt/tautot
7744 gtot = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) &
7745 + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt
7746 ftot = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) &
7747 + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt
7748 ts = taus(wtot,ftot,tautot)
7749 ws = omgs(wtot,ftot)
7750 gs = asys(gtot,ftot)
7751 lm = el(ws,gs)
7752 alp = alpha(ws,coszrs(i),gs,lm)
7753 gam = gamma(ws,coszrs(i),gs,lm)
7754 ue = u(ws,gs,lm)
7755 !
7756 ! Limit argument of exponential to 25, in case lm very large:
7757 !
7758 arg = min(lm*ts,25._r8)
7759 extins = exp(-arg)
7760 ne = n(ue,extins)
7761 rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
7762 tdif(ns,i,k) = 4._r8*ue/ne
7763 !
7764 ! Limit argument of exponential to 25, in case coszrs is very small:
7765 !
7766 arg = min(ts/coszrs(i),25._r8)
7767 explay(ns,i,k) = exp(-arg)
7768 apg = alp + gam
7769 amg = alp - gam
7770 rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k)
7771 tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k)
7772 !
7773 ! Under rare conditions, reflectivies and transmissivities can be
7774 ! negative; zero out any negative values
7775 !
7776 rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8)
7777 tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8)
7778 rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8)
7779 tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8)
7780 !
7781 ! Clear-sky calculation
7782 !
7783 if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then
7785 rdirc(ns,i,k) = rdir(ns,i,k)
7786 tdirc(ns,i,k) = tdir(ns,i,k)
7787 rdifc(ns,i,k) = rdif(ns,i,k)
7788 tdifc(ns,i,k) = tdif(ns,i,k)
7789 explayc(ns,i,k) = explay(ns,i,k)
7790 else
7791 tautot = tauray(i) + taugab(i) + tauxar(i,k)
7792 taucsc = tauxar(i,k)*wa(i,k)
7793 !
7794 ! wtau already computed for all-sky
7795 !
7796 wt = wtau + taucsc
7797 wtot = wt/tautot
7798 gtot = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt
7799 ftot = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt
7800 ts = taus(wtot,ftot,tautot)
7801 ws = omgs(wtot,ftot)
7802 gs = asys(gtot,ftot)
7803 lm = el(ws,gs)
7804 alp = alpha(ws,coszrs(i),gs,lm)
7805 gam = gamma(ws,coszrs(i),gs,lm)
7806 ue = u(ws,gs,lm)
7807 !
7808 ! Limit argument of exponential to 25, in case lm very large:
7809 !
7810 arg = min(lm*ts,25._r8)
7811 extins = exp(-arg)
7812 ne = n(ue,extins)
7813 rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
7814 tdifc(ns,i,k) = 4._r8*ue/ne
7815 !
7816 ! Limit argument of exponential to 25, in case coszrs is very small:
7817 !
7818 arg = min(ts/coszrs(i),25._r8)
7819 explayc(ns,i,k) = exp(-arg)
7820 apg = alp + gam
7821 amg = alp - gam
7822 rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ &
7823 apg*rdifc(ns,i,k)
7824 tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* &
7825 explayc(ns,i,k)
7826 !
7827 ! Under rare conditions, reflectivies and transmissivities can be
7828 ! negative; zero out any negative values
7829 !
7830 rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8)
7831 tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8)
7832 rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8)
7833 tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8)
7834 end if
7835 end do
7836 end do
7838 return
7839 end subroutine raddedmx
7841 subroutine radinp(lchnk ,ncol , pcols, pver, pverp, &
7842 pmid ,pint ,o3vmr , pmidrd ,&
7843 pintrd ,eccf ,o3mmr )
7844 !-----------------------------------------------------------------------
7845 !
7846 ! Purpose:
7847 ! Set latitude and time dependent arrays for input to solar
7848 ! and longwave radiation.
7849 ! Convert model pressures to cgs, and compute ozone mixing ratio, needed for
7850 ! the solar radiation.
7851 !
7852 ! Method:
7853 ! <Describe the algorithm(s) used in the routine.>
7854 ! <Also include any applicable external references.>
7855 !
7856 ! Author: CCM1, CMS Contact J. Kiehl
7857 !
7858 !-----------------------------------------------------------------------
7859 ! use shr_kind_mod, only: r8 => shr_kind_r8
7860 ! use ppgrid
7861 ! use time_manager, only: get_curr_calday
7863 implicit none
7865 !------------------------------Arguments--------------------------------
7866 !
7867 ! Input arguments
7868 !
7869 integer, intent(in) :: lchnk ! chunk identifier
7870 integer, intent(in) :: pcols, pver, pverp
7871 integer, intent(in) :: ncol ! number of atmospheric columns
7873 real(r8), intent(in) :: pmid(pcols,pver) ! Pressure at model mid-levels (pascals)
7874 real(r8), intent(in) :: pint(pcols,pverp) ! Pressure at model interfaces (pascals)
7875 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
7876 !
7877 ! Output arguments
7878 !
7879 real(r8), intent(out) :: pmidrd(pcols,pver) ! Pressure at mid-levels (dynes/cm*2)
7880 real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2)
7881 real(r8), intent(out) :: eccf ! Earth-sun distance factor
7882 real(r8), intent(out) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
7884 !
7885 !---------------------------Local variables-----------------------------
7886 !
7887 integer i ! Longitude loop index
7888 integer k ! Vertical loop index
7890 real(r8) :: calday ! current calendar day
7891 real(r8) vmmr ! Ozone volume mixing ratio
7892 real(r8) delta ! Solar declination angle
7894 !
7895 !-----------------------------------------------------------------------
7896 !
7897 ! calday = get_curr_calday()
7898 eccf = 1. ! declared intent(out) so fill a value (not used in WRF)
7899 ! call shr_orb_decl (calday ,eccen ,mvelpp ,lambm0 ,obliqr , &
7900 ! delta ,eccf)
7902 !
7903 ! Convert pressure from pascals to dynes/cm2
7904 !
7905 do k=1,pver
7906 do i=1,ncol
7907 pmidrd(i,k) = pmid(i,k)*10.0
7908 pintrd(i,k) = pint(i,k)*10.0
7909 end do
7910 end do
7911 do i=1,ncol
7912 pintrd(i,pverp) = pint(i,pverp)*10.0
7913 end do
7914 !
7915 ! Convert ozone volume mixing ratio to mass mixing ratio:
7916 !
7917 vmmr = amo/amd
7918 do k=1,pver
7919 do i=1,ncol
7920 o3mmr(i,k) = vmmr*o3vmr(i,k)
7921 end do
7922 end do
7923 !
7924 return
7925 end subroutine radinp
7926 subroutine radoz2(lchnk ,ncol ,pcols, pver, pverp, o3vmr ,pint ,plol ,plos, ntoplw )
7927 !-----------------------------------------------------------------------
7928 !
7929 ! Purpose:
7930 ! Computes the path length integrals to the model interfaces given the
7931 ! ozone volume mixing ratio
7932 !
7933 ! Method:
7934 ! <Describe the algorithm(s) used in the routine.>
7935 ! <Also include any applicable external references.>
7936 !
7937 ! Author: CCM1, CMS Contact J. Kiehl
7938 !
7939 !-----------------------------------------------------------------------
7940 ! use shr_kind_mod, only: r8 => shr_kind_r8
7941 ! use ppgrid
7942 ! use comozp
7944 implicit none
7945 !------------------------------Input arguments--------------------------
7946 !
7947 integer, intent(in) :: lchnk ! chunk identifier
7948 integer, intent(in) :: ncol ! number of atmospheric columns
7949 integer, intent(in) :: pcols, pver, pverp
7951 real(r8), intent(in) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
7952 real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures
7954 integer, intent(in) :: ntoplw ! topmost level/layer longwave is solved for
7956 !
7957 !----------------------------Output arguments---------------------------
7958 !
7959 real(r8), intent(out) :: plol(pcols,pverp) ! Ozone prs weighted path length (cm)
7960 real(r8), intent(out) :: plos(pcols,pverp) ! Ozone path length (cm)
7962 !
7963 !---------------------------Local workspace-----------------------------
7964 !
7965 integer i ! longitude index
7966 integer k ! level index
7967 !
7968 !-----------------------------------------------------------------------
7969 !
7970 ! Evaluate the ozone path length integrals to interfaces;
7971 ! factors of .1 and .01 to convert pressures from cgs to mks:
7972 !
7973 do i=1,ncol
7974 plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw)
7975 plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw)
7976 end do
7977 do k=ntoplw+1,pverp
7978 do i=1,ncol
7979 plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1))
7980 plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* &
7981 (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1))
7982 end do
7983 end do
7984 !
7985 return
7986 end subroutine radoz2
7989 subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr)
7990 !-----------------------------------------------------------------------
7991 !
7992 ! Purpose: Interpolate ozone from current time-interpolated values to model levels
7993 !
7994 ! Method: Use pressure values to determine interpolation levels
7995 !
7996 ! Author: Bruce Briegleb
7997 !
7998 !--------------------------------------------------------------------------
7999 ! use shr_kind_mod, only: r8 => shr_kind_r8
8000 ! use ppgrid
8001 ! use phys_grid, only: get_lat_all_p, get_lon_all_p
8002 ! use comozp
8003 ! use abortutils, only: endrun
8004 !--------------------------------------------------------------------------
8005 implicit none
8006 !--------------------------------------------------------------------------
8007 !
8008 ! Arguments
8009 !
8010 integer, intent(in) :: lchnk ! chunk identifier
8011 integer, intent(in) :: pcols, pver
8012 integer, intent(in) :: ncol ! number of atmospheric columns
8013 integer, intent(in) :: levsiz ! number of ozone layers
8015 real(r8), intent(in) :: pmid(pcols,pver) ! level pressures (mks)
8016 real(r8), intent(in) :: pin(levsiz) ! ozone data level pressures (mks)
8017 real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio
8019 real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
8020 !
8021 ! local storage
8022 !
8023 integer i ! longitude index
8024 integer k, kk, kkstart ! level indices
8025 integer kupper(pcols) ! Level indices for interpolation
8026 integer kount ! Counter
8027 integer lats(pcols) ! latitude indices
8028 integer lons(pcols) ! latitude indices
8030 real(r8) dpu ! upper level pressure difference
8031 real(r8) dpl ! lower level pressure difference
8032 !
8033 ! Initialize latitude indices
8034 !
8035 ! call get_lat_all_p(lchnk, ncol, lats)
8036 ! call get_lon_all_p(lchnk, ncol, lons)
8037 !
8038 ! Initialize index array
8039 !
8040 do i=1,ncol
8041 kupper(i) = 1
8042 end do
8044 do k=1,pver
8045 !
8046 ! Top level we need to start looking is the top level for the previous k
8047 ! for all longitude points
8048 !
8049 kkstart = levsiz
8050 do i=1,ncol
8051 kkstart = min0(kkstart,kupper(i))
8052 end do
8053 kount = 0
8054 !
8055 ! Store level indices for interpolation
8056 !
8057 do kk=kkstart,levsiz-1
8058 do i=1,ncol
8059 if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then
8060 kupper(i) = kk
8061 kount = kount + 1
8062 end if
8063 end do
8064 !
8065 ! If all indices for this level have been found, do the interpolation and
8066 ! go to the next level
8067 !
8068 if (kount.eq.ncol) then
8069 do i=1,ncol
8070 dpu = pmid(i,k) - pin(kupper(i))
8071 dpl = pin(kupper(i)+1) - pmid(i,k)
8072 o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
8073 ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
8074 end do
8075 goto 35
8076 end if
8077 end do
8078 !
8079 ! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
8080 ! must extrapolate from the bottom or top ozone data level for at least some
8081 ! of the longitude points.
8082 !
8083 do i=1,ncol
8084 if (pmid(i,k) .lt. pin(1)) then
8085 o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1)
8086 else if (pmid(i,k) .gt. pin(levsiz)) then
8087 o3vmr(i,k) = ozmix(i,levsiz)
8088 else
8089 dpu = pmid(i,k) - pin(kupper(i))
8090 dpl = pin(kupper(i)+1) - pmid(i,k)
8091 o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
8092 ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
8093 end if
8094 end do
8096 if (kount.gt.ncol) then
8097 call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected')
8098 end if
8099 35 continue
8100 end do
8102 return
8103 end subroutine radozn
8106 #endif
8108 end MODULE module_ra_cam