| blob | 5a3e0d20198092453fa15a8c6a131e6529f9c4dc |
1 MODULE module_aerosols_soa_vbs_het
2 !
3 ! 10/12/2011: This module is a modified version of the "module_aerosols_sorgam.F". The sorgam subroutine
4 ! has been replaced by a new SOA scheme based on the Volatiliry Basis Set (VBS) approach, recent smog chamber yields
5 ! and multi-generational VOC oxidation mechanism (aging) for SOA formation. The SOA_VBS code has been
6 ! developed by Ravan Ahmadov (ravan.ahmadov@noaa.gov) and Stuart McKeen (Stuart.A.McKeen@noaa.gov) at NOAA/ESRL/CSD.
7 ! This module has been coupled to the modified version of RACM_ESRL_KPP gas chemistry mechanism. Major modifications to the gas
8 ! gas chemistry are inclusion of Sesquiterpenes and separation of MBO from OLI.
9 ! Unlike MOSAIC_VBS this option is for modal approach - MADE aerosol scheme
10 !
11 ! Some references for the SOA_VBS scheme:
12 ! 1) Ahmadov R., McKeen S.A., Robinson A.L., Bahreini R., Middlebrook A., deGouw J., Meagher J., Hsie E.-Y.,
13 ! Edgerton E., Shaw S., Trainer M. (2012), A volatility basis set model for summertime secondary organic aerosols
14 ! over the eastern U.S. in 2006. J. Geophys. Res.,117, D06301, doi:10.1029/2011JD016831.
15 ! 2) Murphy, B. N. and S. N. Pandis (2009). "Simulating the Formation of Semivolatile Primary and Secondary Organic Aerosol
16 ! in a Regional Chemical Transport Model." Environmental Science & Technology 43(13): 4722-4728.
17 ! 3) Donahue, N. M., A. L. Robinson, et al. (2006). "Coupled partitioning, dilution, and chemical aging of semivolatile
18 ! organics." Environmental Science & Technology 40(8): 2635-2643.
19 !
20 ! A reference for the MADE aerosol parameterization:
21 ! Ackermann, I. J., H. Hass, M. Memmesheimer, A. Ebel, F. S. Binkowski, and U. Shankar (1998),
22 ! Modal aerosol dynamics model for Europe: Development and first applications, Atmos. Environ., 32(17), 2981-2999.
23 !
24 !!WARNING! The deposition of organic condensable vapours (cvasoa* and cvbsoa*) are highly uncertain due to lack of observations.
25 ! Currently this process is parameterized using modeled dry deposition velocities of HNO3 (multiplied by "depo_fact" for OCVs).
26 ! Paper by Ahmadov et al. (2012) desribes this approach. The default value for "depo_fact" in WRF-CHEM is 0.25.
27 ! A user can set a different value for "depo_fact" in namelist.input.
28 !
29 !!WARNING! Another uncertainty is wet removal of OCVs! This is neglected in the current version of the WRF-CHEM code.
30 !
31 ! 30/06/2014: Modified by Paolo Tuccella
32 ! The module has been modified in order to include the aqueous phase
33 ! 10/10/2022: Changed so only option 100 calls this module, Jordan Schnell
34 !
35 USE module_state_description
36 ! USE module_data_radm2
37 USE module_data_soa_vbs_het
38 ! USE module_radm
40 IMPLICIT NONE
41 #define cw_species_are_in_registry
43 CONTAINS
45 SUBROUTINE soa_vbs_het_driver ( id,ktau,dtstep,t_phy,moist,aerwrf,p8w, &
46 t8w,alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
47 !liqy
48 gamn2o5,cn2o5,kn2o5,yclno2,snu,sac, &
49 !liqy - 20150319
50 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
51 vcsulf_old, &
52 vdrog3, &
53 kemit,brch_ratio,do_isorropia,do_n2o5het, &
54 ids,ide, jds,jde, kds,kde, &
55 ims,ime, jms,jme, kms,kme, &
56 its,ite, jts,jte, kts,kte )
58 ! USE module_configure, only: grid_config_rec_type
59 ! TYPE (grid_config_rec_type), INTENT (in) :: config_flags
61 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
62 ims,ime, jms,jme, kms,kme, &
63 its,ite, jts,jte, kts,kte, &
64 kemit, id, ktau
66 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
67 INTENT(IN ) :: moist
69 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
70 INTENT(INOUT ) :: chem
71 !
72 ! following are aerosol arrays that are not advected
73 !
74 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
75 INTENT(INOUT ) :: &
76 !liqy
77 gamn2o5,cn2o5,kn2o5,yclno2,snu,sac, &
78 !liqy - 20150319
79 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
81 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
82 INTENT(INOUT ) :: brch_ratio
84 ! cvasoa1,cvasoa2, &
85 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4
87 REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog_vbs), &
88 INTENT(IN ) :: VDROG3
89 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
90 INTENT(IN ) :: t_phy, &
91 alt, &
92 p_phy, &
93 dz8w, &
94 rh, & ! fractional relative humidity
95 z, &
96 t8w,p8w,z_at_w , &
97 aerwrf , &
98 rho_phy
99 REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , &
100 INTENT(IN ) :: vcsulf_old
101 REAL, INTENT(IN ) :: dtstep
102 LOGICAL, INTENT(IN ) :: do_isorropia,do_n2o5het
104 REAL drog_in(ldrog_vbs) ! anthropogenic AND biogenic organic aerosol precursors [ug m**-3 s**-1]
106 ! REAL condvap_in(lspcv) ! condensable vapors [ug m**-3]
107 REAL, PARAMETER :: rgas=8.314510
108 REAL convfac,convfac2
110 !...BLKSIZE set to one in column model ciarev02
111 INTEGER, PARAMETER :: blksize=1
113 !...number of aerosol species
114 ! number of species (gas + aerosol)
115 INTEGER nspcsda
116 PARAMETER (nspcsda=l1ae) !bs
117 ! (internal aerosol dynamics)
118 !bs # of anth. cond. vapors in SOA_VBS
119 INTEGER nacv
120 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
121 !bs total # of cond. vapors in SOA_VBS
122 INTEGER ncv
123 PARAMETER (ncv=lspcv) !bs
124 !bs total # of cond. vapors in CTM
125 REAL cblk(blksize,nspcsda) ! main array of variables
126 ! particles [ug/m^3/s]
127 REAL soilrat_in
128 ! emission rate of soil derived coars
129 ! input HNO3 to CBLK [ug/m^3]
130 REAL nitrate_in
131 ! input NH3 to CBLK [ug/m^3]
132 REAL nh3_in
133 ! input SO4 vapor [ug/m^3]
134 REAL hcl_in
136 REAL vsulf_in
138 REAL so4rat_in
139 ! input SO4 formation[ug/m^3/sec]
140 REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
141 ! Emission rate of i-mode EC [ug m**-3 s**-1]
142 REAL eeci_in
143 ! Emission rate of j-mode EC [ug m**-3 s**-1]
144 REAL eecj_in
145 ! Emission rate of j-mode org. aerosol [ug m**-
146 REAL eorgi_in
148 REAL eorgj_in ! Emission rate of j-mode org. aerosol [ug m**-
149 REAL pres ! pressure in cb
150 REAL temp ! temperature in K
151 ! REAL relhum ! rel. humidity (0,1)
152 REAL brrto
154 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
156 !...molecular weights ciarev02
157 ! these molecular weights aren't used at all
159 ! molecular weight for SO4
160 REAL mwso4
161 PARAMETER (mwso4=96.0576)
163 ! molecular weight for HNO3
164 REAL mwhno3
165 PARAMETER (mwhno3=63.01287)
167 ! molecular weight for NH3
168 REAL mwnh3
169 PARAMETER (mwnh3=17.03061)
171 ! molecular weight for HCL
172 REAL mwhcl
173 PARAMETER (mwhcl=36.46100)
175 !bs molecular weight for Elemental Carbon
176 REAL mwec
177 PARAMETER (mwec=12.0)
178 !liqy
179 REAL mwn2o5
180 PARAMETER (mwn2o5=108.009)
182 REAL mwclno2
183 PARAMETER (mwclno2=81.458)
184 !liqy-20140905
185 ! they aren't used
186 !!rs molecular weight
187 ! REAL mwaro1
188 ! PARAMETER (mwaro1=150.0)
189 !
190 !!rs molecular weight
191 ! REAL mwaro2
192 ! PARAMETER (mwaro2=150.0)
193 !
194 !!rs molecular weight
195 ! REAL mwalk1
196 ! PARAMETER (mwalk1=140.0)
197 !
198 !!rs molecular weight
199 ! REAL mwalk2
200 ! PARAMETER (mwalk2=140.0)
201 !
202 !!rs molecular weight
203 ! REAL mwole1
204 ! PARAMETER (mwole1=140.0)
205 !
206 !!rs molecular weight
207 ! REAL mwapi1
208 ! PARAMETER (mwapi1=200.0)
209 !
210 !!rs molecular weight
211 ! REAL mwapi2
212 ! PARAMETER (mwapi2=200.0)
213 !
214 !!rs molecular weight
215 ! REAL mwlim1
216 ! PARAMETER (mwlim1=200.0)
217 !
218 !!rs molecular weight
219 ! REAL mwlim2
220 ! PARAMETER (mwlim2=200.0)
222 INTEGER :: i,j,k,l,debug_level
223 ! convert advected aerosol variables to ug/m3 from mixing ratio
224 ! they will be converted back at the end of this driver
225 !
226 do l=p_so4aj,num_chem
227 do j=jts,jte
228 do k=kts,kte
229 do i=its,ite
230 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j))
231 enddo
232 enddo
233 enddo
234 enddo
236 ! Use RH from phys/???
237 do 100 j=jts,jte
238 do 100 i=its,ite
239 debug_level=0
240 ! do k=kts,kte
241 ! t(k) = t_phy(i,k,j)
242 ! p(k) = .001*p_phy(i,k,j)
243 ! rh0(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / &
244 ! (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
245 ! (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) )
246 ! rh0(k)=max(.1,0.01*rh0(k))
247 ! enddo
249 do k=kts,kte
251 ! added here
252 t(k) = t_phy(i,k,j)
253 p(k) = .001*p_phy(i,k,j)
254 rh0(k) = rh(i,k,j)
256 ! IF ( rh0(k)<0.1 .OR. rh0(k)>0.95 ) THEN
257 ! CALL wrf_error_fatal ( 'rh0 is out of the permissible range' )
258 ! ENDIF
260 cblk=0.
262 ! do l=1,ldrog
263 ! drog_in(l)=0.
264 ! enddo
266 ! do l=1,lspcv
267 ! condvap_in(l)=0.
268 ! enddo
270 convfac = p(k)/rgas/t(k)*1000.
271 so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
272 soilrat_in = 0.
273 nitrate_in = max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
274 nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
275 !liqy
276 !uncomment hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
277 hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
278 !comment hcl_in = 0.
279 ! hcl_in = 0.
280 cblk(1,vn2o5) = max(epsilc,chem(i,k,j,p_n2o5)*convfac*mwn2o5)
281 cblk(1,vclno2) =max(epsilc,chem(i,k,j,p_clno2)*convfac*mwclno2)
282 !liqy-20140905
283 vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
285 ! * organic aerosol precursors DeltaROG and SOA production
286 drog_in(PALK4) = VDROG3(i,k,j,PALK4)
287 drog_in(PALK5) = VDROG3(i,k,j,PALK5)
288 drog_in(POLE1) = VDROG3(i,k,j,POLE1)
289 drog_in(POLE2) = VDROG3(i,k,j,POLE2)
290 drog_in(PARO1) = VDROG3(i,k,j,PARO1)
291 drog_in(PARO2) = VDROG3(i,k,j,PARO2)
292 drog_in(PISOP) = VDROG3(i,k,j,PISOP)
293 drog_in(PTERP) = VDROG3(i,k,j,PTERP)
294 drog_in(PSESQ) = VDROG3(i,k,j,PSESQ)
295 drog_in(PBRCH) = VDROG3(i,k,j,PBRCH)
297 cblk(1,VASOA1J) = chem(i,k,j,p_asoa1j)
298 cblk(1,VASOA1I) = chem(i,k,j,p_asoa1i)
299 cblk(1,VASOA2J) = chem(i,k,j,p_asoa2j)
300 cblk(1,VASOA2I) = chem(i,k,j,p_asoa2i)
301 cblk(1,VASOA3J) = chem(i,k,j,p_asoa3j)
302 cblk(1,VASOA3I) = chem(i,k,j,p_asoa3i)
303 cblk(1,VASOA4J) = chem(i,k,j,p_asoa4j)
304 cblk(1,VASOA4I) = chem(i,k,j,p_asoa4i)
306 cblk(1,VBSOA1J) = chem(i,k,j,p_bsoa1j)
307 cblk(1,VBSOA1I) = chem(i,k,j,p_bsoa1i)
308 cblk(1,VBSOA2J) = chem(i,k,j,p_bsoa2j)
309 cblk(1,VBSOA2I) = chem(i,k,j,p_bsoa2i)
310 cblk(1,VBSOA3J) = chem(i,k,j,p_bsoa3j)
311 cblk(1,VBSOA3I) = chem(i,k,j,p_bsoa3i)
312 cblk(1,VBSOA4J) = chem(i,k,j,p_bsoa4j)
313 cblk(1,VBSOA4I) = chem(i,k,j,p_bsoa4i)
315 ! Comment out the old code
316 ! condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
317 ! condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
318 ! condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
319 ! condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
320 ! cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j)
321 ! cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i)
322 ! cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j)
323 ! cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i)
324 ! cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j)
325 ! cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i)
326 ! cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j)
327 ! cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i)
328 ! cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j)
329 ! cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i)
330 ! cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j)
331 ! cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i)
332 ! cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j)
333 ! cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i)
334 ! cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j)
335 ! cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i)
337 cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj)
338 cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai)
339 cblk(1,VECJ ) = chem(i,k,j,p_ecj)
340 cblk(1,VECI ) = chem(i,k,j,p_eci)
341 cblk(1,VP25AJ ) = chem(i,k,j,p_p25j)
342 cblk(1,VP25AI ) = chem(i,k,j,p_p25i)
343 cblk(1,VANTHA ) = chem(i,k,j,p_antha)
344 cblk(1,VSEAS ) = chem(i,k,j,p_seas)
345 cblk(1,VSOILA ) = chem(i,k,j,p_soila)
346 cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j))
347 cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j))
348 cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j))
349 cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j))
351 cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j))
352 !liqy
353 cblk(1,vgamn2o5) = max(epsilc,gamn2o5(i,k,j))
354 cblk(1,vcn2o5) = max(epsilc,cn2o5(i,k,j))
355 cblk(1,vkn2o5) = max(epsilc,kn2o5(i,k,j))
356 cblk(1,vyclno2) = max(epsilc,yclno2(i,k,j))
357 cblk(1,vsnu) = max(epsilc,snu(i,k,j))
358 cblk(1,vsac) = max(epsilc,sac(i,k,j))
359 !liqy-20150319
360 cblk(1,vcvasoa1) = chem(i,k,j,p_cvasoa1)
361 cblk(1,vcvasoa2) = chem(i,k,j,p_cvasoa2)
362 cblk(1,vcvasoa3) = chem(i,k,j,p_cvasoa3)
363 cblk(1,vcvasoa4) = chem(i,k,j,p_cvasoa4)
365 cblk(1,vcvbsoa1) = chem(i,k,j,p_cvbsoa1)
366 cblk(1,vcvbsoa2) = chem(i,k,j,p_cvbsoa2)
367 cblk(1,vcvbsoa3) = chem(i,k,j,p_cvbsoa3)
368 cblk(1,vcvbsoa4) = chem(i,k,j,p_cvbsoa4)
369 !
370 ! Set emissions to zero
371 epmcoarse(1) = 0.
372 epm25i(1) = 0.
373 epm25j(1) = 0.
374 eeci_in = 0.
375 eecj_in = 0.
376 eorgi_in = 0.
377 eorgj_in = 0.
378 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
379 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
380 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
381 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
382 cblk(1,VNAAJ ) = chem(i,k,j,p_naaj)
383 cblk(1,VNAAI ) = chem(i,k,j,p_naai)
384 !liqy
385 !uncomment cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
386 !uncomment cblk(1,VCLAI ) = chem(i,k,j,p_clai)
387 cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
388 cblk(1,VCLAI ) = chem(i,k,j,p_clai)
389 !comment cblk(1,VCLAJ ) = 0.
390 !comment cblk(1,VCLAI ) = 0.
391 ! cblk(1,VCLAJ ) = 0.
392 ! cblk(1,VCLAI ) = 0.
393 cblk(1,vcaaj) = chem(i,k,j,p_caaj)
394 cblk(1,vcaai) = chem(i,k,j,p_caai)
395 cblk(1,vkaj) = chem(i,k,j,p_kaj)
396 cblk(1,vkai) = chem(i,k,j,p_kai)
397 cblk(1,vmgaj) = chem(i,k,j,p_mgaj)
398 cblk(1,vmgai) = chem(i,k,j,p_mgai)
399 !liqy-20140623
400 !
401 !rs. nitrate, nh3, sulf
402 cblk(1,vsulf) = vsulf_in
403 cblk(1,vhno3) = nitrate_in
404 cblk(1,vnh3) = nh3_in
405 cblk(1,vhcl) = hcl_in
406 cblk(1,VNH4AJ) = chem(i,k,j,p_nh4aj)
407 cblk(1,VNH4AI) = chem(i,k,j,p_nh4ai)
408 cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0))
409 cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0))
410 cblk(1,VCORN ) = chem(i,k,j,p_corn)
411 !liqy
412 cblk(1,valt_in) = alt(i,k,j)
413 !liqy -20150319
414 ! the following operation updates cblk, which includes the vapors and SOA species
415 ! condvap_in is removed
416 CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh0(k),nitrate_in,nh3_in, &
417 vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv,nacv,eeci_in,eecj_in, &
418 eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k,brrto, &
419 do_isorropia,do_n2o5het )
421 ! calculation of brch_ratio
422 brch_ratio(i,k,j)= brrto
423 !------------------------------------------------------------------------
425 chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
426 chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
427 chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
428 chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
429 chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
430 chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
431 chem(i,k,j,p_naaj) = cblk(1,VNAAJ )
432 chem(i,k,j,p_naai) = cblk(1,VNAAI )
433 !liqy
434 !uncomment chem(i,k,j,p_claj) = cblk(1,VCLAJ )
435 !uncomment chem(i,k,j,p_clai) = cblk(1,VCLAI )
436 chem(i,k,j,p_claj) = cblk(1,VCLAJ )
437 chem(i,k,j,p_clai) = cblk(1,VCLAI )
439 chem(i,k,j,p_caaj) = cblk(1,vcaaj)
440 chem(i,k,j,p_caai) = cblk(1,vcaai)
441 chem(i,k,j,p_kaj) = cblk(1,vkaj)
442 chem(i,k,j,p_kai) = cblk(1,vkai)
443 chem(i,k,j,p_mgaj) = cblk(1,vmgaj)
444 chem(i,k,j,p_mgai) = cblk(1,vmgai)
445 !liqy-20140616
447 chem(i,k,j,p_asoa1j) = cblk(1,VASOA1J)
448 chem(i,k,j,p_asoa1i) = cblk(1,VASOA1I)
449 chem(i,k,j,p_asoa2j) = cblk(1,VASOA2J)
450 chem(i,k,j,p_asoa2i) = cblk(1,VASOA2I)
451 chem(i,k,j,p_asoa3j) = cblk(1,VASOA3J)
452 chem(i,k,j,p_asoa3i) = cblk(1,VASOA3I)
453 chem(i,k,j,p_asoa4j) = cblk(1,VASOA4J)
454 chem(i,k,j,p_asoa4i) = cblk(1,VASOA4I)
456 chem(i,k,j,p_bsoa1j) = cblk(1,VBSOA1J)
457 chem(i,k,j,p_bsoa1i) = cblk(1,VBSOA1I)
458 chem(i,k,j,p_bsoa2j) = cblk(1,VBSOA2J)
459 chem(i,k,j,p_bsoa2i) = cblk(1,VBSOA2I)
460 chem(i,k,j,p_bsoa3j) = cblk(1,VBSOA3J)
461 chem(i,k,j,p_bsoa3i) = cblk(1,VBSOA3I)
462 chem(i,k,j,p_bsoa4j) = cblk(1,VBSOA4J)
463 chem(i,k,j,p_bsoa4i) = cblk(1,VBSOA4I)
465 ! chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
466 ! chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
467 ! chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
468 ! chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
469 ! chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
470 ! chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
471 ! chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
472 ! chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
473 ! chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
474 ! chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
475 ! chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
476 ! chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
477 ! chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
478 ! chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
479 ! chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
480 ! chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
482 chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ )
483 chem(i,k,j,p_orgpai) = cblk(1,VORGPAI )
484 chem(i,k,j,p_ecj) = cblk(1,VECJ )
485 chem(i,k,j,p_eci) = cblk(1,VECI )
486 chem(i,k,j,p_p25j) = cblk(1,VP25AJ )
487 chem(i,k,j,p_p25i) = cblk(1,VP25AI )
488 chem(i,k,j,p_antha) = cblk(1,VANTHA )
489 chem(i,k,j,p_seas) = cblk(1,VSEAS )
490 chem(i,k,j,p_soila) = cblk(1,VSOILA )
491 chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 ))
492 chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 ))
494 chem(i,k,j,p_corn) = cblk(1,VCORN )
495 h2oaj(i,k,j) = cblk(1,VH2OAJ )
496 h2oai(i,k,j) = cblk(1,VH2OAI )
497 nu3(i,k,j) = cblk(1,VNU3 )
498 ac3(i,k,j) = cblk(1,VAC3 )
499 cor3(i,k,j) = cblk(1,VCOR3 )
500 !liqy
501 gamn2o5(i,k,j)= cblk(1,vgamn2o5)
502 cn2o5(i,k,j) = cblk(1,vcn2o5)
503 kn2o5(i,k,j) = cblk(1,vkn2o5)
504 yclno2(i,k,j) = cblk(1,vyclno2)
505 snu(i,k,j) = cblk(1,vsnu)
506 sac(i,k,j) = cblk(1,vsac)
507 !liqy-20150319
509 chem(i,k,j,p_cvasoa1)= cblk(1,VCVASOA1 )
510 chem(i,k,j,p_cvasoa2)= cblk(1,VCVASOA2 )
511 chem(i,k,j,p_cvasoa3)= cblk(1,VCVASOA3 )
512 chem(i,k,j,p_cvasoa4)= cblk(1,VCVASOA4 )
514 chem(i,k,j,p_cvbsoa1)= cblk(1,VCVBSOA1 )
515 chem(i,k,j,p_cvbsoa2)= cblk(1,VCVBSOA2 )
516 chem(i,k,j,p_cvbsoa3)= cblk(1,VCVBSOA3 )
517 chem(i,k,j,p_cvbsoa4)= cblk(1,VCVBSOA4 )
519 !---------------------------------------------------------------------------
521 ! cvbsoa1(i,k,j) = 0.
522 ! cvbsoa2(i,k,j) = 0.
523 ! cvbsoa3(i,k,j) = 0.
524 ! cvbsoa4(i,k,j) = 0.
526 ! cvaro1(i,k,j) = cblk(1,VCVARO1 )
527 ! cvaro2(i,k,j) = cblk(1,VCVARO2 )
528 ! cvalk1(i,k,j) = cblk(1,VCVALK1 )
529 ! cvole1(i,k,j) = cblk(1,VCVOLE1 )
530 ! cvapi1(i,k,j) = 0.
531 ! cvapi2(i,k,j) = 0.
532 ! cvlim1(i,k,j) = 0.
533 ! cvlim2(i,k,j) = 0.
535 chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
536 chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
537 chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
539 !liqy
540 chem(i,k,j,p_hcl) = max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL)
541 chem(i,k,j,p_n2o5) = max(epsilc,cblk(1,vn2o5)/CONVFAC/MWN2O5)
542 chem(i,k,j,p_clno2) = max(epsilc,cblk(1,vclno2)/CONVFAC/MWCLNO2)
543 !liqy-20140905
544 enddo ! k-loop
545 100 continue ! i,j-loop ends
547 ! convert aerosol variables back to mixing ratio from ug/m3
548 do l=p_so4aj,num_chem
549 do j=jts,jte
550 do k=kts,kte
551 do i=its,ite
552 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j))
553 enddo
554 enddo
555 enddo
556 enddo
558 END SUBROUTINE soa_vbs_het_driver
559 ! ///////////////////////////////////////////////////
561 SUBROUTINE sum_pm_soa_vbs ( &
562 alt, chem, h2oaj, h2oai, &
563 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10,dust_opt, &
564 ids,ide, jds,jde, kds,kde, &
565 ims,ime, jms,jme, kms,kme, &
566 its,ite, jts,jte, kts,kte )
568 INTEGER, INTENT(IN ) :: dust_opt, &
569 ids,ide, jds,jde, kds,kde, &
570 ims,ime, jms,jme, kms,kme, &
571 its,ite, jts,jte, kts,kte
573 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
574 INTENT(IN ) :: chem
576 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
577 INTENT(IN ) :: alt,h2oaj,h2oai
579 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
580 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
582 INTEGER :: i,ii,j,jj,k,n
583 !
584 ! sum up pm2_5 and pm10 output
585 !
586 pm2_5_dry(its:ite, kts:kte, jts:jte) = 0.
587 pm2_5_water(its:ite, kts:kte, jts:jte) = 0.
588 pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0.
589 do j=jts,jte
590 jj=min(jde-1,j)
591 do k=kts,kte
592 do i=its,ite
593 ii=min(ide-1,i)
594 do n=p_so4aj,p_p25i
595 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
596 enddo
598 !!! TUCCELLA
599 if( p_p25cwi .gt. p_p25i) then
600 do n=p_so4cwj,p_p25cwi
601 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
602 enddo
603 endif
605 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) &
606 + chem(ii,k,jj,p_eci)
607 pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) &
608 + h2oai(i,k,j)
610 !Convert the units from mixing ratio to concentration (ug m^-3)
611 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,k,jj)
612 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj)
613 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,k,jj)
614 enddo
615 enddo
616 enddo
617 do j=jts,jte
618 jj=min(jde-1,j)
619 do k=kts,kte
620 do i=its,ite
621 ii=min(ide-1,i)
622 pm10(i,k,j) = pm2_5_dry(i,k,j) &
623 + ( chem(ii,k,jj,p_antha) &
624 + chem(ii,k,jj,p_soila) &
625 + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj)
626 !!!TUCCELLA
627 if( p_p25cwi .gt. p_p25i) then
628 pm10(i,k,j) = pm10(i,k,j) &
629 + ( chem(ii,k,jj,p_anthcw) &
630 + chem(ii,k,jj,p_soilcw) &
631 + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj)
632 endif
633 enddo
634 enddo
635 enddo
636 END SUBROUTINE sum_pm_soa_vbs
637 ! ///////////////////////////////////////////////////
639 SUBROUTINE soa_vbs_het_depdriver (id,config_flags,ktau,dtstep, &
640 ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, &
641 alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
642 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
644 ! the vapors are part of chem array
645 ! cvasoa1,cvasoa2, &
646 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4, &
648 aer_res,vgsa, &
649 numaer, &
650 ids,ide, jds,jde, kds,kde, &
651 ims,ime, jms,jme, kms,kme, &
652 its,ite, jts,jte, kts,kte )
654 USE module_configure,only: grid_config_rec_type
655 TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags
657 INTEGER, INTENT(IN ) :: numaer, &
658 ids,ide, jds,jde, kds,kde, &
659 ims,ime, jms,jme, kms,kme, &
660 its,ite, jts,jte, kts,kte, &
661 id,ktau
663 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
664 INTENT(IN ) :: moist
665 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
666 INTENT(INOUT ) :: chem
667 !
668 ! following are aerosol arrays that are not advected
669 !
670 REAL, DIMENSION( its:ite, jts:jte, numaer ), &
671 INTENT(INOUT ) :: &
672 vgsa
673 REAL, DIMENSION( its:ite, jts:jte ), &
674 INTENT(INOUT ) :: &
675 aer_res
677 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
678 INTENT(INOUT ) :: &
679 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
681 ! no vapors
682 !cvaro1,cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
684 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
685 INTENT(IN ) :: t_phy, &
686 alt, &
687 p_phy, &
688 dz8w, &
689 rh, &
690 z, &
691 t8w,p8w,z_at_w , &
692 rho_phy
693 REAL, DIMENSION( ims:ime , jms:jme ) , &
694 INTENT(IN ) :: ust,rmol, pbl, znt
695 REAL, INTENT(IN ) :: dtstep
697 REAL, PARAMETER :: rgas=8.314510
698 REAL convfac,convfac2
699 !...BLKSIZE set to one in column model ciarev02
701 INTEGER, PARAMETER :: blksize=1
703 !...number of aerosol species
704 ! number of species (gas + aerosol)
705 INTEGER nspcsda
706 PARAMETER (nspcsda=l1ae) !bs
707 ! (internal aerosol dynamics)
708 !bs # of anth. cond. vapors in SOA_VBS
709 INTEGER nacv
710 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
711 !bs total # of cond. vapors in SOA_VBS
712 INTEGER, PARAMETER :: ncv=lspcv ! number of bins=8
713 !bs total # of cond. vapors in CTM
714 REAL cblk(blksize,nspcsda) ! main array of variables
715 ! particles [ug/m^3/s]
716 REAL soilrat_in
717 ! emission rate of soil derived coars
718 ! input HNO3 to CBLK [ug/m^3]
719 REAL nitrate_in
720 ! input NH3 to CBLK [ug/m^3]
721 REAL nh3_in
722 ! input SO4 vapor [ug/m^3]
723 REAL vsulf_in
725 REAL so4rat_in
726 ! input SO4 formation[ug/m^3/sec]
727 ! pressure in cb
728 REAL pres
729 ! temperature in K
730 REAL temp
731 !bs
732 REAL relhum
733 ! rel. humidity (0,1)
734 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
736 !...molecular weights ciarev02
738 ! molecular weight for SO4
739 REAL mwso4
740 PARAMETER (mwso4=96.0576)
742 ! molecular weight for HNO3
743 REAL mwhno3
744 PARAMETER (mwhno3=63.01287)
746 ! molecular weight for NH3
747 REAL mwnh3
748 PARAMETER (mwnh3=17.03061)
750 !bs molecular weight for Organic Spec
751 ! REAL mworg
752 ! PARAMETER (mworg=175.0)
754 !bs molecular weight for Elemental Ca
755 REAL mwec
756 PARAMETER (mwec=12.0)
758 ! they aren't used
759 !!rs molecular weight
760 ! REAL mwaro1
761 ! PARAMETER (mwaro1=150.0)
762 !
763 !!rs molecular weight
764 ! REAL mwaro2
765 ! PARAMETER (mwaro2=150.0)
766 !
767 !!rs molecular weight
768 ! REAL mwalk1
769 ! PARAMETER (mwalk1=140.0)
770 !
771 !!rs molecular weight
772 ! REAL mwalk2
773 ! PARAMETER (mwalk2=140.0)
774 !
775 !!rs molecular weight
776 !!rs molecular weight
777 ! REAL mwole1
778 ! PARAMETER (mwole1=140.0)
779 !
780 !!rs molecular weight
781 ! REAL mwapi1
782 ! PARAMETER (mwapi1=200.0)
783 !
784 !!rs molecular weight
785 ! REAL mwapi2
786 ! PARAMETER (mwapi2=200.0)
787 !
788 !!rs molecular weight
789 ! REAL mwlim1
790 ! PARAMETER (mwlim1=200.0)
791 !
792 ! REAL mwlim2
793 ! PARAMETER (mwlim2=200.0)
795 INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model)
796 !ia kept to 1 in current version of column model
797 PARAMETER( NUMCELLS = 1)
799 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
800 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
801 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
802 REAL PBLH( BLKSIZE ) ! PBL height (m)
803 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
804 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
806 REAL BLKPRS(BLKSIZE) ! pressure in cb
807 REAL BLKTA(BLKSIZE) ! temperature in K
808 REAL BLKDENS(BLKSIZE) ! Air density in kg/m3
809 !
810 ! *** OUTPUT:
811 !
812 ! *** atmospheric properties
814 REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ]
815 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ]
817 ! *** followng is for future version
818 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
819 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
821 ! *** modal diameters: [ m ]
822 REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ]
823 REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ]
824 REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ]
826 ! *** aerosol properties:
827 ! *** Modal mass concentrations [ ug m**3 ]
828 REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode
829 REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode
830 REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode
832 ! *** average modal particle densities [ kg/m**3 ]
833 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode
834 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode
835 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode
837 ! *** average modal Knudsen numbers
838 REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number
839 REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number
840 REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number
841 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
843 INTEGER :: i,j,k,l
844 !
845 ! print *,'in sorgdepdriver ',its,ite,jts,jte
846 do l=1,numaer
847 do i=its,ite
848 do j=jts,jte
849 vgsa(i,j,l)=0.
850 enddo
851 enddo
852 enddo
853 vdep=0.
855 do 100 j=jts,jte
856 do 100 i=its,ite
857 cblk=epsilc
858 do k=kts,kte
859 t(k) = t_phy(i,k,j)
860 p(k) = .001*p_phy(i,k,j)
861 rh0(k) = rh(i,k,j)
862 end do
864 k=kts
865 convfac = p(k)/rgas/t(k)*1000.
866 nitrate_in = chem(i,k,j,p_hno3)*convfac*mwhno3
867 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
868 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4
870 !rs. nitrate, nh3, sulf
871 BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa
872 BLKTA(BLKSIZE) = T(K) ! temperature in K
873 USTAR(BLKSIZE) = max(1.e-1,UST(i,j))
874 WSTAR(BLKSIZE) = 0.
875 pblh(blksize) = pbl(i,j)
876 zntt(blksize) = znt(i,j)
877 rmolm(blksize)= rmol(i,j)
878 convfac2=1./alt(i,k,j) ! density of dry air
879 BLKDENS(BLKSIZE)=convfac2
880 cblk(1,vsulf) = max(epsilc,vsulf_in)
881 cblk(1,vhno3) = max(epsilc,nitrate_in)
882 cblk(1,vnh3) = max(epsilc,nh3_in)
883 cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
884 cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
885 cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
886 cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
887 cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
888 cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
890 if (p_naai >= param_first_scalar) &
891 cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2)
892 if (p_naaj >= param_first_scalar) &
893 cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2)
894 if (p_clai >= param_first_scalar) &
895 cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2)
896 if (p_claj >= param_first_scalar) &
897 cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2)
899 !liqy
900 if (p_caai >= param_first_scalar) &
901 cblk(1,VCAAI ) = max(epsilc,chem(i,k,j,p_caai)*convfac2)
902 if (p_caaj >= param_first_scalar) &
903 cblk(1,VCAAJ ) = max(epsilc,chem(i,k,j,p_caaj)*convfac2)
904 if (p_kai >= param_first_scalar) &
905 cblk(1,VKAI ) = max(epsilc,chem(i,k,j,p_kai)*convfac2)
906 if (p_kaj >= param_first_scalar) &
907 cblk(1,VKAJ ) = max(epsilc,chem(i,k,j,p_kaj)*convfac2)
908 if (p_mgai >= param_first_scalar) &
909 cblk(1,VMGAI ) = max(epsilc,chem(i,k,j,p_mgai)*convfac2)
910 if (p_mgaj >= param_first_scalar) &
911 cblk(1,VMGAJ ) = max(epsilc,chem(i,k,j,p_mgaj)*convfac2)
912 !liqy-20140617
914 cblk(1,VASOA1J) = max(epsilc,chem(i,k,j,p_asoa1j)*convfac2) ! ug/kg-air to ug/m3
915 cblk(1,VASOA1I) = max(epsilc,chem(i,k,j,p_asoa1i)*convfac2)
916 cblk(1,VASOA2J) = max(epsilc,chem(i,k,j,p_asoa2j)*convfac2)
917 cblk(1,VASOA2I) = max(epsilc,chem(i,k,j,p_asoa2i)*convfac2)
918 cblk(1,VASOA3J) = max(epsilc,chem(i,k,j,p_asoa3j)*convfac2)
919 cblk(1,VASOA3I) = max(epsilc,chem(i,k,j,p_asoa3i)*convfac2)
920 cblk(1,VASOA4J) = max(epsilc,chem(i,k,j,p_asoa4j)*convfac2)
921 cblk(1,VASOA4I) = max(epsilc,chem(i,k,j,p_asoa4i)*convfac2)
923 cblk(1,VBSOA1J) = max(epsilc,chem(i,k,j,p_bsoa1j)*convfac2)
924 cblk(1,VBSOA1I) = max(epsilc,chem(i,k,j,p_bsoa1i)*convfac2)
925 cblk(1,VBSOA2J) = max(epsilc,chem(i,k,j,p_bsoa2j)*convfac2)
926 cblk(1,VBSOA2I) = max(epsilc,chem(i,k,j,p_bsoa2i)*convfac2)
927 cblk(1,VBSOA3J) = max(epsilc,chem(i,k,j,p_bsoa3j)*convfac2)
928 cblk(1,VBSOA3I) = max(epsilc,chem(i,k,j,p_bsoa3i)*convfac2)
929 cblk(1,VBSOA4J) = max(epsilc,chem(i,k,j,p_bsoa4j)*convfac2)
930 cblk(1,VBSOA4I) = max(epsilc,chem(i,k,j,p_bsoa4i)*convfac2)
932 ! cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
933 ! cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
934 ! cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
935 ! cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
936 ! cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
937 ! cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
938 ! cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
939 ! cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
940 ! cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
941 ! cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
942 ! cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
943 ! cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
944 ! cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
945 ! cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
946 ! cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
947 ! cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
949 cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
950 cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
951 cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2)
952 cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2)
953 cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2)
954 cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2)
956 cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2)
957 cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2)
958 cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2)
960 cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2)
961 cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2)
963 cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2)
964 cblk(1,VH2OAJ ) = h2oaj(i,k,j)
965 cblk(1,VH2OAI ) = h2oai(i,k,j)
966 cblk(1,VNU3 ) = nu3(i,k,j)
967 cblk(1,VAC3 ) = ac3(i,k,j)
968 cblk(1,VCOR3 ) = cor3(i,k,j)
970 ! here cblk is used to call modpar, however modpar doesn't need vapors!
971 ! cblk(1,vcvasoa1 ) = cvasoa1(i,k,j)
972 ! cblk(1,vcvasoa2 ) = cvasoa2(i,k,j)
973 ! cblk(1,vcvasoa3 ) = cvasoa3(i,k,j)
974 ! cblk(1,vcvasoa4 ) = cvasoa4(i,k,j)
975 ! cblk(1,vcvbsoa1) = 0.
976 ! cblk(1,vcvbsoa2) = 0.
977 ! cblk(1,vcvbsoa3) = 0.
978 ! cblk(1,vcvbsoa4) = 0.
980 ! cblk(1,VCVARO1 ) = cvaro1(i,k,j)
981 ! cblk(1,VCVARO2 ) = cvaro2(i,k,j)
982 ! cblk(1,VCVALK1 ) = cvalk1(i,k,j)
983 ! cblk(1,VCVOLE1 ) = cvole1(i,k,j)
984 ! cblk(1,VCVAPI1 ) = 0.
985 ! cblk(1,VCVAPI2 ) = 0.
986 ! cblk(1,VCVLIM1 ) = 0.
987 ! cblk(1,VCVLIM2 ) = 0.
989 ! cblk(1,VCVAPI1 ) = cvapi1(i,k,j)
990 ! cblk(1,VCVAPI2 ) = cvapi2(i,k,j)
991 ! cblk(1,VCVLIM1 ) = cvlim1(i,k,j)
992 ! cblk(1,VCVLIM2 ) = cvlim2(i,k,j)
993 !
994 !rs. get size distribution information
995 ! if(i.eq.126.and.j.eq.99)then
996 ! print *,'in modpar ',i,j
997 ! print *,cblk,BLKTA,BLKPRS,USTAR
998 ! print *,'BLKSIZE, NSPCSDA, NUMCELLS'
999 ! print *,BLKSIZE, NSPCSDA, NUMCELLS
1000 ! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
1001 ! print *,XLM, AMU,PDENSN, PDENSA, PDENSC
1002 ! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
1003 ! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
1004 ! endif
1006 CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, &
1007 CBLK, &
1008 BLKTA, BLKPRS, &
1009 PMASSN, PMASSA, PMASSC, &
1010 PDENSN, PDENSA, PDENSC, &
1011 XLM, AMU, &
1012 DGNUC, DGACC, DGCOR, &
1013 KNNUC, KNACC,KNCOR )
1015 if (config_flags%aer_drydep_opt == 11) then
1016 CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
1017 BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, &
1018 DGNUC, DGACC, DGCOR, &
1019 KNNUC, KNACC,KNCOR, &
1020 PDENSN, PDENSA, PDENSC, &
1021 VSED, VDEP )
1022 else
1023 ! for aerosol dry deposition, no CBLK in VDVG_2
1024 CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k, &
1025 BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,&
1026 ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,&
1027 KNNUC, KNACC,KNCOR, &
1028 PDENSN, PDENSA, PDENSC, &
1029 VSED, VDEP )
1030 endif
1032 VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC )
1033 VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC )
1034 VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ )
1035 VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI )
1036 VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ )
1037 VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI )
1039 if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI )
1040 if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ )
1041 if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI )
1042 if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ )
1043 !liqy
1044 if (p_caai >= param_first_scalar) VGSA(i, j, VCAAI ) = VGSA(i,j,VSO4AI )
1045 if (p_caaj >= param_first_scalar) VGSA(i, j, VCAAJ ) = VGSA(i,j,VSO4AJ)
1046 if (p_kai >= param_first_scalar) VGSA(i, j, VKAI ) = VGSA(i, j,VSO4AI)
1047 if (p_kaj >= param_first_scalar) VGSA(i, j, VKAJ ) = VGSA(i, j,VSO4AJ)
1048 if (p_mgai >= param_first_scalar) VGSA(i, j, VMGAI ) = VGSA(i,j,VSO4AI )
1049 if (p_mgaj >= param_first_scalar) VGSA(i, j, VMGAJ ) = VGSA(i,j,VSO4AJ )
1050 !liqy-20140703
1051 VGSA(i, j, VASOA1J ) = VGSA(i, j, VSO4AJ )
1052 VGSA(i, j, VASOA1I ) = VGSA(i, j, VSO4AI )
1053 VGSA(i, j, VASOA2J ) = VGSA(i, j, VSO4AJ )
1054 VGSA(i, j, VASOA2I ) = VGSA(i, j, VSO4AI )
1055 VGSA(i, j, VASOA3J ) = VGSA(i, j, VSO4AJ )
1056 VGSA(i, j, VASOA3I ) = VGSA(i, j, VSO4AI )
1057 VGSA(i, j, VASOA4J ) = VGSA(i, j, VSO4AJ )
1058 VGSA(i, j, VASOA4I ) = VGSA(i, j, VSO4AI )
1060 VGSA(i, j, VBSOA1J ) = VGSA(i, j, VSO4AJ )
1061 VGSA(i, j, VBSOA1I ) = VGSA(i, j, VSO4AI )
1062 VGSA(i, j, VBSOA2J ) = VGSA(i, j, VSO4AJ )
1063 VGSA(i, j, VBSOA2I ) = VGSA(i, j, VSO4AI )
1064 VGSA(i, j, VBSOA3J ) = VGSA(i, j, VSO4AJ )
1065 VGSA(i, j, VBSOA3I ) = VGSA(i, j, VSO4AI )
1066 VGSA(i, j, VBSOA4J ) = VGSA(i, j, VSO4AJ )
1067 VGSA(i, j, VBSOA4I ) = VGSA(i, j, VSO4AI )
1068 !----------------------------------------------------------------------
1070 ! VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ )
1071 ! VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI )
1072 ! VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ )
1073 ! VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI )
1074 ! VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ )
1075 ! VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI )
1076 ! VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ )
1077 ! VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI )
1078 ! VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ )
1079 ! VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI )
1080 ! VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ )
1081 ! VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI )
1082 ! VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ )
1083 ! VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI )
1084 ! VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ )
1085 ! VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI )
1087 VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ )
1088 VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI )
1089 VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ )
1090 VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI )
1091 VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ )
1092 VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI )
1094 VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR )
1095 VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA )
1096 VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA )
1097 VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC )
1098 VGSA(i, j, VAC0 ) = VDEP(1, VDNACC )
1099 VGSA(i, j, VCORN ) = VDEP(1, VDNCOR )
1100 ! enddo ! k-loop
1101 100 continue ! i,j-loop
1103 END SUBROUTINE soa_vbs_het_depdriver
1104 ! ///////////////////////////////////////////////////
1106 SUBROUTINE actcof(cat,an,gama,molnu,phimult)
1107 ! DESCRIPTION:
1108 ! This subroutine computes the activity coefficients of (2NH4+,SO4--),
1109 ! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
1110 ! multicomponent solution, using Bromley's model and Pitzer's method.
1112 ! REFERENCES:
1113 ! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
1114 ! in aqueous solutions. AIChE J. 19, 313-320.
1116 ! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of
1117 ! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
1119 ! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
1120 ! of strong acids over saline solutions - I HNO3,
1121 ! Atmos. Environ. (22): 91-100
1123 ! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
1124 ! and mean activity and osmotic coefficients of 0-100% nitric acid
1125 ! as a function of temperature, J. Phys. Chem (94): 5369 - 5380
1127 ! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
1128 ! general equilibrium model for inorganic multicomponent atmospheric
1129 ! aerosols. Atmos. Environ. 21(11), 2453-2466.
1131 ! ARGUMENT DESCRIPTION:
1132 ! CAT(1) : conc. of H+ (moles/kg)
1133 ! CAT(2) : conc. of NH4+ (moles/kg)
1134 ! AN(1) : conc. of SO4-- (moles/kg)
1135 ! AN(2) : conc. of NO3- (moles/kg)
1136 ! AN(3) : conc. of HSO4- (moles/kg)
1137 ! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--)
1138 ! GAMA(2,2) : (NH4+,NO3-)
1139 ! GAMA(2,3) : (NH4+. HSO4-)
1140 ! GAMA(1,1) : (2H+,SO4--)
1141 ! GAMA(1,2) : (H+,NO3-)
1142 ! GAMA(1,3) : (H+,HSO4-)
1143 ! MOLNU : the total number of moles of all ions.
1144 ! PHIMULT : the multicomponent paractical osmotic coefficient.
1146 ! REVISION HISTORY:
1147 ! Who When Detailed description of changes
1148 ! --------- -------- -------------------------------------------
1149 ! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this
1150 ! new routine using a method described by Pilini
1151 ! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
1152 ! S.Roselle 7/30/97 Modified for use in Models-3
1153 ! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA
1155 !-----------------------------------------------------------------------
1156 !...........INCLUDES and their descriptions
1157 ! INCLUDE SUBST_XSTAT ! M3EXIT status codes
1158 !....................................................................
1160 ! Normal, successful completion
1161 INTEGER xstat0
1162 PARAMETER (xstat0=0)
1163 ! File I/O error
1164 INTEGER xstat1
1165 PARAMETER (xstat1=1)
1166 ! Execution error
1167 INTEGER xstat2
1168 PARAMETER (xstat2=2)
1169 ! Special error
1170 INTEGER xstat3
1171 PARAMETER (xstat3=3)
1172 CHARACTER*120 xmsg
1174 !...........PARAMETERS and their descriptions:
1175 ! number of cations
1176 INTEGER ncat
1177 PARAMETER (ncat=2)
1179 ! number of anions
1180 INTEGER nan
1181 PARAMETER (nan=3)
1183 !...........ARGUMENTS and their descriptions
1184 ! tot # moles of all ions
1185 REAL molnu
1186 ! multicomponent paractical osmo
1187 REAL phimult
1188 REAL cat(ncat) ! cation conc in moles/kg (input
1189 REAL an(nan) ! anion conc in moles/kg (input)
1190 REAL gama(ncat,nan)
1191 !...........SCRATCH LOCAL VARIABLES and their descriptions:
1192 ! mean molal ionic activity coef
1193 CHARACTER*16 & ! driver program name
1194 pname
1195 SAVE pname
1197 ! anion indX
1198 INTEGER ian
1200 INTEGER icat
1201 ! cation indX
1203 REAL fgama
1204 ! ionic strength
1205 REAL i
1206 REAL r
1207 REAL s
1208 REAL ta
1209 REAL tb
1210 REAL tc
1211 REAL texpv
1212 REAL trm
1213 ! 2*ionic strength
1214 REAL twoi
1215 ! 2*sqrt of ionic strength
1216 REAL twosri
1217 REAL zbar
1218 REAL zbar2
1219 REAL zot1
1220 ! square root of ionic strength
1221 REAL sri
1222 REAL f2(ncat)
1223 REAL f1(nan)
1224 REAL zp(ncat) ! absolute value of charges of c
1225 REAL zm(nan) ! absolute value of charges of a
1226 REAL bgama(ncat,nan)
1227 REAL x(ncat,nan)
1228 REAL m(ncat,nan) ! molality of each electrolyte
1229 REAL lgama0(ncat,nan) ! binary activity coefficients
1230 REAL y(nan,ncat)
1231 REAL beta0(ncat,nan) ! binary activity coefficient pa
1232 REAL beta1(ncat,nan) ! binary activity coefficient pa
1233 REAL cgama(ncat,nan) ! binary activity coefficient pa
1234 REAL v1(ncat,nan) ! number of cations in electroly
1235 REAL v2(ncat,nan)
1236 ! number of anions in electrolyt
1237 DATA zp/1.0, 1.0/
1238 DATA zm/2.0, 1.0, 1.0/
1239 DATA xmsg/' '/
1240 DATA pname/'ACTCOF'/
1242 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1244 ! *** (1,1);(1,3) - Clegg & Brimblecombe (1988)
1245 ! *** (2,3) - Pilinis & Seinfeld (1987), cgama different
1246 ! *** (1,2) - Clegg & Brimblecombe (1990)
1247 ! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992)
1249 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1251 DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 / ! 2H+SO4
1252 DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 / ! HNO3
1253 DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 / ! H+HSO4
1254 DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/,cgama(2,1)/ -1.2683E-3/ ! (NH4)2
1255 DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/,cgama(2,2)/3.51217E-5/ ! NH4NO3
1256 DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 /
1257 ! NH4HSO
1258 DATA v1(1,1), v2(1,1)/2.0, 1.0/ ! 2H+SO4-
1259 DATA v1(2,1), v2(2,1)/2.0, 1.0/ ! (NH4)2SO4
1260 DATA v1(1,2), v2(1,2)/1.0, 1.0/ ! HNO3
1261 DATA v1(2,2), v2(2,2)/1.0, 1.0/ ! NH4NO3
1262 DATA v1(1,3), v2(1,3)/1.0, 1.0/ ! H+HSO4-
1263 DATA v1(2,3), v2(2,3)/1.0, 1.0/
1264 !-----------------------------------------------------------------------
1265 ! begin body of subroutine ACTCOF
1267 !...compute ionic strength
1268 ! NH4HSO4
1269 i = 0.0
1270 DO icat = 1, ncat
1271 i = i + cat(icat)*zp(icat)*zp(icat)
1272 END DO
1274 DO ian = 1, nan
1275 i = i + an(ian)*zm(ian)*zm(ian)
1276 END DO
1278 i = 0.5*i
1279 !...check for problems in the ionic strength
1280 IF (i==0.0) THEN
1281 DO ian = 1, nan
1282 DO icat = 1, ncat
1283 gama(icat,ian) = 0.0
1284 END DO
1285 END DO
1287 ! xmsg = 'Ionic strength is zero...returning zero activities'
1288 ! WRITE (6,*) xmsg
1289 RETURN
1291 ELSE IF (i<0.0) THEN
1292 ! xmsg = 'Ionic strength below zero...negative concentrations'
1293 ! CALL wrf_error_fatal ( xmsg )
1295 xmsg = 'WARNING: Ionic strength below zero (= negative ion concentrations) - setting ion concentrations to zero.'
1296 call wrf_message(xmsg)
1297 DO ian = 1, nan
1298 DO icat = 1, ncat
1299 gama(icat,ian) = 0.0
1300 END DO
1301 END DO
1302 RETURN
1304 END IF
1306 !...compute some essential expressions
1307 sri = sqrt(i)
1308 twosri = 2.0*sri
1309 twoi = 2.0*i
1310 texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1311 r = 1.0 + 0.75*i
1312 s = 1.0 + 1.5*i
1313 zot1 = 0.511*sri/(1.0+sri)
1315 !...Compute binary activity coeffs
1316 fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1317 DO icat = 1, ncat
1318 DO ian = 1, nan
1320 bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1321 )*texpv
1323 !...compute the molality of each electrolyte for given ionic strength
1325 m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1326 (1.0/(v1(icat,ian)+v2(icat,ian)))
1328 !...calculate the binary activity coefficients
1330 lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1331 ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1332 ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1333 v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1334 ian)))/2.302585093
1336 END DO
1337 END DO
1339 !...prepare variables for computing the multicomponent activity coeffs
1341 DO ian = 1, nan
1342 DO icat = 1, ncat
1343 zbar = (zp(icat)+zm(ian))*0.5
1344 zbar2 = zbar*zbar
1345 y(ian,icat) = zbar2*an(ian)/i
1346 x(icat,ian) = zbar2*cat(icat)/i
1347 END DO
1348 END DO
1350 DO ian = 1, nan
1351 f1(ian) = 0.0
1352 DO icat = 1, ncat
1353 f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1354 zot1*zp(icat)*zm(ian)*x(icat,ian)
1355 END DO
1356 END DO
1358 DO icat = 1, ncat
1359 f2(icat) = 0.0
1360 DO ian = 1, nan
1361 f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1362 zot1*zp(icat)*zm(ian)*y(ian,icat)
1363 END DO
1364 END DO
1366 !...now calculate the multicomponent activity coefficients
1368 DO ian = 1, nan
1369 DO icat = 1, ncat
1371 ta = -zot1*zp(icat)*zm(ian)
1372 tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1373 tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1374 trm = ta + tb*tc
1376 IF (trm>30.0) THEN
1377 gama(icat,ian) = 1.0E+30
1378 ! xmsg = 'Multicomponent activity coefficient is extremely large'
1379 ! WRITE (6,*) xmsg
1380 ELSE
1381 gama(icat,ian) = 10.0**trm
1382 END IF
1384 END DO
1385 END DO
1387 RETURN
1388 !ia*********************************************************************
1389 END SUBROUTINE actcof
1391 !ia
1392 !ia AEROSOL DYNAMICS DRIVER ROUTINE *
1393 !ia based on MODELS3 formulation by FZB
1394 !ia Modified by IA in November 97
1395 !ia
1396 !ia Revision history
1397 !ia When WHO WHAT
1398 !ia ---- ---- ----
1399 !ia ???? FZB BEGIN
1400 !ia 05/97 IA Adapted for use in CTM2-S
1401 !ia 11/97 IA Modified for new model version
1402 !ia see comments under iarev02
1403 !ia
1404 !ia Called BY: RPMMOD3
1405 !ia
1406 !ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1407 !ia GETVSED
1408 !ia
1409 !ia*********************************************************************
1411 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1412 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat, &
1413 orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,epm25i, &
1414 epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1415 dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1416 kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1417 ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid,brrto,do_isorropia,do_n2o5het)
1419 !USE module_configure, only: grid_config_rec_type
1420 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
1422 ! IMPLICIT NONE
1423 ! dimension of arrays
1424 INTEGER blksize
1425 ! number of species in CBLK
1426 INTEGER nspcsda
1427 ! actual number of cells in arrays
1428 INTEGER numcells
1429 ! number of k-level
1430 INTEGER layer
1431 ! of organic aerosol precursor
1432 INTEGER ldrog_vbs
1433 REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1435 REAL dt
1436 ! *** Meteorological information:
1438 ! synchronization time [s]
1439 REAL blkta(blksize) ! Air temperature [ K ]
1440 REAL blkprs(blksize) ! Air pressure in [ Pa ]
1441 REAL blkdens(blksize) ! Air density [ kg/ m**3 ]
1442 REAL blkrh(blksize)
1443 ! *** Chemical production rates: [ ug / m**3 s ]
1445 ! Fractional relative humidity
1446 REAL so4rat(blksize)
1447 ! sulfate gas-phase production rate
1448 ! total # of cond. vapors & SOA species
1449 INTEGER ncv
1450 INTEGER nacv
1451 !bs * organic condensable vapor production rate
1452 ! # of anthrop. cond. vapors & SOA speci
1453 REAL drog(blksize,ldrog_vbs) !bs
1454 ! *** anthropogenic organic aerosol mass production rates from aromatics
1455 ! Delta ROG conc. [ppm]
1456 REAL organt1rat(blksize)
1458 ! *** anthropogenic organic aerosol mass production rates from aromatics
1459 REAL organt2rat(blksize)
1461 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1462 REAL organt3rat(blksize)
1464 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1465 REAL organt4rat(blksize)
1467 ! *** biogenic organic aerosol production rates
1468 REAL orgbio1rat(blksize)
1470 ! *** biogenic organic aerosol production rates
1471 REAL orgbio2rat(blksize)
1473 ! *** biogenic organic aerosol production rates
1474 REAL orgbio3rat(blksize)
1476 ! *** biogenic organic aerosol production rates
1477 REAL orgbio4rat(blksize)
1479 ! *** Primary emissions rates: [ ug / m**3 s ]
1480 ! *** emissions rates for unidentified PM2.5 mass
1481 REAL epm25i(blksize) ! Aitken mode
1482 REAL epm25j(blksize)
1483 ! *** emissions rates for primary organic aerosol
1484 ! Accumululaton mode
1485 REAL eorgi(blksize) ! Aitken mode
1486 REAL eorgj(blksize)
1487 ! *** emissions rates for elemental carbon
1488 ! Accumululaton mode
1489 REAL eeci(blksize) ! Aitken mode
1490 REAL eecj(blksize)
1491 ! *** emissions rates for coarse mode particles
1492 ! Accumululaton mode
1493 REAL esoil(blksize) ! soil derived coarse aerosols
1494 REAL eseas(blksize) ! marine coarse aerosols
1495 REAL epmcoarse(blksize)
1497 ! *** OUTPUT:
1498 ! *** atmospheric properties
1499 ! anthropogenic coarse aerosols
1500 REAL xlm(blksize) ! atmospheric mean free path [ m ]
1501 REAL amu(blksize)
1502 ! *** modal diameters: [ m ]
1504 ! atmospheric dynamic viscosity [ kg
1505 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1506 REAL dgacc(blksize) ! accumulation geometric mean diamet
1507 REAL dgcor(blksize)
1509 ! *** aerosol properties:
1510 ! *** Modal mass concentrations [ ug m**3 ]
1511 ! coarse mode geometric mean diamete
1512 REAL pmassn(blksize) ! mass concentration in Aitken mode
1513 REAL pmassa(blksize) ! mass concentration in accumulation
1514 REAL pmassc(blksize)
1515 ! *** average modal particle densities [ kg/m**3 ]
1517 ! mass concentration in coarse mode
1518 REAL pdensn(blksize) ! average particle density in nuclei
1519 REAL pdensa(blksize) ! average particle density in accumu
1520 REAL pdensc(blksize)
1521 ! *** average modal Knudsen numbers
1523 ! average particle density in coarse
1524 REAL knnuc(blksize) ! nuclei mode Knudsen number
1525 REAL knacc(blksize) ! accumulation Knudsen number
1526 REAL kncor(blksize)
1527 ! *** modal condensation factors ( see comments in NUCLCOND )
1529 ! coarse mode Knudsen number
1530 REAL fconcn(blksize)
1531 REAL fconca(blksize)
1532 !bs
1533 REAL fconcn_org(blksize)
1534 REAL fconca_org(blksize)
1535 !bs
1537 ! *** Rates for secondary particle formation:
1539 ! *** production of new mass concentration [ ug/m**3 s ]
1540 REAL dmdt(blksize) ! by particle formation
1542 ! *** production of new number concentration [ number/m**3 s ]
1544 ! rate of production of new mass concen
1545 REAL dndt(blksize) ! by particle formation
1547 ! *** growth rate for third moment by condensation of precursor
1548 ! vapor on existing particles [ 3rd mom/m**3 s ]
1550 ! rate of producton of new particle num
1551 REAL cgrn3(blksize) ! Aitken mode
1552 REAL cgra3(blksize)
1553 ! *** Rates for coaglulation: [ m**3/s ]
1555 ! *** Unimodal Rates:
1557 ! Accumulation mode
1558 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1559 REAL ura00(blksize)
1561 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
1563 ! accumulation mode 0th moment self-coagulat
1564 REAL brna01(blksize)
1565 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1566 ! rate for 0th moment
1567 REAL c30(blksize) ! by intermodal c
1568 REAL brrto
1569 !
1570 LOGICAL do_isorropia,do_n2o5het
1571 ! *** other processes
1573 ! intermodal 3rd moment transfer r
1574 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
1576 ! INTEGER NN, VV ! loop indICES
1577 ! increment of concentration added to
1579 ! ////////////////////// Begin code ///////////////////////////////////
1580 ! concentration lower limit
1581 CHARACTER*16 pname
1582 PARAMETER (pname=' AEROPROC ')
1584 INTEGER unit
1585 PARAMETER (unit=20)
1586 integer igrid,jgrid,kgrid,isorop
1588 ! *** get water, ammonium and nitrate content:
1589 ! for now, don't call if temp is below -40C (humidity
1590 ! for this wrf version is already limited to 10 percent)
1591 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. do_isorropia )then
1592 CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1593 else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. (.not. do_isorropia) )then
1594 CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1595 endif
1596 if ( do_n2o5het ) then
1597 CALL n2o5het(blksize,nspcsda,numcells,dt,cblk,blkta,blkrh,dgnuc,dgacc,dgcor,igrid,jgrid,kgrid)
1598 endif
1599 !liqy-20140709
1601 ! isorop=0
1603 ! *** get water, ammonium and nitrate content:
1604 ! for now, don't call if temp is below -40C (humidity
1605 ! for this wrf version is already limited to 10 percent)
1607 ! if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then
1608 ! CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
1609 ! else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then
1610 ! CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1611 ! endif
1613 ! *** get size distribution information:
1615 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1616 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1617 kncor)
1619 ! *** Calculate coagulation rates for fine particles:
1621 CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1622 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1624 ! *** get condensation and particle formation (nucleation) rates:
1626 CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1627 so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
1628 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
1629 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
1631 ! *** advance forward in time DT seconds:
1632 CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,organt1rat, &
1633 organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1634 orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1635 dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1636 dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1638 ! *** get new distribution information:
1639 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1640 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1641 kncor)
1643 RETURN
1644 END SUBROUTINE aeroproc
1645 !//////////////////////////////////////////////////////////////////
1646 !//////////////////////////////////////////////////////////////////
1647 !******************************************************************************
1648 !liqy
1649 SUBROUTINE n2o5het(blksize,nspcsda,numcells,dt,cblk,blkta,blkrh,dgnuc,dgacc,dgcor,igrid,jgrid,kgrid)
1651 ! dimension of arrays
1652 INTEGER blksize
1653 ! actual number of cells in arrays
1654 INTEGER numcells
1655 ! nmber of species in CBLK
1656 INTEGER nspcsda
1657 REAL cblk(blksize,nspcsda)
1658 REAL dt
1659 ! *** Meteorological information in blocked arays:
1660 REAL blkta(blksize) ! Air temperature [ K ]
1661 REAL blkrh(blksize) ! Fractional relative humidity
1662 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1663 REAL dgacc(blksize) ! accumulation geometric mean diamet
1664 REAL dgcor(blksize)
1665 !
1666 Integer igrid,jgrid,kgrid
1668 INTEGER lcell ! loop counter
1669 ! air temperature
1670 REAL temp
1671 !relative humidity.
1672 REAL rh
1673 !aerosol number density
1674 REAL nnu
1675 REAL nac
1676 !aerosol mean diameter
1677 REAL dnu!nuclei
1678 REAL dac !accumulation
1679 !aerosol surface area density
1680 REAL snu
1681 REAL sac
1682 !uptake of n2o5 on aerosols
1683 REAL gamn2o5
1684 !n2o5 molecular speed
1685 REAL cn2o5
1686 !reaction rate constants of N2O5 hydrolysis
1687 REAL kn2o5
1688 !yield of clno2
1689 REAL yclno2
1692 REAL ah2o
1693 REAL acl
1694 REAL ano3
1695 REAL gn2o5
1697 REAL mwh2o
1698 PARAMETER (mwh2o = 18.015)
1699 REAL mwcl
1700 PARAMETER (mwcl = 35.453)
1701 REAL mwno3
1702 PARAMETER (mwno3 = 62.004)
1703 REAL mwn2o5
1704 PARAMETER (mwn2o5 = 108.009)
1705 REAL mwclno2
1706 PARAMETER (mwclno2 = 81.458)
1707 REAL deln2o5
1708 REAL pclno2
1709 REAL pno3
1711 REAL fraci,fracj,fracij
1712 REAL rgasuniv
1713 PARAMETER (rgasuniv = 8.314510)
1714 REAL pirs
1715 PARAMETER (pirs = 3.14)
1716 INTEGER xxx
1717 PARAMETER (xxx = 1)
1719 real vaer
1720 !==================================================
1721 DO lcell = 1, numcells
1724 temp = blkta(lcell)
1725 rh = blkrh(lcell)
1726 nnu = cblk(lcell,vnu0) !#/m3-dry air
1727 nac = cblk(lcell,vac0)
1728 dnu = dgnuc(lcell) !m
1729 dac = dgacc(lcell)
1730 vaer = (pirs/6.0) * (cblk(lcell,vnu3) + cblk(lcell,vac3))
1731 !aerosol volume in i and j mode.
1732 !=================================================
1733 !convert the unit from ug/m3 to mol/L (in aerosol solution)
1734 ah2o = ( cblk(lcell,vh2oaj) + cblk(lcell,vh2oai) ) * 1.0E-9 / ( mwh2o*vaer)
1736 !convert the unit from ug/m3 to mol/L (in aerosol solution)
1737 acl = ( cblk(lcell,vclaj) + cblk(lcell,vclai) ) * 1.0E-9/(mwcl*vaer)
1738 ano3 = ( cblk(lcell,vno3aj) + cblk(lcell,vno3ai) ) * 1.0E-9/(mwno3*vaer)
1740 ! convert the unit from ug/m3 to mol/L in air atmosphere.
1741 gn2o5 = cblk(lcell,vn2o5) * 1.0E-9 /mwn2o5
1743 cblk(lcell,vgamn2o5) = 3.2E-8 * ( 1.15E6 - 1.15E6 * exp(-1.3E-1* ah2o ) ) * ( 1 - (1/((6E-2*ah2o/ano3)+1+(29*acl/ano3))))
1745 cblk(lcell,vsnu) = nnu*dnu*dnu*esn16*pirs
1746 cblk(lcell,vsac) = nac*dac*dac*esa16*pirs
1748 cblk(lcell,vcn2o5) = SQRT( 8.0 * rgasuniv * temp * 1000 / ( pirs* mwn2o5 ) )
1749 cblk(lcell,vkn2o5) = cblk(lcell,vcn2o5) * ( cblk(lcell,vsnu) +cblk(lcell,vsac) ) * cblk(lcell,vgamn2o5) / 4
1750 deln2o5 = gn2o5-gn2o5*exp(-1*cblk(lcell,vkn2o5)*dt) !mole/L in atmosphere
1752 cblk(lcell,vyclno2)= 1/(1+ah2o/(483*acl))
1754 pclno2=deln2o5*cblk(lcell,vyclno2) !mol/L in atmosphere
1756 if (acl*vaer .lt. pclno2) then
1757 pclno2=abs(acl*vaer-epsilc*epsilc)
1758 cblk(lcell,vyclno2)=pclno2/deln2o5
1759 end if
1762 pno3 = deln2o5 * ( 2 - cblk(lcell,vyclno2) ) !mole/L in atmosphere
1764 cblk(lcell,vclno2) = cblk(lcell,vclno2) + pclno2*mwclno2*1.0E9
1766 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
1767 fracj = 1.0 - fraci
1769 cblk(lcell,vclaj)=max(epsilc*epsilc,(acl*vaer-pclno2))*mwcl*1.0E9*fracj
1770 cblk(lcell,vclai)=max(epsilc*epsilc,(acl*vaer-pclno2))*mwcl*1.0E9*fraci
1772 cblk(lcell,vn2o5) = cblk(lcell,vn2o5)*exp(-1*cblk(lcell,vkn2o5)*dt)
1773 cblk(lcell,vno3ai) = (ano3*vaer + pno3) * mwno3 * 1.0E9* fraci
1774 cblk(lcell,vno3aj) = (ano3*vaer + pno3) * mwno3 * 1.0E9* fracj
1776 END DO
1778 END SUBROUTINE n2o5het
1779 !liqy-20140905
1780 !//////////////////////////////////////////////////////////////////////////////
1783 ! *** Time stepping code advances the aerosol moments one timestep;
1784 SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat &
1785 ,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat &
1786 ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1787 ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn &
1788 ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1789 igrid,jgrid,kgrid)
1791 ! *** DESCRIPTION: Integrate the Number and Mass equations
1792 ! for each mode over the time interval DT.
1793 ! PRECONDITIONS:
1794 ! AEROSTEP() must follow calls to all other dynamics routines.
1796 ! *** Revision history:
1797 ! Adapted 3/95 by UAS and CJC from EAM2's code.
1798 ! Revised 7/29/96 by FSB to use block structure
1799 ! Revised 11/15/96 by FSB dropped flow-through and cast
1800 ! number solver into Riccati equation form.
1801 ! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mode
1802 ! each predicted rather than total mass and
1803 ! Aitken mode mass. Also used a local approximation
1804 ! the error function. Also added coarse mode.
1805 ! Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1806 ! accumulation mode by coagulation
1807 ! Revised 10/27/97 by FSB to modify code to use primay emissions
1808 ! and to correct 3rd moment updates.
1809 ! Also added coarse mode.
1810 ! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1811 ! Revised 11/5/97 by FSB to fix error in MSTRNSFR
1812 ! Revised 11/6/97 FSB to correct the expression for FACTRANS to
1813 ! remove the 6/pi coefficient. UAS found this.
1814 ! Revised 12/15/97 by FSB to change equations for mass concentratin
1815 ! to a chemical production form with analytic
1816 ! solutions for the Aitken mode and to remove
1817 ! time stepping of the 3rd moments. The mass concentration
1818 ! in the accumulation mode is updated with a forward
1819 ! Eulerian step.
1820 ! Revised 1/6/98 by FSB Lowered minimum concentration for
1821 ! sulfate aerosol to 0.1 [ ng / m**3 ].
1822 ! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represents
1823 ! intermodal transfer rate of 3rd moment in place
1824 ! of 3rd moment coagulation rate.
1825 ! Revised 5/5/98 added new renaming criterion based on diameters
1826 ! Added 3/23/98 by BS condensational groth factors for organics
1828 !**********************************************************************
1829 ! IMPLICIT NONE
1831 ! *** ARGUMENTS:
1833 ! dimension of arrays
1834 INTEGER blksize
1835 ! actual number of cells in arrays
1836 INTEGER numcells
1837 ! nmber of species in CBLK
1838 INTEGER nspcsda
1839 ! model layer
1840 INTEGER layer
1841 REAL cblk(blksize,nspcsda) ! main array of variables
1842 INTEGER igrid,jgrid,kgrid
1843 REAL dt
1844 ! *** Chemical production rates: [ ug / m**3 s ]
1846 ! time step [sec]
1847 REAL so4rat(blksize) ! sulfate gas-phase production rate
1849 ! anthropogenic organic aerosol mass production rates
1850 REAL organt1rat(blksize)
1851 REAL organt2rat(blksize)
1852 REAL organt3rat(blksize)
1853 REAL organt4rat(blksize)
1855 ! biogenic organic aerosol production rates
1856 REAL orgbio1rat(blksize)
1857 REAL orgbio2rat(blksize)
1858 REAL orgbio3rat(blksize)
1859 REAL orgbio4rat(blksize)
1861 ! *** Primary emissions rates: [ ug / m**3 s ]
1862 ! *** emissions rates for unidentified PM2.5 mass
1863 REAL epm25i(blksize) ! Aitken mode
1864 REAL epm25j(blksize)
1865 ! *** emissions rates for primary organic aerosol
1866 ! Accumululaton mode
1867 REAL eorgi(blksize) ! Aitken mode
1868 REAL eorgj(blksize)
1869 ! *** emissions rates for elemental carbon
1870 ! Accumululaton mode
1871 REAL eeci(blksize) ! Aitken mode
1872 REAL eecj(blksize)
1873 ! *** emissions rates for coarse mode particles
1874 ! Accumululaton mode
1875 REAL esoil(blksize) ! soil derived coarse aerosols
1876 REAL eseas(blksize) ! marine coarse aerosols
1877 REAL epmcoarse(blksize)
1878 ! anthropogenic coarse aerosols
1879 REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1880 REAL dgacc(blksize)
1881 ! accumulation
1882 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
1883 ! reciprocal condensation rate
1884 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
1885 ! reciprocal condensation rate
1886 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
1887 ! reciprocal condensation rate for organ
1888 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
1889 ! reciprocal condensation rate for organ
1890 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
1891 ! rate of production of new mass concent
1892 REAL dndt(blksize) ! by particle formation [ number/m**3 /s
1893 ! rate of producton of new particle numb
1894 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
1895 ! increment of concentration added to
1896 REAL urn00(blksize) ! Aitken intramodal coagulation rate
1897 REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1898 REAL brna01(blksize) ! bimodal coagulation rate for number
1899 REAL c30(blksize) ! by intermodal coagulation
1900 ! intermodal 3rd moment transfer rate by
1901 REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1902 REAL cgra3(blksize)
1903 ! *** Modal mass concentrations [ ug m**3 ]
1905 ! growth rate for 3rd moment for Accumul
1906 REAL pmassn(blksize) ! mass concentration in Aitken mode
1907 REAL pmassa(blksize) ! mass concentration in accumulation
1908 REAL pmassc(blksize)
1910 ! *** Local Variables
1912 ! mass concentration in coarse mode
1913 INTEGER l, lcell, spc
1914 ! ** following scratch variables are used for solvers
1916 ! *** variables needed for modal dynamics solvers:
1917 ! Loop indices
1918 REAL*8 a, b, c
1919 REAL*8 m1, m2, y0, y
1920 REAL*8 dhat, p, pexpdt, expdt
1921 REAL*8 loss, prod, pol, lossinv
1922 ! mass intermodal transfer by coagulation
1923 REAL mstrnsfr
1925 REAL factrans
1927 ! *** CODE additions for renaming
1928 REAL getaf2
1929 REAL aaa, xnum, xm3, fnum, fm3, phnum, phm3 ! Defined below
1930 REAL erf, & ! Error and complementary error function
1931 erfc
1933 REAL xx
1934 ! dummy argument for ERF and ERFC
1935 ! a numerical value for a minimum concentration
1937 ! *** This value is smaller than any reported tropospheric concentration
1939 ! *** Statement function given for error function. Source is
1940 ! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1941 ! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1942 ! 20:253-265. They cite Reasearch & Education Asociation (REA), (19
1943 ! Handbook of Mathematical, Scientific, and Engineering Formulas,
1944 ! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1946 erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1947 erfc(xx) = 1.0 - erf(xx)
1948 ! ::::::::::::::::::::::::::::::::::::::::
1950 ! ///// begin code
1951 ! *** set up time-step integration
1953 DO l = 1, numcells
1955 ! *** code to move number forward by one time step.
1956 ! *** solves the Ricatti equation:
1958 ! dY/dt = C - A * Y ** 2 - B * Y
1960 ! Coded 11/21/96 by Dr. Francis S. Binkowski
1962 ! *** Aitken mode:
1963 ! *** coefficients
1964 a = urn00(l)
1965 b = brna01(l)*cblk(l,vac0)
1966 c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1968 ! includes primary emissions
1969 y0 = cblk(l,vnu0)
1970 ! *** trap on C = 0
1972 ! initial condition
1973 IF (c>0.0D0) THEN
1975 dhat = sqrt(b*b+4.0D0*a*c)
1977 m1 = 2.0D0*a*c/(b+dhat)
1979 m2 = -0.5D0*(b+dhat)
1981 p = -(m1-a*y0)/(m2-a*y0)
1983 pexpdt = p*exp(-dhat*dt)
1985 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1986 ! solution
1987 ELSE
1989 ! *** rearrange solution for NUMERICAL stability
1990 ! note If B << A * Y0, the following form, although
1991 ! seemingly awkward gives the correct answer.
1993 expdt = exp(-b*dt)
1994 IF (expdt<1.0D0) THEN
1995 y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1996 ELSE
1997 y = y0
1998 END IF
2000 END IF
2001 ! if(y.lt.nummin_i)then
2002 ! print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
2003 ! print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
2004 ! print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
2005 ! endif
2007 cblk(l,vnu0) = max(nummin_i,y)
2009 ! *** now do accumulation mode number
2011 ! *** coefficients
2013 ! update
2014 a = ura00(l)
2015 b = & ! NOTE B = 0.0
2016 0.0D0
2017 c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
2018 ! includes primary emissi
2019 y0 = cblk(l,vac0)
2020 ! *** this equation requires special handling, because C can be zero.
2021 ! if this happens, the form of the equation is different:
2023 ! initial condition
2024 ! print *,vac0,y0,c,nummin_j,a
2025 IF (c>0.0D0) THEN
2027 dhat = sqrt(4.0D0*a*c)
2029 m1 = 2.0D0*a*c/dhat
2031 m2 = -0.5D0*dhat
2033 p = -(m1-a*y0)/(m2-a*y0)
2035 ! print *,p,-dhat,dt,-dhat*dt
2036 ! print *,exp(-dhat*dt)
2037 pexpdt = p*exp(-dhat*dt)
2039 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
2040 ! solution
2041 ELSE
2043 y = y0/(1.0D0+dt*a*y0)
2044 ! print *,dhat,y0,dt,a
2045 y = y0/(1.+dt*a*y0)
2046 ! print *,y
2047 ! correct solution to equation
2048 END IF
2050 cblk(l,vac0) = max(nummin_j,y)
2051 ! *** now do coarse mode number neglecting coagulation
2052 ! update
2053 ! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
2054 prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
2056 ! print *,cblk(l,vcorn),factnumc,prod
2057 cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
2059 ! *** Prepare to advance modal mass concentration one time step.
2061 ! *** Set up production and and intermodal transfer terms terms:
2062 ! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
2063 cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
2065 ! includes growth from pri
2066 cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
2067 orgfac*eorgj(l) ! and transfer of 3rd momen
2068 ! intermodal coagulation
2070 ! *** set up transfer coefficients for coagulation between Aitken and ac
2073 ! *** set up special factors for mass transfer from the Aitken to accumulation
2074 ! intermodal coagulation. The mass transfer rate is proportional to
2075 ! transfer rate, C30. The proportionality factor is p/6 times the the
2076 ! density. The average particle density for a species is the species
2077 ! divided by the particle volume concentration, pi/6 times the 3rd m
2078 ! The p/6 coefficients cancel.
2080 ! includes growth from prim
2081 ! print *,'loss',vnu3,c30(l),cblk(l,vnu3)
2082 loss = c30(l)/cblk(l,vnu3)
2084 ! Normalized coagulation transfer r
2085 factrans = loss*dt ! yields an estimate of the amount of mass t
2086 ! the Aitken to the accumulation mode in the
2088 ! Multiplying this factor by the species con
2089 ! print *,'factrans = ',factrans,loss
2090 expdt = exp(-factrans) ! decay term is common to all Aitken mode
2091 ! print *,'factrans = ',factrans,loss,expdt
2092 ! variable name is re-used here. This expo
2093 lossinv = 1.0/loss
2094 ! *** now advance mass concentrations one time step.
2096 ! *** update sulfuric acid vapor concentration by removing mass concent
2097 ! condensed sulfate and newly produced particles.
2098 ! *** The method follows Youngblood and Kreidenweis, Further Development
2099 ! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
2100 ! Atmospheric Science Paper Number 550, April,1994, pp 85-89.
2101 ! set up for multiplication rather than divi
2102 cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
2104 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
2105 ! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
2107 ! *** sulfate:
2108 mstrnsfr = cblk(l,vso4ai)*factrans
2109 prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
2110 pol = prod*lossinv
2111 ! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
2113 cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
2114 cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
2115 cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
2117 ! *** anthropogenic secondary organic:
2118 !bs * anthropogenic secondary organics from aromatic precursors
2119 !!! anthropogenic secondary organics from different precursors
2120 !!! the formulas are the same as in BS's version, only precursors and partition are different!
2122 mstrnsfr = cblk(l,vasoa1i)*factrans
2123 prod = organt1rat(l)*fconcn_org(l)
2124 pol = prod*lossinv
2126 cblk(l,vasoa1i) = pol + (cblk(l,vasoa1i)-pol)*expdt
2127 cblk(l,vasoa1i) = max(conmin,cblk(l,vasoa1i))
2128 cblk(l,vasoa1j) = cblk(l,vasoa1j) + organt1rat(l)*fconca_org(l)*dt + mstrnsfr
2129 !!!!!!!!!!!!!
2131 mstrnsfr = cblk(l,vasoa2i)*factrans
2132 prod = organt2rat(l)*fconcn_org(l)
2133 pol = prod*lossinv
2135 cblk(l,vasoa2i) = pol + (cblk(l,vasoa2i)-pol)*expdt
2136 cblk(l,vasoa2i) = max(conmin,cblk(l,vasoa2i))
2137 cblk(l,vasoa2j) = cblk(l,vasoa2j) + organt2rat(l)*fconca_org(l)*dt + mstrnsfr
2138 !!!!!!!!!!!!!
2140 mstrnsfr = cblk(l,vasoa3i)*factrans
2141 prod = organt3rat(l)*fconcn_org(l)
2142 pol = prod*lossinv
2144 cblk(l,vasoa3i) = pol + (cblk(l,vasoa3i)-pol)*expdt
2145 cblk(l,vasoa3i) = max(conmin,cblk(l,vasoa3i))
2146 cblk(l,vasoa3j) = cblk(l,vasoa3j) + organt3rat(l)*fconca_org(l)*dt + mstrnsfr
2147 !!!!!!!!!!!!!
2149 mstrnsfr = cblk(l,vasoa4i)*factrans
2150 prod = organt4rat(l)*fconcn_org(l)
2151 pol = prod*lossinv
2153 cblk(l,vasoa4i) = pol + (cblk(l,vasoa4i)-pol)*expdt
2154 cblk(l,vasoa4i) = max(conmin,cblk(l,vasoa4i))
2155 cblk(l,vasoa4j) = cblk(l,vasoa4j) + organt4rat(l)*fconca_org(l)*dt + mstrnsfr
2157 ! *** biogenic secondary organic
2158 mstrnsfr = cblk(l,vbsoa1i)*factrans
2159 prod = orgbio1rat(l)*fconcn_org(l)
2160 pol = prod*lossinv
2162 cblk(l,vbsoa1i) = pol + (cblk(l,vbsoa1i)-pol)*expdt
2163 cblk(l,vbsoa1i) = max(conmin,cblk(l,vbsoa1i))
2164 cblk(l,vbsoa1j) = cblk(l,vbsoa1j) + orgbio1rat(l)*fconca_org(l)*dt + mstrnsfr
2165 !!!!!!!!!!!!!
2167 mstrnsfr = cblk(l,vbsoa2i)*factrans
2168 prod = orgbio2rat(l)*fconcn_org(l)
2169 pol = prod*lossinv
2171 cblk(l,vbsoa2i) = pol + (cblk(l,vbsoa2i)-pol)*expdt
2172 cblk(l,vbsoa2i) = max(conmin,cblk(l,vbsoa2i))
2173 cblk(l,vbsoa2j) = cblk(l,vbsoa2j) + orgbio2rat(l)*fconca_org(l)*dt + mstrnsfr
2174 !!!!!!!!!!!!!
2176 mstrnsfr = cblk(l,vbsoa3i)*factrans
2177 prod = orgbio3rat(l)*fconcn_org(l)
2178 pol = prod*lossinv
2180 cblk(l,vbsoa3i) = pol + (cblk(l,vbsoa3i)-pol)*expdt
2181 cblk(l,vbsoa3i) = max(conmin,cblk(l,vbsoa3i))
2182 cblk(l,vbsoa3j) = cblk(l,vbsoa3j) + orgbio3rat(l)*fconca_org(l)*dt + mstrnsfr
2183 !!!!!!!!!!!!!
2185 mstrnsfr = cblk(l,vbsoa4i)*factrans
2186 prod = orgbio4rat(l)*fconcn_org(l)
2187 pol = prod*lossinv
2189 cblk(l,vbsoa4i) = pol + (cblk(l,vbsoa4i)-pol)*expdt
2190 cblk(l,vbsoa4i) = max(conmin,cblk(l,vbsoa4i))
2191 cblk(l,vbsoa4j) = cblk(l,vbsoa4j) + orgbio4rat(l)*fconca_org(l)*dt + mstrnsfr
2193 ! *** primary anthropogenic organic
2194 mstrnsfr = cblk(l,vorgpai)*factrans
2195 prod = eorgi(l)
2196 pol = prod*lossinv
2198 cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
2199 cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
2200 cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
2202 ! *** other anthropogenic PM2.5
2203 mstrnsfr = cblk(l,vp25ai)*factrans
2204 prod = epm25i(l)
2205 pol = prod*lossinv
2207 cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
2208 cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
2209 cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
2211 ! *** elemental carbon
2212 mstrnsfr = cblk(l,veci)*factrans
2213 prod = eeci(l)
2214 pol = prod*lossinv
2216 cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
2217 cblk(l,veci) = max(conmin,cblk(l,veci))
2218 cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
2220 ! *** coarse mode
2221 ! *** soil dust
2222 cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
2223 cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
2225 ! *** sea salt
2226 cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
2227 cblk(l,vseas) = max(conmin,cblk(l,vseas))
2229 ! *** anthropogenic PM10 coarse fraction
2230 cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
2231 cblk(l,vantha) = max(conmin,cblk(l,vantha))
2233 END DO
2236 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
2237 ! then merge modes by renaming.
2239 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
2241 ! end of time-step loop for total mass
2242 DO lcell = 1, numcells
2244 ! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
2245 ! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
2246 IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
2247 lcell,vnu0)>cblk(lcell,vac0)) &
2248 THEN
2250 ! check if mer
2251 aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
2252 dgacc(lcell),xxlsgn,xxlsga,sqrt2)
2254 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2255 ! dd is the diameter at which the Aitken-mode and accumulation-mo
2256 ! distributions intersect (overap).
2258 xnum = max(aaa,xxm3) ! this means that no more than one ha
2259 ! total Aitken mode number may be tra per call.
2261 ! do not let XNUM become negative bec
2262 xm3 = xnum - &
2263 xxm3
2264 ! set up for 3rd moment and mass tran
2265 IF (xm3>0.0) &
2266 THEN
2267 ! do mode merging if overlap is corr
2268 phnum = 0.5*(1.0+erf(xnum))
2269 phm3 = 0.5*(1.0+erf(xm3))
2270 fnum = 0.5*erfc(xnum)
2271 fm3 = 0.5*erfc(xm3)
2273 ! In the Aitken mode:
2275 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2276 ! distributions with diameters greater than dd respectively.
2278 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2279 ! distributions with diameters less than dd.
2281 ! *** rename the Aitken mode particle number as accumulation mode
2282 ! particle number
2284 cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2286 ! *** adjust the Aitken mode number
2288 cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2290 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2291 ! to the accumulation mode is proportional to the amount of 3rd mome
2292 ! transferred, therefore FM3 is used for mass transfer.
2294 cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2296 cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2298 cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2300 !liqy
2301 cblk(lcell,vnaaj) = cblk(lcell,vnaaj) + cblk(lcell,vnaai)*fm3
2302 cblk(lcell,vclaj) = cblk(lcell,vclaj) + cblk(lcell,vclai)*fm3
2303 cblk(lcell,vcaaj) = cblk(lcell,vcaaj) + cblk(lcell,vcaai)*fm3
2304 cblk(lcell,vkaj) = cblk(lcell,vkaj) + cblk(lcell,vkai)*fm3
2305 cblk(lcell,vmgaj) = cblk(lcell,vmgaj) + cblk(lcell,vmgai)*fm3
2306 !liqy-20140617
2308 cblk(lcell,vasoa1j) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)*fm3
2310 cblk(lcell,vasoa2j) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)*fm3
2312 cblk(lcell,vasoa3j) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)*fm3
2314 cblk(lcell,vasoa4j) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)*fm3
2316 cblk(lcell,vbsoa1j) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)*fm3
2318 cblk(lcell,vbsoa2j) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)*fm3
2320 cblk(lcell,vbsoa3j) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)*fm3
2322 cblk(lcell,vbsoa4j) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)*fm3
2324 cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + cblk(lcell,vorgpai)*fm3
2326 cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2328 cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2330 ! *** update Aitken mode for mass loss to accumulation mode
2331 cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2333 cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2335 cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2336 !liqy
2337 cblk(lcell,vnaai) = cblk(lcell,vnaai)*phm3
2338 cblk(lcell,vclai) = cblk(lcell,vclai)*phm3
2339 cblk(lcell,vcaai) = cblk(lcell,vcaai)*phm3
2340 cblk(lcell,vkai) = cblk(lcell,vkai)*phm3
2341 cblk(lcell,vmgai) = cblk(lcell,vmgai)*phm3
2342 !liqy-20140617
2344 cblk(lcell,vasoa1i) = cblk(lcell,vasoa1i)*phm3
2346 cblk(lcell,vasoa2i) = cblk(lcell,vasoa2i)*phm3
2348 cblk(lcell,vasoa3i) = cblk(lcell,vasoa3i)*phm3
2350 cblk(lcell,vasoa4i) = cblk(lcell,vasoa4i)*phm3
2352 cblk(lcell,vbsoa1i) = cblk(lcell,vbsoa1i)*phm3
2354 cblk(lcell,vbsoa2i) = cblk(lcell,vbsoa2i)*phm3
2356 cblk(lcell,vbsoa3i) = cblk(lcell,vbsoa3i)*phm3
2358 cblk(lcell,vbsoa4i) = cblk(lcell,vbsoa4i)*phm3
2360 cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2362 cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2364 cblk(lcell,veci) = cblk(lcell,veci)*phm3
2366 END IF
2367 ! end check on whether modal overlap is OK
2369 END IF
2370 ! end check on necessity for merging
2372 END DO
2373 ! set min value for all concentrations
2375 ! loop for merging
2376 DO spc = 1, nspcsda
2377 DO lcell = 1, numcells
2378 cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2379 END DO
2380 END DO
2381 !---------------------------------------------------------------------------------
2383 RETURN
2384 END SUBROUTINE aerostep
2385 !#######################################################################
2387 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2388 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2389 ! mso4,mnh4,mno3 are in microMOLES / cubic meter
2391 ! This version uses polynomials rather than tables, and uses empirical
2392 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2393 ! where:
2395 ! mfs = ms / ( ms + mw)
2396 ! ms is the mass of solute
2397 ! mw is the mass of water.
2399 ! Define y = mw/ ms
2401 ! then mfs = 1 / (1 + y)
2403 ! y can then be obtained from the values of mfs as
2405 ! y = (1 - mfs) / mfs
2408 ! the aerosol is assumed to be in a metastable state if the rh is
2409 ! is below the rh of deliquescence, but above the rh of crystallizat
2411 ! ZSR interpolation is used for sulfates with x ( the molar ratio of
2412 ! ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2413 ! section 1: 0 <= x < 1
2414 ! section 2: 1 <= x < 1.5
2415 ! section 3: 1.5 <= x < 2.0
2416 ! section 4: 2 <= x
2417 ! In sections 1 through 3, only the sulfates can affect the amount o
2418 ! on the particles.
2419 ! In section 4, we have fully neutralized sulfate, and extra ammoniu
2420 ! allows more nitrate to be present. Thus, the ammount of water is c
2421 ! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2422 ! assumed to occur in sections 2,3,and 4. See detailed discussion be
2424 ! definitions:
2425 ! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2426 ! for sulfate, ammonium, and nitrate respectively
2427 ! irhx is the relative humidity (%)
2428 ! wh2o is the returned water amount in micrograms / cubic meter of a
2429 ! x is the molar ratio of ammonium to sulfate
2430 ! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2431 ! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2432 ! y3 is the value of the mass ratio of water to solute for
2433 ! a pure ammonium nitrate solution.
2435 !coded by Dr. Francis S. Binkowski, 4/8/96.
2437 ! IMPLICIT NONE
2438 INTEGER irhx, irh
2439 REAL mso4, mnh4, mno3
2440 REAL tso4, tnh4, tno3, wh2o, x
2441 REAL aw, awc
2442 ! REAL poly4, poly6
2443 REAL mfs0, mfs1, mfs15, mfs2
2444 REAL c0(4), c1(4), c15(4), c2(4)
2445 REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2446 REAL kso4(6), kno3(6), mfsso4, mfsno3
2447 REAL mwso4, mwnh4, mwno3, mw2, mwano3
2449 ! *** molecular weights:
2450 PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2451 mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2453 ! The polynomials use data for aw as a function of mfs from Tang and
2454 ! Munkelwitz, JGR 99: 18801-18808, 1994.
2455 ! The polynomials were fit to Tang's values of water activity as a
2456 ! function of mfs.
2458 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2459 ! now give mfs as a function of water activity.
2461 DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2462 DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2463 DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2465 ! *** the following coefficients are a fit to the data in Table 1 of
2466 ! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2467 ! data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2468 ! *** New data fit to data from
2469 ! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2470 ! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2471 ! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2472 DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2474 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2475 ! Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2477 DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2478 DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2480 ! *** check range of per cent relative humidity
2481 irh = irhx
2482 irh = max(1,irh)
2483 irh = min(irh,100)
2484 aw = float(irh)/ & ! water activity = fractional relative h
2485 100.0
2486 tso4 = max(mso4,0.0)
2487 tnh4 = max(mnh4,0.0)
2488 tno3 = max(mno3,0.0)
2489 x = 0.0
2490 ! *** if there is non-zero sulfate calculate the molar ratio
2491 IF (tso4>0.0) THEN
2492 x = tnh4/tso4
2493 ELSE
2494 ! *** otherwise check for non-zero nitrate and ammonium
2495 IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2496 END IF
2498 ! *** begin screen on x for calculating wh2o
2499 IF (x<1.0) THEN
2501 mfs0 = poly4(c0,aw)
2502 mfs1 = poly4(c1,aw)
2503 y0 = (1.0-mfs0)/mfs0
2504 y1 = (1.0-mfs1)/mfs1
2505 y = (1.0-x)*y0 + x*y1
2507 ELSE IF (x<1.5) THEN
2509 IF (irh>=40) THEN
2510 mfs1 = poly4(c1,aw)
2511 mfs15 = poly4(c15,aw)
2512 y1 = (1.0-mfs1)/mfs1
2513 y15 = (1.0-mfs15)/mfs15
2514 y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2515 ELSE
2516 ! *** set up for crystalization
2518 ! *** Crystallization is done as follows:
2519 ! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2520 ! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2521 ! and since the code does not allow ar rh < 0.01, crystallization
2522 ! is assumed not to occur in this range.
2523 ! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2524 ! from a value of y15 at rh = 0.4 to a value of zero at y1. From
2525 ! point B to point A in the diagram.
2526 ! The algorithm does a double interpolation to calculate the amount
2527 ! water.
2529 ! y1(0.40) y15(0.40)
2530 ! + + Point B
2532 ! +--------------------+
2533 ! x=1 x=1.5
2534 ! Point A
2536 awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2537 y = 0.0
2538 IF (aw>=awc) & ! interpolate using crystalization
2539 THEN
2540 mfs1 = poly4(c1,0.40)
2541 mfs15 = poly4(c15,0.40)
2542 y140 = (1.0-mfs1)/mfs1
2543 y1540 = (1.0-mfs15)/mfs15
2544 y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2545 yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2546 y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2547 ! end of checking for aw
2548 END IF
2550 END IF
2551 ! end of checking on irh
2552 ELSE IF (x<1.9999) THEN
2554 y = 0.0
2555 IF (irh>=40) THEN
2556 mfs15 = poly4(c15,aw)
2557 mfs2 = poly4(c2,aw)
2558 y15 = (1.0-mfs15)/mfs15
2559 y2 = (1.0-mfs2)/mfs2
2560 y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2562 END IF
2564 ! end of check for crystallization
2566 ELSE
2567 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2569 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2570 ! *** check for crystallization here. their data indicate a 40% value
2571 ! is appropriate.
2572 ! 1.9999 < x
2573 y2 = 0.0
2574 y3 = 0.0
2575 IF (irh>=40) THEN
2576 mfsso4 = poly6(kso4,aw)
2577 mfsno3 = poly6(kno3,aw)
2578 y2 = (1.0-mfsso4)/mfsso4
2579 y3 = (1.0-mfsno3)/mfsno3
2581 END IF
2583 END IF
2584 ! *** now set up output of wh2o
2586 ! wh2o units are micrograms (liquid water) / cubic meter of air
2588 ! end of checking on x
2589 IF (x<1.9999) THEN
2591 wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2593 ELSE
2595 ! *** this is the case that all the sulfate is ammonium sulfate
2596 ! and the excess ammonium forms ammonum nitrate
2598 wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2600 END IF
2602 RETURN
2603 END SUBROUTINE awater
2604 !//////////////////////////////////////////////////////////////////////
2606 SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2607 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2608 !***********************************************************************
2609 !** DESCRIPTION: calculates aerosol coagulation rates for unimodal
2610 ! and bimodal coagulation using E. Whitby 1990's prescription.
2612 !....... Rates for coaglulation:
2613 !....... Unimodal Rates:
2614 !....... URN00: nuclei mode 0th moment self-coagulation rate
2615 !....... URA00: accumulation mode 0th moment self-coagulation rate
2617 !....... Bimodal Rates: (only 1st order coeffs appear)
2618 !....... NA-- nuclei with accumulation coagulation rates,
2619 !....... AN-- accumulation with nuclei coagulation rates
2620 !....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term)
2621 !....... BRNA31: 3rd ( d(nuclei mode 3) / dt term)
2622 !** Revision history:
2623 ! prototype 1/95 by Uma and Carlie
2624 ! Revised 8/95 by US for calculation of density from stmt func
2625 ! and collect met variable stmt funcs in one include fil
2626 ! REVISED 7/25/96 by FSB to use block structure
2627 ! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2628 ! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2629 ! changed. All coagulation coefficients
2630 ! returned with positive signs. Their
2631 ! linearization is also abandoned.
2632 ! Fixed values are used for the corrections
2633 ! to the free-molecular coagulation integra
2634 ! The code forces the harmonic means to be
2635 ! evaluated in 64 bit arithmetic on 32 bit
2636 ! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit
2638 ! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa
2639 ! because BRNA31 can become zero on a works
2640 ! because of limited precision. With the ch
2641 ! aerostep to omit update of the 3rd moment
2642 ! C30 is the only variable now needed.
2643 ! the logic using ONE88 to force REAL*8 ari
2644 ! has been removed and all intermediates ar
2645 ! REAL*8.
2646 ! IMPLICIT NONE
2648 ! dimension of arrays
2649 INTEGER blksize
2650 ! actual number of cells in arrays
2651 INTEGER numcells
2653 INTEGER nspcsda
2655 ! nmber of species in CBLK
2656 REAL cblk(blksize,nspcsda) ! main array of variables
2657 REAL blkta(blksize) ! Air temperature [ K ]
2658 REAL pdensn(blksize) ! average particel density in Aitk
2659 REAL pdensa(blksize) ! average particel density in accu
2660 REAL amu(blksize) ! atmospheric dynamic viscosity [
2661 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2662 REAL dgacc(blksize) ! accumulation mode mean diameter
2663 REAL knnuc(blksize) ! Aitken mode Knudsen number
2664 REAL knacc(blksize)
2665 ! *** output:
2667 ! accumulation mode Knudsen number
2668 REAL urn00(blksize) ! intramodal coagulation rate (Ait
2669 REAL ura00(blksize)
2670 ! intramodal coagulation rate (acc
2671 REAL brna01(blksize) ! intermodal coagulaton rate (numb
2672 REAL c30(blksize) ! by inter
2674 ! *** Local variables:
2675 ! intermodal 3rd moment transfer r
2676 REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2677 kncacc
2678 REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2679 kfmacc
2680 REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2681 kfm
2682 REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2683 bencna
2684 REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2685 bencm3n
2686 REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2687 befmna
2688 REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2689 befm3n
2690 REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2691 betana
2692 REAL*8 & ! intermodal coagulation rate for 3rd mo
2693 brna31
2694 REAL*8 & ! scratch subexpression
2695 s1
2696 REAL*8 t1, & ! scratch subexpressions
2697 t2
2698 REAL*8 t16, & ! T1**6, T2**6
2699 t26
2700 REAL*8 rat, & ! ratio of acc to nuc size and its inver
2701 rin
2702 REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2703 rsq4
2704 REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2705 rsqi3
2706 REAL*8 & ! dgnuc**3
2707 dgn3
2708 REAL*8 & ! in 64 bit arithmetic
2709 dga3
2710 ! dgacc**3
2712 INTEGER lcell
2713 ! *** Fixed values for correctionss to coagulation
2714 ! integrals for free-molecular case.
2715 ! loop counter
2716 REAL*8 bm0
2717 PARAMETER (bm0=0.8D0)
2718 REAL*8 bm0i
2719 PARAMETER (bm0i=0.9D0)
2720 REAL*8 bm3i
2721 PARAMETER (bm3i=0.9D0)
2722 REAL*8 & ! approx Cunningham corr. factor
2723 a
2724 PARAMETER (a=1.246D0)
2725 !.......................................................................
2726 ! begin body of subroutine COAGRATE
2728 !........... Main computational grid-traversal loops
2729 !........... for computing coagulation rates.
2731 ! *** Both modes have fixed std devs.
2732 DO lcell = 1, &
2733 numcells
2734 ! *** moment independent factors
2736 ! loop on LCELL
2737 s1 = two3*boltz*blkta(lcell)/amu(lcell)
2739 ! For unimodal coagualtion:
2741 kncnuc = s1
2742 kncacc = s1
2744 kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2745 kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2747 ! For bimodal coagulation:
2749 knc = s1
2750 kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2752 !........... Begin unimodal coagulation rate calculations:
2753 !........... Near-continuum regime.
2755 dgn3 = dgnuc(lcell)**3
2756 dga3 = dgacc(lcell)**3
2758 t1 = sqrt(dgnuc(lcell))
2759 t2 = sqrt(dgacc(lcell))
2760 t16 = & ! = T1**6
2761 dgn3
2762 t26 = &
2763 dga3
2764 !....... Note rationalization of fractions and subsequent cancellation
2765 !....... from the formulation in Whitby et al. (1990)
2767 ! = T2**6
2768 bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2770 bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2772 !........... Free molecular regime. Uses fixed value for correction
2773 ! factor BM0
2775 befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2776 befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2778 !........... Calculate half the harmonic mean between unimodal rates
2779 !........... free molecular and near-continuum regimes
2781 ! FSB 64 bit evaluation
2783 betann = bencnn*befmnn/(bencnn+befmnn)
2784 betana = bencna*befmna/(bencna+befmna)
2786 urn00(lcell) = betann
2787 ura00(lcell) = betana
2789 ! *** End of unimodal coagulation calculations.
2791 !........... Begin bimodal coagulation rate calculations:
2793 rat = dgacc(lcell)/dgnuc(lcell)
2794 rin = 1.0D0/rat
2795 rsqt = sqrt(rat)
2796 rsq4 = rat**2
2798 rsqti = 1.0D0/rsqt
2799 rsqi3 = rin*rsqti
2801 !........... Near-continuum coeffs:
2802 !........... 0th moment nuc mode bimodal coag coefficient
2804 bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2805 )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2807 !........... 3rd moment nuc mode bimodal coag coefficient
2809 bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2810 *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2811 rin*esn64*esa04)
2813 !........... Free molecular regime coefficients:
2814 !........... Uses fixed value for correction
2815 ! factor BM0I, BM3I
2816 !........... 0th moment nuc mode coeff
2818 befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2819 rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2821 !........... 3rd moment nuc mode coeff
2823 befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2824 rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2827 !........... Calculate half the harmonic mean between bimodal rates
2828 !........... free molecular and near-continuum regimes
2830 ! FSB Force 64 bit evaluation
2832 brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2834 brna31 = bencm3n* & ! BRNA31 now is a scala
2835 befm3n/(bencm3n+befm3n)
2836 c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2837 ! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2838 ! 3d moment transfer by intermodal coagula
2839 ! End bimodal coagulation rate.
2841 END DO
2842 ! end of main lop over cells
2843 RETURN
2844 END SUBROUTINE coagrate
2845 !------------------------------------------------------------------
2847 ! subroutine to find the roots of a cubic equation / 3rd order polynomi
2848 ! formulae can be found in numer. recip. on page 145
2849 ! kiran developed this version on 25/4/1990
2850 ! dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2851 ! ***
2852 !234567
2853 ! coagrate
2854 SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2855 ! IMPLICIT NONE
2856 INTEGER nr
2857 REAL*8 a2, a1, a0
2858 REAL crutes(3)
2859 REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2860 REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2861 REAL*8 costh, sinth
2862 DATA sqrt3/1.732050808/, one3rd/0.333333333/
2863 !bs
2864 REAL*8 onebs
2865 PARAMETER (onebs=1.0)
2866 !bs
2867 a2sq = a2*a2
2868 qq = (a2sq-3.*a1)/9.
2869 rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2870 ! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT
2871 dum1 = qq*qq*qq
2872 rrsq = rr*rr
2873 dum2 = dum1 - rrsq
2874 IF (dum2>=0.) THEN
2875 ! NOW WE HAVE THREE REAL ROOTS
2876 phi = sqrt(dum1)
2877 IF (abs(phi)<1.E-20) THEN
2878 print *, ' cubic phi small, phi = ',phi
2879 crutes(1) = 0.0
2880 crutes(2) = 0.0
2881 crutes(3) = 0.0
2882 nr = 0
2883 CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2884 END IF
2885 theta = acos(rr/phi)/3.0
2886 costh = cos(theta)
2887 sinth = sin(theta)
2888 ! *** use trig identities to simplify the expressions
2889 ! *** binkowski's modification
2890 part1 = sqrt(qq)
2891 yy1 = part1*costh
2892 yy2 = yy1 - a2/3.0
2893 yy3 = sqrt3*part1*sinth
2894 crutes(3) = -2.0*yy1 - a2/3.0
2895 crutes(2) = yy2 + yy3
2896 crutes(1) = yy2 - yy3
2897 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2898 IF (crutes(1)<0.0) crutes(1) = 1.0E9
2899 IF (crutes(2)<0.0) crutes(2) = 1.0E9
2900 IF (crutes(3)<0.0) crutes(3) = 1.0E9
2901 ! *** put smallest positive root in crutes(1)
2902 crutes(1) = min(crutes(1),crutes(2),crutes(3))
2903 nr = 3
2904 ! NOW HERE WE HAVE ONLY ONE REAL ROOT
2905 ELSE
2906 ! dum IS NEGATIVE
2907 part1 = sqrt(rrsq-dum1)
2908 part2 = abs(rr)
2909 part3 = (part1+part2)**one3rd
2910 crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2911 !bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2912 crutes(2) = 0.
2913 crutes(3) = 0.
2914 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2915 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2916 ! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2917 nr = 1
2918 END IF
2919 RETURN
2920 END SUBROUTINE cubic
2921 !///////////////////////////////////////////////////////////////////////
2923 !liqy
2924 ! Calculate the aerosol chemical speciation and water content.
2925 ! cubic
2926 SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
2927 !***********************************************************************
2928 !** DESCRIPTION:
2929 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2930 ! and water between the gas and aerosol phases as the total sulfate,
2931 ! ammonia, and nitrate concentrations, relative humidity and
2932 ! temperature change. The evolution of the aerosol mass concentration
2933 ! due to the change in aerosol chemical composition is calculated.
2934 !** REVISION HISTORY:
2935 ! prototype 1/95 by Uma and Carlie
2936 ! Revised 8/95 by US to calculate air density in stmt func
2937 ! and collect met variable stmt funcs in one include fil
2938 ! Revised 7/26/96 by FSB to use block concept.
2939 ! Revise 12/1896 to do do i-mode calculation.
2940 !**********************************************************************
2941 ! IMPLICIT NONE
2943 ! dimension of arrays
2944 INTEGER blksize
2945 ! actual number of cells in arrays
2946 INTEGER numcells
2947 ! nmber of species in CBLK
2948 INTEGER nspcsda,igrid,jgrid,kgrid
2949 REAL cblk(blksize,nspcsda)
2950 ! *** Meteorological information in blocked arays:
2952 ! main array of variables
2953 REAL blkta(blksize) ! Air temperature [ K ]
2954 REAL blkrh(blksize) ! Fractional relative humidity
2956 INTEGER lcell ! loop counter
2957 ! air temperature
2958 REAL temp
2959 !iamodels3
2960 REAL rh
2961 ! relative humidity
2962 REAL so4, no3, nh3, nh4, hno3
2963 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2964 ! Fraction of dry sulfate mass in i-mode
2965 REAL fraci
2966 REAL fracj
2967 ! Fraction of dry sulfate mass in j-mode
2969 ! ISOROPIA variables double precision
2970 ! real(kind=8) wi(5),wt(5),wt_save(5)
2971 ! real(kind=8) rhi,tempi,cntrl(2)
2972 ! real(kind=8) gas(3),aerliq(12),aersld(9),other(6)
2973 ! character*15 scasi
2975 !aerosol phase na,cl. gas phase hcl.
2976 REAL ana,acl,aca,ak,amg
2977 REAL ghcl
2978 !delta nh3, hno3, and hcl in gaseous phase.
2979 real dgnh3,dgno3,dghcl
2980 !dmax equals to the maximum available nh4+, no3-, and cl- for evaporation.
2981 real dmax
2982 ! ISOROPIA variables
2983 DOUBLE PRECISION WI(8), GAS(3), AERLIQ(15), AERSLD(19), CNTRL(2), &
2984 WT(8), OTHER(9), RHI, TEMPI
2985 CHARACTER SCASE*15
2987 !molecular weight for all isorropia species
2989 REAL intmw(37)
2990 DATA intmw/1.008, &
2991 22.990, 18.039, 35.453, 96.061, 97.069, 62.004, 18.015, &
2992 17.031, 36.461, 63.012, 17.007, 40.078, 39.098, 24.305, 84.994,&
2993 80.043, 58.443, 53.492, 142.041, 132.139, 120.059, 115.108, &
2994 247.247, 136.139, 164.086, 110.984, 174.257, 136.167, 101.102, &
2995 74.551, 120.366, 148.313, 95.211, 17.031, 63.012, 36.461 /
2997 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
2998 REAL dgacc(blksize) ! accumulation geometric mean diamet
2999 REAL dgcor(blksize)
3000 REAL dtstep
3002 !intmw AERLIQ Name
3003 ! 1 1 H+
3004 ! 2 2 Na+
3005 ! 3 3 NH4+
3006 ! 4 4 Cl-
3007 ! 5 5 SO42-
3008 ! 6 6 HSO4-
3009 ! 7 7 NO3-
3010 ! 8 8 H2O
3011 ! 9 9 NH3
3012 ! 10 10 HCL
3013 ! 11 11 HNO3
3014 ! 12 12 OH-
3015 ! 13 13 Ca2+
3016 ! 14 14 K+
3017 ! 15 15 Mg2+
3019 !intmw AERSLD Name
3020 ! 16 1 NaNO3
3021 ! 17 2 NH4NO3
3022 ! 18 3 NaCl
3023 ! 19 4 NH4Cl
3024 ! 20 5 Na2SO4
3025 ! 21 6 (NH4)2SO4
3026 ! 22 7 NaHSO4
3027 ! 23 8 NH4HSO4
3028 ! 24 9 (NH4)3H(SO4)2
3029 ! 25 10 CaSO4
3030 ! 26 11 Ca(NO3)2
3031 ! 27 12 CaCl2
3032 ! 28 13 K2SO4
3033 ! 29 14 KHSO4
3034 ! 30 15 KNO3
3035 ! 31 16 KCL
3036 ! 32 17 MgSO4
3037 ! 33 18 Mg(NO3)2
3038 ! 34 19 MgCl2
3039 !intmw GAS Name
3040 ! 35 1 NH3
3041 ! 36 2 HNO3
3042 ! 37 3 HCL
3044 character*8 date
3045 character*10 time
3046 character*5 zone
3047 integer*4 values(8)
3050 DO lcell = 1,numcells
3051 ! equilibrium for the fine mode.
3052 ! *** Fetch temperature, fractional relative humidity, and air density
3053 temp = blkta(lcell)
3054 rh = blkrh(lcell)
3055 RHI = DBLE(rh)
3056 TEMPI = DBLE(temp) ! Temperature (K) provided by phys
3058 WI(1) = DBLE(((cblk(lcell,vnaaj) + cblk(lcell,vnaai)) &
3059 /22.99)*1.e-6) ! sodium
3061 WI(2) = DBLE( &
3062 ((cblk(lcell,vso4aj) + cblk(lcell,vso4ai)) &
3063 /96.061)*1.e-6) ! sulfate
3065 WI(3) = DBLE(((cblk(lcell,vnh3)/(18.039-1.)) + &
3066 ((cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)) &
3067 /18.039))*1.e-6) ! ammoinum
3069 WI(4) = DBLE(((cblk(lcell,vhno3)/(62.004+1.)) + &
3070 ((cblk(lcell,vno3aj) + cblk(lcell,vno3ai)) &
3071 /62.004))*1.e-6) ! nitrate
3073 WI(5) = DBLE(((cblk(lcell,vhcl)/(35.453+1.)) + &
3074 ((cblk(lcell,vclaj) + cblk(lcell,vclai)) &
3075 /35.453))*1.e-6) ! chloride
3077 WI(6) = DBLE((cblk(lcell,vcaaj) + cblk(lcell,vcaai)) &
3078 /40.078*1.e-6) !calcium
3080 WI(7) = DBLE((cblk(lcell,vkaj) + cblk(lcell,vkai)) &
3081 /39.098*1.e-6) !potassium
3083 WI(8) = DBLE((cblk(lcell,vmgaj) + cblk(lcell,vmgai)) &
3084 /24.305*1.e-6) !magnesium
3087 CNTRL(1) = DBLE(0.) ! 0=FORWARD PROBLEM, 1=REVERSE PROBLEM
3088 CNTRL(2) = DBLE(1.) ! 0=SOLID+LIQUID AEROSOL, 1=METASTABLE
3090 CALL ISOROPIA2p1 (WI, RHI, TEMPI, CNTRL, &
3091 WT, GAS, AERLIQ, AERSLD, SCASE, OTHER)
3093 !****************************************************************************
3095 gnh3 = real(GAS(1)*DBLE(17.031)*1.D6) ! in ug/m3
3096 anh4 = real((wt(3) - gas(1))*DBLE(18.039)*1.D6)
3097 gno3 = real(GAS(2)*DBLE(63.012)*1.D6) ! in ug/m3
3098 ano3 = real((wt(4) - gas(2))*DBLE(62.004)*1.D6)
3099 ghcl = real(GAS(3)*DBLE(36.461)*1.D6) ! in ug/m3
3100 acl = real((wt(5) - gas(3))*DBLE(35.453)*1.D6)
3102 aso4 = real(wt(2)*DBLE(96.061)*1.D6) ! in ug/m3
3104 ah2o = real(AERLIQ(8)*DBLE(18.015)*1.D6) !H2O
3105 ana = real(wt(1)*DBLE(22.99)*1.D6)
3106 aca = real(wt(6)*DBLE(40.078)*1.D6)
3107 ak = real(wt(7)*DBLE(39.098)*1.D6)
3108 amg = real(wt(8)*DBLE(24.305)*1.D6)
3109 !****************************************************************************
3110 !****************************************************************************
3111 ! *** the following is an interim procedure. Assume the i-mode has the
3112 ! same relative mass concentrations as the total mass. Use SO4 as
3113 ! the surrogate.
3115 ! *** get modal fraction
3116 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3117 fracj = 1.0 - fraci
3119 ! *** update do i-mode
3120 cblk(lcell,vso4ai) = fraci*aso4
3122 cblk(lcell,vh2oai) = fraci*ah2o
3123 cblk(lcell,vnh4ai) = fraci*anh4
3124 cblk(lcell,vno3ai) = fraci*ano3
3125 cblk(lcell,vnaai) = fraci*ana
3126 cblk(lcell,vclai) = fraci*acl
3127 cblk(lcell,vcaai) = fraci*aca
3128 cblk(lcell,vkai) = fraci*ak
3129 cblk(lcell,vmgai) = fraci*amg
3131 ! *** update accumulation mode:
3132 cblk(lcell,vso4aj) = fracj*aso4
3134 cblk(lcell,vh2oaj) = fracj*ah2o
3135 cblk(lcell,vnh4aj) = fracj*anh4
3136 cblk(lcell,vno3aj) = fracj*ano3
3137 cblk(lcell,vnaaj) = fracj*ana
3138 cblk(lcell,vclaj) = fracj*acl
3139 cblk(lcell,vcaaj) = fracj*aca
3140 cblk(lcell,vkaj) = fracj*ak
3141 cblk(lcell,vmgaj) = fracj*amg
3143 ! *** update gas / vapor phase
3144 cblk(lcell,vnh3) = gnh3
3145 cblk(lcell,vhno3) = gno3
3146 cblk(lcell,vhcl) = ghcl
3147 ! cblk(lcell,vsulf) = epsilc
3148 !end threatment for the equilibrium for fine mode.
3149 !**************************************************************************************
3150 END DO ! end loop on cells
3152 RETURN
3154 END SUBROUTINE eql3
3155 !liqy-20140709
3158 SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
3159 !***********************************************************************
3160 !** DESCRIPTION:
3161 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
3162 ! and water between the gas and aerosol phases as the total sulfate,
3163 ! ammonia, and nitrate concentrations, relative humidity and
3164 ! temperature change. The evolution of the aerosol mass concentration
3165 ! due to the change in aerosol chemical composition is calculated.
3166 !** REVISION HISTORY:
3167 ! prototype 1/95 by Uma and Carlie
3168 ! Revised 8/95 by US to calculate air density in stmt func
3169 ! and collect met variable stmt funcs in one include fil
3170 ! Revised 7/26/96 by FSB to use block concept.
3171 ! Revise 12/1896 to do do i-mode calculation.
3172 !**********************************************************************
3173 ! IMPLICIT NONE
3175 ! dimension of arrays
3176 INTEGER blksize
3177 ! actual number of cells in arrays
3178 INTEGER numcells
3179 ! nmber of species in CBLK
3180 INTEGER nspcsda
3181 REAL cblk(blksize,nspcsda)
3182 ! *** Meteorological information in blocked arays:
3184 ! main array of variables
3185 REAL blkta(blksize) ! Air temperature [ K ]
3186 REAL blkrh(blksize)
3188 ! Fractional relative humidity
3190 INTEGER lcell
3191 ! loop counter
3192 ! air temperature
3193 REAL temp
3194 !iamodels3
3195 REAL rh
3196 ! relative humidity
3197 REAL so4, no3, nh3, nh4, hno3
3198 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
3199 ! Fraction of dry sulfate mass in i-mode
3200 REAL fraci
3201 !.......................................................................
3202 REAL fracj
3203 ! Fraction of dry sulfate mass in j-mode
3204 DO lcell = 1, &
3205 numcells
3206 ! *** Fetch temperature, fractional relative humidity, and
3207 ! air density
3209 ! loop on cells
3210 temp = blkta(lcell)
3211 rh = blkrh(lcell)
3213 ! *** the following is an interim procedure. Assume the i-mode has the
3214 ! same relative mass concentrations as the total mass. Use SO4 as
3215 ! the surrogate. The results of this should be the same as those
3216 ! from the original RPM.
3218 ! *** do total aerosol
3219 so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
3221 !iamodels3
3222 no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
3223 ! & + CBLK(LCELL, VHNO3)
3225 hno3 = cblk(lcell,vhno3)
3227 !iamodels3
3229 nh3 = cblk(lcell,vnh3)
3231 nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
3232 ! & + CBLK(LCELL, VNH3)
3234 !bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
3235 !bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
3236 !bs
3237 !bs * call old version of rpmares
3238 !bs
3239 CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
3240 gnh3,gno3)
3241 !bs
3243 ! *** get modal fraction
3244 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3245 fracj = 1.0 - fraci
3247 ! *** update do i-mode
3249 cblk(lcell,vh2oai) = fraci*ah2o
3250 cblk(lcell,vnh4ai) = fraci*anh4
3251 cblk(lcell,vno3ai) = fraci*ano3
3253 ! *** update accumulation mode:
3255 cblk(lcell,vh2oaj) = fracj*ah2o
3256 cblk(lcell,vnh4aj) = fracj*anh4
3257 cblk(lcell,vno3aj) = fracj*ano3
3260 ! *** update gas / vapor phase
3261 cblk(lcell,vnh3) = gnh3
3262 cblk(lcell,vhno3) = gno3
3264 END DO
3265 ! end loop on cells
3266 RETURN
3268 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3269 END SUBROUTINE eql4
3270 ! eql4
3272 SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
3273 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3274 !bs !
3275 !bs Description: !
3276 !bs !
3277 !bs Get the Jacobian of the function !
3278 !bs !
3279 !bs ( a1 * X1^2 + b1 * X1 + c1 ) !
3280 !bs ( a2 * X2^2 + b2 * X1 + c2 ) !
3281 !bs ( a3 * X3^2 + b3 * X1 + c3 ) !
3282 !bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. !
3283 !bs ( a5 * X5^2 + b5 * X1 + c5 ) !
3284 !bs ( a6 * X6^2 + b6 * X1 + c6 ) !
3285 !bs !
3286 !bs a_i = IMW_i !
3287 !bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i !
3288 !bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] !
3289 !bs !
3290 !bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j !
3291 !bs J_ij = ----------- = ( !
3292 !bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j !
3293 !bs !
3294 !bs !
3295 !bs Called by: NEWT !
3296 !bs !
3297 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3298 !bs
3299 ! IMPLICIT NONE
3300 !bs
3301 !bs
3302 !dimension of problem
3303 INTEGER n
3304 REAL x(n) !bs
3305 ! INTEGER NP !bs maximum expected value of N
3306 ! PARAMETER (NP = 6)
3307 !bs initial guess of CAER
3308 REAL ct(np)
3309 REAL cs(np)
3310 REAL imw(np)
3311 !bs
3312 REAL fjac(n,n)
3313 !bs
3314 INTEGER i, & !bs loop index
3315 j
3316 REAL a(np)
3317 REAL b(np)
3318 REAL b1(np)
3319 REAL b2(np)
3320 REAL sum_jnei
3321 !bs
3322 DO i = 1, n
3323 a(i) = imw(i)
3324 sum_jnei = 0.
3325 DO j = 1, n
3326 sum_jnei = sum_jnei + x(j)*imw(j)
3327 END DO
3328 b1(i) = sum_jnei - (x(i)*imw(i))
3329 b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
3330 b(i) = b1(i) + b2(i)
3331 END DO
3332 DO j = 1, n
3333 DO i = 1, n
3334 IF (i==j) THEN
3335 fjac(i,j) = 2.*a(i)*x(i) + b(i)
3336 ELSE
3337 fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
3338 END IF
3339 END DO
3340 END DO
3341 !bs
3342 RETURN
3343 END SUBROUTINE fdjac
3344 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3345 FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
3346 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3347 !bs !
3348 !bs Description: !
3349 !bs !
3350 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3351 !bs !
3352 !bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, !
3353 !bs user-supplied routine that returns the vector of functions at X. !
3354 !bs The common block NEWTV communicates the function values back to !
3355 !bs NEWT. !
3356 !bs !
3357 !bs Called by: NEWT !
3358 !bs !
3359 !bs Calls: FUNCV !
3360 !bs !
3361 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3363 ! IMPLICIT NONE
3365 !bs
3366 !bs
3367 INTEGER n
3368 ! INTEGER NP
3369 ! PARAMETER (NP = 6)
3370 REAL ct(np)
3371 REAL cs(np)
3372 REAL imw(np)
3373 REAL m,fmin
3374 REAL x(*), fvec(np)
3376 INTEGER i
3377 REAL sum
3379 CALL funcv(n,x,fvec,ct,cs,imw,m)
3380 sum = 0.
3381 DO i = 1, n
3382 sum = sum + fvec(i)**2
3383 END DO
3384 fmin = 0.5*sum
3385 RETURN
3386 END FUNCTION fmin
3387 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3388 SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
3389 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3390 !bs !
3391 !bs Description: !
3392 !bs !
3393 !bs Called by: FMIN !
3394 !bs !
3395 !bs Calls: None !
3396 !bs !
3397 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3398 !bs
3399 ! IMPLICIT NONE
3400 !bs
3401 !bs
3402 INTEGER n
3403 REAL x(*)
3404 REAL fvec(n)
3405 !bs
3406 ! INTEGER NP
3407 ! PARAMETER (NP = 6)
3408 REAL ct(np)
3409 REAL cs(np)
3410 REAL imw(np)
3411 REAL m
3412 !bs
3413 INTEGER i, j
3414 REAL sum_jnei
3415 REAL a(np)
3416 REAL b(np)
3417 REAL c(np)
3418 !bs
3419 DO i = 1, n
3420 a(i) = imw(i)
3421 sum_jnei = 0.
3422 DO j = 1, n
3423 sum_jnei = sum_jnei + x(j)*imw(j)
3424 END DO
3425 sum_jnei = sum_jnei - (x(i)*imw(i))
3426 b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
3427 c(i) = -ct(i)*(sum_jnei+m)
3428 fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
3429 END DO
3430 !bs
3431 RETURN
3432 END SUBROUTINE funcv
3433 REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
3434 ! *** set up new processor for renaming of particles from i to j modes
3435 ! IMPLICIT NONE
3436 REAL aa, bb, cc, disc, qq, alfa, l, yji
3437 REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
3439 alfa = xlsgi/xlsgj
3440 yji = log(dgnj/dgni)/(sqrt2*xlsgi)
3441 aa = 1.0 - alfa*alfa
3442 l = log(alfa*nj/ni)
3443 bb = 2.0*yji*alfa*alfa
3444 cc = l - yji*yji*alfa*alfa
3445 disc = bb*bb - 4.0*aa*cc
3446 IF (disc<0.0) THEN
3447 getaf = - & ! error in intersection
3448 5.0
3449 RETURN
3450 END IF
3451 qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3452 getaf = cc/qq
3453 RETURN
3454 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3455 END FUNCTION getaf
3456 ! Parameterization for sulfuric acid/water
3457 ! nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3458 ! April 20, 1998.
3460 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3461 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3463 !ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3464 ! getaf
3465 SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3466 ! IMPLICIT NONE
3468 ! *** Input:
3470 ! ambient temperature [ K ]
3471 REAL temp
3472 ! fractional relative humidity
3473 REAL rh
3474 ! sulfuric acid concentration [ ug / m**3 ]
3475 REAL h2so4
3477 REAL so4rat
3478 ! *** Output:
3480 !sulfuric acid production rate [ ug / ( m**3 s )]
3481 ! particle number production rate [ # / ( m**3 s )]
3482 REAL ndot1
3483 ! particle mass production rate [ ug / ( m**3 s )]
3484 REAL mdot1
3485 ! [ m**2 / ( m**3 s )]
3486 REAL m2dot
3488 ! *** Internal:
3490 ! *** NOTE, all units are cgs internally.
3491 ! particle second moment production rate
3493 REAL ra
3494 ! fractional relative acidity
3495 ! sulfuric acid vaper concentration [ cm ** -3 ]
3496 REAL nav
3497 ! water vapor concentration [ cm ** -3 ]
3498 REAL nwv
3499 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3500 REAL nav0
3501 ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1
3502 REAL nac
3503 ! critical sulfuric acid vapor concentration [ cm ** -3
3504 ! mole fractio of the critical nucleus
3505 REAL xal
3506 REAL nsulf, & ! see usage
3507 delta
3508 REAL*8 & ! factor to calculate Jnuc
3509 chi
3510 REAL*8 &
3511 jnuc
3512 ! nucleation rate [ cm ** -3 s ** -1 ]
3513 REAL tt, & ! dummy variables for statement functions
3514 rr
3515 REAL pi
3516 PARAMETER (pi=3.14159265)
3518 REAL pid6
3519 PARAMETER (pid6=pi/6.0)
3521 ! avogadro's constant [ 1/mol ]
3522 REAL avo
3523 PARAMETER (avo=6.0221367E23)
3525 ! universal gas constant [ j/mol-k ]
3526 REAL rgasuniv
3527 PARAMETER (rgasuniv=8.314510)
3529 ! 1 atmosphere in pascals
3530 REAL atm
3531 PARAMETER (atm=1013.25E+02)
3533 ! formula weight for h2so4 [ g mole **-1 ]
3534 REAL mwh2so4
3535 PARAMETER (mwh2so4=98.07948)
3537 ! diameter of a 3.5 nm particle in cm
3538 REAL d35
3539 PARAMETER (d35=3.5E-07)
3540 REAL d35sq
3541 PARAMETER (d35sq=d35*d35)
3542 ! volume of a 3.5 nm particle in cm**3
3543 REAL v35
3544 PARAMETER (v35=pid6*d35*d35sq)
3545 !ia rev01
3547 REAL mp
3548 ! *** conversion factors:
3549 ! mass of sulfate in a 3.5 nm particle
3550 ! number per cubic cm.
3551 REAL ugm3_ncm3
3552 ! micrograms per cubic meter to
3553 PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3554 !ia rev01
3555 ! molecules to micrograms
3556 REAL nc_ug
3557 PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3559 ! *** statement functions **************
3561 REAL pdens, &
3562 rho_p
3563 ! particle density [ g / cm**3]
3564 REAL ad0, ad1, ad2, &
3565 ad3
3566 ! coefficients for density expression
3567 PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3568 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3569 ! as a function of relative humidity,
3570 ! J. Aerosol Science, 6, pp 265-271, 1975.
3572 !ia rev01
3574 ! fit to Nair & Vohra data
3575 ! the mass of sulfate in a 3.5 nm particle
3576 REAL mp35
3577 ! arithmetic statement function to compute
3578 REAL a0, a1, a2, & ! coefficients for cubic in mp35
3579 a3
3580 PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3582 REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ]
3583 ph2o
3585 ! arithmetic statement functions
3586 pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3588 ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3590 ph2so4(tt) = exp(27.78492066-10156.0/tt)
3592 ! *** both ph2o and ph2so4 are as in Kulmala et al. paper
3594 !ia rev01
3596 ! *** function for the mass of sulfate in a 3.5 nm sphere
3597 ! *** obtained from a fit to the number of sulfate monomers in
3598 ! a 3.5 nm particle. Uses data from Nair & Vohra
3599 mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3601 ! *** begin code:
3603 ! The 1.0e-6 factor in the following converts from MKS to cgs units
3605 ! *** get water vapor concentration [ molecles / cm **3 ]
3607 nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3609 ! *** calculate the equilibrium h2so4 vapor concentration.
3611 ! *** use Kulmala corrections:
3613 ! ***
3614 nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3616 ! *** convert sulfuric acid vapor concentration from micrograms
3617 ! per cubic meter to molecules per cubic centimeter.
3619 nav = ugm3_ncm3*h2so4
3621 ! *** calculate critical concentration of sulfuric acid vapor
3623 nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3625 ! *** calculate relative acidity
3627 ra = nav/nav0
3629 ! *** calculate temperature correction
3631 delta = 1.0 + (temp-273.15)/273.14
3633 ! *** calculate molar fraction
3635 xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3636 0.0016*temp
3638 ! *** calculate Nsulf
3639 nsulf = log(nav/nac)
3641 ! *** calculate particle produtcion rate [ # / cm**3 ]
3643 chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3644 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3646 jnuc = exp(chi)
3647 ! [ # / cm**3 ]
3648 ndot1 = (1.0E06)*jnuc
3649 ! write(91,*) ' inside klpnuc '
3650 ! write(91,*) ' Jnuc = ', Jnuc
3651 ! write(91,*) ' NDOT = ', NDOT1
3653 ! *** calculate particle density
3655 rho_p = pdens(rh)
3657 ! write(91,*) ' rho_p =', rho_p
3659 ! *** get the mass of sulfate in a 3.5 nm particle
3661 mp = mp35(rh) ! in a 3.5 nm particle at ambient RH
3663 ! *** calculate mass production rate [ ug / m**3]
3664 ! assume that the particles are 3.5 nm in diameter.
3666 ! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc
3668 !ia rev01
3670 ! number of micrograms of sulfate
3671 mdot1 = mp*ndot1
3673 !ia rev02
3675 IF (mdot1>so4rat) THEN
3677 mdot1 = &
3678 so4rat
3679 ! limit nucleated mass by available ma
3680 ndot1 = mdot1/ &
3681 mp
3682 ! adjust DNDT to this
3683 END IF
3685 IF (mdot1==0.) ndot1 = 0.
3687 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3689 m2dot = 1.0E-04*d35sq*ndot1
3691 RETURN
3693 END SUBROUTINE klpnuc
3694 !------------------------------------------------------------------------------
3696 SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3697 pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3698 knacc,kncor)
3700 !** DESCRIPTION:
3701 ! Calculates modal parameters and derived variables,
3702 ! log-squared of std deviation, mode mean size, Knudsen number)
3703 ! based on current values of moments for the modes.
3704 ! FSB Now calculates the 3rd moment, mass, and density in all 3 modes.
3705 !**
3706 !** Revision history:
3707 ! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3708 ! Revised 7/23/96 by FSB to use COMMON blocks and small blocks
3709 ! instead of large 3-d arrays, and to assume a fixed std.
3710 ! Revised 12/06/96 by FSB to include coarse mode
3711 ! Revised 1/10/97 by FSB to have arrays passed in call vector
3712 !**********************************************************************
3714 ! IMPLICIT NONE
3716 ! Includes:
3718 ! *** input:
3720 ! dimension of arrays
3721 INTEGER blksize
3722 ! actual number of cells in arrays
3723 INTEGER numcells
3725 INTEGER nspcsda
3727 ! nmber of species in CBLK
3728 REAL cblk(blksize,nspcsda) ! main array of variables
3729 REAL blkta(blksize) ! Air temperature [ K ]
3730 REAL blkprs(blksize)
3731 ! *** output:
3733 ! Air pressure in [ Pa ]
3734 ! concentration lower limit [ ug/m*
3735 ! lowest particle diameter ( m )
3736 REAL dgmin
3737 PARAMETER (dgmin=1.0E-09)
3739 ! lowest particle density ( Kg/m**3
3740 REAL densmin
3741 PARAMETER (densmin=1.0E03)
3743 REAL pmassn(blksize) ! mass concentration in nuclei mode
3744 REAL pmassa(blksize) ! mass concentration in accumulation
3745 REAL pmassc(blksize) ! mass concentration in coarse mode
3746 REAL pdensn(blksize) ! average particel density in Aitken
3747 REAL pdensa(blksize) ! average particel density in accumu
3748 REAL pdensc(blksize) ! average particel density in coarse
3749 REAL xlm(blksize) ! atmospheric mean free path [ m]
3750 REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3751 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3752 REAL dgacc(blksize) ! accumulation
3753 REAL dgcor(blksize) ! coarse mode
3754 REAL knnuc(blksize) ! Aitken mode Knudsen number
3755 REAL knacc(blksize) ! accumulation
3756 REAL kncor(blksize)
3758 ! coarse mode
3760 INTEGER lcell
3761 ! WRITE(20,*) ' IN MODPAR '
3763 ! *** set up aerosol 3rd moment, mass, density
3765 ! loop counter
3766 DO lcell = 1, numcells
3768 ! *** Aitken-mode
3769 ! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3770 cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3771 vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3772 vh2oai)+no3fac*cblk(lcell,vno3ai)+ &
3773 nafac*cblk(lcell,vnaai)+ clfac*cblk(lcell,vclai)+ &
3774 !liqy
3775 cafac*cblk(lcell,vcaai)+ kfac*cblk(lcell,vkai) + &
3776 mgfac*cblk(lcell,vmgai)+ &
3777 !liqy-20140616
3778 orgfac*cblk(lcell, &
3779 vasoa1i)+orgfac*cblk(lcell,vasoa2i)+orgfac*cblk(lcell, &
3780 vasoa3i)+orgfac*cblk(lcell,vasoa4i)+orgfac*cblk(lcell, &
3781 vbsoa1i)+orgfac*cblk(lcell,vbsoa2i)+orgfac*cblk(lcell, &
3782 vbsoa3i)+orgfac*cblk(lcell,vbsoa4i)+orgfac*cblk(lcell, &
3783 vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
3784 ! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan
3786 ! *** Accumulation-mode
3787 ! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3788 cblk(lcell,vac3) = so4fac*cblk(lcell, &
3789 vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
3790 vh2oaj)+no3fac*cblk(lcell,vno3aj) + &
3791 nafac*cblk(lcell,vnaaj)+ clfac*cblk(lcell,vclaj)+ &
3792 !liqy
3793 cafac*cblk(lcell,vcaaj)+ kfac*cblk(lcell,vkaj) + &
3794 mgfac*cblk(lcell,vmgaj)+ &
3795 !liqy-20140616
3796 orgfac*cblk(lcell, &
3797 vasoa1j)+orgfac*cblk(lcell,vasoa2j)+orgfac*cblk(lcell, &
3798 vasoa3j)+orgfac*cblk(lcell,vasoa4j)+orgfac*cblk(lcell, &
3799 vbsoa1j)+orgfac*cblk(lcell,vbsoa2j)+orgfac*cblk(lcell, &
3800 vbsoa3j)+orgfac*cblk(lcell,vbsoa4j)+orgfac*cblk(lcell, &
3801 vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
3802 ! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan
3804 ! *** coarse mode
3805 ! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
3806 ! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
3808 cblk(lcell,vcor3) = soilfac*cblk(lcell, &
3809 vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
3811 ! *** now get particle mass and density
3813 ! *** Aitken-mode:
3814 pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
3815 vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
3816 vasoa1i)+cblk(lcell,vasoa2i)+cblk(lcell,vasoa3i)+cblk(lcell, &
3817 vasoa4i)+cblk(lcell,vbsoa1i)+cblk(lcell,vbsoa2i)+cblk(lcell, &
3818 vbsoa3i)+cblk(lcell,vbsoa4i)+cblk(lcell,vorgpai)+cblk(lcell, &
3819 ! vp25ai)+cblk(lcell,veci)))
3820 !liqy
3821 vp25ai)+cblk(lcell,veci)+cblk(lcell,vcaai)+cblk(lcell,vkai) &
3822 +cblk(lcell,vmgai)))
3823 !liqy-20140616
3825 ! *** Accumulation-mode:
3826 pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
3827 vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
3828 vasoa1j)+cblk(lcell,vasoa2j)+cblk(lcell,vasoa3j)+cblk(lcell, &
3829 vasoa4j)+cblk(lcell,vbsoa1j)+cblk(lcell,vbsoa2j)+cblk(lcell, &
3830 vbsoa3j)+cblk(lcell,vbsoa4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
3831 ! vp25aj)+cblk(lcell,vecj)))
3832 !liqy
3833 vp25aj)+cblk(lcell,vecj)+cblk(lcell,vcaaj)+cblk(lcell,vkaj) &
3834 +cblk(lcell,vmgaj)))
3835 !liqy-20140616
3836 ! *** coarse mode:
3837 pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
3838 lcell,vantha))
3840 END DO
3841 ! *** now get particle density, mean free path, and dynamic viscosity
3843 ! aerosol 3rd moment and mass
3844 DO lcell = 1, &
3845 numcells
3846 ! *** density in [ kg m**-3 ]
3848 ! Density and mean free path
3849 pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
3850 pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
3851 pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
3853 ! *** Calculate mean free path [ m ]:
3854 xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
3856 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
3857 ! *** on page 10 of U.S. Standard Atmosphere 1962
3859 ! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
3861 ! *** U.S. Standard Atmosphere 1962 page 14 expression
3862 ! for dynamic viscosity is:
3863 ! dynamic viscosity = beta * T * sqrt(T) / ( T + S)
3864 ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
3866 amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
3867 (blkta(lcell)+110.4)
3869 END DO
3870 !............... Standard deviation fixed in both modes, so
3871 !............... diagnose diameter from 3rd moment and number concentr
3873 ! density and mean free path
3874 DO lcell = 1, &
3875 numcells
3877 ! calculate diameters
3878 dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
3879 one3)
3881 dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
3882 one3)
3884 dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
3885 **one3)
3887 ! when running with cloudborne aerosol, apply some very mild bounding
3888 ! to avoid unrealistic dg values
3889 if (cw_phase > 0) then
3890 dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2 ) ! > 0.002 um
3891 dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 ) ! < 0.10 um
3892 dgacc(lcell) = max( dgacc(lcell), dginia*0.2 ) ! > 0.014 um
3893 dgacc(lcell) = min( dgacc(lcell), dginia*10.0 ) ! < 0.7 um
3894 dgcor(lcell) = max( dgcor(lcell), dginic*0.2 ) ! > 0.2 um
3895 dgcor(lcell) = min( dgcor(lcell), dginic*10.0 ) ! < 10.0 um
3896 end if
3898 END DO
3899 ! end loop on diameters
3900 DO lcell = 1, &
3901 numcells
3902 ! Calculate Knudsen numbers
3903 knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
3905 knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
3907 kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
3909 END DO
3911 ! end loop for Knudsen numbers
3912 RETURN
3914 END SUBROUTINE modpar
3915 !------------------------------------------------------------------------------
3917 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
3918 blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
3919 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
3920 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
3922 !***********************************************************************
3923 !** DESCRIPTION: calculates aerosol nucleation and condensational
3924 !** growth rates using Binkowski and Shankar (1995) method.
3926 ! *** In this version, the method od RPM is followed where
3927 ! the diffusivity, the average molecular ve3locity, and
3928 ! the accomodation coefficient for sulfuric acid are used for
3929 ! the organics. This is for consistency.
3930 ! Future versions will use the correct values. FSB 12/12/96
3933 !**
3934 !** Revision history:
3935 ! prototype 1/95 by Uma and Carlie
3936 ! Corrected 7/95 by Uma for condensation of mass not nucleated
3937 ! and mass conservation check
3938 ! Revised 8/95 by US to calculate air density in stmt function
3939 ! and collect met variable stmt funcs in one include fil
3940 ! Revised 7/25/96 by FSB to use block structure.
3941 ! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
3942 ! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units.
3943 ! Revised 1/13/97 by FSB to pass arrays and simplify code.
3944 ! Added 23/03/99 by BS growth factors for organics
3945 !**********************************************************************
3946 ! IMPLICIT NONE
3948 ! Includes:
3949 ! *** arguments
3951 ! *** input;
3952 !USE module_configure, only: grid_config_rec_type
3953 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
3956 ! dimension of arrays
3957 INTEGER blksize
3958 INTEGER layer
3959 ! number of species in CBLK
3960 INTEGER nspcsda
3961 ! actual number of cells in arrays
3962 INTEGER numcells
3963 INTEGER igrid,jgrid,kgrid
3965 INTEGER ldrog_vbs
3966 ! # of organic aerosol precursor
3967 REAL cblk(blksize,nspcsda) ! main array of variables
3968 ! model time step in SECONDS
3969 REAL dt
3970 REAL blkta(blksize) ! Air temperature [ K ]
3971 REAL blkprs(blksize) ! Air pressure in [ Pa ]
3972 REAL blkrh(blksize) ! Fractional relative humidity
3973 REAL so4rat(blksize) ! rate [ ug/m**3 /s ]
3974 REAL brrto
3975 !bs
3976 ! sulfate gas-phase production
3977 ! total # of cond. vapors & SOA spe
3978 INTEGER ncv
3979 !bs
3980 INTEGER nacv
3981 !bs * anthropogenic organic condensable vapor production rate
3982 ! # of anthrop. cond. vapors & SOA
3983 REAL drog(blksize,ldrog_vbs) !bs
3984 ! Delta ROG conc. [ppm]
3986 ! anthropogenic vapor production rates
3987 REAL organt1rat(blksize)
3988 REAL organt2rat(blksize)
3989 REAL organt3rat(blksize)
3990 REAL organt4rat(blksize)
3992 ! biogenic vapor production rates
3993 REAL orgbio1rat(blksize)
3994 REAL orgbio2rat(blksize)
3995 REAL orgbio3rat(blksize)
3996 REAL orgbio4rat(blksize)
3998 ! biogenic organic aerosol production
3999 REAL dgnuc(blksize) ! accumulation
4000 REAL dgacc(blksize)
4001 ! *** output:
4003 ! coarse mode
4004 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
4005 ! reciprocal condensation rate
4006 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
4007 ! reciprocal condensation rate
4008 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
4009 ! reciprocal condensation rate
4010 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
4011 ! reciprocal condensation rate
4012 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
4013 ! rate of production of new mass concent
4014 REAL dndt(blksize) ! concentration by particle formation [#
4015 ! rate of producton of new particle numb
4016 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
4017 ! increment of concentration added to
4018 REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ]
4019 ! growth rate for 3rd moment for
4020 REAL cgra3(blksize) ! Accumulation mode
4022 !........... SCRATCH local variables and their descriptions:
4024 ! growth rate for 3rd moment for
4026 INTEGER lcell
4028 ! LOOP INDEX
4029 ! conv rate so2 --> so4 [mom-3/g/s]
4030 REAL chemrat
4031 ! conv rate for organics [mom-3/g/s]
4032 REAL chemrat_org
4033 REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
4034 am1a
4035 REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
4036 am2a
4037 REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
4038 gnc3a
4039 REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den
4040 gfm3a
4041 ! total reciprocal condensation rate
4042 REAL fconc
4044 REAL td
4045 ! d * tinf (cgs)
4046 REAL*8 & ! Cnstant to force 64 bit evaluation of
4047 one88
4048 PARAMETER (one88=1.0D0)
4049 ! *** variables to set up sulfate and organic condensation rates
4051 ! sulfuric acid vapor at current time step
4052 REAL vapor1
4053 ! chemistry and emissions
4054 REAL vapor2
4055 ! Sulfuric acid vapor prior to addition from
4056 !bs
4057 REAL deltavap
4058 !bs * start update
4059 !bs
4060 ! change to vapor at previous time step
4061 REAL diffcorr
4063 !bs *
4064 REAL csqt_org
4065 !bs * end update
4066 !bs
4067 REAL csqt
4068 !.......................................................................
4069 ! begin body of subroutine NUCLCOND
4072 !........... Main computational grid-traversal loop nest
4073 !........... for computing condensation and nucleation:
4075 DO lcell = 1, &
4076 numcells
4077 ! *** First moment:
4079 ! 1st loop over NUMCELLS
4080 am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
4081 am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
4083 !.............. near-continuum factors [ 1 / sec ]
4084 !bs
4085 !bs * adopted from code of FSB
4086 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
4087 !bs
4088 diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
4089 !bs
4090 gnc3n = cconc*am1n*diffcorr
4091 gnc3a = cconc*am1a*diffcorr
4093 ! *** Second moment:
4095 am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
4096 am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
4098 csqt = ccofm*sqrt(blkta(lcell))
4099 !............... free molecular factors [ 1 / sec ]
4101 ! put in temperature fac
4102 gfm3n = csqt*am2n
4103 gfm3a = csqt*am2a
4105 ! *** Condensation factors in [ s**-1] for h2so4
4106 ! *** In the future, separate factors for condensing organics will
4107 ! be included. In this version, the h2so4 values are used.
4109 !............... Twice the harmonic mean of fm, nc functions:
4110 ! *** Force 64 bit evaluation:
4112 fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4113 fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4114 fconc = fconcn(lcell) + fconca(lcell)
4116 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
4117 !bs
4118 !bs * start modifications for organcis
4119 !bs
4120 gnc3n = cconc_org*am1n*diffcorr
4121 gnc3a = cconc_org*am1a*diffcorr
4122 !bs
4123 csqt_org = ccofm_org*sqrt(blkta(lcell))
4124 gfm3n = csqt_org*am2n
4125 gfm3a = csqt_org*am2a
4126 !bs
4127 fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4128 fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4129 !bs
4130 !bs * end modifications for organics
4131 !bs
4132 ! *** calculate the total change to sulfuric acid vapor from production
4133 ! and condensation
4135 vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
4136 vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
4137 dt
4138 ! vapor at prev
4139 vapor2 = max(0.0,vapor2)
4140 deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
4142 ! *** Calculate increment in total sufate aerosol mass concentration
4144 ! *** This follows the method of Youngblood & Kreidenweis.!bs
4145 !bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
4146 !bs
4147 !bs * allow DELTASO4A to be negative, but the change must not be larger
4148 !bs * than the amount of vapor available.
4149 !bs
4150 deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
4151 so4rat(lcell)*dt-deltavap)
4153 ! *** zero out growth coefficients
4154 cgrn3(lcell) = 0.0
4155 cgra3(lcell) = 0.0
4157 END DO
4159 ! *** Select method of nucleation
4160 ! End 1st loop over NUMCELLS
4161 IF (inucl==1) THEN
4163 ! *** Do Youngblood & Kreidenweis Nucleation
4165 ! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4166 ! & DNDT,DMDT,NUMCELLS,BLKSIZE,
4167 ! & VAPOR1)
4168 ! IF (firstime) THEN
4169 ! WRITE (6,*)
4170 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4171 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4172 ! firstime = .FALSE.
4173 ! END IF
4175 ELSE IF (inucl==0) THEN
4177 ! *** Do Kerminen & Wexler Nucleation
4179 ! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4180 ! & DNDT,DMDT,NUMCELLS,BLKSIZE)
4181 ! IF (firstime) THEN
4182 ! WRITE (6,*)
4183 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4184 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4185 ! firstime = .FALSE.
4186 ! END IF
4188 ELSE IF (inucl==2) THEN
4190 !bs ** Do Kulmala et al. Nucleation
4191 ! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
4193 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
4194 CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4195 else
4196 dndt(1)=0.
4197 dmdt(1)=0.
4198 endif
4200 ! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4201 ! if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
4202 IF (dndt(1)==0.) dmdt(1) = 0.
4203 IF (dmdt(1)==0.) dndt(1) = 0.
4204 ! IF (firstime) THEN
4205 ! WRITE (6,*)
4206 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4207 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4208 ! firstime = .FALSE.
4209 ! END IF
4210 ! ELSE
4211 ! WRITE (6,'(a)') '*************************************'
4212 ! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!'
4213 ! WRITE (6,'(a)') ' PROGRAM TERMINATED !!'
4214 ! WRITE (6,'(a)') '*************************************'
4215 ! STOP
4217 END IF
4218 !bs
4219 !bs * Secondary organic aerosol module (SOA_VBS)
4220 !bs
4221 ! end of selection of nucleation method
4223 CALL soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
4224 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
4225 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto )
4226 !bs
4227 !bs * Secondary organic aerosol module (SOA_VBS)
4228 !bs
4229 DO lcell = 1, numcells
4231 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
4232 ! condensation factors
4234 td = 1.0/(fconcn(lcell)+fconca(lcell))
4235 fconcn(lcell) = td*fconcn(lcell)
4236 fconca(lcell) = td*fconca(lcell)
4237 !bs
4238 td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
4239 fconcn_org(lcell) = td*fconcn_org(lcell)
4240 fconca_org(lcell) = td*fconca_org(lcell)
4241 !bs
4242 END DO
4244 ! *** Begin second loop over cells
4246 DO lcell = 1,numcells
4247 ! *** note CHEMRAT includes species other than sulfate.
4249 ! 3rd loop on NUMCELLS
4250 chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
4251 chemrat_org = orgfac*(organt1rat(lcell)+organt2rat(lcell)+organt3rat( &
4252 lcell)+organt4rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
4253 orgbio3rat(lcell)+orgbio4rat(lcell))
4255 ! *** Calculate the production rates for new particle
4256 ! [mom3 m**-3 s-
4257 cgrn3(lcell) = so4fac*dmdt(lcell)
4258 ! Rate of increase of 3rd
4259 chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro
4261 !bs Remove the rate of new pa
4262 chemrat = max(chemrat,0.0)
4263 ! *** Now calculate the rate of condensation on existing particles.
4265 ! Prevent CHEMRAT from being negativ
4266 cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
4267 chemrat_org*fconcn_org(lcell)
4268 cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
4269 ! ***
4270 END DO
4271 ! end 2nd loop over NUMCELLS
4272 RETURN
4274 END SUBROUTINE nuclcond
4275 !------------------------------------------------------------------------------
4277 ! nuclcond
4278 REAL FUNCTION poly4(a,x)
4279 REAL a(4), x
4281 poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
4282 RETURN
4283 END FUNCTION poly4
4284 REAL FUNCTION poly6(a,x)
4285 REAL a(6), x
4287 poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
4288 RETURN
4289 END FUNCTION poly6
4290 !-----------------------------------------------------------------------
4292 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
4293 gnh3,gno3)
4294 ! Description:
4296 ! ARES calculates the chemical composition of a sulfate/nitrate/
4297 ! ammonium/water aerosol based on equilibrium thermodynamics.
4299 ! This code considers two regimes depending upon the molar ratio
4300 ! of ammonium to sulfate.
4302 ! For values of this ratio less than 2,the code solves a cubic for
4303 ! hydrogen ion molality, HPLUS, and if enough ammonium and liquid
4304 ! water are present calculates the dissolved nitric acid. For molal
4305 ! ionic strengths greater than 50, nitrate is assumed not to be present
4307 ! For values of the molar ratio of 2 or greater, all sulfate is assumed
4308 ! to be ammonium sulfate and a calculation is made for the presence of
4309 ! ammonium nitrate.
4311 ! The Pitzer multicomponent approach is used in subroutine ACTCOF to
4312 ! obtain the activity coefficients. Abandoned -7/30/97 FSB
4314 ! The Bromley method of calculating the activity coefficients is used in this version
4316 ! The calculation of liquid water is done in subroutine water. Details for both calculations are given
4317 ! in the respective subroutines.
4319 ! Based upon MARS due to
4320 ! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
4321 ! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
4323 ! and SCAPE due to
4324 ! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
4325 ! Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
4327 ! NOTE: All concentrations supplied to this subroutine are TOTAL
4328 ! over gas and aerosol phases
4330 ! Parameters:
4332 ! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
4333 ! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
4334 ! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
4335 ! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
4336 ! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
4337 ! RH : Fractional relative humidity (IN)
4338 ! TEMP : Temperature in Kelvin (IN)
4339 ! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
4340 ! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
4341 ! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
4342 ! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
4343 ! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
4344 ! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT)
4345 ! NITR : Number of iterations for obtaining activity coefficients (OU
4346 ! NR : Number of real roots to the cubic in the low ammonia case (OU
4348 ! Revision History:
4349 ! Who When Detailed description of changes
4350 ! --------- -------- -------------------------------------------
4351 ! S.Roselle 11/10/87 Received the first version of the MARS code
4352 ! S.Roselle 12/30/87 Restructured code
4353 ! S.Roselle 2/12/88 Made correction to compute liquid-phase
4354 ! concentration of H2O2.
4355 ! S.Roselle 5/26/88 Made correction as advised by SAI, for
4356 ! computing H+ concentration.
4357 ! S.Roselle 3/1/89 Modified to operate with EM2
4358 ! S.Roselle 5/19/89 Changed the maximum ionic strength from
4359 ! 100 to 20, for numerical stability.
4360 ! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case
4361 ! using equations for nitrate budget.
4362 ! F.Binkowski 6/18/91 New ammonia poor case which
4363 ! omits letovicite.
4364 ! F.Binkowski 7/25/91 Rearranged entire code, restructured
4365 ! ammonia poor case.
4366 ! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output
4367 ! as SO4--
4368 ! F.Binkowski 12/6/91 Changed the ammonia defficient case so that
4369 ! there is only neutralized sulfate (ammonium
4370 ! sulfate) and sulfuric acid.
4371 ! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen
4372 ! with the Cohen et al. (1987) maximum molalit
4373 ! of 36.2 in Table III.( J. Phys Chem (91) page
4374 ! 4569, and Table IV p 4587.)
4375 ! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem
4376 ! possibility for denomenator becoming zero;
4377 ! this involved solving for HPLUS first.
4378 ! Note that for a relative humidity
4379 ! less than 50%, the model assumes that there i
4380 ! aerosol nitrate.
4381 ! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System
4382 ! Redid logic as follows
4383 ! 1. Water algorithm now follows Spann & Richard
4384 ! 2. Pitzer Multicomponent method used
4385 ! 3. Multicomponent practical osmotic coefficien
4386 ! use to close iterations.
4387 ! 4. The model now assumes that for a water
4388 ! mass fraction WFRAC less than 50% there is
4389 ! no aerosol nitrate.
4390 ! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p
4391 ! case, and changed the WFRAC criterion to 40%.
4392 ! For ammonium to sulfate ratio less than 1.0
4393 ! all ammonium is aerosol and no nitrate aerosol
4394 ! exists.
4395 ! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case
4396 ! allow gas-phase ammonia to exist.
4397 ! F.Binkowski 7/26/95 Changed equilibrium constants to values from
4398 ! Kim et al. (1993)
4399 ! F.Binkowski 6/27/96 Changed to new water format
4400 ! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent
4401 ! activity coefficients. The binary activity coe
4402 ! are the same as the previous version
4403 ! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
4404 ! 1 picogram per cubic meter
4406 !-----------------------------------------------------------------------
4407 ! IMPLICIT NONE
4408 !...........INCLUDES and their descriptions
4409 !cc INCLUDE SUBST_CONST ! constants
4410 !...........PARAMETERS and their descriptions:
4412 ! molecular weight for NaCl
4413 REAL mwnacl
4414 PARAMETER (mwnacl=58.44277)
4416 ! molecular weight for NO3
4417 REAL mwno3
4418 PARAMETER (mwno3=62.0049)
4420 ! molecular weight for HNO3
4421 REAL mwhno3
4422 PARAMETER (mwhno3=63.01287)
4424 ! molecular weight for SO4
4425 REAL mwso4
4426 PARAMETER (mwso4=96.0576)
4428 ! molecular weight for HSO4
4429 REAL mwhso4
4430 PARAMETER (mwhso4=mwso4+1.0080)
4432 ! molecular weight for H2SO4
4433 REAL mh2so4
4434 PARAMETER (mh2so4=98.07354)
4436 ! molecular weight for NH3
4437 REAL mwnh3
4438 PARAMETER (mwnh3=17.03061)
4440 ! molecular weight for NH4
4441 REAL mwnh4
4442 PARAMETER (mwnh4=18.03858)
4444 ! molecular weight for Organic Species
4445 REAL mworg
4446 PARAMETER (mworg=16.0)
4448 ! molecular weight for Chloride
4449 REAL mwcl
4450 PARAMETER (mwcl=35.453)
4452 ! molecular weight for AIR
4453 REAL mwair
4454 PARAMETER (mwair=28.964)
4456 ! molecular weight for Letovicite
4457 REAL mwlct
4458 PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4460 ! molecular weight for Ammonium Sulfa
4461 REAL mwas
4462 PARAMETER (mwas=2.0*mwnh4+mwso4)
4464 ! molecular weight for Ammonium Bisul
4465 REAL mwabs
4466 PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4468 !...........ARGUMENTS and their descriptions
4470 !iamodels3
4471 REAL so4
4472 ! Total sulfate in micrograms / m**3
4473 ! Total nitric acid in micrograms / m
4474 REAL hno3
4475 ! Total nitrate in micrograms / m**3
4476 REAL no3
4477 ! Total ammonia in micrograms / m**3
4478 REAL nh3
4479 ! Total ammonium in micrograms / m**3
4480 REAL nh4
4481 ! Fractional relative humidity
4482 REAL rh
4483 ! Temperature in Kelvin
4484 REAL temp
4485 ! Aerosol sulfate in micrograms / m**
4486 REAL aso4
4487 ! Aerosol nitrate in micrograms / m**
4488 REAL ano3
4489 ! Aerosol liquid water content water
4490 REAL ah2o
4491 ! Aerosol ammonium in micrograms / m*
4492 REAL anh4
4493 ! Gas-phase nitric acid in micrograms
4494 REAL gno3
4495 REAL gnh3
4496 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4498 ! Gas-phase ammonia in micrograms / m
4499 ! Index set to percent relative humid
4500 INTEGER irh
4501 ! Number of iterations for activity c
4502 INTEGER nitr
4503 ! Loop index for iterations
4504 INTEGER nnn
4505 INTEGER nr
4506 ! Number of roots to cubic equation f
4507 REAL*8 & ! Coefficients and roots of
4508 a0
4509 REAL*8 & ! Coefficients and roots of
4510 a1
4511 REAL*8 & ! Coefficients and roots of
4512 a2
4513 ! Coefficients and discriminant for q
4514 REAL aa
4515 ! internal variables ( high ammonia c
4516 REAL bal
4517 ! Coefficients and discriminant for q
4518 REAL bb
4519 ! Variables used for ammonia solubili
4520 REAL bhat
4521 ! Coefficients and discriminant for q
4522 REAL cc
4523 ! Factor for conversion of units
4524 REAL convt
4525 ! Coefficients and discriminant for q
4526 REAL dd
4527 ! Coefficients and discriminant for q
4528 REAL disc
4529 ! Relative error used for convergence
4530 REAL eror
4531 ! Free ammonia concentration , that
4532 REAL fnh3
4533 ! Activity Coefficient for (NH4+, HSO
4534 REAL gamaab
4535 ! Activity coefficient for (NH4+, NO3
4536 REAL gamaan
4537 ! Variables used for ammonia solubili
4538 REAL gamahat
4539 ! Activity coefficient for (H+ ,NO3-)
4540 REAL gamana
4541 ! Activity coefficient for (2H+, SO4-
4542 REAL gamas1
4543 ! Activity coefficient for (H+, HSO4-
4544 REAL gamas2
4545 ! used for convergence of iteration
4546 REAL gamold
4547 ! internal variables ( high ammonia c
4548 REAL gasqd
4549 ! Hydrogen ion (low ammonia case) (mo
4550 REAL hplus
4551 ! Equilibrium constant for ammoniua t
4552 REAL k1a
4553 ! Equilibrium constant for sulfate-bi
4554 REAL k2sa
4555 ! Dissociation constant for ammonium
4556 REAL k3
4557 ! Equilibrium constant for ammonium n
4558 REAL kan
4559 ! Variables used for ammonia solubili
4560 REAL khat
4561 ! Equilibrium constant for nitric aci
4562 REAL kna
4563 ! Henry's Law Constant for ammonia
4564 REAL kph
4565 ! Equilibrium constant for water diss
4566 REAL kw
4567 ! Internal variable using KAN
4568 REAL kw2
4569 ! Nitrate (high ammonia case) (moles
4570 REAL man
4571 ! Sulfate (high ammonia case) (moles
4572 REAL mas
4573 ! Bisulfate (low ammonia case) (moles
4574 REAL mhso4
4575 ! Nitrate (low ammonia case) (moles /
4576 REAL mna
4577 ! Ammonium (moles / kg water)
4578 REAL mnh4
4579 ! Total number of moles of all ions
4580 REAL molnu
4581 ! Sulfate (low ammonia case) (moles /
4582 REAL mso4
4583 ! Practical osmotic coefficient
4584 REAL phibar
4585 ! Previous value of practical osmotic
4586 REAL phiold
4587 ! Molar ratio of ammonium to sulfate
4588 REAL ratio
4589 ! Internal variable using K2SA
4590 REAL rk2sa
4591 ! Internal variables using KNA
4592 REAL rkna
4593 ! Internal variables using KNA
4594 REAL rknwet
4595 REAL rr1
4596 REAL rr2
4597 ! Ionic strength
4598 REAL stion
4599 ! Internal variables for temperature
4600 REAL t1
4601 ! Internal variables for temperature
4602 REAL t2
4603 ! Internal variables of convenience (
4604 REAL t21
4605 ! Internal variables of convenience (
4606 REAL t221
4607 ! Internal variables for temperature
4608 REAL t3
4609 ! Internal variables for temperature
4610 REAL t4
4611 ! Internal variables for temperature
4612 REAL t6
4613 ! Total ammonia and ammonium in micro
4614 REAL tnh4
4615 ! Total nitrate in micromoles / meter
4616 REAL tno3
4617 ! Tolerances for convergence test
4618 REAL toler1
4619 ! Tolerances for convergence test
4620 REAL toler2
4621 ! Total sulfate in micromoles / meter
4622 REAL tso4
4623 ! 2.0 * TSO4 (high ammonia case) (mo
4624 REAL twoso4
4625 ! Water mass fraction
4626 REAL wfrac
4627 ! micrograms / meter **3 on output
4628 REAL wh2o
4629 ! internally it is 10 ** (-6) kg (wat
4630 ! the conversion factor (1000 g = 1 k
4631 ! for AH2O output
4632 ! Aerosol liquid water content (inter
4633 ! internal variables ( high ammonia c
4634 REAL wsqd
4635 ! Nitrate aerosol concentration in mi
4636 REAL xno3
4637 ! Variable used in quadratic solution
4638 REAL xxq
4639 ! Ammonium aerosol concentration in m
4640 REAL ynh4
4641 ! Water variable saved in case ionic
4642 REAL zh2o
4644 REAL zso4
4645 ! Total sulfate molality - mso4 + mhs
4646 REAL cat(2) ! Array for cations (1, H+); (2, NH4+
4647 REAL an(3) ! Array for anions (1, SO4--); (2, NO
4648 REAL crutes(3) ! Coefficients and roots of
4649 REAL gams(2,3) ! Array of activity coefficients
4650 ! Minimum value of sulfate laerosol c
4651 REAL minso4
4652 PARAMETER (minso4=1.0E-6/mwso4)
4653 REAL floor
4654 PARAMETER (floor=1.0E-30)
4655 !-----------------------------------------------------------------------
4656 ! begin body of subroutine RPMARES
4658 !...convert into micromoles/m**3
4659 !cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
4660 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
4661 ! minimum concentration
4662 tso4 = max(0.0,so4/mwso4)
4663 tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
4664 tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
4665 !cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
4667 !...now set humidity index IRH as a percent
4669 irh = nint(100.0*rh)
4671 !...Check for valid IRH
4673 irh = max(1,irh)
4674 irh = min(99,irh)
4675 !cc WRITE(10,*)'RH,IRH ',RH,IRH
4677 !...Specify the equilibrium constants at correct
4678 !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA
4679 !... KPH, and K3 )
4680 !... Values from Kim et al. (1993) except as noted.
4682 convt = 1.0/(0.082*temp)
4683 t6 = 0.082E-9*temp
4684 t1 = 298.0/temp
4685 t2 = alog(t1)
4686 t3 = t1 - 1.0
4687 t4 = 1.0 + t2 - t1
4688 kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
4689 k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
4690 k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
4691 kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
4692 kph = 57.639*exp(13.79*t3-5.39*t4)*t6
4693 !cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6
4694 khat = kph*k1a/kw
4695 kan = kna*khat
4697 !...Compute temperature dependent equilibrium constant for NH4NO3
4698 !... ( from Mozurkewich, 1993)
4699 k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
4701 !...Convert to (micromoles/m**3) **2
4702 k3 = k3*convt*convt
4703 wh2o = 0.0
4704 stion = 0.0
4705 ah2o = 0.0
4706 mas = 0.0
4707 man = 0.0
4708 hplus = 0.0
4709 toler1 = 0.00001
4710 toler2 = 0.001
4711 nitr = 0
4712 nr = 0
4713 ratio = 0.0
4714 gamaan = 1.0
4715 gamold = 1.0
4717 !...set the ratio according to the amount of sulfate and nitrate
4718 IF (tso4>minso4) THEN
4719 ratio = tnh4/tso4
4721 !...If there is no sulfate and no nitrate, there can be no ammonium
4722 !... under the current paradigm. Organics are ignored in this version.
4724 ELSE
4726 IF (tno3==0.0) THEN
4728 ! *** If there is very little sulfate and no nitrate set concentrations
4729 ! to a very small value and return.
4730 aso4 = max(floor,aso4)
4731 ano3 = max(floor,ano3)
4732 wh2o = 0.0
4733 ah2o = 0.0
4734 gnh3 = max(floor,gnh3)
4735 gno3 = max(floor,gno3)
4736 RETURN
4737 END IF
4739 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
4740 !... to send the code to the high ammonia case
4742 ratio = 5.0
4743 END IF
4745 !....................................
4746 !......... High Ammonia Case ........
4747 !....................................
4749 IF (ratio>2.0) THEN
4751 gamaan = 0.1
4753 !...Set up twice the sulfate for future use.
4755 twoso4 = 2.0*tso4
4756 xno3 = 0.0
4757 ynh4 = twoso4
4759 !...Treat different regimes of relative humidity
4761 !...ZSR relationship is used to set water levels. Units are
4762 !... 10**(-6) kg water/ (cubic meter of air)
4763 !... start with ammomium sulfate solution without nitrate
4765 CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
4766 wh2o = 1.0E-3*ah2o
4767 aso4 = tso4*mwso4
4768 ano3 = 0.0
4769 anh4 = ynh4*mwnh4
4770 wfrac = ah2o/(aso4+anh4+ah2o)
4771 !cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water
4772 IF (wfrac<0.2) THEN
4774 !... dry ammonium sulfate and ammonium nitrate
4775 !... compute free ammonia
4777 fnh3 = tnh4 - twoso4
4778 cc = tno3*fnh3 - k3
4780 !...check for not enough to support aerosol
4782 IF (cc<=0.0) THEN
4783 xno3 = 0.0
4784 ELSE
4785 aa = 1.0
4786 bb = -(tno3+fnh3)
4787 disc = bb*bb - 4.0*cc
4789 !...Check for complex roots of the quadratic
4790 !... set nitrate to zero and RETURN if complex roots are found
4792 IF (disc<0.0) THEN
4793 xno3 = 0.0
4794 ah2o = 1000.0*wh2o
4795 ynh4 = twoso4
4796 gno3 = tno3*mwhno3
4797 gnh3 = (tnh4-ynh4)*mwnh3
4798 aso4 = tso4*mwso4
4799 ano3 = 0.0
4800 anh4 = ynh4*mwnh4
4801 RETURN
4802 END IF
4804 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
4806 dd = sqrt(disc)
4807 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4809 !...Since both roots are positive, select smaller root.
4811 xno3 = min(xxq/aa,cc/xxq)
4813 END IF
4814 ah2o = 1000.0*wh2o
4815 ynh4 = 2.0*tso4 + xno3
4816 gno3 = (tno3-xno3)*mwhno3
4817 gnh3 = (tnh4-ynh4)*mwnh3
4818 aso4 = tso4*mwso4
4819 ano3 = xno3*mwno3
4820 anh4 = ynh4*mwnh4
4821 RETURN
4823 END IF
4825 !...liquid phase containing completely neutralized sulfate and
4826 !... some nitrate. Solve for composition and quantity.
4828 mas = tso4/wh2o
4829 man = 0.0
4830 xno3 = 0.0
4831 ynh4 = twoso4
4832 phiold = 1.0
4834 !...Start loop for iteration
4836 !...The assumption here is that all sulfate is ammonium sulfate,
4837 !... and is supersaturated at lower relative humidities.
4839 DO nnn = 1, 150
4840 nitr = nnn
4841 gasqd = gamaan*gamaan
4842 wsqd = wh2o*wh2o
4843 kw2 = kan*wsqd/gasqd
4844 aa = 1.0 - kw2
4845 bb = twoso4 + kw2*(tno3+tnh4-twoso4)
4846 cc = -kw2*tno3*(tnh4-twoso4)
4848 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
4850 disc = bb*bb - 4.0*aa*cc
4852 !...Check for complex roots, if so set nitrate to zero and RETURN
4854 IF (disc<0.0) THEN
4855 xno3 = 0.0
4856 ah2o = 1000.0*wh2o
4857 ynh4 = twoso4
4858 gno3 = tno3*mwhno3
4859 gnh3 = (tnh4-ynh4)*mwnh3
4860 aso4 = tso4*mwso4
4861 ano3 = 0.0
4862 anh4 = ynh4*mwnh4
4863 !cc WRITE( 10, * ) ' COMPLEX ROOTS '
4864 RETURN
4865 END IF
4867 dd = sqrt(disc)
4868 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4869 rr1 = xxq/aa
4870 rr2 = cc/xxq
4872 !...Check for two non-positive roots, if so set nitrate to zero and RETURN
4873 IF (rr1 <= 0.0 .AND. rr2 <= 0.0) THEN
4874 xno3 = 0.0
4875 ah2o = 1000.0*wh2o
4876 ynh4 = twoso4
4877 gno3 = tno3*mwhno3
4878 gnh3 = (tnh4-ynh4)*mwnh3
4879 aso4 = tso4*mwso4
4880 ano3 = 0.0
4881 anh4 = ynh4*mwnh4
4882 ! WRITE(*,*) 'TWO NON-POSITIVE ROOTS!!! '
4883 RETURN
4884 END IF
4886 !...choose minimum positve root
4888 IF ((rr1*rr2)<0.0) THEN
4889 xno3 = max(rr1,rr2)
4890 ELSE
4891 xno3 = min(rr1,rr2)
4892 END IF
4893 xno3 = min(xno3,tno3)
4895 !...This version assumes no solid sulfate forms (supersaturated )
4896 !... Now update water
4898 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4900 !...ZSR relationship is used to set water levels. Units are
4901 !... 10**(-6) kg water/ (cubic meter of air)
4902 !... The conversion from micromoles to moles is done by the units of WH
4904 wh2o = 1.0E-3*ah2o
4906 !...Ionic balance determines the ammonium in solution.
4908 man = xno3/wh2o
4909 mas = tso4/wh2o
4910 mnh4 = 2.0*mas + man
4911 ynh4 = mnh4*wh2o
4913 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
4914 !... and ammonium in molal units (moles/(kg water) ).
4916 stion = 3.0*mas + man
4917 cat(1) = 0.0
4918 cat(2) = mnh4
4919 an(1) = mas
4920 an(2) = man
4921 an(3) = 0.0
4922 CALL actcof(cat,an,gams,molnu,phibar)
4923 gamaan = gams(2,2)
4925 !...Use GAMAAN for convergence control
4927 eror = abs(gamold-gamaan)/gamold
4928 gamold = gamaan
4930 !...Check to see if we have a solution
4932 IF (eror<=toler1) THEN
4933 !cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
4934 !cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
4936 aso4 = tso4*mwso4
4937 ano3 = xno3*mwno3
4938 anh4 = ynh4*mwnh4
4939 gno3 = (tno3-xno3)*mwhno3
4940 gnh3 = (tnh4-ynh4)*mwnh3
4941 ah2o = 1000.0*wh2o
4942 RETURN
4943 END IF
4945 END DO
4947 !...If after NITR iterations no solution is found, then:
4949 aso4 = tso4*mwso4
4950 ano3 = 0.0
4951 ynh4 = twoso4
4952 anh4 = ynh4*mwnh4
4953 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4954 gno3 = tno3*mwhno3
4955 gnh3 = (tnh4-ynh4)*mwnh3
4956 RETURN
4958 ELSE
4959 !......................................
4960 !......... Low Ammonia Case ...........
4961 !......................................
4963 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
4965 !...All cases covered by this logic
4966 wh2o = 0.0
4967 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4968 wh2o = 1.0E-3*ah2o
4969 zh2o = ah2o
4970 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4971 !... per cubic meter of air (1000 g = 1 kg)
4973 aso4 = tso4*mwso4
4974 anh4 = tnh4*mwnh4
4975 ano3 = 0.0
4976 gno3 = tno3*mwhno3
4977 gnh3 = 0.0
4979 !...Check for zero water.
4980 IF (wh2o==0.0) RETURN
4981 zso4 = tso4/wh2o
4983 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
4985 !cc IF ( ZSO4 .GT. 11.0 ) THEN
4987 !...do not solve for aerosol nitrate for total sulfate molality
4988 !... greater than 11.0 because the model parameters break down
4989 !... greater than 9.0 because the model parameters break down
4991 IF (zso4>9.0) & ! 18 June 97
4992 THEN
4993 RETURN
4994 END IF
4996 !...First solve with activity coeffs of 1.0, then iterate.
4997 phiold = 1.0
4998 gamana = 1.0
4999 gamas1 = 1.0
5000 gamas2 = 1.0
5001 gamaab = 1.0
5002 gamold = 1.0
5004 !...All ammonia is considered to be aerosol ammonium.
5005 mnh4 = tnh4/wh2o
5007 !...MNH4 is the molality of ammonium ion.
5008 ynh4 = tnh4
5010 !...loop for iteration
5011 DO nnn = 1, 150
5012 nitr = nnn
5014 !...set up equilibrium constants including activities
5015 !... solve the system for hplus first then sulfate & nitrate
5016 ! print*,'gamas,gamana',gamas1,gamas2,gamana
5017 rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
5018 rkna = kna/(gamana*gamana)
5019 rknwet = rkna*wh2o
5020 t21 = zso4 - mnh4
5021 t221 = zso4 + t21
5023 !...set up coefficients for cubic
5025 a2 = rk2sa + rknwet - t21
5026 a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
5027 a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
5029 CALL cubic(a2,a1,a0,nr,crutes)
5031 !...Code assumes the smallest positive root is in CRUTES(1)
5033 hplus = crutes(1)
5034 bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
5035 mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
5036 mhso4 = zso4 - & ! molality of bisulf
5037 mso4
5038 mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
5039 mna = max(0.0,mna)
5040 mna = min(mna,tno3/wh2o)
5041 xno3 = mna*wh2o
5042 ano3 = mna*wh2o*mwno3
5043 gno3 = (tno3-xno3)*mwhno3
5045 !...Calculate ionic strength
5046 stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
5048 !...Update water
5049 CALL awater(irh,tso4,ynh4,xno3,ah2o)
5051 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
5052 !... per cubic meter of air (1000 g = 1 kg)
5054 wh2o = 1.0E-3*ah2o
5055 cat(1) = hplus
5056 cat(2) = mnh4
5057 an(1) = mso4
5058 an(2) = mna
5059 an(3) = mhso4
5060 ! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
5061 CALL actcof(cat,an,gams,molnu,phibar)
5063 gamana = gams(1,2)
5064 gamas1 = gams(1,1)
5065 gamas2 = gams(1,3)
5066 gamaan = gams(2,2)
5068 gamahat = (gamas2*gamas2/(gamaab*gamaab))
5069 bhat = khat*gamahat
5070 !cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
5071 !cc PHIOLD = PHIBAR
5072 eror = abs(gamold-gamahat)/gamold
5073 gamold = gamahat
5075 !...write out molalities and activity coefficient
5076 !... and return with good solution
5078 IF (eror<=toler2) THEN
5079 !cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
5080 !cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
5081 !cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
5082 RETURN
5083 END IF
5085 END DO
5087 !...after NITR iterations, failure to solve the system, no ANO3
5089 gno3 = tno3*mwhno3
5090 ano3 = 0.0
5091 CALL awater(irh,tso4,tnh4,tno3,ah2o)
5092 RETURN
5094 END IF
5095 ! ratio .gt. 2.0
5096 END SUBROUTINE rpmares_old
5098 !ia*********************************************************
5099 !ia *
5100 !ia BEGIN OF AEROSOL ROUTINE *
5101 !ia *
5102 !ia*********************************************************
5104 !***********************************************************************
5105 ! BEGIN OF AEROSOL CALCULATIONS
5106 !***********************************************************************
5107 !ia *
5108 !ia MAIN AEROSOL DYNAMICS ROUTINE *
5109 !ia based on MODELS3 formulation by FZB *
5110 !ia Modified by IA in May 97 *
5111 !ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
5112 !ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
5113 !ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
5114 !ia CALCULATIONS.
5115 !ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
5116 !ia ONE GRID CELL!!!!
5117 !ia and passed to dynamics calcs. subroutines.
5118 !ia *
5119 !ia Revision history *
5120 !ia When WHO WHAT *
5121 !ia ---- ---- ---- *
5122 !ia ???? FZB BEGIN *
5123 !ia 05/97 IA Adapted for use in CTM2-S *
5124 !ia Modified renaming/bug fixing *
5125 !ia 11/97 IA Modified for new model version
5126 !ia see comments under iarev02
5127 !ia 03/98 IA corrected error on pressure units
5128 !ia *
5129 !ia Called BY: CHEM *
5130 !ia *
5131 !ia Calls to: OUTPUT1,AEROPRC *
5132 !ia *
5133 !ia*********************************************************************
5135 ! end RPMares
5136 ! convapr_in is removed, it wasn't used indeed
5137 SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
5138 nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv, &
5139 nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, &
5140 soilrat_in,cblk,igrid,jgrid,kgrid,brrto,do_isorropia,do_n2o5het)
5142 !USE module_configure, only: grid_config_rec_type
5143 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
5145 ! IMPLICIT NONE
5147 ! Includes:
5148 !iarev02 INCLUDE AEROINCL.EXT
5149 ! block size, set to 1 in column model ciarev0
5150 INTEGER blksize
5151 !ia kept to 1 in current version of column model
5152 ! actual number of cells in arrays ( default is
5153 INTEGER, PARAMETER :: numcells=1
5155 INTEGER layer
5156 ! number of layer (default is 1 in
5158 ! index for cell in blocked array (default is 1 in
5159 INTEGER, PARAMETER :: ncell=1
5160 ! *** inputs
5161 ! Input temperature [ K ]
5162 REAL temp
5163 ! Input relative humidity [ fraction ]
5164 REAL relhum
5165 ! Input pressure [ hPa ]
5166 REAL pres
5167 ! Input number for Aitken mode [ m**-3 ]
5168 REAL numnuc_in
5169 ! Input number for accumulation mode [ m**-3 ]
5170 REAL numacc_in
5171 ! Input number for coarse mode [ m**-3 ]
5172 REAL numcor_in
5173 ! sulfuric acid [ ug m**-3 ]
5174 REAL vsulf_in
5175 ! total sulfate vapor as sulfuric acid as
5176 ! sulfuric acid [ ug m**-3 ]
5177 REAL asulf_in
5178 ! total sulfate aerosol as sulfuric acid as
5179 ! i-mode sulfate input as sulfuric acid [ ug m*
5180 REAL asulfi_in
5181 ! ammonia gas [ ug m**-3 ]
5182 REAL nh3_in
5183 ! input value of nitric acid vapor [ ug m**-3 ]
5184 REAL nitrate_in
5185 ! Production rate of sulfuric acid [ ug m**-3
5186 REAL so4rat_in
5187 ! aerosol [ ug m**-3 s**-1 ]
5188 REAL soilrat_in
5189 ! Production rate of soil derived coarse
5190 ! Emission rate of i-mode EC [ug m**-3 s**-1]
5191 REAL eeci_in
5192 ! Emission rate of j-mode EC [ug m**-3 s**-1]
5193 REAL eecj_in
5194 ! Emission rate of j-mode org. aerosol [ug m**-
5195 REAL eorgi_in
5196 REAL eorgj_in
5197 ! Emission rate of j-mode org. aerosol [ug m**-
5198 ! total # of cond. vapors & SOA species
5199 INTEGER ncv
5200 ! # of anthrop. cond. vapors & SOA speci
5201 INTEGER nacv
5202 ! # of organic aerosol precursor
5203 INTEGER ldrog_vbs
5204 REAL drog_in(ldrog_vbs) ! organic aerosol precursor [ppm]
5205 ! Input delta ROG concentration of
5206 REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
5207 REAL drog(blksize,ldrog_vbs) ! organic aerosol precursor [ppm]
5209 REAL brrto
5210 LOGICAL do_isorropia,do_n2o5het
5211 !bs
5212 ! *** Primary emissions rates: [ ug / m**3 s ]
5214 ! *** emissions rates for unidentified PM2.5 mass
5215 ! Delta ROG concentration of
5216 REAL epm25i(blksize) ! Aitken mode
5217 REAL epm25j(blksize)
5218 ! *** emissions rates for primary organic aerosol
5219 ! Accumululaton mode
5220 REAL eorgi(blksize) ! Aitken mode
5221 REAL eorgj(blksize)
5222 ! *** emissions rates for elemental carbon
5223 ! Accumululaton mode
5224 REAL eeci(blksize) ! Aitken mode
5225 REAL eecj(blksize)
5226 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
5228 ! Accumululaton mode
5229 REAL epm25(blksize) ! emissions rate for PM2.5 mass
5230 REAL esoil(blksize) ! emissions rate for soil derived coarse a
5231 REAL eseas(blksize) ! emissions rate for marine coarse aerosol
5232 REAL epmcoarse(blksize)
5233 ! emissions rate for anthropogenic coarse
5235 REAL dtsec
5236 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
5238 REAL newm3
5239 REAL totaersulf
5240 ! total aerosol sulfate
5241 ! loop index for time steps
5242 INTEGER numsteps
5243 REAL step
5245 ! *** arrays for aerosol model codes:
5247 ! synchronization time [s]
5249 INTEGER nspcsda
5251 ! number of species in CBLK ciarev02
5252 REAL cblk(blksize,nspcsda)
5254 ! *** Meteorological information in blocked arays:
5256 ! *** Thermodynamic variables:
5258 ! main array of variables
5259 REAL blkta(blksize) ! Air temperature [ K ]
5260 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5261 REAL blkdens(blksize) ! Air density [ kg m^-3 ]
5262 REAL blkrh(blksize)
5264 ! *** Chemical production rates [ ug m**-3 s -1 ] :
5266 ! Fractional relative humidity
5267 REAL so4rat(blksize) ! rate [ug/m^3/s]
5268 ! sulfuric acid vapor-phase production
5269 REAL organt1rat(blksize) ! production rate from aromatics [ ug /
5270 ! anthropogenic organic aerosol mass
5271 REAL organt2rat(blksize) ! production rate from aromatics [ ug /
5272 ! anthropogenic organic aerosol mass
5273 REAL organt3rat(blksize) ! rate from alkanes & others [ ug / m^3
5274 ! anthropogenic organic aerosol mass pro
5275 REAL organt4rat(blksize) ! rate from alkanes & others [ ug / m^3
5276 ! anthropogenic organic aerosol mass pro
5277 REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ]
5278 ! biogenic organic aerosol production
5279 REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ]
5280 ! biogenic organic aerosol production
5281 REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ]
5282 ! biogenic organic aerosol production
5283 REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ]
5284 !bs
5285 ! *** atmospheric properties
5287 ! biogenic organic aerosol production
5288 REAL xlm(blksize) ! atmospheric mean free path [ m ]
5289 REAL amu(blksize)
5290 ! *** aerosol properties:
5292 ! *** modal diameters:
5294 ! atmospheric dynamic viscosity [ kg
5295 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
5296 REAL dgacc(blksize) ! accumulation geometric mean diamet
5297 REAL dgcor(blksize)
5299 ! *** Modal mass concentrations [ ug m**3 ]
5301 ! coarse mode geometric mean diamete
5302 REAL pmassn(blksize) ! mass concentration in Aitken mode
5303 REAL pmassa(blksize) ! mass concentration in accumulation
5304 REAL pmassc(blksize)
5305 ! *** average modal particle densities [ kg/m**3 ]
5307 ! mass concentration in coarse mode
5308 REAL pdensn(blksize) ! average particle density in nuclei
5309 REAL pdensa(blksize) ! average particle density in accumu
5310 REAL pdensc(blksize)
5311 ! *** average modal Knudsen numbers
5313 ! average particle density in coarse
5314 REAL knnuc(blksize) ! nuclei mode Knudsen number
5315 REAL knacc(blksize) ! accumulation Knudsen number
5316 REAL kncor(blksize)
5317 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
5319 ! coarse mode Knudsen number
5320 REAL fconcn(blksize)
5321 ! reciprocal condensation rate Aitke
5322 REAL fconca(blksize) !bs
5323 ! reciprocal condensation rate acclu
5324 REAL fconcn_org(blksize)
5325 REAL fconca_org(blksize)
5327 ! *** Rates for secondary particle formation:
5329 ! *** production of new mass concentration [ ug/m**3 s ]
5330 REAL dmdt(blksize) ! by particle formation
5332 ! *** production of new number concentration [ number/m**3 s ]
5334 ! rate of production of new mass concen
5335 REAL dndt(blksize) ! by particle formation
5336 ! *** growth rate for third moment by condensation of precursor
5337 ! vapor on existing particles [ 3rd mom/m**3 s ]
5339 ! rate of producton of new particle num
5340 REAL cgrn3(blksize) ! Aitken mode
5341 REAL cgra3(blksize)
5342 ! *** Rates for coaglulation: [ m**3/s ]
5344 ! *** Unimodal Rates:
5346 ! Accumulation mode
5347 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
5348 REAL ura00(blksize)
5350 ! *** Bimodal Rates: Aitken mode with accumulation mode ( Aitken mode)
5351 ! accumulation mode 0th moment self-coagulat
5352 REAL brna01(blksize) ! rate for 0th moment
5353 REAL brna31(blksize)
5354 ! *** other processes
5356 ! rate for 3rd moment
5357 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
5359 ! *** housekeeping variables:
5360 ! increment of concentration added to
5361 INTEGER unit
5362 PARAMETER (unit=30)
5363 CHARACTER*16 pname
5364 PARAMETER (pname=' BOX ')
5365 INTEGER isp,igrid,jgrid,kgrid
5367 ! loop index for species.
5368 INTEGER ii, iimap(8)
5369 DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
5371 ! begin body of program box
5373 ! *** Set up files and other info
5374 ! *** set up experimental conditions
5375 ! *** initialize model variables
5376 !ia *** not required any more
5378 !ia DO ISP = 1, NSPCSDA
5379 !ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
5380 !ia END DO
5382 step = dtsec ! set time step
5384 blkta(blksize) = temp ! T in Kelvin
5386 blkprs(blksize)= pres*100. ! P in Pa (pres is given in
5388 blkrh(blksize) = relhum ! fractional RH
5390 blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in
5392 !rs CBLK(BLKSIZE,VHNO3) = nitrate_in
5393 !rs CBLK(BLKSIZE,VNH3) = nh3_in
5394 !bs
5395 !rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
5396 !rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
5397 !rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
5398 !rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
5399 !rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
5400 !rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
5401 !rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
5402 !rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
5404 DO isp = 1, ldrog_vbs
5405 drog(blksize,isp) = drog_in(isp)
5406 END DO
5408 ! print*,'drog in rpm',drog
5409 !bs
5410 !ia *** 27/05/97 the following variables are transported quantities
5411 !ia *** of the column-model now and thuse do not need this init.
5412 !ia *** step.
5414 ! CBLK(BLKSIZE,VNU0) = numnuc_in
5415 ! CBLK(BLKSIZE,VAC0) = numacc_in
5416 ! CBLK(BLKSIZE,VSO4A) = asulf_in
5417 ! CBLK(BLKSIZE,VSO4AI) = asulfi_in
5418 ! CBLK(BLKSIZE, VCORN) = numcor_in
5420 so4rat(blksize) = so4rat_in
5422 !...INITIALISE EMISSION RATES
5424 ! epm25i(blksize) = & ! unidentified PM2.5 mass
5425 ! 0.0
5426 ! epm25j(blksize) = &
5427 ! 0.0
5428 ! unidentified PM2.5 m
5429 eorgi(blksize) = & ! primary organic
5430 eorgi_in
5431 eorgj(blksize) = &
5432 eorgj_in
5433 ! primary organic
5434 eeci(blksize) = & ! elemental carbon
5435 eeci_in
5436 eecj(blksize) = &
5437 eecj_in
5438 ! elemental carbon
5439 epm25(blksize) = & !currently from input file ACTIONIA
5440 0.0
5441 esoil(blksize) = & ! ACTIONIA
5442 soilrat_in
5443 eseas(blksize) = & !currently from input file ACTIONIA
5444 0.0
5445 ! epmcoarse(blksize) = & !currently from input file ACTIONIA
5446 ! 0.0
5447 dgnuc(blksize) = dginin
5448 dgacc(blksize) = dginia
5449 dgcor(blksize) = dginic
5450 newm3 = 0.0
5452 ! *** Set up initial total 3rd moment factors
5454 totaersulf = 0.0
5455 newm3 = 0.0
5456 ! *** time loop
5457 ! write(50,*) ' numsteps dgnuc dgacc ', ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5459 ! *** Call aerosol routines
5460 CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5461 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat, &
5462 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5463 nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5464 amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5465 knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5466 urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid,brrto,do_isorropia,do_n2o5het)
5468 ! *** write output
5469 ! WRITE(UNIT,*) ' AFTER AEROPROC '
5470 ! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5472 ! *** Write out file for graphing.
5474 ! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5477 ! *** update sulfuric acid vapor
5478 !ia 21.04.98 this update is not required here
5479 !ia artefact from box model
5480 ! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5481 ! & SO4RAT(BLKSIZE) * STEP
5483 RETURN
5484 END SUBROUTINE rpmmod3
5485 !---------------------------------------------------------------------------
5486 SUBROUTINE soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
5487 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5488 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto)
5490 !***** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM *!
5491 !bs Description: !
5492 !bs !
5493 !bs SOA_VBS calculates the formation and partitioning of secondary !
5494 !bs organic aerosol based on (pseudo-)ideal solution thermodynamics. !
5495 !bs !
5496 !sam The original Schell model (JGR, vol. 106, D22, 28275-28293, 2001) !
5497 !sam is modified drastically to incorporate the SOA vapor-pressure !
5498 !sam basis set approach developed by Carnegie Mellon folks. !
5499 !sam Recommended changes according to Allen Robinson, 9/15/09 !
5500 !sam The treatment is done very similar to Lane et al., Atmos. Envrn., !
5501 !sam vol 42, 7439-7451, 2008. !
5502 !sam Four basis vapor-pressures for anthropogenic and 4 basis vp's !
5503 !sam for biogenic SOA are used. The SAPRC-99 yield information for !
5504 !sam low and high NOx conditions (Lane, Donahue and Pandis, ES&T, !
5505 !sam vol. 42, 6022-6027, 2008) are mapped to RADM2/RACM species. !
5506 !sam !
5507 !sam Basis vapor pressures (@ 300K) !
5508 !sam Anthro (1 ug/m3) - asoa1 Biogenic (1 ug/m3) - bsoa1 !
5509 !sam Anthro (10 ug/m3) - asoa2 Biogenic (10 ug/m3) - bsoa2 !
5510 !sam Anthro (100 ug/m3) - asoa3 Biogenic (100 ug/m3) - bsoa3 !
5511 !sam Anthro (1000 ug/m3)- asoa4 Biogenic (1000 ug/m3)- bsoa4 !
5512 !bs !
5513 !bs This code considers two cases: !
5514 !bs i) initil absorbing mass is existend in the aerosol phase !
5515 !bs ii) a threshold has to be exeeded before partitioning (even below !
5516 !bs saturation) will take place. !
5517 !bs !
5518 !bs The temperature dependence of the saturation concentrations are !
5519 !bs calculated using the Clausius-Clapeyron equation. !
5520 !bs !
5521 !bs If there is no absorbing mass at all the Pandis method is applied !
5522 !bs for the first steps. !
5523 !bs !
5524 !bs References: !
5525 !bs Pankow (1994): !
5526 !bs An absorption model of the gas/aerosol !
5527 !bs partitioning involved in the formation of !
5528 !bs secondary organic aerosol, Atmos. Environ. 28(2), !
5529 !bs 189-193. !
5530 !bs Odum et al. (1996): !
5531 !bs Gas/particle partitioning and secondary organic !
5532 !bs aerosol yields, Environ. Sci. Technol. 30, !
5533 !bs 2580-2585. !
5534 !bs see also !
5535 !bs Bowman et al. (1997): !
5536 !bs Mathematical model for gas-particle partitioning !
5537 !bs of secondary organic aerosols, Atmos. Environ. !
5538 !bs 31(23), 3921-3931. !
5539 !bs Seinfeld and Pandis (1998): !
5540 !bs Atmospheric Chemistry and Physics (0-471-17816-0) !
5541 !bs chapter 13.5.2 Formation of binary ideal solution !
5542 !bs with -- preexisting aerosol !
5543 !bs -- other organic vapor !
5544 !bs !
5545 !bs Called by: SOA_VBS !
5546 !bs !
5547 !bs Calls: None !
5548 !bs !
5549 !bs Arguments: LAYER, !
5550 !bs BLKTA, BLKPRS, !
5551 !bs ORGARO1RAT, ORGARO2RAT, !
5552 !bs ORGALK1RAT, ORGOLE1RAT, !
5553 !bs ORGBIO1RAT, ORGBIO2RAT, !
5554 !bs ORGBIO3RAT, ORGBIO4RAT, !
5555 !bs DROG, LDROG, NCV, NACV, !
5556 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
5557 !bs DT !
5558 !bs !
5559 !bs Include files: AEROSTUFF.EXT !
5560 !bs AERO_internal.EXT !
5561 !bs !
5562 !bs Data: None !
5563 !bs !
5564 !bs Input files: None !
5565 !bs !
5566 !bs Output files: None !
5567 !bs !
5568 !bs--------------------------------------------------------------------!
5569 !bs !
5570 !bs History: !
5571 !bs No Date Author Change !
5572 !bs ____ ______ ________________ _________________________________ !
5573 ! 01 052011 McKeen/Ahmadov Subroutine development !
5575 USE module_configure, only: grid_config_rec_type
5577 ! model layer
5578 INTEGER layer
5579 ! dimension of arrays
5580 INTEGER blksize
5581 ! number of species in CBLK
5582 INTEGER nspcsda ! actual number of cells in arrays
5583 INTEGER numcells ! # of organic aerosol precursor
5584 INTEGER ldrog_vbs ! total # of cond. vapors & SOA sp
5585 INTEGER ncv ! # of anthrop. cond. vapors & SOA
5586 INTEGER nacv
5587 INTEGER igrid,jgrid,kgrid
5589 REAL cblk(blksize,nspcsda) ! main array of variables
5590 REAL dt ! model time step in SECONDS
5591 REAL blkta(blksize) ! Air temperature [ K ]
5592 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5594 REAL, INTENT(OUT) :: brrto ! branching ratio for NOx conditions
5596 ! anthropogenic organic vapor production rates
5598 REAL organt1rat(blksize) ! rates from
5599 REAL organt2rat(blksize) ! rates from
5600 REAL organt3rat(blksize) ! rates from
5601 REAL organt4rat(blksize) ! rates from
5603 ! biogenic organic vapor production rates
5604 REAL orgbio1rat(blksize)
5605 REAL orgbio2rat(blksize)
5606 REAL orgbio3rat(blksize)
5607 REAL orgbio4rat(blksize)
5608 REAL drog(blksize,ldrog_vbs) !blksize=1, ldrog_vbs=9+1, the last ldrog_vbs is actually is the branching ratio
5610 !bs * local variable declaration
5611 ! Delta ROG conc. [ppm]
5612 !bs numerical value for a minimum thresh
5613 REAL,PARAMETER :: thrsmin=1.E-19
5614 !bs numerical value for a minimum thresh
5615 !bs
5616 !bs universal gas constant [J/mol-K]
5617 REAL, PARAMETER :: rgas=8.314510
5619 !sam reference temperature T0 = 300 K, a change from original 298K
5620 REAL, PARAMETER :: tnull=300.
5622 !bs molecular weight for C
5623 REAL, PARAMETER :: mwc=12.0
5624 !bs molecular weight for organic species
5625 REAL, PARAMETER :: mworg=175.0
5626 !bs molecular weight for SO4
5627 REAL, PARAMETER :: mwso4=96.0576
5628 !bs molecular weight for NH4
5629 REAL, PARAMETER :: mwnh4=18.03858
5630 !bs molecular weight for NO3
5631 REAL, PARAMETER :: mwno3=62.01287
5632 ! molecular weight for AIR
5634 ! REAL mwair
5635 ! PARAMETER (mwair=28.964)
5636 !bs relative tolerance for mass check
5637 REAL, PARAMETER :: CABSMIN=.00001 ! Minimum amount of absorbing material - needed in iteration method
5638 !sm number of basis set variables in CMU partitioning scheme
5639 INTEGER, PARAMETER :: nbin=4 ! we use 4 bin volatility according to Robinson A. et al.
5641 ! we have 2 type of SOA - anthropogenic and biogenic
5642 !sm number of SAPRC species variables in CMU lumped partitioning table
5643 !sm 1=ALK4(hc5),2=ALK5(hc8),3=OLE1(ol2),4=OLE2(oli),5=ARO1(tol)
5644 !sm 6=AOR2(xyl),7=ISOP(iso),8=SESQ(?),9=TERP(alp)
5645 INTEGER, PARAMETER :: nsaprc=9 ! number of precursor classes
5647 !bs loop indices
5648 INTEGER lcell, n, l, ll, bn, cls
5649 !bs conversion factor ppm --> ug/m^3
5650 REAL convfac
5651 !bs difference of inverse temperatures
5652 REAL ttinv
5653 !bs initial organic absorbing mass [ug/m^3]
5654 REAL minit
5655 !bs inorganic mass [ug/m^3]
5656 REAL mnono
5657 !bs total organic mass [ug/m^3]
5658 REAL mtot
5660 ! REAL msum(ncv) !bs input total mass [ug/m^3]
5661 REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
5662 REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
5663 REAL dhvap(ncv) !bs heat of vaporisation of compound i [
5664 REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]
5665 REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
5666 REAL cgas(ncv) !bs gasphase concentration of cond. vapors
5667 REAL caer(ncv) !bs aerosolphase concentration of cond.
5668 REAL asav(ncv) !bs saved CAER for iteration
5669 REAL aold(ncv) !bs saved CAER for rate determination
5670 REAL csat(ncv) !bs saturation conc. of cond. vapor ug/,
5672 ! in basis set approach we need only 4 csat
5673 REAL ccsat(nbin)
5674 REAL ccaer(nbin)
5675 REAL cctot(nbin)
5676 REAL w1(nbin), w2(nbin)
5678 REAL prod(ncv) !bs production of condensable vapor ug/
5679 REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]
5680 REAL f(ldrog_vbs) !bs scaling factor for ind. oxidant
5682 REAL alphlowN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors low NOx condition
5683 REAL alphhiN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors high NOx condition
5684 REAL alphai(nbin,nsaprc) ! mass-based stoichometric yield for product i and csti is the effective saturation
5685 ! concentration in ug m^-3
5686 REAL mwvoc(nsaprc) ! molecular weight of the SOA precusors
5688 REAL PnGtotal,DUM,FMTOT,FMTOT2,DUM2 ! Real constants used in Newton iteration
5689 integer, save :: icall
5691 ! this is a correction factor to take into account the density of aerosols, from Murphy et al. (2009)
5692 ! Now it's determined by namelist
5694 ! in the preliminary version we use alphlowN only to check what would be the maximum yeild
5695 ! SAM: from Murphy et al. 2009
5696 DATA alphlowN / &
5697 0.0000, 0.0750, 0.0000, 0.0000, & ! ALK4
5698 0.0000, 0.3000, 0.0000, 0.0000, & ! ALK5
5699 0.0045, 0.0090, 0.0600, 0.2250, & ! OLE1
5700 0.0225, 0.0435, 0.1290, 0.3750, & ! OLE2
5701 0.0750, 0.2250, 0.3750, 0.5250, & ! ARO1
5702 0.0750, 0.3000, 0.3750, 0.5250, & ! ARO2
5703 0.0090, 0.0300, 0.0150, 0.0000, & ! ISOP
5704 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5705 0.1073, 0.0918, 0.3587, 0.6075/ ! TERP
5707 DATA alphhiN / &
5708 0.0000, 0.0375, 0.0000, 0.0000, & ! ALK4
5709 0.0000, 0.1500, 0.0000, 0.0000, & ! ALK5
5710 0.0008, 0.0045, 0.0375, 0.1500, & ! OLE1
5711 0.0030, 0.0255, 0.0825, 0.2700, & ! OLE2
5712 0.0030, 0.1650, 0.3000, 0.4350, & ! ARO1
5713 0.0015, 0.1950, 0.3000, 0.4350, & ! ARO2
5714 0.0003, 0.0225, 0.0150, 0.0000, & ! ISOP
5715 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5716 0.0120, 0.1215, 0.2010, 0.5070/ ! TERP
5718 DATA mwvoc / &
5719 73.23, & ! ALK4
5720 106.97, & ! ALK5
5721 61.68, & ! OLE1
5722 79.05, & ! OLE2
5723 100.47, & ! ARO1
5724 113.93, & ! ARO2
5725 68.12, & ! ISOP
5726 204.0, & ! SESQ
5727 136.24 / ! TERP
5729 !bs * initialisation
5730 !bs
5731 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
5732 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5733 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5734 !bs * average value is 156 kJ/mol
5735 !
5736 !sam changed 156kJ/mol to 30.kJ/mol as in Lane et al., AE, 2008
5737 dhvap(pasoa1) = 30.0E03
5738 dhvap(pasoa2) = 30.0E03
5739 dhvap(pasoa3) = 30.0E03
5740 dhvap(pasoa4) = 30.0E03
5742 dhvap(pbsoa1) = 30.0E03
5743 dhvap(pbsoa2) = 30.0E03
5744 dhvap(pbsoa3) = 30.0E03
5745 dhvap(pbsoa4) = 30.0E03
5746 !----------------------------------------------------------------
5747 !bs
5748 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
5749 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5750 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5751 !bs * average value is 222.5 g/mol
5752 !bs *
5753 !bs * molecular weights used are estimates taking the origin (reactants)
5754 !bs * into account. This should be updated if more information about
5755 !bs * the products is available.
5756 !bs * First hints are taken from Forstner et al. (1997), Environ. S
5757 !bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmos.
5758 !bs * Environ. 31(13), 1953-1964.
5759 !bs *
5760 ! Molecular weights of OCVs as in Murphy and Pandis, 2009
5761 mwcv(pasoa1) = 150.
5762 mwcv(pasoa2) = 150.
5763 mwcv(pasoa3) = 150.
5764 mwcv(pasoa4) = 150.
5766 mwcv(pbsoa1) = 180.
5767 mwcv(pbsoa2) = 180.
5768 mwcv(pbsoa3) = 180.
5769 mwcv(pbsoa4) = 180.
5771 ! In Shell partitioned aerosols according to their precursors, but we do as Allen due to the saturation concentrations
5772 ! We have 2 sets for anthropogenic and biogenic and therefore we use the same denotation
5773 pnull(pasoa1) = 1.
5774 pnull(pasoa2) = 10.
5775 pnull(pasoa3) = 100.
5776 pnull(pasoa4) = 1000.
5778 pnull(pbsoa1) = 1.
5779 pnull(pbsoa2) = 10.
5780 pnull(pbsoa3) = 100.
5781 pnull(pbsoa4) = 1000.
5783 ! scaling factors, for testing purposes, check TOL and ISO only
5784 ! 05/23/2011: for testing all are zero!
5785 f(palk4) = 1.
5786 f(palk5) = 1.
5787 f(pole1) = 1.
5788 f(pole2) = 1.
5789 f(paro1) = 1.
5790 f(paro2) = 1.
5791 f(pisop) = 1.
5792 f(pterp) = 1.
5793 f(psesq) = 1.
5795 loop_cells: DO lcell = 1, numcells ! numcells=1
5796 DO l= 1, ldrog_vbs-1
5797 drog(lcell,l) = f(l)*drog(lcell,l)
5798 END DO
5800 ! calculation of the yields using the branching ratio
5801 brrto= drog(lcell,pbrch) ! temporary variable for the branching ratio
5802 DO bn=1,nbin ! bins
5803 DO cls=1,nsaprc ! classes
5804 alphai(bn,cls)= mwvoc(cls)*( alphhiN(bn,cls)*brrto + alphlowN(bn,cls)*(1.-brrto) )
5805 ENDDO
5806 ENDDO
5808 ttinv = 1./tnull - 1./blkta(lcell)
5809 convfac = blkprs(lcell)/(rgas*blkta(lcell))
5811 ! cblk for gases comes in ppmv, we get the density in ug/m3 (microgram/m3)
5812 ! by multiplying it by (convfac=rho_air/mu_air)x mwcv
5813 cgas(pasoa1) = cblk(lcell,vcvasoa1)*convfac*mwcv(pasoa1)
5814 cgas(pasoa2) = cblk(lcell,vcvasoa2)*convfac*mwcv(pasoa2)
5815 cgas(pasoa3) = cblk(lcell,vcvasoa3)*convfac*mwcv(pasoa3)
5816 cgas(pasoa4) = cblk(lcell,vcvasoa4)*convfac*mwcv(pasoa4)
5818 cgas(pbsoa1) = cblk(lcell,vcvbsoa1)*convfac*mwcv(pbsoa1)
5819 cgas(pbsoa2) = cblk(lcell,vcvbsoa2)*convfac*mwcv(pbsoa2)
5820 cgas(pbsoa3) = cblk(lcell,vcvbsoa3)*convfac*mwcv(pbsoa3)
5821 cgas(pbsoa4) = cblk(lcell,vcvbsoa4)*convfac*mwcv(pbsoa4)
5823 ! cblk for aerosols come in density (ug/m3), converted already in soa_vbs_driver
5824 caer(pasoa1) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)
5825 caer(pasoa2) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)
5826 caer(pasoa3) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)
5827 caer(pasoa4) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)
5829 caer(pbsoa1) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)
5830 caer(pbsoa2) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)
5831 caer(pbsoa3) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)
5832 caer(pbsoa4) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)
5834 ! #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
5835 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5836 !SAM diagnostics
5837 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5838 ! if (igrid .eq. 1 .AND. jgrid .eq. 18) then
5839 ! if (kgrid .eq. 1 )then
5840 ! write(6,*)'drog', drog
5841 ! write(6,*)'caer(pasoa1)',caer(pasoa1)
5842 ! write(6,*)'caer(pasoa4)',caer(pasoa4)
5843 ! write(6,*)'caer(pbsoa1)',caer(pbsoa1)
5844 ! endif
5845 ! endif
5846 !SAM end print of aerosol physical parameter diagnostics
5847 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5848 ! #endif
5849 ! Production of SOA by oxidation of VOCs
5850 ! There are 6 classes of the precursors for ansthropogenic SOA
5851 prod(pasoa1) = alphai(1,1)*drog(lcell,palk4) + alphai(1,2)*drog(lcell,palk5) + &
5852 alphai(1,3)*drog(lcell,pole1) + alphai(1,4)*drog(lcell,pole2) + &
5853 alphai(1,5)*drog(lcell,paro1) + alphai(1,6)*drog(lcell,paro2)
5855 prod(pasoa2) = alphai(2,1)*drog(lcell,palk4) + alphai(2,2)*drog(lcell,palk5) + &
5856 alphai(2,3)*drog(lcell,pole1) + alphai(2,4)*drog(lcell,pole2) + &
5857 alphai(2,5)*drog(lcell,paro1) + alphai(2,6)*drog(lcell,paro2)
5859 prod(pasoa3) = alphai(3,1)*drog(lcell,palk4) + alphai(3,2)*drog(lcell,palk5) + &
5860 alphai(3,3)*drog(lcell,pole1) + alphai(3,4)*drog(lcell,pole2) + &
5861 alphai(3,5)*drog(lcell,paro1) + alphai(3,6)*drog(lcell,paro2)
5863 prod(pasoa4) = alphai(4,1)*drog(lcell,palk4) + alphai(4,2)*drog(lcell,palk5) + &
5864 alphai(4,3)*drog(lcell,pole1) + alphai(4,4)*drog(lcell,pole2) + &
5865 alphai(4,5)*drog(lcell,paro1) + alphai(4,6)*drog(lcell,paro2)
5867 ! There are 3 classes of the precursors for biogenic SOA
5868 prod(pbsoa1) = alphai(1,7)*drog(lcell,pisop) + alphai(1,8)*drog(lcell,psesq) + &
5869 alphai(1,9)*drog(lcell,pterp)
5871 prod(pbsoa2) = alphai(2,7)*drog(lcell,pisop) + alphai(2,8)*drog(lcell,psesq) + &
5872 alphai(2,9)*drog(lcell,pterp)
5874 prod(pbsoa3) = alphai(3,7)*drog(lcell,pisop) + alphai(3,8)*drog(lcell,psesq) + &
5875 alphai(3,9)*drog(lcell,pterp)
5877 prod(pbsoa4) = alphai(4,7)*drog(lcell,pisop) + alphai(4,8)*drog(lcell,psesq) + &
5878 alphai(4,9)*drog(lcell,pterp)
5880 !bs * calculate actual production from gasphase reactions [ug/m^3]
5881 !bs * calculate vapor pressure of pure compound as a liquid using the Clausius-Clapeyron equation and the actual saturation concentration.
5882 !bs * calculate the threshold for partitioning if no initial mass is present to partition into.
5884 loop_cc: DO l = 1,ncv ! we've total ncv=4*2 bins, no alpha is needed here
5885 prod(l) = convfac*prod(l) ! get in density units (ug/m3) from ppmv, (convfac=rho_air/mu_air)
5886 ctot(l) = prod(l) + cgas(l) + caer(l)
5887 aold(l) = caer(l)
5889 ! csat should be calculated 4 times, since pnull is the same for biogenic!
5890 csat(l) = pnull(l)*tnull/blkta(lcell)*exp(dhvap(l)/rgas*ttinv)
5891 END DO loop_cc
5893 ! when we solve the nonlinear equation to determine "caer" we need to combine
5894 ! asoa(n) and bsoa(n), since they have the same saturation concentrations, hence the equilibrium should cover the same bins
5896 PnGtotal=0. ! track total Condensed Vapors&SOA over bins for limits on Newton Iteration of total SOA mass
5897 do ll=1,nbin
5898 ccsat(ll)= csat(ll)
5899 ccaer(ll)= caer(ll) + caer(ll+4)
5900 cctot(ll)= ctot(ll) + ctot(ll+4)
5901 PnGtotal=PnGtotal+cctot(ll)
5902 w1(ll)= ctot(ll)/cctot(ll) ! Anthropogenic fraction to total
5903 w2(ll)= 1. - w1(ll) ! Biogenic fraction of total
5904 end do
5906 !bs
5907 !bs * small amount of non-volatile absorbing mass is assumed to be
5908 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
5909 !bs * mass in each size section, here mode)
5910 !bs
5911 ! inorganic mass isn't needed here
5912 !mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+ cblk(lcell,vno3aj))
5913 !mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+ cblk(lcell,vno3ai))
5915 ! they're assigned to zero at the next step
5916 ! test with minit=0
5917 ! minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) !+ mnono
5918 minit= 1.4*( cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) ) ! exclude EC from absorbing mass
5920 ! minit is taken into account
5922 !bs * If MINIT is set to zero partitioning will occur if the pure
5923 !bs * saturation concentation is exceeded (Pandis et al. 1992).
5924 !bs * If some amount of absorbing organic mass is formed gas/particle
5925 !bs * partitioning will follow the ideal solution approach.
5926 !bs
5927 !SAM 9/8/09 - Include absorbing SOA material within aerosols in calculation !
5929 minit = AMAX1(minit,CABSMIN)
5931 ! mtot is initial guess to SOA mass (aerosol plus extra absorbing mass (minit))
5932 mtot = 0.
5933 DO L=1,NBIN
5934 mtot = mtot + AMIN1(1.,CCTOT(L)/CCSAT(L))*CCTOT(L)
5935 ENDDO
5936 mtot = mtot + minit
5937 !
5938 ! debugging
5939 !if (igrid .eq. 8 .AND. jgrid .eq. 18) then
5940 ! if (kgrid .eq. 1 )then
5941 ! write(6,*)'before Newton iteration'
5942 ! write(6,*)'MTOT=',MTOT
5943 ! write(6,*)'minit=',minit
5944 ! write(6,*)'w1=',w1,'w2=',w2
5945 ! write(6,*)'cctot=',cctot
5946 ! write(6,*)'ccaer=',ccaer
5947 ! write(6,*)'ccsat=',ccsat
5948 ! write(6,*)'nbin=',nbin
5949 ! endif
5950 !endif
5952 !SAM: Find total SOA mass from newton iteration, needs only 5 iterations for exact solution
5953 loop_newt: DO LL=1,5 ! Fixed Newton iteration number
5954 FMTOT=0.
5955 FMTOT2=0.
5956 DO L=1,NBIN
5957 DUM=CCTOT(L)/(1.+CCSAT(L)/MTOT)
5958 FMTOT=FMTOT+DUM
5959 FMTOT2=FMTOT2+DUM**2
5960 ENDDO
5961 FMTOT=FMTOT+MINIT ! Forecast total SOA mass
5962 DUM=MTOT-FMTOT
5963 DUM2=((FMTOT-MINIT)/MTOT)-MTOT*FMTOT2
5964 MTOT=MTOT-DUM/(1.-DUM2)
5965 MTOT=AMAX1(MTOT,MINIT) ! Limit MTOT to min possible in case of instability
5966 MTOT=AMIN1(MTOT,PnGtotal+minit) ! Limit MTOT to max possible in case of instability
5967 END DO loop_newt ! LL iteration number loop
5969 ! Have total mass MTOT, get aerosol mass from semi-ideal partitioning equation
5970 DO L=1,NBIN
5971 CCAER(L)=CCTOT(L)*MTOT/(MTOT+CCSAT(L))
5972 ENDDO
5973 !
5975 do ll=1,nbin
5976 caer(ll)= AMAX1(w1(ll)*ccaer(ll),CONMIN)
5977 caer(ll+4)= AMAX1(w2(ll)*ccaer(ll),CONMIN)
5978 cgas(ll)= w1(ll)*(cctot(ll) - ccaer(ll))
5979 cgas(ll+4)= w2(ll)*(cctot(ll) - ccaer(ll))
5980 end do
5982 ! assigning values to CBLK array (gases), convert to ppm since it goes to chem
5983 cblk(lcell,vcvasoa1) = max(cgas(pasoa1),conmin)/convfac/mwcv(pasoa1)
5984 cblk(lcell,vcvasoa2) = max(cgas(pasoa2),conmin)/convfac/mwcv(pasoa2)
5985 cblk(lcell,vcvasoa3) = max(cgas(pasoa3),conmin)/convfac/mwcv(pasoa3)
5986 cblk(lcell,vcvasoa4) = max(cgas(pasoa4),conmin)/convfac/mwcv(pasoa4)
5988 cblk(lcell,vcvbsoa1) = max(cgas(pbsoa1),conmin)/convfac/mwcv(pbsoa1)
5989 cblk(lcell,vcvbsoa2) = max(cgas(pbsoa2),conmin)/convfac/mwcv(pbsoa2)
5990 cblk(lcell,vcvbsoa3) = max(cgas(pbsoa3),conmin)/convfac/mwcv(pbsoa3)
5991 cblk(lcell,vcvbsoa4) = max(cgas(pbsoa4),conmin)/convfac/mwcv(pbsoa4)
5993 organt1rat(lcell) = (caer(pasoa1)-aold(pasoa1))/dt
5994 organt2rat(lcell) = (caer(pasoa2)-aold(pasoa2))/dt
5995 organt3rat(lcell) = (caer(pasoa3)-aold(pasoa3))/dt
5996 organt4rat(lcell) = (caer(pasoa4)-aold(pasoa4))/dt
5998 orgbio1rat(lcell) = (caer(pbsoa1)-aold(pbsoa1))/dt
5999 orgbio2rat(lcell) = (caer(pbsoa2)-aold(pbsoa2))/dt
6000 orgbio3rat(lcell) = (caer(pbsoa3)-aold(pbsoa3))/dt
6001 orgbio4rat(lcell) = (caer(pbsoa4)-aold(pbsoa4))/dt
6002 END DO loop_cells
6003 RETURN
6004 END SUBROUTINE soa_vbs
6005 !
6006 ! *** this routine calculates the dry deposition and sedimentation
6007 ! velocities for the three modes.
6008 ! coded 1/23/97 by Dr. Francis S. Binkowski. Follows
6009 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
6010 ! velocity but includes Marv Wesely's wstar contribution.
6011 !ia eliminated Stokes term for coarse mode deposition calcs.,
6012 !ia see comments below
6014 SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, &
6015 LAYER, &
6016 CBLK, &
6017 BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, &
6018 DGNUC, DGACC, DGCOR, &
6019 KNNUC, KNACC,KNCOR, &
6020 PDENSN, PDENSA, PDENSC, &
6021 VSED, VDEP )
6023 ! *** calculate size-averaged particle dry deposition and
6024 ! size-averaged sedimentation velocities.
6027 ! IMPLICIT NONE
6029 INTEGER BLKSIZE ! dimension of arrays
6030 INTEGER NSPCSDA ! number of species in CBLK
6031 INTEGER NUMCELLS ! actual number of cells in arrays
6032 INTEGER LAYER ! number of layer
6034 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6035 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
6036 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
6037 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
6038 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
6039 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
6040 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6041 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
6042 REAL DGACC( BLKSIZE ) ! accumulation
6043 REAL DGCOR( BLKSIZE ) ! coarse mode
6044 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
6045 REAL KNACC( BLKSIZE ) ! accumulation
6046 REAL KNCOR( BLKSIZE ) ! coarse mode
6047 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
6048 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
6049 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
6052 ! *** modal particle diffusivities for number and 3rd moment, or mass:
6054 REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
6055 REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
6057 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
6059 REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
6060 REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
6062 ! *** deposition and sedimentation velocities
6064 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
6065 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
6068 INTEGER LCELL
6069 REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
6070 REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
6071 REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
6072 REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
6073 REAL ST0N, ST0A, ST0C ! Stokes numbers for number
6074 REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
6075 REAL RD0N, RD0A, RD0C ! canopy resistance for number
6076 REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment
6077 REAL UTSCALE ! scratch function of USTAR and WSTAR.
6078 REAL NU !kinematic viscosity [ m**2 s**-1 ]
6079 REAL USTFAC ! scratch function of USTAR, NU, and GRAV
6080 REAL BHAT
6081 PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction.
6084 ! *** check layer value.
6086 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
6087 ! sedimentation velocities
6089 DO LCELL = 1, NUMCELLS
6091 DCONST1 = BOLTZ * BLKTA(LCELL) / &
6092 ( THREEPI * AMU(LCELL) )
6093 DCONST1N = DCONST1 / DGNUC( LCELL )
6094 DCONST1A = DCONST1 / DGACC( LCELL )
6095 DCONST1C = DCONST1 / DGCOR( LCELL )
6096 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6097 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6098 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6099 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6101 ! *** i-mode
6103 DCHAT0N(LCELL) = DCONST1N &
6104 * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
6106 DCHAT3N(LCELL) = DCONST1N &
6107 * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
6109 VGHAT0N(LCELL) = DCONST3N &
6110 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6112 VGHAT3N(LCELL) = DCONST3N &
6113 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6115 ! *** j-mode
6117 DCHAT0A(LCELL) = DCONST1A &
6118 * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
6120 DCHAT3A(LCELL) = DCONST1A &
6121 * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
6123 VGHAT0A(LCELL) = DCONST3A &
6124 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6126 VGHAT3A(LCELL) = DCONST3A &
6127 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6130 ! *** coarse mode
6132 DCHAT0C(LCELL)= DCONST1C &
6133 * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
6135 DCHAT3C(LCELL) = DCONST1C &
6136 * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
6138 VGHAT0C(LCELL) = DCONST3C &
6139 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6141 VGHAT3C(LCELL) = DCONST3C &
6142 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6144 END DO
6146 ! *** now calculate the deposition and sedmentation velocities
6148 !ia 07.05.98
6149 ! *** NOTE In the deposition velocity for coarse mode,
6150 ! the impaction term 10.0 ** (-3.0 / st) is eliminated because
6151 ! coarse particles are likely to bounce on impact and the current
6152 ! formulation does not account for this.
6155 DO LCELL = 1, NUMCELLS
6157 NU = AMU(LCELL) / BLKDENS(LCELL)
6158 USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
6159 UTSCALE = USTAR(LCELL) + &
6160 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
6162 ! *** first do number
6164 ! *** nuclei or Aitken mode ( no sedimentation velocity )
6166 SC0N = NU / DCHAT0N(LCELL)
6167 ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
6168 RD0N = 1.0 / ( UTSCALE * &
6169 ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
6171 VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + &
6172 1.0 / ( &
6173 RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
6175 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6177 ! *** accumulation mode
6179 SC0A = NU / DCHAT0A(LCELL)
6180 ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
6181 RD0A = 1.0 / ( UTSCALE * &
6182 ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
6184 VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + &
6185 1.0 / ( &
6186 RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
6188 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6190 ! *** coarse mode
6192 SC0C = NU / DCHAT0C(LCELL)
6193 !ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
6194 !ia RD0C = 1.0 / ( UTSCALE *
6195 !ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
6197 RD0C = 1.0 / ( UTSCALE * &
6198 ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term
6200 VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + &
6201 1.0 / ( &
6202 RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
6204 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6206 ! *** now do m3 for the deposition of mass
6208 ! *** nuclei or Aitken mode
6210 SC3N = NU / DCHAT3N(LCELL)
6211 ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
6212 RD3N = 1.0 / ( UTSCALE * &
6213 ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
6215 VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + &
6216 1.0 / ( &
6217 RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
6219 VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
6221 ! *** accumulation mode
6223 SC3A = NU / DCHAT3A(LCELL)
6224 ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
6225 RD3A = 1.0 / ( UTSCALE * &
6226 ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
6228 VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + &
6229 1.0 / ( &
6230 RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
6233 ! *** fine mass deposition velocity: combine Aitken and accumulation
6234 ! mode deposition velocities. Assume density is the same
6235 ! for both modes.
6238 ! VDEP(LCELL,VDMFINE) = (
6239 ! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
6240 ! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
6241 ! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
6244 ! *** fine mass sedimentation velocity
6246 ! VSED( LCELL, VSMFINE) = (
6247 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6248 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6249 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6251 VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
6253 ! *** coarse mode
6255 SC3C = NU / DCHAT3C(LCELL)
6256 !ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
6257 !ia RD3C = 1.0 / ( UTSCALE *
6258 !ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
6260 RD3C = 1.0 / ( UTSCALE * &
6261 ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
6262 VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + &
6263 1.0 / ( &
6264 RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
6266 ! *** coarse mode sedmentation velocity
6268 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6272 END DO
6274 ELSE ! LAYER greater than 1
6276 ! *** for layer greater than 1 calculate sedimentation velocities only
6278 DO LCELL = 1, NUMCELLS
6280 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6282 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6283 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6284 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6286 VGHAT0N(LCELL) = DCONST3N &
6287 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6289 ! *** nucleation mode number sedimentation velocity
6291 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6293 VGHAT3N(LCELL) = DCONST3N &
6294 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6296 ! *** nucleation mode volume sedimentation velocity
6298 VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
6300 VGHAT0A(LCELL) = DCONST3A &
6301 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6303 ! *** accumulation mode number sedimentation velocity
6305 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6307 VGHAT3A(LCELL) = DCONST3A &
6308 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6310 ! *** fine mass sedimentation velocity
6312 ! VSED( LCELL, VSMFINE) = (
6313 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6314 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6315 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6317 VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
6319 VGHAT0C(LCELL) = DCONST3C &
6320 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6322 ! *** coarse mode sedimentation velocity
6324 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6327 VGHAT3C(LCELL) = DCONST3C &
6328 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6330 ! *** coarse mode mass sedimentation velocity
6332 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6334 END DO
6336 END IF ! check on layer
6338 END SUBROUTINE VDVG
6339 !
6340 !---------------------------------------------------------------------------
6341 !
6342 ! *** this routine calculates the dry deposition and sedimentation
6343 ! velocities for the three modes.
6344 ! Stu McKeen 10/13/08
6345 ! Gaussian Quadrature numerical integration over diameter range for each mode.
6346 ! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10
6347 ! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv
6348 ! Numerical Integration allows more complete discription of the
6349 ! Cunningham Slip correction factor, Interception Term (not included previously),
6350 ! and the correction due to rebound for higher diameter particles.
6351 ! Sedimentation velocities the same as original Binkowski code, also the
6352 ! Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the
6353 ! same as Binkowski.
6354 ! Stokes number, and efficiency dependence on Stokes number now according to
6355 ! Peters and Eiden (1992). Interception term taken from Slinn (1982) with
6356 ! efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy
6357 ! for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction
6358 ! term is that of Slinn (1982)
6359 !
6360 ! Original code 1/23/97 by Dr. Francis S. Binkowski. Follows
6361 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
6362 ! velocity but includes Marv Wesely's wstar contribution.
6363 !ia eliminated Stokes term for coarse mode deposition calcs.,
6364 !ia see comments below
6366 ! CBLK is eliminated since the subroutine doesn't use it!
6367 SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, &
6368 LAYER, &
6369 BLKTA, BLKDENS, &
6370 RA, USTAR, PBLH, ZNTT, RMOLM, AMU, &
6371 DGNUC, DGACC, DGCOR, XLM, &
6372 KNNUC, KNACC,KNCOR, &
6373 PDENSN, PDENSA, PDENSC, &
6374 VSED, VDEP)
6376 ! *** calculate size-averaged particle dry deposition and
6377 ! size-averaged sedimentation velocities.
6378 ! IMPLICIT NONE
6380 INTEGER BLKSIZE ! dimension of arrays
6381 INTEGER NSPCSDA ! number of species in CBLK
6382 INTEGER NUMCELLS ! actual number of cells in arrays
6383 INTEGER LAYER ! number of layer
6384 INTEGER, PARAMETER :: iprnt = 0
6386 ! REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6387 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
6388 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
6389 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
6390 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
6391 REAL PBLH( BLKSIZE ) ! PBL height (m)
6392 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
6393 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
6394 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6395 REAL XLM( BLKSIZE ) ! mean free path of dry air [ m ]
6396 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
6397 REAL DGACC( BLKSIZE ) ! accumulation
6398 REAL DGCOR( BLKSIZE ) ! coarse mode
6399 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
6400 REAL KNACC( BLKSIZE ) ! accumulation
6401 REAL KNCOR( BLKSIZE ) ! coarse mode
6402 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode [ kg / m**3 ]
6403 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode [ kg / m**3 ]
6404 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode [ kg / m**3 ]
6406 ! *** deposition and sedimentation velocities
6408 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimentation velocity [ m s**-1 ]
6409 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
6411 INTEGER LCELL,N
6412 REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C
6413 REAL UTSCALE,CZH ! scratch functions of USTAR and WSTAR.
6414 REAL NU !kinematic viscosity [ m**2 s**-1 ]
6415 REAL BHAT
6416 PARAMETER( BHAT = 1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction.
6417 REAL COLCTR_BIGD,COLCTR_SMALD
6418 PARAMETER ( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6 ) ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest)
6419 REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim
6420 REAL Eff_dif, Eff_imp, Eff_int, RBcor
6421 INTEGER ISTOPvd0,IdoWesCor
6422 PARAMETER (ISTOPvd0 = 0) ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs.
6424 ! no Wesley deposition, otherwise EC is too low
6425 PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means don't do correction
6426 IF (ISTOPvd0.EQ.1)THEN
6427 RETURN
6428 ENDIF
6429 ! *** check layer value.
6431 IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER
6432 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and sedimentation velocities
6434 DO LCELL = 1, NUMCELLS
6435 DCONST1 = BOLTZ * BLKTA(LCELL) / &
6436 ( THREEPI * AMU(LCELL) )
6437 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6438 DCONST3 = USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD)
6440 ! *** now calculate the deposition velocities at layer 1
6442 NU = AMU(LCELL) / BLKDENS(LCELL)
6444 UTSCALE = 1.
6445 IF (IdoWesCor.EQ.1)THEN
6446 ! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08)
6447 IF(RMOLM(LCELL).LT.0.)THEN
6448 CZH = -1.*PBLH(LCELL)*RMOLM(LCELL)
6449 IF(CZH.GT.30.0)THEN
6450 UTSCALE=0.45*CZH**0.6667
6451 ELSE
6452 UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667
6453 ENDIF
6454 ENDIF
6455 ENDIF ! end of (IdoWesCor.EQ.1) test
6457 UTSCALE = USTAR(LCELL)*UTSCALE
6458 IF(iprnt.eq.1)THEN
6459 print *,'NGAUSdv,xxlsga,USTAR,UTSCALE'
6460 print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE
6461 print *,'DCONST2,PDENSA,DGACC,GRAV,AMU'
6462 print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL)
6463 endif
6465 ! *** nuclei mode
6467 SUM0=0.
6468 SUM3=0.
6469 DO N=1,NGAUSdv
6470 DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn) ! Diameter (m) at quadrature point
6471 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6472 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6473 VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6474 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6475 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6476 STQ=DCONST3*PDENSN(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6477 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6478 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6479 Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn trm, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6480 RBcor=1. ! Rebound correction factor
6481 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6482 ! vdplim=.002*UTSCALE
6483 vdplim=min(vdplim,.02)
6484 RSURFQ=RA(LCELL)+1./vdplim
6485 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6486 !
6487 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6488 !
6489 ! RSURFQ=max(RSURFQ,50.)
6490 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6491 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6492 ENDDO
6493 VDEP(LCELL, VDNNUC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6494 VDEP(LCELL, VDMNUC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgn)**2)*DGNUC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6496 ! *** accumulation mode
6498 SUM0=0.
6499 SUM3=0.
6500 DO N=1,NGAUSdv
6501 DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga) ! Diameter (m) at quadrature point
6502 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6503 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6504 VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6505 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6506 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6507 STQ=DCONST3*PDENSA(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6508 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6509 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6510 Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6511 RBcor=1. ! Rebound correction factor
6512 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6513 vdplim=min(vdplim,.02)
6514 RSURFQ=RA(LCELL)+1./vdplim
6515 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6516 !
6517 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6518 !
6519 ! RSURFQ=max(RSURFQ,50.)
6520 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6521 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6522 IF(iprnt.eq.1)THEN
6523 print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ'
6524 print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ
6525 print *,'N,Eff_dif,imp,int,SUM0,SUM3'
6526 print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3
6527 endif
6528 ENDDO
6529 VDEP(LCELL, VDNACC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6530 VDEP(LCELL, VDMACC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsga)**2)*DGACC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6532 ! *** coarse mode
6534 SUM0=0.
6535 SUM3=0.
6536 DO N=1,NGAUSdv
6537 DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc) ! Diameter (m) at quadrature point
6538 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6539 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6540 VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6541 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6542 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6543 STQ=DCONST3*PDENSC(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6544 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6545 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6546 Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Interception term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen
6547 EFF_int=min(1.,EFF_int)
6548 RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982)
6549 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6550 vdplim=min(vdplim,.02)
6551 RSURFQ=RA(LCELL)+1./vdplim
6552 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6553 !
6554 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6555 !
6556 ! RSURFQ=max(RSURFQ,50.)
6557 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6558 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6559 ENDDO
6560 VDEP(LCELL, VDNCOR) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6561 VDEP(LCELL, VDMCOR) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgc)**2)*DGCOR(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum
6562 END DO
6564 ENDIF ! ENDOF LAYER = 1 test
6566 ! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995)
6568 DO LCELL = 1, NUMCELLS
6570 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6571 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6572 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6573 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6575 ! *** nucleation mode number and mass sedimentation velociticies
6576 VSED( LCELL, VSNNUC) = DCONST3N &
6577 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6578 VSED( LCELL, VSMNUC) = DCONST3N &
6579 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6581 ! *** accumulation mode number and mass sedimentation velociticies
6582 VSED( LCELL, VSNACC) = DCONST3A &
6583 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6584 VSED( LCELL, VSMACC) = DCONST3A &
6585 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6587 ! *** coarse mode number and mass sedimentation velociticies
6588 VSED( LCELL, VSNCOR) = DCONST3C &
6589 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6590 VSED( LCELL, VSMCOR) = DCONST3C &
6591 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6592 END DO
6593 END SUBROUTINE VDVG_2
6594 !------------------------------------------------------------------------------
6596 SUBROUTINE aerosols_soa_vbs_het_init(chem,convfac,z_at_w, &
6597 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
6598 chem_in_opt,aer_ic_opt, is_aerosol, &
6599 ids,ide, jds,jde, kds,kde, &
6600 ims,ime, jms,jme, kms,kme, &
6601 its,ite, jts,jte, kts,kte, config_flags )
6603 USE module_configure, only: grid_config_rec_type
6604 !!! TUCCELLA (BUG, commented the line below)
6605 !USE module_prep_wetscav_sorgam,only: aerosols_soa_vbs_init_aercld_ptrs
6607 implicit none
6608 INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt
6609 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
6610 ims,ime, jms,jme, kms,kme, &
6611 its,ite, jts,jte, kts,kte
6612 LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
6613 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , &
6614 INTENT(INOUT ) :: &
6615 chem
6616 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6617 INTENT(INOUT ) :: &
6618 pm2_5_dry,pm2_5_water,pm2_5_dry_ec
6619 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6620 INTENT(IN ) :: &
6621 convfac
6622 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6623 INTENT(IN ) :: &
6624 z_at_w
6625 TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
6628 integer i,j,k,l,ii,jj,kk
6629 real tempfac,mwso4,zz
6630 ! real,dimension(its:ite,kts:kte,jts:jte) :: convfac
6631 REAL splitfac
6632 !between gas and aerosol phase
6633 REAL so4vaptoaer
6634 !factor for splitting initial conc. of SO4
6635 !3rd moment i-mode [3rd moment/m^3]
6636 REAL m3nuc
6637 !3rd MOMENT j-mode [3rd moment/m^3]
6638 REAL m3acc
6639 ! REAL ESN36
6640 REAL m3cor
6641 DATA splitfac/.98/
6642 DATA so4vaptoaer/.999/
6644 ! *** Compute these once and they will all be saved in COMMON
6645 xxlsgn = log(sginin)
6646 xxlsga = log(sginia)
6647 xxlsgc = log(sginic)
6649 l2sginin = xxlsgn**2
6650 l2sginia = xxlsga**2
6651 l2sginic = xxlsgc**2
6653 en1 = exp(0.125*l2sginin)
6654 ea1 = exp(0.125*l2sginia)
6655 ec1 = exp(0.125*l2sginic)
6657 esn04 = en1**4
6658 esa04 = ea1**4
6659 esc04 = ec1**4
6661 esn05 = esn04*en1
6662 esa05 = esa04*ea1
6664 esn08 = esn04*esn04
6665 esa08 = esa04*esa04
6666 esc08 = esc04*esc04
6668 esn09 = esn04*esn05
6669 esa09 = esa04*esa05
6671 esn12 = esn04*esn04*esn04
6672 esa12 = esa04*esa04*esa04
6673 esc12 = esc04*esc04*esc04
6675 esn16 = esn08*esn08
6676 esa16 = esa08*esa08
6677 esc16 = esc08*esc08
6679 esn20 = esn16*esn04
6680 esa20 = esa16*esa04
6681 esc20 = esc16*esc04
6683 esn24 = esn12*esn12
6684 esa24 = esa12*esa12
6685 esc24 = esc12*esc12
6687 esn25 = esn16*esn09
6688 esa25 = esa16*esa09
6690 esn28 = esn20*esn08
6691 esa28 = esa20*esa08
6692 esc28 = esc20*esc08
6695 esn32 = esn16*esn16
6696 esa32 = esa16*esa16
6697 esc32 = esc16*esc16
6699 esn36 = esn16*esn20
6700 esa36 = esa16*esa20
6701 esc36 = esc16*esc20
6703 esn49 = esn25*esn20*esn04
6704 esa49 = esa25*esa20*esa04
6706 esn52 = esn16*esn36
6707 esa52 = esa16*esa36
6709 esn64 = esn32*esn32
6710 esa64 = esa32*esa32
6711 esc64 = esc32*esc32
6713 esn100 = esn36*esn64
6715 esnm20 = 1.0/esn20
6716 esam20 = 1.0/esa20
6717 escm20 = 1.0/esc20
6719 esnm32 = 1.0/esn32
6720 esam32 = 1.0/esa32
6721 escm32 = 1.0/esc32
6723 xxm3 = 3.0*xxlsgn/ sqrt2
6724 ! factor used in error function cal
6725 nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
6727 nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
6729 nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
6731 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
6732 ! size distribution , then
6734 ! vol = (p/6) * density * num * (dgemv_xx**3) *
6735 ! exp(- 4.5 * log( sgem_xx)**2 ) )
6736 ! note minus sign!!
6738 factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
6739 factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
6740 factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
6741 ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
6742 ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
6743 mwso4=96.03
6745 ! initialize pointers used by aerosol-cloud-interaction routines
6746 ! TUCCELLA (BUG, now aerosols_soa_vbs_aercld_ptrs is called chemics_init.F !
6747 ! and was moved to module_prep_wetscav_sorgam.F)
6749 !call aerosols_soa_vbs_init_aercld_ptrs( &
6750 ! num_chem, is_aerosol, config_flags )
6752 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
6753 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
6754 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
6756 !SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv
6758 Y_GQ(1)=-2.651961356835233
6759 WGAUS(1)=0.0009717812450995
6760 Y_GQ(2)=-1.673551628767471
6761 WGAUS(2)=0.05451558281913
6762 Y_GQ(3)=-0.816287882858965
6763 WGAUS(3)=0.4256072526101
6764 Y_GQ(4)=-0.0
6765 WGAUS(4)=0.8102646175568
6766 Y_GQ(5)=0.816287882858965
6767 WGAUS(5)=WGAUS(3)
6768 Y_GQ(6)=1.673551628767471
6769 WGAUS(6)=WGAUS(2)
6770 Y_GQ(7)=2.651961356835233
6771 WGAUS(7)=WGAUS(1)
6772 !
6773 ! IF USING OLD SIMULATION, DO NOT REINITIALIZE!
6774 !
6775 if(chem_in_opt == 1 .OR. config_flags%restart) return
6776 do l=p_so4aj,num_chem
6777 chem(ims:ime,kms:kme,jms:jme,l)=epsilc
6778 enddo
6779 chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
6780 chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
6781 do j=jts,jte
6782 jj=min(jde-1,j)
6783 do k=kts,kte-1
6784 kk=min(kde-1,k)
6785 do i=its,ite
6786 ii=min(ide-1,i)
6788 !Option for alternate ic's
6789 if( aer_ic_opt == AER_IC_DEFAULT ) then
6790 chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer
6791 chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*(1.-splitfac)*so4vaptoaer
6792 chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
6793 chem(i,k,j,p_nh4aj) = 10.E-05
6794 chem(i,k,j,p_nh4ai) = 10.E-05
6795 chem(i,k,j,p_no3aj) = 10.E-05
6796 chem(i,k,j,p_no3ai) = 10.E-05
6797 chem(i,k,j,p_naaj) = 10.E-05
6798 chem(i,k,j,p_naai) = 10.E-05
6799 chem(i,k,j,p_claj) = 10.E-05
6800 chem(i,k,j,p_clai) = 10.E-05
6801 !liqy
6802 chem(i,k,j,p_caaj) = 10.E-05
6803 chem(i,k,j,p_caai) = 10.E-05
6804 chem(i,k,j,p_kaj) = 10.E-05
6805 chem(i,k,j,p_kai) = 10.E-05
6806 chem(i,k,j,p_mgaj) = 10.E-05
6807 chem(i,k,j,p_mgai) = 10.E-05
6808 !liqy-20140619
6809 ! elseif( aer_ic_opt == AER_IC_PNNL ) then
6810 ! zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5
6811 ! call soa_vbs_init_aer_ic_pnnl( &
6812 ! chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
6813 else
6814 call wrf_error_fatal( &
6815 "aerosols_soa_vbs_het_init: unable to parse aer_ic_opt" )
6816 end if
6818 !... i-mode
6819 m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
6820 no3fac*chem(i,k,j,p_no3ai) + &
6821 nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) + &
6822 !liqy
6823 cafac*chem(i,k,j,p_caai) + kfac*chem(i,k,j,p_kai) + &
6824 mgfac*chem(i,k,j,p_mgai) + &
6825 !liqy-20140619
6826 orgfac*chem(i,k,j,p_asoa1i) + &
6827 orgfac*chem(i,k,j,p_asoa2i) + orgfac*chem(i,k,j,p_asoa3i) + &
6828 orgfac*chem(i,k,j,p_asoa4i) + orgfac*chem(i,k,j,p_bsoa1i) + &
6829 orgfac*chem(i,k,j,p_bsoa2i) + orgfac*chem(i,k,j,p_bsoa3i) + &
6830 orgfac*chem(i,k,j,p_bsoa4i) + orgfac*chem(i,k,j,p_orgpai) + &
6831 anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)
6833 !... j-mode
6834 m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + &
6835 no3fac*chem(i,k,j,p_no3aj) + &
6836 nafac*chem(i,k,j,p_naaj) + clfac*chem(i,k,j,p_claj) + &
6837 !liqy
6838 cafac*chem(i,k,j,p_caaj) + kfac*chem(i,k,j,p_kaj) + &
6839 mgfac*chem(i,k,j,p_mgaj) + &
6840 !liqy-20140619
6841 orgfac*chem(i,k,j,p_asoa1j) + &
6842 orgfac*chem(i,k,j,p_asoa2j) + orgfac*chem(i,k,j,p_asoa3j) + &
6843 orgfac*chem(i,k,j,p_asoa4j) + orgfac*chem(i,k,j,p_bsoa1j) + &
6844 orgfac*chem(i,k,j,p_bsoa2j) + orgfac*chem(i,k,j,p_bsoa3j) + &
6845 orgfac*chem(i,k,j,p_bsoa4j) + orgfac*chem(i,k,j,p_orgpaj) + &
6846 anthfac*chem(i,k,j,p_p25j) + anthfac*chem(i,k,j,p_ecj)
6848 !...c-mode
6849 m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
6850 anthfac*chem(i,k,j,p_antha)
6852 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
6853 chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
6855 chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
6857 chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
6859 enddo
6860 enddo
6861 enddo
6863 return
6864 END SUBROUTINE aerosols_soa_vbs_het_init
6866 !
6867 SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, &
6868 ebu, &
6869 slai,ust,smois,ivgtyp,isltyp, &
6870 emis_ant,dust_emiss_active, &
6871 seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, &
6872 dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, &
6873 ids,ide, jds,jde, kds,kde, &
6874 ims,ime, jms,jme, kms,kme, &
6875 its,ite, jts,jte, kts,kte )
6876 !
6877 ! Routine to apply aerosol emissions for MADE/SOA_VBS...
6878 ! William.Gustafson@pnl.gov; 3-May-2007
6879 ! Modified by
6880 ! steven.peckham@noaa.gov; 8-Jan-2008
6881 !------------------------------------------------------------------------
6883 USE module_state_description, only: num_chem
6885 INTEGER, INTENT(IN ) :: seasalt_emiss_active,kemit,emissopt, &
6886 dust_emiss_active,num_soil_layers,id, &
6887 ktau,dust_opt,biom, &
6888 ids,ide, jds,jde, kds,kde, &
6889 ims,ime, jms,jme, kms,kme, &
6890 its,ite, jts,jte, kts,kte
6892 REAL, INTENT(IN ) :: dtstep
6894 ! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air)
6895 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
6896 INTENT(INOUT ) :: chem
6897 !
6898 ! aerosol emissions arrays ((ug/m3)*m/s)
6899 !
6900 REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), &
6901 INTENT(IN ) :: emis_ant
6903 ! biomass burning aerosol emissions arrays ((ug/m3)*m/s)
6904 REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), &
6905 INTENT(IN ) :: ebu
6907 ! 1/(dry air density) and layer thickness (m)
6908 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
6909 INTENT(IN ) :: &
6910 alt, dz8w
6912 ! add for gocart dust
6913 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
6914 INTENT(IN ) :: p8w,u_phy,v_phy,rho_phy
6915 REAL, INTENT(IN ) :: dx, g
6916 REAL, DIMENSION( ims:ime, jms:jme, 3 ), &
6917 INTENT(IN ) :: erod
6919 REAL, DIMENSION( ims:ime , jms:jme ), &
6920 INTENT(IN ) :: &
6921 u10, v10, xland, slai, ust
6922 INTEGER, DIMENSION( ims:ime , jms:jme ), &
6923 INTENT(IN ) :: ivgtyp, isltyp
6924 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ), &
6925 INTENT(INOUT) :: smois
6927 ! Local variables...
6928 real, dimension(its:ite,kts:kte,jts:jte) :: factor
6929 !
6930 ! Get the emissions unit conversion factor including the time step.
6931 ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep]
6932 !
6933 factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ &
6934 dz8w(its:ite,kts:kte,jts:jte)
6935 !
6936 ! Increment the aerosol numbers...
6937 !
6938 ! Increment the aerosol numbers...
6939 if(emissopt .lt. 5 )then
6940 !
6941 ! Aitken mode first...
6943 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
6944 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
6945 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
6946 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + &
6947 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + &
6948 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + &
6949 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) )
6951 ! Accumulation mode next...
6953 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
6954 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
6955 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
6956 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + &
6957 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + &
6958 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + &
6959 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) )
6961 ! And now the coarse mode...
6963 chem(its:ite,kts:kemit,jts:jte,p_corn) = &
6964 chem(its:ite,kts:kemit,jts:jte,p_corn) + &
6965 factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac* &
6966 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)
6967 !
6968 ! Increment the aerosol masses...
6969 !
6970 chem(its:ite,kts:kemit,jts:jte,p_antha) = &
6971 chem(its:ite,kts:kemit,jts:jte,p_antha) + &
6972 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte)
6974 chem(its:ite,kts:kemit,jts:jte,p_p25j) = &
6975 chem(its:ite,kts:kemit,jts:jte,p_p25j) + &
6976 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte)
6978 chem(its:ite,kts:kemit,jts:jte,p_p25i) = &
6979 chem(its:ite,kts:kemit,jts:jte,p_p25i) + &
6980 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte)
6982 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
6983 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
6984 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte)
6986 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
6987 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
6988 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte)
6989 chem(its:ite,kts:kemit,jts:jte,p_naaj) = &
6990 chem(its:ite,kts:kemit,jts:jte,p_naaj) + &
6991 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte)
6992 chem(its:ite,kts:kemit,jts:jte,p_naai) = &
6993 chem(its:ite,kts:kemit,jts:jte,p_naai) + &
6994 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte)
6996 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
6997 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
6998 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte)
7000 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7001 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7002 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte)
7004 chem(its:ite,kts:kemit,jts:jte,p_so4aj) = &
7005 chem(its:ite,kts:kemit,jts:jte,p_so4aj) + &
7006 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte)
7008 chem(its:ite,kts:kemit,jts:jte,p_so4ai) = &
7009 chem(its:ite,kts:kemit,jts:jte,p_so4ai) + &
7010 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte)
7012 chem(its:ite,kts:kemit,jts:jte,p_no3aj) = &
7013 chem(its:ite,kts:kemit,jts:jte,p_no3aj) + &
7014 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte)
7016 chem(its:ite,kts:kemit,jts:jte,p_no3ai) = &
7017 chem(its:ite,kts:kemit,jts:jte,p_no3ai) + &
7018 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte)
7019 !liqy
7020 chem(its:ite,kts:kemit,jts:jte,p_claj) = &
7021 chem(its:ite,kts:kemit,jts:jte,p_claj) + &
7022 emis_ant(its:ite,kts:kemit,jts:jte,p_e_clj)*factor(its:ite,kts:kemit,jts:jte)
7024 chem(its:ite,kts:kemit,jts:jte,p_clai) = &
7025 chem(its:ite,kts:kemit,jts:jte,p_clai) + &
7026 emis_ant(its:ite,kts:kemit,jts:jte,p_e_cli)*factor(its:ite,kts:kemit,jts:jte)
7027 !liqy-20150625
7028 elseif(emissopt == 5)then
7029 !
7030 ! Aitken mode first...
7032 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7033 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7034 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7035 anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7036 orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7038 ! Accumulation mode next...
7040 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7041 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7042 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7043 anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7044 orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7046 !
7047 ! Increment the aerosol masses...
7048 !
7050 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
7051 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
7052 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7054 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
7055 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
7056 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7058 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
7059 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
7060 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7062 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7063 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7064 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7066 endif
7067 ! add biomass burning emissions if present
7068 !
7069 if(biom == 1 )then
7070 !
7071 ! Aitken mode first...
7073 chem(its:ite,kts:kte,jts:jte,p_nu0) = &
7074 chem(its:ite,kts:kte,jts:jte,p_nu0) + &
7075 factor(its:ite,kts:kte,jts:jte)*factnumn*( &
7076 anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7077 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7078 orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7080 ! Accumulation mode next...
7082 chem(its:ite,kts:kte,jts:jte,p_ac0) = &
7083 chem(its:ite,kts:kte,jts:jte,p_ac0) + &
7084 factor(its:ite,kts:kte,jts:jte)*factnuma*( &
7085 anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7086 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7087 orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7088 ! coarse
7089 chem(its:ite,kts:kte,jts:jte,p_corn) = &
7090 chem(its:ite,kts:kte,jts:jte,p_corn) + &
7091 factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* &
7092 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)
7094 !
7095 ! Increment the aerosol masses...
7096 !
7098 chem(its:ite,kts:kte,jts:jte,p_ecj) = &
7099 chem(its:ite,kts:kte,jts:jte,p_ecj) + &
7100 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7102 chem(its:ite,kts:kte,jts:jte,p_eci) = &
7103 chem(its:ite,kts:kte,jts:jte,p_eci) + &
7104 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7106 chem(its:ite,kts:kte,jts:jte,p_orgpaj) = &
7107 chem(its:ite,kts:kte,jts:jte,p_orgpaj) + &
7108 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7110 chem(its:ite,kts:kte,jts:jte,p_orgpai) = &
7111 chem(its:ite,kts:kte,jts:jte,p_orgpai) + &
7112 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7114 chem(its:ite,kts:kte,jts:jte,p_antha) = &
7115 chem(its:ite,kts:kte,jts:jte,p_antha) + &
7116 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte)
7118 chem(its:ite,kts:kte,jts:jte,p_p25j) = &
7119 chem(its:ite,kts:kte,jts:jte,p_p25j) + &
7120 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7122 chem(its:ite,kts:kte,jts:jte,p_p25i) = &
7123 chem(its:ite,kts:kte,jts:jte,p_p25i) + &
7124 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7126 endif !end biomass burning
7127 !
7128 ! Get the sea salt emissions...
7129 !
7130 if( seasalt_emiss_active == 1 ) then
7131 call soa_vbs_seasalt_emiss( &
7132 dtstep, u10, v10, alt, dz8w, xland, chem, &
7133 ids,ide, jds,jde, kds,kde, &
7134 ims,ime, jms,jme, kms,kme, &
7135 its,ite, jts,jte, kts,kte )
7136 end if
7137 ! if( seasalt_emiss_active == 2 ) then
7138 ! end if
7139 if( dust_opt == 2 ) then
7140 call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13")
7141 call soa_vbs_dust_emiss( &
7142 slai, ust, smois, ivgtyp, isltyp, &
7143 id, dtstep, u10, v10, alt, dz8w, &
7144 xland, num_soil_layers, chem, &
7145 ids,ide, jds,jde, kds,kde, &
7146 ims,ime, jms,jme, kms,kme, &
7147 its,ite, jts,jte, kts,kte )
7148 end if
7149 ! dust_opt changed to 13 since it conflicts with gocart/afwa
7150 if( dust_opt == 13 ) then
7151 !czhao --------------------------
7152 call soa_vbs_dust_gocartemis( &
7153 ktau,dtstep,num_soil_layers,alt,u_phy, &
7154 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
7155 ivgtyp,isltyp,xland,dx,g, &
7156 ids,ide, jds,jde, kds,kde, &
7157 ims,ime, jms,jme, kms,kme, &
7158 its,ite, jts,jte, kts,kte )
7159 end if
7161 END SUBROUTINE soa_vbs_addemiss
7163 !------------------------------------------------------------------------
7164 SUBROUTINE soa_vbs_seasalt_emiss( &
7165 dtstep, u10, v10, alt, dz8w, xland, chem, &
7166 ids,ide, jds,jde, kds,kde, &
7167 ims,ime, jms,jme, kms,kme, &
7168 its,ite, jts,jte, kts,kte )
7169 !
7170 ! Routine to calculate seasalt emissions for SOA_VBS over the time
7171 ! dtstep...
7172 ! William.Gustafson@pnl.gov; 10-May-2007
7173 !------------------------------------------------------------------------
7175 USE module_mosaic_addemiss, only: seasalt_emitfactors_1bin
7177 IMPLICIT NONE
7179 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
7180 ims,ime, jms,jme, kms,kme, &
7181 its,ite, jts,jte, kts,kte
7183 REAL, INTENT(IN ) :: dtstep
7185 ! 10-m wind speed components (m/s)
7186 REAL, DIMENSION( ims:ime , jms:jme ), &
7187 INTENT(IN ) :: u10, v10, xland
7189 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7190 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7191 INTENT(INOUT ) :: chem
7193 ! alt = 1.0/(dry air density) in (m3/kg)
7194 ! dz8w = layer thickness in (m)
7195 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7196 INTENT(IN ) :: alt, dz8w
7198 ! local variables
7199 integer :: i, j, k, l, l_na, l_cl, n
7200 integer :: p1st
7202 real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
7203 real :: factaa, factbb, fraccl, fracna
7204 !liqy
7205 real :: fracca, frack, fracmg, fracso4
7206 !liqy-20140709
7208 real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c
7209 real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c
7212 ! Compute emissions factors for the Aitken mode...
7213 ! Nope, we won't because the parameterization is only valid down to
7214 ! 0.1 microns.
7215 ! Setup in units of cm.
7216 ! dumdlo = 0.039e-4
7217 ! dumdhi = 0.078e-4
7218 ssemfact_numb_i = 0.
7219 ssemfact_mass_i = 0.
7221 ! Compute emissions factors for the accumulation mode...
7222 ! Potentially, we could go down to 0.078 microns to match the bin
7223 ! boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end
7224 ! has been chosen to match the MOSAIC bin boundary closest to two
7225 ! standard deviations from the default bin mean diameter for the coarse
7226 ! mode.
7227 dumdlo = 0.1e-4
7228 dumdhi = 1.250e-4
7229 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
7230 ssemfact_numb_j, dum, ssemfact_mass_j )
7232 ! Compute emissions factors for the coarse mode...
7233 dumdlo = 1.25e-4
7234 dumdhi = 10.0e-4
7235 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
7236 ssemfact_numb_c, dum, ssemfact_mass_c )
7238 ! Convert mass emissions factor from (g/m2/s) to (ug/m2/s)
7239 ssemfact_mass_i = ssemfact_mass_i*1.0e6
7240 ssemfact_mass_j = ssemfact_mass_j*1.0e6
7241 ssemfact_mass_c = ssemfact_mass_c*1.0e6
7243 ! Loop over i,j and apply seasalt emissions
7244 k = kts
7245 do j = jts, jte
7246 do i = its, ite
7248 !Skip this point if over land. xland=1 for land and 2 for water.
7249 !Also, there is no way to differentiate fresh from salt water.
7250 !Currently, this assumes all water is salty.
7251 if( xland(i,j) < 1.5 ) cycle
7253 !wig: As far as I can tell, only real.exe knows the fractional breakdown
7254 ! of land use. So, in wrf.exe, dumoceanfrac will always be 1.
7255 dumoceanfrac = 1. !fraction of grid i,j that is salt water
7256 dumspd10 = dumoceanfrac* &
7257 ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
7259 ! factaa is (s*m2/kg-air)
7260 ! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air
7261 ! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air
7262 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7263 factbb = factaa * dumspd10
7265 !liqy
7266 !comment out the old assumption, i.e. "Apportion seasalt mass emissions
7267 !assumming that seasalt is pure NaCl".
7268 ! fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
7269 ! fraccl = 1.0 - fracna
7270 fracna = 10.7838/35.171
7271 fraccl = 19.3529/35.171
7272 fracca = 0.4121/35.171
7273 frack = 0.3991/35.171
7274 fracmg = 1.2837/35.171
7275 fracso4 = 0.0 !2.7124/35.171
7277 ! Add the emissions into the chem array...
7278 chem(i,k,j,p_naai) = chem(i,k,j,p_naai) + &
7279 factbb * ssemfact_mass_i * fracna
7280 chem(i,k,j,p_clai) = chem(i,k,j,p_clai) + &
7281 factbb * ssemfact_mass_i * fraccl
7282 chem(i,k,j,p_caai) = chem(i,k,j,p_caai) + &
7283 factbb * ssemfact_mass_i * fracca
7284 chem(i,k,j,p_kai) = chem(i,k,j,p_kai) + &
7285 factbb * ssemfact_mass_i * frack
7286 chem(i,k,j,p_mgai) = chem(i,k,j,p_mgai) + &
7287 factbb * ssemfact_mass_i * fracmg
7288 ! chem(i,k,j,p_so4ai) = chem(i,k,j,p_so4ai) + &
7289 ! factbb * ssemfact_mass_i * fracso4
7290 chem(i,k,j,p_nu0) = chem(i,k,j,p_nu0) + &
7291 factbb * ssemfact_numb_i
7293 !-------------------------------------------------------------------------
7295 !-------------------------------------------------------------------------
7296 chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) + &
7297 factbb * ssemfact_mass_j * fracna
7298 chem(i,k,j,p_claj) = chem(i,k,j,p_claj) + &
7299 factbb * ssemfact_mass_j * fraccl
7300 chem(i,k,j,p_caaj) = chem(i,k,j,p_caaj) + &
7301 factbb * ssemfact_mass_j * fracca
7302 chem(i,k,j,p_kaj) = chem(i,k,j,p_kaj) + &
7303 factbb * ssemfact_mass_j * frack
7304 chem(i,k,j,p_mgaj) = chem(i,k,j,p_mgaj) + &
7305 factbb * ssemfact_mass_j * fracmg
7306 ! chem(i,k,j,p_so4aj) = chem(i,k,j,p_so4aj) + &
7307 ! factbb * ssemfact_mass_j * fracso4
7308 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + &
7309 factbb * ssemfact_numb_j
7311 !-------------------------------------------------------------------------
7312 chem(i,k,j,p_seas) = chem(i,k,j,p_seas) + &
7313 factbb * ssemfact_mass_c
7314 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + &
7315 factbb * ssemfact_numb_c
7316 !liqy-20140709
7318 end do !i
7319 end do !j
7320 END SUBROUTINE soa_vbs_seasalt_emiss
7321 !----------------------------------------------------------------------
7323 subroutine soa_vbs_dust_emiss( slai,ust, smois, ivgtyp, isltyp, &
7324 id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers, &
7325 chem, &
7326 ids,ide, jds,jde, kds,kde, &
7327 ims,ime, jms,jme, kms,kme, &
7328 its,ite, jts,jte, kts,kte )
7329 !
7330 ! adds dust emissions for mosaic aerosol species (i.e. emission tendencies
7331 ! over time dtstep are applied to the aerosol mixing ratios)
7332 !
7333 ! This is a simple dust scheme based on Shaw et al. (2008) to appear in
7334 ! Atmospheric Environment, recoded by Jerome Fast
7335 !
7336 ! NOTE:
7337 ! 1) This version only works with the 8-bin version of MOSAIC.
7338 ! 2) Dust added to MOSAIC's other inorganic specie, OIN. If Ca and CO3 are
7339 ! activated in the Registry, a small fraction also added to Ca and CO3.
7340 ! 3) The main departure from Shaw et al., is now alphamask is computed since
7341 ! the land-use categories in that paper and in WRF differ. WRF currently
7342 ! does not have that many land-use categories and adhoc assumptions had to
7343 ! be made. This version was tested for Mexico in the dry season. The main
7344 ! land-use categories in WRF that are likely dust sources are grass, shrub,
7345 ! and savannna (that WRF has in the desert regions of NW Mexico). Having
7346 ! dust emitted from these types for other locations and other times of the
7347 ! year is not likely to be valid.
7348 ! 4) An upper bound on ustar was placed because the surface parameterizations
7349 ! in WRF can produce unrealistically high values that lead to very high
7350 ! dust emission rates.
7351 ! 5) Other departures' from Shaw et al. noted below, but are probably not as
7352 ! important as 2) and 3).
7353 !
7354 USE module_configure, only: grid_config_rec_type
7355 USE module_state_description, only: num_chem, param_first_scalar
7356 USE module_data_mosaic_asect
7358 IMPLICIT NONE
7360 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
7362 INTEGER, INTENT(IN ) :: id,num_soil_layers, &
7363 ids,ide, jds,jde, kds,kde, &
7364 ims,ime, jms,jme, kms,kme, &
7365 its,ite, jts,jte, kts,kte
7367 REAL, INTENT(IN ) :: dtstep
7369 ! 10-m wind speed components (m/s)
7370 REAL, DIMENSION( ims:ime , jms:jme ), &
7371 INTENT(IN ) :: u10, v10, xland, slai, ust
7372 INTEGER, DIMENSION( ims:ime , jms:jme ), &
7373 INTENT(IN ) :: ivgtyp, isltyp
7375 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7376 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7377 INTENT(INOUT ) :: chem
7379 ! alt = 1.0/(dry air density) in (m3/kg)
7380 ! dz8w = layer thickness in (m)
7381 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7382 INTENT(IN ) :: alt, dz8w
7384 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
7385 INTENT(INOUT) :: smois
7387 ! local variables
7388 integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
7389 integer iphase, itype, izob
7390 integer p1st
7392 real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
7393 real factaa, factbb, fracoin, fracca, fracco3, fractot
7394 !liqy
7395 real dstfracna, dstfraccl, dstfracca, dstfrack, dstfracmg,dstfrac
7396 !liqy-20140709
7397 real ustart, ustar1, ustart0
7398 real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
7399 real smois_grav, wp, pclay
7400 real :: beta(4,7)
7401 real :: gamma(4), delta(4)
7402 real :: sz(8)
7403 real :: dustflux, densdust, mass1part
7404 real :: dp_meanvol_tmp
7405 !
7406 ! from Nickovic et al., JGR, 2001 and Shaw et al. 2007
7407 ! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7)
7408 ! beta (1,*) for 0.5-1 um
7409 ! beta (2,*) for 1-10 um
7410 ! beta (3,*) for 10-25 um
7411 ! beta (4,*) for 25-50 um
7412 !
7413 beta(1,1)=0.12
7414 beta(2,1)=0.04
7415 beta(3,1)=0.04
7416 beta(4,1)=0.80
7417 beta(1,2)=0.34
7418 beta(2,2)=0.28
7419 beta(3,2)=0.28
7420 beta(4,2)=0.10
7421 beta(1,3)=0.45
7422 beta(2,3)=0.15
7423 beta(3,3)=0.15
7424 beta(4,3)=0.25
7425 beta(1,4)=0.12
7426 beta(2,4)=0.09
7427 beta(3,4)=0.09
7428 beta(4,4)=0.70
7429 beta(1,5)=0.40
7430 beta(2,5)=0.05
7431 beta(3,5)=0.05
7432 beta(4,5)=0.50
7433 beta(1,6)=0.34
7434 beta(2,6)=0.18
7435 beta(3,6)=0.18
7436 beta(4,6)=0.30
7437 beta(1,7)=0.22
7438 beta(2,7)=0.09
7439 beta(3,7)=0.09
7440 beta(4,7)=0.60
7441 gamma(1)=0.08
7442 gamma(2)=1.00
7443 gamma(3)=1.00
7444 gamma(4)=0.12
7445 !
7446 ! * Mass fractions for each size bin. These values were recommended by
7447 ! Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM.
7448 ! * Changed slightly since Natelie's estimates do not add up to 1.0
7449 ! * This would need to be made more generic for other bin sizes.
7450 ! sz(1)=0
7451 ! sz(2)=1.78751e-06
7452 ! sz(3)=0.000273786
7453 ! sz(4)=0.00847978
7454 ! sz(5)=0.056055
7455 ! sz(6)=0.0951896
7456 ! sz(7)=0.17
7457 ! sz(8)=0.67
7458 sz(1)=0.0
7459 sz(2)=0.0
7460 sz(3)=0.0005
7461 sz(4)=0.0095
7462 sz(5)=0.03
7463 sz(6)=0.10
7464 sz(7)=0.18
7465 sz(8)=0.68
7467 ! for now just do itype=1
7468 itype = 1
7469 iphase = ai_phase
7471 ! loop over i,j and apply dust emissions
7472 k = kts
7473 do 1830 j = jts, jte
7474 do 1820 i = its, ite
7476 if( xland(i,j) > 1.5 ) cycle
7478 ! compute wind speed anyway, even though ustar is used below
7480 dumlandfrac = 1.
7481 dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
7482 if(dumspd10 >= 5.0) then
7483 dumspd10 = dumlandfrac* &
7484 ( dumspd10*dumspd10*(dumspd10-5.0))
7485 else
7486 dumspd10=0.
7487 endif
7489 ! part1 - compute vegetation mask
7490 !
7491 ! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories
7492 ! for desert, sand desert, grass aemi-desert, and shrub semi-desert
7493 ! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna
7494 ! that are dominate types in Mexico and probably have some erodable surface
7495 ! during the dry season
7496 ! * currently modified these values so that only a small fraction of cell
7497 ! area is erodable
7498 ! * these values are highly tuneable!
7500 alphamask=0.001
7501 if (ivgtyp(i,j) .eq. 7) then
7502 f8=0.005
7503 f50=0.00
7504 f51=0.10
7505 f52=0.00
7506 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7507 endif
7508 if (ivgtyp(i,j) .eq. 8) then
7509 f8=0.010
7510 f50=0.00
7511 f51=0.00
7512 f52=0.15
7513 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7514 endif
7515 if (ivgtyp(i,j) .eq. 10) then
7516 f8=0.00
7517 f50=0.00
7518 f51=0.01
7519 f52=0.00
7520 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7521 endif
7523 ! part2 - zobler
7524 !
7525 ! * in Shaw's paper, dust is computed for 4 size ranges:
7526 ! 0.5-1 um
7527 ! 1-10 um
7528 ! 10-25 um
7529 ! 25-50 um
7530 ! * Shaw's paper also accounts for sub-grid variability in soil
7531 ! texture, but here we just assume the same soil texture for each
7532 ! grid cell
7533 ! * since MOSAIC is currently has a maximum size range up to 10 um,
7534 ! neglect upper 2 size ranges and lowest size range (assume small)
7535 ! * map WRF soil classes arbitrarily to Zolber soil textural classes
7536 ! * skip dust computations for WRF soil classes greater than 13, i.e.
7537 ! do not compute dust over water, bedrock, and other surfaces
7538 ! * should be skipping for water surface at this point anyway
7539 !
7540 izob=0
7541 if(isltyp(i,j).eq.1) izob=1
7542 if(isltyp(i,j).eq.2) izob=1
7543 if(isltyp(i,j).eq.3) izob=4
7544 if(isltyp(i,j).eq.4) izob=2
7545 if(isltyp(i,j).eq.5) izob=2
7546 if(isltyp(i,j).eq.6) izob=2
7547 if(isltyp(i,j).eq.7) izob=7
7548 if(isltyp(i,j).eq.8) izob=2
7549 if(isltyp(i,j).eq.9) izob=6
7550 if(isltyp(i,j).eq.10) izob=5
7551 if(isltyp(i,j).eq.11) izob=2
7552 if(isltyp(i,j).eq.12) izob=3
7553 if(isltyp(i,j).ge.13) izob=0
7554 if(izob.eq.0) goto 1840
7555 !
7556 ! part3 - dustprod
7557 !
7558 do ii=1,4
7559 delta(ii)=0.0
7560 enddo
7561 sumdelta=0.0
7562 do ii=1,4
7563 delta(ii)=beta(ii,izob)*gamma(ii)
7564 if(ii.lt.4) then
7565 sumdelta=sumdelta+delta(ii)
7566 endif
7567 enddo
7568 do ii=1,4
7569 delta(ii)=delta(ii)/sumdelta
7570 enddo
7572 ! part4 - wetness
7573 !
7574 ! * assume dry for now, have passed in soil moisture to this routine
7575 ! but needs to be included here
7576 ! * wetfactor less than 1 would reduce dustflux
7577 ! * convert model soil moisture (m3/m3) to gravimetric soil moisture
7578 ! (mass of water / mass of soil in %) assuming a constant density
7579 ! for soil
7580 pclay=beta(1,izob)*100.
7581 wp=0.0014*pclay*pclay+0.17*pclay
7582 smois_grav=(smois(i,1,j)/2.6)*100.
7583 if(smois_grav.gt.wp) then
7584 wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
7585 else
7586 wetfactor=1.0
7587 endif
7588 ! wetfactor=1.0
7590 ! part5 - dustflux
7591 ! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper
7592 ! bound to 100 cm/s
7594 ustar1=ust(i,j)*100.0
7595 if(ustar1.gt.100.0) ustar1=100.0
7596 ustart0=20.0
7597 ustart=ustart0*wetfactor
7598 if(ustar1.le.ustart) then
7599 dustflux=0.0
7600 else
7601 dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1))
7602 endif
7603 dustflux=dustflux*10.0
7604 ! units kg m-2 s-1
7605 ftot=0.0
7606 do ii=1,2
7607 ftot=ftot+dustflux*alphamask*delta(ii)
7608 enddo
7609 ! convert to ug m-2 s-1
7610 ftot=ftot*1.0e+09
7612 ! apportion other inorganics only
7613 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7614 factbb = factaa * ftot
7615 fracoin = 1.00
7616 ! fracca = 0.03*0.4
7617 ! fracco3 = 0.03*0.6
7618 fracca = 0.0
7619 fracco3 = 0.0
7620 fractot = fracoin + fracca + fracco3
7622 !liqy
7624 dstfracna = 0.0236
7625 dstfraccl = 0.0
7626 dstfracca = 0.0385
7627 dstfrack = 0.0214
7628 dstfracmg = 0.0220
7629 dstfrac = 1.0-(dstfracna+dstfraccl+dstfracca+dstfrack+dstfracmg)
7631 ! if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot
7633 chem(i,k,j,p_naaj)=chem(i,k,j,p_naaj) + &
7634 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracna
7635 ! chem(i,k,j,p_claj)=chem(i,k,j,p_claj) + &
7636 ! factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfraccl
7637 chem(i,k,j,p_caaj)=chem(i,k,j,p_caaj) + &
7638 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracca
7639 chem(i,k,j,p_kaj)=chem(i,k,j,p_kaj) + &
7640 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfrack
7641 chem(i,k,j,p_mgaj)=chem(i,k,j,p_mgaj) + &
7642 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracmg
7644 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + &
7645 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfrac
7646 !liqy-20140709
7648 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot
7649 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + &
7650 factbb * (sz(7)+sz(8)) * fractot
7651 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot
7652 ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3
7653 densdust=2.5
7654 dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
7655 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7656 chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) + &
7657 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part
7658 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part
7659 dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
7660 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7661 chem(i,k,j,p_corn)=chem(i,k,j,p_corn) + &
7662 factbb * (sz(7)+sz(8)) * fractot / mass1part
7663 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part
7665 1840 continue
7667 1820 continue
7668 1830 continue
7670 return
7672 END subroutine soa_vbs_dust_emiss
7674 !====================================================================================
7675 !add another dust emission scheme following GOCART mechanism --czhao 09/17/2009
7676 !====================================================================================
7677 subroutine soa_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, &
7678 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
7679 ivgtyp,isltyp,xland,dx,g, &
7680 ids,ide, jds,jde, kds,kde, &
7681 ims,ime, jms,jme, kms,kme, &
7682 its,ite, jts,jte, kts,kte )
7683 USE module_data_gocart_dust
7684 USE module_configure
7685 USE module_state_description
7686 USE module_model_constants, ONLY: mwdry
7687 USE module_data_mosaic_asect
7688 IMPLICIT NONE
7690 INTEGER, INTENT(IN ) :: ktau, num_soil_layers, &
7691 ids,ide, jds,jde, kds,kde, &
7692 ims,ime, jms,jme, kms,kme, &
7693 its,ite, jts,jte, kts,kte
7694 INTEGER,DIMENSION( ims:ime , jms:jme ) , &
7695 INTENT(IN ) :: &
7696 ivgtyp, &
7697 isltyp
7698 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7699 INTENT(INOUT ) :: chem
7700 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
7701 INTENT(INOUT) :: smois
7702 REAL, DIMENSION( ims:ime , jms:jme, 3 ) , &
7703 INTENT(IN ) :: erod
7704 REAL, DIMENSION( ims:ime , jms:jme ) , &
7705 INTENT(IN ) :: &
7706 u10, &
7707 v10, &
7708 xland
7709 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7710 INTENT(IN ) :: &
7711 alt, &
7712 dz8w,p8w, &
7713 u_phy,v_phy,rho_phy
7715 REAL, INTENT(IN ) :: dt,dx,g
7716 !
7717 ! local variables
7718 !
7719 integer :: nmx,i,j,k,ndt,imx,jmx,lmx
7720 integer ilwi, start_month
7721 real*8, DIMENSION (3) :: erodin
7722 real*8, DIMENSION (5) :: bems
7723 real*8 w10m,gwet,airden,airmas
7724 real*8 cdustemis,jdustemis,cdustcon,jdustcon
7725 real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
7726 real*8 dxy
7727 real*8 conver,converi
7728 real dttt
7729 real soilfacj,rhosoilj,rhosoilc
7730 real totalemis,accfrac,corfrac,rscale1,rscale2
7732 accfrac=0.07 ! assign 7% to accumulation mode
7733 corfrac=0.93 ! assign 93% to coarse mode
7734 rscale1=1.00 ! to account for the dust larger than 10um in radius
7735 rscale2=1.02 ! to account for the dust larger than 10um in radius
7736 accfrac=accfrac*rscale1
7737 corfrac=corfrac*rscale2
7739 rhosoilj=2.5e3
7740 rhosoilc=2.6e3
7741 soilfacj=soilfac*rhosoilj/rhosoilc
7743 conver=1.e-9
7744 converi=1.e9
7745 !
7746 ! number of dust bins
7747 nmx=5
7748 k=kts
7749 do j=jts,jte
7750 do i=its,ite
7751 !
7752 ! don't do dust over water!!!
7753 if(xland(i,j).lt.1.5)then
7755 ilwi=1
7756 start_month = 3 ! it doesn't matter, ch_dust is not a month dependent now, a constant
7757 w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
7758 airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! kg
7760 ! we don't trust the u10,v10 values, if model layers are very thin near surface
7761 if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j))
7762 !erodin(1)=erod(i,j,1)/dx/dx ! czhao erod shouldn't be scaled to the area, because it's a fraction
7763 !erodin(2)=erod(i,j,2)/dx/dx
7764 !erodin(3)=erod(i,j,3)/dx/dx
7765 erodin(1)=erod(i,j,1)
7766 erodin(2)=erod(i,j,2)
7767 erodin(3)=erod(i,j,3)
7768 !
7769 ! volumetric soil moisture over porosity
7770 gwet=smois(i,1,j)/porosity(isltyp(i,j))
7771 ndt=ifix(dt)
7772 airden=rho_phy(i,kts,j)
7773 dxy=dx*dx
7775 call soa_vbs_source_du( nmx, dt,i,j, &
7776 erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
7777 bems,start_month,g)
7779 !bems: kg/timestep/cell
7780 !sum up the dust emission from 0.1-10 um in radius
7781 ! unit change from kg/timestep/cell to ug/m2/s
7782 totalemis=(sum(bems(1:5))/dt)*converi/dxy
7783 ! to account for the particles larger than 10 um radius
7784 ! based on assumed size distribution
7785 jdustemis = totalemis*accfrac ! accumulation mode
7786 cdustemis = totalemis*corfrac ! coarse mode
7788 cdustcon = sum(bems(1:5))*corfrac/airmas ! kg/kg-dryair
7789 cdustcon = cdustcon * converi ! ug/kg-dryair
7790 jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair
7791 jdustcon = jdustcon * converi ! ug/kg-dryair
7793 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon
7794 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon
7796 ! czhao doing dust number emission following pm10
7797 ! use soilfacj for accumulation mode because GOCART assign a less dense dust in
7798 ! accumulation mode
7799 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj
7800 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac
7802 endif
7803 enddo
7804 enddo
7806 end subroutine soa_vbs_dust_gocartemis
7808 SUBROUTINE soa_vbs_source_du( nmx, dt1,i,j, &
7809 erod, ilwi, dxy, w10m, gwet, airden, airmas, &
7810 bems,month,g0)
7812 ! ****************************************************************************
7813 ! * Evaluate the source of each dust particles size classes (kg/m3)
7814 ! * by soil emission.
7815 ! * Input:
7816 ! * EROD Fraction of erodible grid cell (-)
7817 ! * for 1: Sand, 2: Silt, 3: Clay
7818 ! * DUSTDEN Dust density (kg/m3)
7819 ! * DXY Surface of each grid cell (m2)
7820 ! * AIRVOL Volume occupy by each grid boxes (m3)
7821 ! * NDT1 Time step (s)
7822 ! * W10m Velocity at the anemometer level (10meters) (m/s)
7823 ! * u_tresh Threshold velocity for particule uplifting (m/s)
7824 ! * CH_dust Constant to fudge the total emission of dust (s2/m2)
7825 ! *
7826 ! * Output:
7827 ! * DSRC Source of each dust type (kg/timestep/cell)
7828 ! *
7829 ! * Working:
7830 ! * SRC Potential source (kg/m/timestep/cell)
7831 ! *
7832 ! ****************************************************************************
7834 USE module_data_gocart_dust
7836 INTEGER, INTENT(IN) :: nmx
7837 REAL*8, INTENT(IN) :: erod(ndcls)
7838 INTEGER, INTENT(IN) :: ilwi,month
7840 REAL*8, INTENT(IN) :: w10m, gwet
7841 REAL*8, INTENT(IN) :: dxy
7842 REAL*8, INTENT(IN) :: airden, airmas
7843 REAL*8, INTENT(OUT) :: bems(nmx)
7845 REAL*8 :: den(nmx), diam(nmx)
7846 REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce
7847 REAL, intent(in) :: g0
7848 REAL :: rhoa, g,dt1
7849 INTEGER :: i, j, n, m, k
7851 ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5
7852 !ch_dust(:,:)=0.8D-9 ! ch_dust is defined here instead of in the chemics_ini.F if with SOA_VBS -czhao
7853 ch_dust(:,:)=1.0D-9 ! default
7854 !ch_dust(:,:)=0.65D-9 ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara
7855 !ch_dust(:,:)=1.0D-9*0.36 ! ch_dust is scaled to soa_vbs total dust emission
7857 ! executable statemenst
7858 DO n = 1, nmx
7859 ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941)
7860 den(n) = den_dust(n)*1.0D-3
7861 diam(n) = 2.0*reff_dust(n)*1.0D2
7862 g = g0*1.0E2
7863 ! Pointer to the 3 classes considered in the source data files
7864 m = ipoint(n)
7865 tsrc = 0.0
7866 rhoa = airden*1.0D-3
7867 u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
7868 SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
7869 SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
7871 ! Case of surface dry enough to erode
7872 IF (gwet < 0.5) THEN ! Pete's modified value
7873 ! IF (gwet < 0.2) THEN
7874 u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
7875 ELSE
7876 ! Case of wet surface, no erosion
7877 u_ts = 100.0
7878 END IF
7879 srce = frac_s(n)*erod(m)*dxy ! (m2)
7880 IF (ilwi == 1 ) THEN
7881 dsrc = ch_dust(n,month)*srce*w10m**2 &
7882 * (w10m - u_ts)*dt1 ! (kg)
7883 ELSE
7884 dsrc = 0.0
7885 END IF
7886 IF (dsrc < 0.0) dsrc = 0.0
7888 ! Update dust mixing ratio at first model level.
7889 !tc(n) = tc(n) + dsrc / airmas !kg/kg-dryair -czhao
7890 bems(n) = dsrc ! kg/timestep/cell
7892 ENDDO
7894 END SUBROUTINE soa_vbs_source_du
7896 !===========================================================================
7898 !!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F)
7900 !===========================================================================
7901 ! subroutine wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags, &
7902 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
7903 ! qlsink,precr,preci,precs,precg,qsrflx, &
7904 ! gas_aqfrac, numgas_aqfrac, &
7905 ! ids,ide, jds,jde, kds,kde, &
7906 ! ims,ime, jms,jme, kms,kme, &
7907 ! its,ite, jts,jte, kts,kte )
7909 ! wet removal by grid-resolved precipitation
7910 ! scavenging of cloud-phase aerosols and gases by collection, freezing, ...
7911 ! scavenging of interstitial-phase aerosols by impaction
7912 ! scavenging of gas-phase gases by mass transfer and reaction
7914 !----------------------------------------------------------------------
7915 ! USE module_configure
7916 ! USE module_state_description
7917 ! USE module_data_soa_vbs
7918 ! USE module_mosaic_wetscav,only: wetscav
7920 !----------------------------------------------------------------------
7921 ! IMPLICIT NONE
7923 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
7925 ! INTEGER, INTENT(IN ) :: &
7926 ! ids,ide, jds,jde, kds,kde, &
7927 ! ims,ime, jms,jme, kms,kme, &
7928 ! its,ite, jts,jte, kts,kte, &
7929 ! id, ktau, ktauc, numgas_aqfrac
7930 ! REAL, INTENT(IN ) :: dtstep,dtstepc
7932 ! all advected chemical species
7933 !
7934 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7935 ! INTENT(INOUT ) :: chem
7937 ! fraction of gas species in cloud water
7938 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), &
7939 ! INTENT(IN ) :: gas_aqfrac
7941 !
7942 !
7943 ! input from meteorology
7944 ! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7945 ! INTENT(IN ) :: &
7946 ! alt, &
7947 ! t_phy, &
7948 ! p_phy, &
7949 ! t8w,p8w, &
7950 ! qlsink,precr,preci,precs,precg, &
7951 ! rho_phy,cldfra
7952 ! REAL, DIMENSION( ims:ime, jms:jme, num_chem ), &
7953 ! INTENT(OUT ) :: qsrflx ! column change due to scavening
7955 ! call wetscav (id,ktau,dtstep,ktauc,config_flags, &
7956 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
7957 ! qlsink,precr,preci,precs,precg,qsrflx, &
7958 ! gas_aqfrac, numgas_aqfrac, &
7959 ! ntype_aer, nsize_aer, ncomp_aer, &
7960 ! massptr_aer, dens_aer, numptr_aer, &
7961 ! maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, &
7962 ! volumcen_sect, volumlo_sect, volumhi_sect, &
7963 ! waterptr_aer, dens_water_aer, &
7964 ! scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, &
7965 ! ids,ide, jds,jde, kds,kde, &
7966 ! ims,ime, jms,jme, kms,kme, &
7967 ! its,ite, jts,jte, kts,kte )
7969 ! end subroutine wetscav_soa_vbs_driver
7970 !===========================================================================
7972 END Module module_aerosols_soa_vbs_het