| blob | 491410f85ca937949e2c6740e47d387c12cb0550 |
1 MODULE module_aerosols_soa_vbs
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 !
34 USE module_state_description
35 ! USE module_data_radm2
36 USE module_data_soa_vbs
37 ! USE module_radm
39 IMPLICIT NONE
40 #define cw_species_are_in_registry
42 CONTAINS
44 SUBROUTINE soa_vbs_driver ( id,ktau,dtstep,t_phy,moist,aerwrf,p8w, &
45 t8w,alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
46 !liqy - 20150319
47 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
48 vcsulf_old, &
49 vdrog3, &
50 kemit,brch_ratio, &
51 ids,ide, jds,jde, kds,kde, &
52 ims,ime, jms,jme, kms,kme, &
53 its,ite, jts,jte, kts,kte )
55 ! USE module_configure, only: grid_config_rec_type
56 ! TYPE (grid_config_rec_type), INTENT (in) :: config_flags
58 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
59 ims,ime, jms,jme, kms,kme, &
60 its,ite, jts,jte, kts,kte, &
61 kemit, id, ktau
63 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
64 INTENT(IN ) :: moist
66 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
67 INTENT(INOUT ) :: chem
68 !
69 ! following are aerosol arrays that are not advected
70 !
71 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
72 INTENT(INOUT ) :: &
73 !liqy - 20150319
74 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
76 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
77 INTENT(INOUT ) :: brch_ratio
79 ! cvasoa1,cvasoa2, &
80 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4
82 REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog_vbs), &
83 INTENT(IN ) :: VDROG3
84 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
85 INTENT(IN ) :: t_phy, &
86 alt, &
87 p_phy, &
88 dz8w, &
89 rh, & ! fractional relative humidity
90 z, &
91 t8w,p8w,z_at_w , &
92 aerwrf , &
93 rho_phy
94 REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , &
95 INTENT(IN ) :: vcsulf_old
96 REAL, INTENT(IN ) :: dtstep
98 REAL drog_in(ldrog_vbs) ! anthropogenic AND biogenic organic aerosol precursors [ug m**-3 s**-1]
100 ! REAL condvap_in(lspcv) ! condensable vapors [ug m**-3]
101 REAL, PARAMETER :: rgas=8.314510
102 REAL convfac,convfac2
104 !...BLKSIZE set to one in column model ciarev02
105 INTEGER, PARAMETER :: blksize=1
107 !...number of aerosol species
108 ! number of species (gas + aerosol)
109 INTEGER nspcsda
110 PARAMETER (nspcsda=l1ae) !bs
111 ! (internal aerosol dynamics)
112 !bs # of anth. cond. vapors in SOA_VBS
113 INTEGER nacv
114 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
115 !bs total # of cond. vapors in SOA_VBS
116 INTEGER ncv
117 PARAMETER (ncv=lspcv) !bs
118 !bs total # of cond. vapors in CTM
119 REAL cblk(blksize,nspcsda) ! main array of variables
120 ! particles [ug/m^3/s]
121 REAL soilrat_in
122 ! emission rate of soil derived coars
123 ! input HNO3 to CBLK [ug/m^3]
124 REAL nitrate_in
125 ! input NH3 to CBLK [ug/m^3]
126 REAL nh3_in
127 ! input SO4 vapor [ug/m^3]
128 REAL vsulf_in
130 REAL so4rat_in
131 ! input SO4 formation[ug/m^3/sec]
132 REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
133 ! Emission rate of i-mode EC [ug m**-3 s**-1]
134 REAL eeci_in
135 ! Emission rate of j-mode EC [ug m**-3 s**-1]
136 REAL eecj_in
137 ! Emission rate of j-mode org. aerosol [ug m**-
138 REAL eorgi_in
140 REAL eorgj_in ! Emission rate of j-mode org. aerosol [ug m**-
141 REAL pres ! pressure in cb
142 REAL temp ! temperature in K
143 ! REAL relhum ! rel. humidity (0,1)
144 REAL brrto
146 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
148 !...molecular weights ciarev02
149 ! these molecular weights aren't used at all
151 ! molecular weight for SO4
152 REAL mwso4
153 PARAMETER (mwso4=96.0576)
155 ! molecular weight for HNO3
156 REAL mwhno3
157 PARAMETER (mwhno3=63.01287)
159 ! molecular weight for NH3
160 REAL mwnh3
161 PARAMETER (mwnh3=17.03061)
164 !bs molecular weight for Elemental Carbon
165 REAL mwec
166 PARAMETER (mwec=12.0)
168 !liqy-20140905
169 ! they aren't used
170 !!rs molecular weight
171 ! REAL mwaro1
172 ! PARAMETER (mwaro1=150.0)
173 !
174 !!rs molecular weight
175 ! REAL mwaro2
176 ! PARAMETER (mwaro2=150.0)
177 !
178 !!rs molecular weight
179 ! REAL mwalk1
180 ! PARAMETER (mwalk1=140.0)
181 !
182 !!rs molecular weight
183 ! REAL mwalk2
184 ! PARAMETER (mwalk2=140.0)
185 !
186 !!rs molecular weight
187 ! REAL mwole1
188 ! PARAMETER (mwole1=140.0)
189 !
190 !!rs molecular weight
191 ! REAL mwapi1
192 ! PARAMETER (mwapi1=200.0)
193 !
194 !!rs molecular weight
195 ! REAL mwapi2
196 ! PARAMETER (mwapi2=200.0)
197 !
198 !!rs molecular weight
199 ! REAL mwlim1
200 ! PARAMETER (mwlim1=200.0)
201 !
202 !!rs molecular weight
203 ! REAL mwlim2
204 ! PARAMETER (mwlim2=200.0)
206 INTEGER :: i,j,k,l,debug_level
207 ! convert advected aerosol variables to ug/m3 from mixing ratio
208 ! they will be converted back at the end of this driver
209 !
210 do l=p_so4aj,num_chem
211 do j=jts,jte
212 do k=kts,kte
213 do i=its,ite
214 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j))
215 enddo
216 enddo
217 enddo
218 enddo
220 ! Use RH from phys/???
221 do 100 j=jts,jte
222 do 100 i=its,ite
223 debug_level=0
224 ! do k=kts,kte
225 ! t(k) = t_phy(i,k,j)
226 ! p(k) = .001*p_phy(i,k,j)
227 ! rh0(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / &
228 ! (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
229 ! (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) )
230 ! rh0(k)=max(.1,0.01*rh0(k))
231 ! enddo
233 do k=kts,kte
235 ! added here
236 t(k) = t_phy(i,k,j)
237 p(k) = .001*p_phy(i,k,j)
238 rh0(k) = rh(i,k,j)
240 ! IF ( rh0(k)<0.1 .OR. rh0(k)>0.95 ) THEN
241 ! CALL wrf_error_fatal ( 'rh0 is out of the permissible range' )
242 ! ENDIF
244 cblk=0.
246 ! do l=1,ldrog
247 ! drog_in(l)=0.
248 ! enddo
250 ! do l=1,lspcv
251 ! condvap_in(l)=0.
252 ! enddo
254 convfac = p(k)/rgas/t(k)*1000.
255 so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
256 soilrat_in = 0.
257 nitrate_in = max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
258 nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
259 !liqy
260 !uncomment hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
261 ! hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
262 !comment hcl_in = 0.
263 !liqy-20140905
264 vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
266 ! * organic aerosol precursors DeltaROG and SOA production
267 drog_in(PALK4) = VDROG3(i,k,j,PALK4)
268 drog_in(PALK5) = VDROG3(i,k,j,PALK5)
269 drog_in(POLE1) = VDROG3(i,k,j,POLE1)
270 drog_in(POLE2) = VDROG3(i,k,j,POLE2)
271 drog_in(PARO1) = VDROG3(i,k,j,PARO1)
272 drog_in(PARO2) = VDROG3(i,k,j,PARO2)
273 drog_in(PISOP) = VDROG3(i,k,j,PISOP)
274 drog_in(PTERP) = VDROG3(i,k,j,PTERP)
275 drog_in(PSESQ) = VDROG3(i,k,j,PSESQ)
276 drog_in(PBRCH) = VDROG3(i,k,j,PBRCH)
278 cblk(1,VASOA1J) = chem(i,k,j,p_asoa1j)
279 cblk(1,VASOA1I) = chem(i,k,j,p_asoa1i)
280 cblk(1,VASOA2J) = chem(i,k,j,p_asoa2j)
281 cblk(1,VASOA2I) = chem(i,k,j,p_asoa2i)
282 cblk(1,VASOA3J) = chem(i,k,j,p_asoa3j)
283 cblk(1,VASOA3I) = chem(i,k,j,p_asoa3i)
284 cblk(1,VASOA4J) = chem(i,k,j,p_asoa4j)
285 cblk(1,VASOA4I) = chem(i,k,j,p_asoa4i)
287 cblk(1,VBSOA1J) = chem(i,k,j,p_bsoa1j)
288 cblk(1,VBSOA1I) = chem(i,k,j,p_bsoa1i)
289 cblk(1,VBSOA2J) = chem(i,k,j,p_bsoa2j)
290 cblk(1,VBSOA2I) = chem(i,k,j,p_bsoa2i)
291 cblk(1,VBSOA3J) = chem(i,k,j,p_bsoa3j)
292 cblk(1,VBSOA3I) = chem(i,k,j,p_bsoa3i)
293 cblk(1,VBSOA4J) = chem(i,k,j,p_bsoa4j)
294 cblk(1,VBSOA4I) = chem(i,k,j,p_bsoa4i)
296 ! Comment out the old code
297 ! condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
298 ! condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
299 ! condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
300 ! condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
301 ! cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j)
302 ! cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i)
303 ! cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j)
304 ! cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i)
305 ! cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j)
306 ! cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i)
307 ! cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j)
308 ! cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i)
309 ! cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j)
310 ! cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i)
311 ! cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j)
312 ! cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i)
313 ! cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j)
314 ! cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i)
315 ! cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j)
316 ! cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i)
318 cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj)
319 cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai)
320 cblk(1,VECJ ) = chem(i,k,j,p_ecj)
321 cblk(1,VECI ) = chem(i,k,j,p_eci)
322 cblk(1,VP25AJ ) = chem(i,k,j,p_p25j)
323 cblk(1,VP25AI ) = chem(i,k,j,p_p25i)
324 cblk(1,VANTHA ) = chem(i,k,j,p_antha)
325 cblk(1,VSEAS ) = chem(i,k,j,p_seas)
326 cblk(1,VSOILA ) = chem(i,k,j,p_soila)
327 cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j))
328 cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j))
329 cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j))
330 cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j))
332 cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j))
333 !liqy-20150319
334 cblk(1,vcvasoa1) = chem(i,k,j,p_cvasoa1)
335 cblk(1,vcvasoa2) = chem(i,k,j,p_cvasoa2)
336 cblk(1,vcvasoa3) = chem(i,k,j,p_cvasoa3)
337 cblk(1,vcvasoa4) = chem(i,k,j,p_cvasoa4)
339 cblk(1,vcvbsoa1) = chem(i,k,j,p_cvbsoa1)
340 cblk(1,vcvbsoa2) = chem(i,k,j,p_cvbsoa2)
341 cblk(1,vcvbsoa3) = chem(i,k,j,p_cvbsoa3)
342 cblk(1,vcvbsoa4) = chem(i,k,j,p_cvbsoa4)
343 !
344 ! Set emissions to zero
345 epmcoarse(1) = 0.
346 epm25i(1) = 0.
347 epm25j(1) = 0.
348 eeci_in = 0.
349 eecj_in = 0.
350 eorgi_in = 0.
351 eorgj_in = 0.
352 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
353 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
354 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
355 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
356 cblk(1,VNAAJ ) = chem(i,k,j,p_naaj)
357 cblk(1,VNAAI ) = chem(i,k,j,p_naai)
358 !liqy
359 !uncomment cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
360 !uncomment cblk(1,VCLAI ) = chem(i,k,j,p_clai)
361 cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
362 cblk(1,VCLAI ) = chem(i,k,j,p_clai)
363 !comment cblk(1,VCLAJ ) = 0.
364 !comment cblk(1,VCLAI ) = 0.
365 ! cblk(1,VCLAJ ) = 0.
366 ! cblk(1,VCLAI ) = 0.
367 !liqy-20140623
368 !
369 !rs. nitrate, nh3, sulf
370 cblk(1,vsulf) = vsulf_in
371 cblk(1,vhno3) = nitrate_in
372 cblk(1,vnh3) = nh3_in
373 cblk(1,VNH4AJ) = chem(i,k,j,p_nh4aj)
374 cblk(1,VNH4AI) = chem(i,k,j,p_nh4ai)
375 cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0))
376 cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0))
377 cblk(1,VCORN ) = chem(i,k,j,p_corn)
378 !liqy
379 cblk(1,valt_in) = alt(i,k,j)
380 !liqy -20150319
381 ! the following operation updates cblk, which includes the vapors and SOA species
382 ! condvap_in is removed
383 CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh0(k),nitrate_in,nh3_in, &
384 vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv,nacv,eeci_in,eecj_in, &
385 eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k,brrto)
387 ! calculation of brch_ratio
388 brch_ratio(i,k,j)= brrto
389 !------------------------------------------------------------------------
391 chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
392 chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
393 chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
394 chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
395 chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
396 chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
397 chem(i,k,j,p_naaj) = cblk(1,VNAAJ )
398 chem(i,k,j,p_naai) = cblk(1,VNAAI )
399 !liqy
400 !uncomment chem(i,k,j,p_claj) = cblk(1,VCLAJ )
401 !uncomment chem(i,k,j,p_clai) = cblk(1,VCLAI )
402 chem(i,k,j,p_claj) = cblk(1,VCLAJ )
403 chem(i,k,j,p_clai) = cblk(1,VCLAI )
405 !liqy-20140616
407 chem(i,k,j,p_asoa1j) = cblk(1,VASOA1J)
408 chem(i,k,j,p_asoa1i) = cblk(1,VASOA1I)
409 chem(i,k,j,p_asoa2j) = cblk(1,VASOA2J)
410 chem(i,k,j,p_asoa2i) = cblk(1,VASOA2I)
411 chem(i,k,j,p_asoa3j) = cblk(1,VASOA3J)
412 chem(i,k,j,p_asoa3i) = cblk(1,VASOA3I)
413 chem(i,k,j,p_asoa4j) = cblk(1,VASOA4J)
414 chem(i,k,j,p_asoa4i) = cblk(1,VASOA4I)
416 chem(i,k,j,p_bsoa1j) = cblk(1,VBSOA1J)
417 chem(i,k,j,p_bsoa1i) = cblk(1,VBSOA1I)
418 chem(i,k,j,p_bsoa2j) = cblk(1,VBSOA2J)
419 chem(i,k,j,p_bsoa2i) = cblk(1,VBSOA2I)
420 chem(i,k,j,p_bsoa3j) = cblk(1,VBSOA3J)
421 chem(i,k,j,p_bsoa3i) = cblk(1,VBSOA3I)
422 chem(i,k,j,p_bsoa4j) = cblk(1,VBSOA4J)
423 chem(i,k,j,p_bsoa4i) = cblk(1,VBSOA4I)
425 ! chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
426 ! chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
427 ! chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
428 ! chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
429 ! chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
430 ! chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
431 ! chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
432 ! chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
433 ! chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
434 ! chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
435 ! chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
436 ! chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
437 ! chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
438 ! chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
439 ! chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
440 ! chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
442 chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ )
443 chem(i,k,j,p_orgpai) = cblk(1,VORGPAI )
444 chem(i,k,j,p_ecj) = cblk(1,VECJ )
445 chem(i,k,j,p_eci) = cblk(1,VECI )
446 chem(i,k,j,p_p25j) = cblk(1,VP25AJ )
447 chem(i,k,j,p_p25i) = cblk(1,VP25AI )
448 chem(i,k,j,p_antha) = cblk(1,VANTHA )
449 chem(i,k,j,p_seas) = cblk(1,VSEAS )
450 chem(i,k,j,p_soila) = cblk(1,VSOILA )
451 chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 ))
452 chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 ))
454 chem(i,k,j,p_corn) = cblk(1,VCORN )
455 h2oaj(i,k,j) = cblk(1,VH2OAJ )
456 h2oai(i,k,j) = cblk(1,VH2OAI )
457 nu3(i,k,j) = cblk(1,VNU3 )
458 ac3(i,k,j) = cblk(1,VAC3 )
459 cor3(i,k,j) = cblk(1,VCOR3 )
460 !liqy-20150319
462 chem(i,k,j,p_cvasoa1)= cblk(1,VCVASOA1 )
463 chem(i,k,j,p_cvasoa2)= cblk(1,VCVASOA2 )
464 chem(i,k,j,p_cvasoa3)= cblk(1,VCVASOA3 )
465 chem(i,k,j,p_cvasoa4)= cblk(1,VCVASOA4 )
467 chem(i,k,j,p_cvbsoa1)= cblk(1,VCVBSOA1 )
468 chem(i,k,j,p_cvbsoa2)= cblk(1,VCVBSOA2 )
469 chem(i,k,j,p_cvbsoa3)= cblk(1,VCVBSOA3 )
470 chem(i,k,j,p_cvbsoa4)= cblk(1,VCVBSOA4 )
472 !---------------------------------------------------------------------------
474 ! cvbsoa1(i,k,j) = 0.
475 ! cvbsoa2(i,k,j) = 0.
476 ! cvbsoa3(i,k,j) = 0.
477 ! cvbsoa4(i,k,j) = 0.
479 ! cvaro1(i,k,j) = cblk(1,VCVARO1 )
480 ! cvaro2(i,k,j) = cblk(1,VCVARO2 )
481 ! cvalk1(i,k,j) = cblk(1,VCVALK1 )
482 ! cvole1(i,k,j) = cblk(1,VCVOLE1 )
483 ! cvapi1(i,k,j) = 0.
484 ! cvapi2(i,k,j) = 0.
485 ! cvlim1(i,k,j) = 0.
486 ! cvlim2(i,k,j) = 0.
488 chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
489 chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
490 chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
492 !liqy-20140905
493 enddo ! k-loop
494 100 continue ! i,j-loop ends
496 ! convert aerosol variables back to mixing ratio from ug/m3
497 do l=p_so4aj,num_chem
498 do j=jts,jte
499 do k=kts,kte
500 do i=its,ite
501 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j))
502 enddo
503 enddo
504 enddo
505 enddo
507 END SUBROUTINE soa_vbs_driver
508 ! ///////////////////////////////////////////////////
510 SUBROUTINE sum_pm_soa_vbs ( &
511 alt, chem, h2oaj, h2oai, &
512 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10,dust_opt, &
513 ids,ide, jds,jde, kds,kde, &
514 ims,ime, jms,jme, kms,kme, &
515 its,ite, jts,jte, kts,kte )
517 INTEGER, INTENT(IN ) :: dust_opt, &
518 ids,ide, jds,jde, kds,kde, &
519 ims,ime, jms,jme, kms,kme, &
520 its,ite, jts,jte, kts,kte
522 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
523 INTENT(IN ) :: chem
525 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
526 INTENT(IN ) :: alt,h2oaj,h2oai
528 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
529 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
531 INTEGER :: i,ii,j,jj,k,n
532 !
533 ! sum up pm2_5 and pm10 output
534 !
535 pm2_5_dry(its:ite, kts:kte, jts:jte) = 0.
536 pm2_5_water(its:ite, kts:kte, jts:jte) = 0.
537 pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0.
538 do j=jts,jte
539 jj=min(jde-1,j)
540 do k=kts,kte
541 do i=its,ite
542 ii=min(ide-1,i)
543 do n=p_so4aj,p_p25i
544 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
545 enddo
547 !!! TUCCELLA
548 if( p_p25cwi .gt. p_p25i) then
549 do n=p_so4cwj,p_p25cwi
550 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
551 enddo
552 endif
554 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) &
555 + chem(ii,k,jj,p_eci)
556 pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) &
557 + h2oai(i,k,j)
559 !Convert the units from mixing ratio to concentration (ug m^-3)
560 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,k,jj)
561 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj)
562 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,k,jj)
563 enddo
564 enddo
565 enddo
566 do j=jts,jte
567 jj=min(jde-1,j)
568 do k=kts,kte
569 do i=its,ite
570 ii=min(ide-1,i)
571 pm10(i,k,j) = pm2_5_dry(i,k,j) &
572 + ( chem(ii,k,jj,p_antha) &
573 + chem(ii,k,jj,p_soila) &
574 + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj)
575 !!!TUCCELLA
576 if( p_p25cwi .gt. p_p25i) then
577 pm10(i,k,j) = pm10(i,k,j) &
578 + ( chem(ii,k,jj,p_anthcw) &
579 + chem(ii,k,jj,p_soilcw) &
580 + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj)
581 endif
582 enddo
583 enddo
584 enddo
585 END SUBROUTINE sum_pm_soa_vbs
586 ! ///////////////////////////////////////////////////
588 SUBROUTINE soa_vbs_depdriver (id,config_flags,ktau,dtstep, &
589 ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, &
590 alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
591 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
593 ! the vapors are part of chem array
594 ! cvasoa1,cvasoa2, &
595 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4, &
597 aer_res,vgsa, &
598 numaer, &
599 ids,ide, jds,jde, kds,kde, &
600 ims,ime, jms,jme, kms,kme, &
601 its,ite, jts,jte, kts,kte )
603 USE module_configure,only: grid_config_rec_type
604 TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags
606 INTEGER, INTENT(IN ) :: numaer, &
607 ids,ide, jds,jde, kds,kde, &
608 ims,ime, jms,jme, kms,kme, &
609 its,ite, jts,jte, kts,kte, &
610 id,ktau
612 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
613 INTENT(IN ) :: moist
614 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
615 INTENT(INOUT ) :: chem
616 !
617 ! following are aerosol arrays that are not advected
618 !
619 REAL, DIMENSION( its:ite, jts:jte, numaer ), &
620 INTENT(INOUT ) :: &
621 vgsa
622 REAL, DIMENSION( its:ite, jts:jte ), &
623 INTENT(INOUT ) :: &
624 aer_res
626 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
627 INTENT(INOUT ) :: &
628 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
630 ! no vapors
631 !cvaro1,cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
633 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
634 INTENT(IN ) :: t_phy, &
635 alt, &
636 p_phy, &
637 dz8w, &
638 rh, &
639 z, &
640 t8w,p8w,z_at_w , &
641 rho_phy
642 REAL, DIMENSION( ims:ime , jms:jme ) , &
643 INTENT(IN ) :: ust,rmol, pbl, znt
644 REAL, INTENT(IN ) :: dtstep
646 REAL, PARAMETER :: rgas=8.314510
647 REAL convfac,convfac2
648 !...BLKSIZE set to one in column model ciarev02
650 INTEGER, PARAMETER :: blksize=1
652 !...number of aerosol species
653 ! number of species (gas + aerosol)
654 INTEGER nspcsda
655 PARAMETER (nspcsda=l1ae) !bs
656 ! (internal aerosol dynamics)
657 !bs # of anth. cond. vapors in SOA_VBS
658 INTEGER nacv
659 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
660 !bs total # of cond. vapors in SOA_VBS
661 INTEGER, PARAMETER :: ncv=lspcv ! number of bins=8
662 !bs total # of cond. vapors in CTM
663 REAL cblk(blksize,nspcsda) ! main array of variables
664 ! particles [ug/m^3/s]
665 REAL soilrat_in
666 ! emission rate of soil derived coars
667 ! input HNO3 to CBLK [ug/m^3]
668 REAL nitrate_in
669 ! input NH3 to CBLK [ug/m^3]
670 REAL nh3_in
671 ! input SO4 vapor [ug/m^3]
672 REAL vsulf_in
674 REAL so4rat_in
675 ! input SO4 formation[ug/m^3/sec]
676 ! pressure in cb
677 REAL pres
678 ! temperature in K
679 REAL temp
680 !bs
681 REAL relhum
682 ! rel. humidity (0,1)
683 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
685 !...molecular weights ciarev02
687 ! molecular weight for SO4
688 REAL mwso4
689 PARAMETER (mwso4=96.0576)
691 ! molecular weight for HNO3
692 REAL mwhno3
693 PARAMETER (mwhno3=63.01287)
695 ! molecular weight for NH3
696 REAL mwnh3
697 PARAMETER (mwnh3=17.03061)
699 !bs molecular weight for Organic Spec
700 ! REAL mworg
701 ! PARAMETER (mworg=175.0)
703 !bs molecular weight for Elemental Ca
704 REAL mwec
705 PARAMETER (mwec=12.0)
707 ! they aren't used
708 !!rs molecular weight
709 ! REAL mwaro1
710 ! PARAMETER (mwaro1=150.0)
711 !
712 !!rs molecular weight
713 ! REAL mwaro2
714 ! PARAMETER (mwaro2=150.0)
715 !
716 !!rs molecular weight
717 ! REAL mwalk1
718 ! PARAMETER (mwalk1=140.0)
719 !
720 !!rs molecular weight
721 ! REAL mwalk2
722 ! PARAMETER (mwalk2=140.0)
723 !
724 !!rs molecular weight
725 !!rs molecular weight
726 ! REAL mwole1
727 ! PARAMETER (mwole1=140.0)
728 !
729 !!rs molecular weight
730 ! REAL mwapi1
731 ! PARAMETER (mwapi1=200.0)
732 !
733 !!rs molecular weight
734 ! REAL mwapi2
735 ! PARAMETER (mwapi2=200.0)
736 !
737 !!rs molecular weight
738 ! REAL mwlim1
739 ! PARAMETER (mwlim1=200.0)
740 !
741 ! REAL mwlim2
742 ! PARAMETER (mwlim2=200.0)
744 INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model)
745 !ia kept to 1 in current version of column model
746 PARAMETER( NUMCELLS = 1)
748 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
749 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
750 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
751 REAL PBLH( BLKSIZE ) ! PBL height (m)
752 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
753 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
755 REAL BLKPRS(BLKSIZE) ! pressure in cb
756 REAL BLKTA(BLKSIZE) ! temperature in K
757 REAL BLKDENS(BLKSIZE) ! Air density in kg/m3
758 !
759 ! *** OUTPUT:
760 !
761 ! *** atmospheric properties
763 REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ]
764 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ]
766 ! *** followng is for future version
767 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
768 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
770 ! *** modal diameters: [ m ]
771 REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ]
772 REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ]
773 REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ]
775 ! *** aerosol properties:
776 ! *** Modal mass concentrations [ ug m**3 ]
777 REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode
778 REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode
779 REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode
781 ! *** average modal particle densities [ kg/m**3 ]
782 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode
783 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode
784 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode
786 ! *** average modal Knudsen numbers
787 REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number
788 REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number
789 REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number
790 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
792 INTEGER :: i,j,k,l
793 !
794 ! print *,'in sorgdepdriver ',its,ite,jts,jte
795 do l=1,numaer
796 do i=its,ite
797 do j=jts,jte
798 vgsa(i,j,l)=0.
799 enddo
800 enddo
801 enddo
802 vdep=0.
804 do 100 j=jts,jte
805 do 100 i=its,ite
806 cblk=epsilc
807 do k=kts,kte
808 t(k) = t_phy(i,k,j)
809 p(k) = .001*p_phy(i,k,j)
810 rh0(k) = rh(i,k,j)
811 end do
813 k=kts
814 convfac = p(k)/rgas/t(k)*1000.
815 nitrate_in = chem(i,k,j,p_hno3)*convfac*mwhno3
816 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
817 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4
819 !rs. nitrate, nh3, sulf
820 BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa
821 BLKTA(BLKSIZE) = T(K) ! temperature in K
822 USTAR(BLKSIZE) = max(1.e-1,UST(i,j))
823 WSTAR(BLKSIZE) = 0.
824 pblh(blksize) = pbl(i,j)
825 zntt(blksize) = znt(i,j)
826 rmolm(blksize)= rmol(i,j)
827 convfac2=1./alt(i,k,j) ! density of dry air
828 BLKDENS(BLKSIZE)=convfac2
829 cblk(1,vsulf) = max(epsilc,vsulf_in)
830 cblk(1,vhno3) = max(epsilc,nitrate_in)
831 cblk(1,vnh3) = max(epsilc,nh3_in)
832 cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
833 cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
834 cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
835 cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
836 cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
837 cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
839 if (p_naai >= param_first_scalar) &
840 cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2)
841 if (p_naaj >= param_first_scalar) &
842 cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2)
843 if (p_clai >= param_first_scalar) &
844 cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2)
845 if (p_claj >= param_first_scalar) &
846 cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2)
848 !liqy-20140617
850 cblk(1,VASOA1J) = max(epsilc,chem(i,k,j,p_asoa1j)*convfac2) ! ug/kg-air to ug/m3
851 cblk(1,VASOA1I) = max(epsilc,chem(i,k,j,p_asoa1i)*convfac2)
852 cblk(1,VASOA2J) = max(epsilc,chem(i,k,j,p_asoa2j)*convfac2)
853 cblk(1,VASOA2I) = max(epsilc,chem(i,k,j,p_asoa2i)*convfac2)
854 cblk(1,VASOA3J) = max(epsilc,chem(i,k,j,p_asoa3j)*convfac2)
855 cblk(1,VASOA3I) = max(epsilc,chem(i,k,j,p_asoa3i)*convfac2)
856 cblk(1,VASOA4J) = max(epsilc,chem(i,k,j,p_asoa4j)*convfac2)
857 cblk(1,VASOA4I) = max(epsilc,chem(i,k,j,p_asoa4i)*convfac2)
859 cblk(1,VBSOA1J) = max(epsilc,chem(i,k,j,p_bsoa1j)*convfac2)
860 cblk(1,VBSOA1I) = max(epsilc,chem(i,k,j,p_bsoa1i)*convfac2)
861 cblk(1,VBSOA2J) = max(epsilc,chem(i,k,j,p_bsoa2j)*convfac2)
862 cblk(1,VBSOA2I) = max(epsilc,chem(i,k,j,p_bsoa2i)*convfac2)
863 cblk(1,VBSOA3J) = max(epsilc,chem(i,k,j,p_bsoa3j)*convfac2)
864 cblk(1,VBSOA3I) = max(epsilc,chem(i,k,j,p_bsoa3i)*convfac2)
865 cblk(1,VBSOA4J) = max(epsilc,chem(i,k,j,p_bsoa4j)*convfac2)
866 cblk(1,VBSOA4I) = max(epsilc,chem(i,k,j,p_bsoa4i)*convfac2)
868 ! cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
869 ! cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
870 ! cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
871 ! cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
872 ! cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
873 ! cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
874 ! cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
875 ! cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
876 ! cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
877 ! cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
878 ! cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
879 ! cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
880 ! cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
881 ! cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
882 ! cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
883 ! cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
885 cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
886 cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
887 cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2)
888 cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2)
889 cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2)
890 cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2)
892 cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2)
893 cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2)
894 cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2)
896 cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2)
897 cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2)
899 cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2)
900 cblk(1,VH2OAJ ) = h2oaj(i,k,j)
901 cblk(1,VH2OAI ) = h2oai(i,k,j)
902 cblk(1,VNU3 ) = nu3(i,k,j)
903 cblk(1,VAC3 ) = ac3(i,k,j)
904 cblk(1,VCOR3 ) = cor3(i,k,j)
906 ! here cblk is used to call modpar, however modpar doesn't need vapors!
907 ! cblk(1,vcvasoa1 ) = cvasoa1(i,k,j)
908 ! cblk(1,vcvasoa2 ) = cvasoa2(i,k,j)
909 ! cblk(1,vcvasoa3 ) = cvasoa3(i,k,j)
910 ! cblk(1,vcvasoa4 ) = cvasoa4(i,k,j)
911 ! cblk(1,vcvbsoa1) = 0.
912 ! cblk(1,vcvbsoa2) = 0.
913 ! cblk(1,vcvbsoa3) = 0.
914 ! cblk(1,vcvbsoa4) = 0.
916 ! cblk(1,VCVARO1 ) = cvaro1(i,k,j)
917 ! cblk(1,VCVARO2 ) = cvaro2(i,k,j)
918 ! cblk(1,VCVALK1 ) = cvalk1(i,k,j)
919 ! cblk(1,VCVOLE1 ) = cvole1(i,k,j)
920 ! cblk(1,VCVAPI1 ) = 0.
921 ! cblk(1,VCVAPI2 ) = 0.
922 ! cblk(1,VCVLIM1 ) = 0.
923 ! cblk(1,VCVLIM2 ) = 0.
925 ! cblk(1,VCVAPI1 ) = cvapi1(i,k,j)
926 ! cblk(1,VCVAPI2 ) = cvapi2(i,k,j)
927 ! cblk(1,VCVLIM1 ) = cvlim1(i,k,j)
928 ! cblk(1,VCVLIM2 ) = cvlim2(i,k,j)
929 !
930 !rs. get size distribution information
931 ! if(i.eq.126.and.j.eq.99)then
932 ! print *,'in modpar ',i,j
933 ! print *,cblk,BLKTA,BLKPRS,USTAR
934 ! print *,'BLKSIZE, NSPCSDA, NUMCELLS'
935 ! print *,BLKSIZE, NSPCSDA, NUMCELLS
936 ! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
937 ! print *,XLM, AMU,PDENSN, PDENSA, PDENSC
938 ! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
939 ! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
940 ! endif
942 CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, &
943 CBLK, &
944 BLKTA, BLKPRS, &
945 PMASSN, PMASSA, PMASSC, &
946 PDENSN, PDENSA, PDENSC, &
947 XLM, AMU, &
948 DGNUC, DGACC, DGCOR, &
949 KNNUC, KNACC,KNCOR )
951 if (config_flags%aer_drydep_opt == 11) then
952 CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
953 BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, &
954 DGNUC, DGACC, DGCOR, &
955 KNNUC, KNACC,KNCOR, &
956 PDENSN, PDENSA, PDENSC, &
957 VSED, VDEP )
958 else
959 ! for aerosol dry deposition, no CBLK in VDVG_2
960 CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k, &
961 BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,&
962 ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,&
963 KNNUC, KNACC,KNCOR, &
964 PDENSN, PDENSA, PDENSC, &
965 VSED, VDEP )
966 endif
968 VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC )
969 VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC )
970 VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ )
971 VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI )
972 VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ )
973 VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI )
975 if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI )
976 if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ )
977 if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI )
978 if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ )
979 !liqy
980 !liqy-20140703
981 VGSA(i, j, VASOA1J ) = VGSA(i, j, VSO4AJ )
982 VGSA(i, j, VASOA1I ) = VGSA(i, j, VSO4AI )
983 VGSA(i, j, VASOA2J ) = VGSA(i, j, VSO4AJ )
984 VGSA(i, j, VASOA2I ) = VGSA(i, j, VSO4AI )
985 VGSA(i, j, VASOA3J ) = VGSA(i, j, VSO4AJ )
986 VGSA(i, j, VASOA3I ) = VGSA(i, j, VSO4AI )
987 VGSA(i, j, VASOA4J ) = VGSA(i, j, VSO4AJ )
988 VGSA(i, j, VASOA4I ) = VGSA(i, j, VSO4AI )
990 VGSA(i, j, VBSOA1J ) = VGSA(i, j, VSO4AJ )
991 VGSA(i, j, VBSOA1I ) = VGSA(i, j, VSO4AI )
992 VGSA(i, j, VBSOA2J ) = VGSA(i, j, VSO4AJ )
993 VGSA(i, j, VBSOA2I ) = VGSA(i, j, VSO4AI )
994 VGSA(i, j, VBSOA3J ) = VGSA(i, j, VSO4AJ )
995 VGSA(i, j, VBSOA3I ) = VGSA(i, j, VSO4AI )
996 VGSA(i, j, VBSOA4J ) = VGSA(i, j, VSO4AJ )
997 VGSA(i, j, VBSOA4I ) = VGSA(i, j, VSO4AI )
998 !----------------------------------------------------------------------
1000 ! VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ )
1001 ! VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI )
1002 ! VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ )
1003 ! VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI )
1004 ! VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ )
1005 ! VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI )
1006 ! VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ )
1007 ! VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI )
1008 ! VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ )
1009 ! VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI )
1010 ! VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ )
1011 ! VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI )
1012 ! VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ )
1013 ! VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI )
1014 ! VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ )
1015 ! VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI )
1017 VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ )
1018 VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI )
1019 VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ )
1020 VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI )
1021 VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ )
1022 VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI )
1024 VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR )
1025 VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA )
1026 VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA )
1027 VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC )
1028 VGSA(i, j, VAC0 ) = VDEP(1, VDNACC )
1029 VGSA(i, j, VCORN ) = VDEP(1, VDNCOR )
1030 ! enddo ! k-loop
1031 100 continue ! i,j-loop
1033 END SUBROUTINE soa_vbs_depdriver
1034 ! ///////////////////////////////////////////////////
1036 SUBROUTINE actcof(cat,an,gama,molnu,phimult)
1037 ! DESCRIPTION:
1038 ! This subroutine computes the activity coefficients of (2NH4+,SO4--),
1039 ! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
1040 ! multicomponent solution, using Bromley's model and Pitzer's method.
1042 ! REFERENCES:
1043 ! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
1044 ! in aqueous solutions. AIChE J. 19, 313-320.
1046 ! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of
1047 ! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
1049 ! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
1050 ! of strong acids over saline solutions - I HNO3,
1051 ! Atmos. Environ. (22): 91-100
1053 ! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
1054 ! and mean activity and osmotic coefficients of 0-100% nitric acid
1055 ! as a function of temperature, J. Phys. Chem (94): 5369 - 5380
1057 ! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
1058 ! general equilibrium model for inorganic multicomponent atmospheric
1059 ! aerosols. Atmos. Environ. 21(11), 2453-2466.
1061 ! ARGUMENT DESCRIPTION:
1062 ! CAT(1) : conc. of H+ (moles/kg)
1063 ! CAT(2) : conc. of NH4+ (moles/kg)
1064 ! AN(1) : conc. of SO4-- (moles/kg)
1065 ! AN(2) : conc. of NO3- (moles/kg)
1066 ! AN(3) : conc. of HSO4- (moles/kg)
1067 ! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--)
1068 ! GAMA(2,2) : (NH4+,NO3-)
1069 ! GAMA(2,3) : (NH4+. HSO4-)
1070 ! GAMA(1,1) : (2H+,SO4--)
1071 ! GAMA(1,2) : (H+,NO3-)
1072 ! GAMA(1,3) : (H+,HSO4-)
1073 ! MOLNU : the total number of moles of all ions.
1074 ! PHIMULT : the multicomponent paractical osmotic coefficient.
1076 ! REVISION HISTORY:
1077 ! Who When Detailed description of changes
1078 ! --------- -------- -------------------------------------------
1079 ! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this
1080 ! new routine using a method described by Pilini
1081 ! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
1082 ! S.Roselle 7/30/97 Modified for use in Models-3
1083 ! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA
1085 !-----------------------------------------------------------------------
1086 !...........INCLUDES and their descriptions
1087 ! INCLUDE SUBST_XSTAT ! M3EXIT status codes
1088 !....................................................................
1090 ! Normal, successful completion
1091 INTEGER xstat0
1092 PARAMETER (xstat0=0)
1093 ! File I/O error
1094 INTEGER xstat1
1095 PARAMETER (xstat1=1)
1096 ! Execution error
1097 INTEGER xstat2
1098 PARAMETER (xstat2=2)
1099 ! Special error
1100 INTEGER xstat3
1101 PARAMETER (xstat3=3)
1102 CHARACTER*120 xmsg
1104 !...........PARAMETERS and their descriptions:
1105 ! number of cations
1106 INTEGER ncat
1107 PARAMETER (ncat=2)
1109 ! number of anions
1110 INTEGER nan
1111 PARAMETER (nan=3)
1113 !...........ARGUMENTS and their descriptions
1114 ! tot # moles of all ions
1115 REAL molnu
1116 ! multicomponent paractical osmo
1117 REAL phimult
1118 REAL cat(ncat) ! cation conc in moles/kg (input
1119 REAL an(nan) ! anion conc in moles/kg (input)
1120 REAL gama(ncat,nan)
1121 !...........SCRATCH LOCAL VARIABLES and their descriptions:
1122 ! mean molal ionic activity coef
1123 CHARACTER*16 & ! driver program name
1124 pname
1125 SAVE pname
1127 ! anion indX
1128 INTEGER ian
1130 INTEGER icat
1131 ! cation indX
1133 REAL fgama
1134 ! ionic strength
1135 REAL i
1136 REAL r
1137 REAL s
1138 REAL ta
1139 REAL tb
1140 REAL tc
1141 REAL texpv
1142 REAL trm
1143 ! 2*ionic strength
1144 REAL twoi
1145 ! 2*sqrt of ionic strength
1146 REAL twosri
1147 REAL zbar
1148 REAL zbar2
1149 REAL zot1
1150 ! square root of ionic strength
1151 REAL sri
1152 REAL f2(ncat)
1153 REAL f1(nan)
1154 REAL zp(ncat) ! absolute value of charges of c
1155 REAL zm(nan) ! absolute value of charges of a
1156 REAL bgama(ncat,nan)
1157 REAL x(ncat,nan)
1158 REAL m(ncat,nan) ! molality of each electrolyte
1159 REAL lgama0(ncat,nan) ! binary activity coefficients
1160 REAL y(nan,ncat)
1161 REAL beta0(ncat,nan) ! binary activity coefficient pa
1162 REAL beta1(ncat,nan) ! binary activity coefficient pa
1163 REAL cgama(ncat,nan) ! binary activity coefficient pa
1164 REAL v1(ncat,nan) ! number of cations in electroly
1165 REAL v2(ncat,nan)
1166 ! number of anions in electrolyt
1167 DATA zp/1.0, 1.0/
1168 DATA zm/2.0, 1.0, 1.0/
1169 DATA xmsg/' '/
1170 DATA pname/'ACTCOF'/
1172 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1174 ! *** (1,1);(1,3) - Clegg & Brimblecombe (1988)
1175 ! *** (2,3) - Pilinis & Seinfeld (1987), cgama different
1176 ! *** (1,2) - Clegg & Brimblecombe (1990)
1177 ! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992)
1179 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1181 DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 / ! 2H+SO4
1182 DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 / ! HNO3
1183 DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 / ! H+HSO4
1184 DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/,cgama(2,1)/ -1.2683E-3/ ! (NH4)2
1185 DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/,cgama(2,2)/3.51217E-5/ ! NH4NO3
1186 DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 /
1187 ! NH4HSO
1188 DATA v1(1,1), v2(1,1)/2.0, 1.0/ ! 2H+SO4-
1189 DATA v1(2,1), v2(2,1)/2.0, 1.0/ ! (NH4)2SO4
1190 DATA v1(1,2), v2(1,2)/1.0, 1.0/ ! HNO3
1191 DATA v1(2,2), v2(2,2)/1.0, 1.0/ ! NH4NO3
1192 DATA v1(1,3), v2(1,3)/1.0, 1.0/ ! H+HSO4-
1193 DATA v1(2,3), v2(2,3)/1.0, 1.0/
1194 !-----------------------------------------------------------------------
1195 ! begin body of subroutine ACTCOF
1197 !...compute ionic strength
1198 ! NH4HSO4
1199 i = 0.0
1200 DO icat = 1, ncat
1201 i = i + cat(icat)*zp(icat)*zp(icat)
1202 END DO
1204 DO ian = 1, nan
1205 i = i + an(ian)*zm(ian)*zm(ian)
1206 END DO
1208 i = 0.5*i
1209 !...check for problems in the ionic strength
1210 IF (i==0.0) THEN
1211 DO ian = 1, nan
1212 DO icat = 1, ncat
1213 gama(icat,ian) = 0.0
1214 END DO
1215 END DO
1217 ! xmsg = 'Ionic strength is zero...returning zero activities'
1218 ! WRITE (6,*) xmsg
1219 RETURN
1221 ELSE IF (i<0.0) THEN
1222 ! xmsg = 'Ionic strength below zero...negative concentrations'
1223 ! CALL wrf_error_fatal ( xmsg )
1225 xmsg = 'WARNING: Ionic strength below zero (= negative ion concentrations) - setting ion concentrations to zero.'
1226 call wrf_message(xmsg)
1227 DO ian = 1, nan
1228 DO icat = 1, ncat
1229 gama(icat,ian) = 0.0
1230 END DO
1231 END DO
1232 RETURN
1234 END IF
1236 !...compute some essential expressions
1237 sri = sqrt(i)
1238 twosri = 2.0*sri
1239 twoi = 2.0*i
1240 texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1241 r = 1.0 + 0.75*i
1242 s = 1.0 + 1.5*i
1243 zot1 = 0.511*sri/(1.0+sri)
1245 !...Compute binary activity coeffs
1246 fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1247 DO icat = 1, ncat
1248 DO ian = 1, nan
1250 bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1251 )*texpv
1253 !...compute the molality of each electrolyte for given ionic strength
1255 m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1256 (1.0/(v1(icat,ian)+v2(icat,ian)))
1258 !...calculate the binary activity coefficients
1260 lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1261 ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1262 ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1263 v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1264 ian)))/2.302585093
1266 END DO
1267 END DO
1269 !...prepare variables for computing the multicomponent activity coeffs
1271 DO ian = 1, nan
1272 DO icat = 1, ncat
1273 zbar = (zp(icat)+zm(ian))*0.5
1274 zbar2 = zbar*zbar
1275 y(ian,icat) = zbar2*an(ian)/i
1276 x(icat,ian) = zbar2*cat(icat)/i
1277 END DO
1278 END DO
1280 DO ian = 1, nan
1281 f1(ian) = 0.0
1282 DO icat = 1, ncat
1283 f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1284 zot1*zp(icat)*zm(ian)*x(icat,ian)
1285 END DO
1286 END DO
1288 DO icat = 1, ncat
1289 f2(icat) = 0.0
1290 DO ian = 1, nan
1291 f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1292 zot1*zp(icat)*zm(ian)*y(ian,icat)
1293 END DO
1294 END DO
1296 !...now calculate the multicomponent activity coefficients
1298 DO ian = 1, nan
1299 DO icat = 1, ncat
1301 ta = -zot1*zp(icat)*zm(ian)
1302 tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1303 tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1304 trm = ta + tb*tc
1306 IF (trm>30.0) THEN
1307 gama(icat,ian) = 1.0E+30
1308 ! xmsg = 'Multicomponent activity coefficient is extremely large'
1309 ! WRITE (6,*) xmsg
1310 ELSE
1311 gama(icat,ian) = 10.0**trm
1312 END IF
1314 END DO
1315 END DO
1317 RETURN
1318 !ia*********************************************************************
1319 END SUBROUTINE actcof
1321 !ia
1322 !ia AEROSOL DYNAMICS DRIVER ROUTINE *
1323 !ia based on MODELS3 formulation by FZB
1324 !ia Modified by IA in November 97
1325 !ia
1326 !ia Revision history
1327 !ia When WHO WHAT
1328 !ia ---- ---- ----
1329 !ia ???? FZB BEGIN
1330 !ia 05/97 IA Adapted for use in CTM2-S
1331 !ia 11/97 IA Modified for new model version
1332 !ia see comments under iarev02
1333 !ia
1334 !ia Called BY: RPMMOD3
1335 !ia
1336 !ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1337 !ia GETVSED
1338 !ia
1339 !ia*********************************************************************
1341 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1342 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat, &
1343 orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,epm25i, &
1344 epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1345 dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1346 kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1347 ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid,brrto)
1349 !USE module_configure, only: grid_config_rec_type
1350 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
1352 ! IMPLICIT NONE
1353 ! dimension of arrays
1354 INTEGER blksize
1355 ! number of species in CBLK
1356 INTEGER nspcsda
1357 ! actual number of cells in arrays
1358 INTEGER numcells
1359 ! number of k-level
1360 INTEGER layer
1361 ! of organic aerosol precursor
1362 INTEGER ldrog_vbs
1363 REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1365 REAL dt
1366 ! *** Meteorological information:
1368 ! synchronization time [s]
1369 REAL blkta(blksize) ! Air temperature [ K ]
1370 REAL blkprs(blksize) ! Air pressure in [ Pa ]
1371 REAL blkdens(blksize) ! Air density [ kg/ m**3 ]
1372 REAL blkrh(blksize)
1373 ! *** Chemical production rates: [ ug / m**3 s ]
1375 ! Fractional relative humidity
1376 REAL so4rat(blksize)
1377 ! sulfate gas-phase production rate
1378 ! total # of cond. vapors & SOA species
1379 INTEGER ncv
1380 INTEGER nacv
1381 !bs * organic condensable vapor production rate
1382 ! # of anthrop. cond. vapors & SOA speci
1383 REAL drog(blksize,ldrog_vbs) !bs
1384 ! *** anthropogenic organic aerosol mass production rates from aromatics
1385 ! Delta ROG conc. [ppm]
1386 REAL organt1rat(blksize)
1388 ! *** anthropogenic organic aerosol mass production rates from aromatics
1389 REAL organt2rat(blksize)
1391 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1392 REAL organt3rat(blksize)
1394 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1395 REAL organt4rat(blksize)
1397 ! *** biogenic organic aerosol production rates
1398 REAL orgbio1rat(blksize)
1400 ! *** biogenic organic aerosol production rates
1401 REAL orgbio2rat(blksize)
1403 ! *** biogenic organic aerosol production rates
1404 REAL orgbio3rat(blksize)
1406 ! *** biogenic organic aerosol production rates
1407 REAL orgbio4rat(blksize)
1409 ! *** Primary emissions rates: [ ug / m**3 s ]
1410 ! *** emissions rates for unidentified PM2.5 mass
1411 REAL epm25i(blksize) ! Aitken mode
1412 REAL epm25j(blksize)
1413 ! *** emissions rates for primary organic aerosol
1414 ! Accumululaton mode
1415 REAL eorgi(blksize) ! Aitken mode
1416 REAL eorgj(blksize)
1417 ! *** emissions rates for elemental carbon
1418 ! Accumululaton mode
1419 REAL eeci(blksize) ! Aitken mode
1420 REAL eecj(blksize)
1421 ! *** emissions rates for coarse mode particles
1422 ! Accumululaton mode
1423 REAL esoil(blksize) ! soil derived coarse aerosols
1424 REAL eseas(blksize) ! marine coarse aerosols
1425 REAL epmcoarse(blksize)
1427 ! *** OUTPUT:
1428 ! *** atmospheric properties
1429 ! anthropogenic coarse aerosols
1430 REAL xlm(blksize) ! atmospheric mean free path [ m ]
1431 REAL amu(blksize)
1432 ! *** modal diameters: [ m ]
1434 ! atmospheric dynamic viscosity [ kg
1435 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1436 REAL dgacc(blksize) ! accumulation geometric mean diamet
1437 REAL dgcor(blksize)
1439 ! *** aerosol properties:
1440 ! *** Modal mass concentrations [ ug m**3 ]
1441 ! coarse mode geometric mean diamete
1442 REAL pmassn(blksize) ! mass concentration in Aitken mode
1443 REAL pmassa(blksize) ! mass concentration in accumulation
1444 REAL pmassc(blksize)
1445 ! *** average modal particle densities [ kg/m**3 ]
1447 ! mass concentration in coarse mode
1448 REAL pdensn(blksize) ! average particle density in nuclei
1449 REAL pdensa(blksize) ! average particle density in accumu
1450 REAL pdensc(blksize)
1451 ! *** average modal Knudsen numbers
1453 ! average particle density in coarse
1454 REAL knnuc(blksize) ! nuclei mode Knudsen number
1455 REAL knacc(blksize) ! accumulation Knudsen number
1456 REAL kncor(blksize)
1457 ! *** modal condensation factors ( see comments in NUCLCOND )
1459 ! coarse mode Knudsen number
1460 REAL fconcn(blksize)
1461 REAL fconca(blksize)
1462 !bs
1463 REAL fconcn_org(blksize)
1464 REAL fconca_org(blksize)
1465 !bs
1467 ! *** Rates for secondary particle formation:
1469 ! *** production of new mass concentration [ ug/m**3 s ]
1470 REAL dmdt(blksize) ! by particle formation
1472 ! *** production of new number concentration [ number/m**3 s ]
1474 ! rate of production of new mass concen
1475 REAL dndt(blksize) ! by particle formation
1477 ! *** growth rate for third moment by condensation of precursor
1478 ! vapor on existing particles [ 3rd mom/m**3 s ]
1480 ! rate of producton of new particle num
1481 REAL cgrn3(blksize) ! Aitken mode
1482 REAL cgra3(blksize)
1483 ! *** Rates for coaglulation: [ m**3/s ]
1485 ! *** Unimodal Rates:
1487 ! Accumulation mode
1488 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1489 REAL ura00(blksize)
1491 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
1493 ! accumulation mode 0th moment self-coagulat
1494 REAL brna01(blksize)
1495 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1496 ! rate for 0th moment
1497 REAL c30(blksize) ! by intermodal c
1498 REAL brrto
1499 !
1500 ! *** other processes
1502 ! intermodal 3rd moment transfer r
1503 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
1505 ! INTEGER NN, VV ! loop indICES
1506 ! increment of concentration added to
1508 ! ////////////////////// Begin code ///////////////////////////////////
1509 ! concentration lower limit
1510 CHARACTER*16 pname
1511 PARAMETER (pname=' AEROPROC ')
1513 INTEGER unit
1514 PARAMETER (unit=20)
1515 integer igrid,jgrid,kgrid,isorop
1517 ! *** get water, ammonium and nitrate content:
1518 ! for now, don't call if temp is below -40C (humidity
1519 ! for this wrf version is already limited to 10 percent)
1520 ! if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. do_isorropia )then
1521 ! CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1522 if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 )then
1523 CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1524 endif
1525 ! if ( do_n2o5het ) then
1526 ! CALL n2o5het(blksize,nspcsda,numcells,dt,cblk,blkta,blkrh,dgnuc,dgacc,dgcor,igrid,jgrid,kgrid)
1527 ! endif
1528 !liqy-20140709
1530 ! isorop=0
1532 ! *** get water, ammonium and nitrate content:
1533 ! for now, don't call if temp is below -40C (humidity
1534 ! for this wrf version is already limited to 10 percent)
1536 ! if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then
1537 ! CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
1538 ! else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then
1539 ! CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1540 ! endif
1542 ! *** get size distribution information:
1544 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1545 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1546 kncor)
1548 ! *** Calculate coagulation rates for fine particles:
1550 CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1551 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1553 ! *** get condensation and particle formation (nucleation) rates:
1555 CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1556 so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
1557 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
1558 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
1560 ! *** advance forward in time DT seconds:
1561 CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,organt1rat, &
1562 organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1563 orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1564 dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1565 dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1567 ! *** get new distribution information:
1568 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1569 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1570 kncor)
1572 RETURN
1573 END SUBROUTINE aeroproc
1574 !//////////////////////////////////////////////////////////////////
1575 !//////////////////////////////////////////////////////////////////
1577 ! *** Time stepping code advances the aerosol moments one timestep;
1578 SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat &
1579 ,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat &
1580 ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1581 ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn &
1582 ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1583 igrid,jgrid,kgrid)
1585 ! *** DESCRIPTION: Integrate the Number and Mass equations
1586 ! for each mode over the time interval DT.
1587 ! PRECONDITIONS:
1588 ! AEROSTEP() must follow calls to all other dynamics routines.
1590 ! *** Revision history:
1591 ! Adapted 3/95 by UAS and CJC from EAM2's code.
1592 ! Revised 7/29/96 by FSB to use block structure
1593 ! Revised 11/15/96 by FSB dropped flow-through and cast
1594 ! number solver into Riccati equation form.
1595 ! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mode
1596 ! each predicted rather than total mass and
1597 ! Aitken mode mass. Also used a local approximation
1598 ! the error function. Also added coarse mode.
1599 ! Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1600 ! accumulation mode by coagulation
1601 ! Revised 10/27/97 by FSB to modify code to use primay emissions
1602 ! and to correct 3rd moment updates.
1603 ! Also added coarse mode.
1604 ! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1605 ! Revised 11/5/97 by FSB to fix error in MSTRNSFR
1606 ! Revised 11/6/97 FSB to correct the expression for FACTRANS to
1607 ! remove the 6/pi coefficient. UAS found this.
1608 ! Revised 12/15/97 by FSB to change equations for mass concentratin
1609 ! to a chemical production form with analytic
1610 ! solutions for the Aitken mode and to remove
1611 ! time stepping of the 3rd moments. The mass concentration
1612 ! in the accumulation mode is updated with a forward
1613 ! Eulerian step.
1614 ! Revised 1/6/98 by FSB Lowered minimum concentration for
1615 ! sulfate aerosol to 0.1 [ ng / m**3 ].
1616 ! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represents
1617 ! intermodal transfer rate of 3rd moment in place
1618 ! of 3rd moment coagulation rate.
1619 ! Revised 5/5/98 added new renaming criterion based on diameters
1620 ! Added 3/23/98 by BS condensational groth factors for organics
1622 !**********************************************************************
1623 ! IMPLICIT NONE
1625 ! *** ARGUMENTS:
1627 ! dimension of arrays
1628 INTEGER blksize
1629 ! actual number of cells in arrays
1630 INTEGER numcells
1631 ! nmber of species in CBLK
1632 INTEGER nspcsda
1633 ! model layer
1634 INTEGER layer
1635 REAL cblk(blksize,nspcsda) ! main array of variables
1636 INTEGER igrid,jgrid,kgrid
1637 REAL dt
1638 ! *** Chemical production rates: [ ug / m**3 s ]
1640 ! time step [sec]
1641 REAL so4rat(blksize) ! sulfate gas-phase production rate
1643 ! anthropogenic organic aerosol mass production rates
1644 REAL organt1rat(blksize)
1645 REAL organt2rat(blksize)
1646 REAL organt3rat(blksize)
1647 REAL organt4rat(blksize)
1649 ! biogenic organic aerosol production rates
1650 REAL orgbio1rat(blksize)
1651 REAL orgbio2rat(blksize)
1652 REAL orgbio3rat(blksize)
1653 REAL orgbio4rat(blksize)
1655 ! *** Primary emissions rates: [ ug / m**3 s ]
1656 ! *** emissions rates for unidentified PM2.5 mass
1657 REAL epm25i(blksize) ! Aitken mode
1658 REAL epm25j(blksize)
1659 ! *** emissions rates for primary organic aerosol
1660 ! Accumululaton mode
1661 REAL eorgi(blksize) ! Aitken mode
1662 REAL eorgj(blksize)
1663 ! *** emissions rates for elemental carbon
1664 ! Accumululaton mode
1665 REAL eeci(blksize) ! Aitken mode
1666 REAL eecj(blksize)
1667 ! *** emissions rates for coarse mode particles
1668 ! Accumululaton mode
1669 REAL esoil(blksize) ! soil derived coarse aerosols
1670 REAL eseas(blksize) ! marine coarse aerosols
1671 REAL epmcoarse(blksize)
1672 ! anthropogenic coarse aerosols
1673 REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1674 REAL dgacc(blksize)
1675 ! accumulation
1676 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
1677 ! reciprocal condensation rate
1678 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
1679 ! reciprocal condensation rate
1680 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
1681 ! reciprocal condensation rate for organ
1682 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
1683 ! reciprocal condensation rate for organ
1684 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
1685 ! rate of production of new mass concent
1686 REAL dndt(blksize) ! by particle formation [ number/m**3 /s
1687 ! rate of producton of new particle numb
1688 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
1689 ! increment of concentration added to
1690 REAL urn00(blksize) ! Aitken intramodal coagulation rate
1691 REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1692 REAL brna01(blksize) ! bimodal coagulation rate for number
1693 REAL c30(blksize) ! by intermodal coagulation
1694 ! intermodal 3rd moment transfer rate by
1695 REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1696 REAL cgra3(blksize)
1697 ! *** Modal mass concentrations [ ug m**3 ]
1699 ! growth rate for 3rd moment for Accumul
1700 REAL pmassn(blksize) ! mass concentration in Aitken mode
1701 REAL pmassa(blksize) ! mass concentration in accumulation
1702 REAL pmassc(blksize)
1704 ! *** Local Variables
1706 ! mass concentration in coarse mode
1707 INTEGER l, lcell, spc
1708 ! ** following scratch variables are used for solvers
1710 ! *** variables needed for modal dynamics solvers:
1711 ! Loop indices
1712 REAL*8 a, b, c
1713 REAL*8 m1, m2, y0, y
1714 REAL*8 dhat, p, pexpdt, expdt
1715 REAL*8 loss, prod, pol, lossinv
1716 ! mass intermodal transfer by coagulation
1717 REAL mstrnsfr
1719 REAL factrans
1721 ! *** CODE additions for renaming
1722 REAL getaf2
1723 REAL aaa, xnum, xm3, fnum, fm3, phnum, phm3 ! Defined below
1724 REAL erf, & ! Error and complementary error function
1725 erfc
1727 REAL xx
1728 ! dummy argument for ERF and ERFC
1729 ! a numerical value for a minimum concentration
1731 ! *** This value is smaller than any reported tropospheric concentration
1733 ! *** Statement function given for error function. Source is
1734 ! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1735 ! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1736 ! 20:253-265. They cite Reasearch & Education Asociation (REA), (19
1737 ! Handbook of Mathematical, Scientific, and Engineering Formulas,
1738 ! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1740 erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1741 erfc(xx) = 1.0 - erf(xx)
1742 ! ::::::::::::::::::::::::::::::::::::::::
1744 ! ///// begin code
1745 ! *** set up time-step integration
1747 DO l = 1, numcells
1749 ! *** code to move number forward by one time step.
1750 ! *** solves the Ricatti equation:
1752 ! dY/dt = C - A * Y ** 2 - B * Y
1754 ! Coded 11/21/96 by Dr. Francis S. Binkowski
1756 ! *** Aitken mode:
1757 ! *** coefficients
1758 a = urn00(l)
1759 b = brna01(l)*cblk(l,vac0)
1760 c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1762 ! includes primary emissions
1763 y0 = cblk(l,vnu0)
1764 ! *** trap on C = 0
1766 ! initial condition
1767 IF (c>0.0D0) THEN
1769 dhat = sqrt(b*b+4.0D0*a*c)
1771 m1 = 2.0D0*a*c/(b+dhat)
1773 m2 = -0.5D0*(b+dhat)
1775 p = -(m1-a*y0)/(m2-a*y0)
1777 pexpdt = p*exp(-dhat*dt)
1779 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1780 ! solution
1781 ELSE
1783 ! *** rearrange solution for NUMERICAL stability
1784 ! note If B << A * Y0, the following form, although
1785 ! seemingly awkward gives the correct answer.
1787 expdt = exp(-b*dt)
1788 IF (expdt<1.0D0) THEN
1789 y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1790 ELSE
1791 y = y0
1792 END IF
1794 END IF
1795 ! if(y.lt.nummin_i)then
1796 ! print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
1797 ! print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
1798 ! print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
1799 ! endif
1801 cblk(l,vnu0) = max(nummin_i,y)
1803 ! *** now do accumulation mode number
1805 ! *** coefficients
1807 ! update
1808 a = ura00(l)
1809 b = & ! NOTE B = 0.0
1810 0.0D0
1811 c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
1812 ! includes primary emissi
1813 y0 = cblk(l,vac0)
1814 ! *** this equation requires special handling, because C can be zero.
1815 ! if this happens, the form of the equation is different:
1817 ! initial condition
1818 ! print *,vac0,y0,c,nummin_j,a
1819 IF (c>0.0D0) THEN
1821 dhat = sqrt(4.0D0*a*c)
1823 m1 = 2.0D0*a*c/dhat
1825 m2 = -0.5D0*dhat
1827 p = -(m1-a*y0)/(m2-a*y0)
1829 ! print *,p,-dhat,dt,-dhat*dt
1830 ! print *,exp(-dhat*dt)
1831 pexpdt = p*exp(-dhat*dt)
1833 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1834 ! solution
1835 ELSE
1837 y = y0/(1.0D0+dt*a*y0)
1838 ! print *,dhat,y0,dt,a
1839 y = y0/(1.+dt*a*y0)
1840 ! print *,y
1841 ! correct solution to equation
1842 END IF
1844 cblk(l,vac0) = max(nummin_j,y)
1845 ! *** now do coarse mode number neglecting coagulation
1846 ! update
1847 ! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
1848 prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
1850 ! print *,cblk(l,vcorn),factnumc,prod
1851 cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
1853 ! *** Prepare to advance modal mass concentration one time step.
1855 ! *** Set up production and and intermodal transfer terms terms:
1856 ! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
1857 cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
1859 ! includes growth from pri
1860 cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
1861 orgfac*eorgj(l) ! and transfer of 3rd momen
1862 ! intermodal coagulation
1864 ! *** set up transfer coefficients for coagulation between Aitken and ac
1867 ! *** set up special factors for mass transfer from the Aitken to accumulation
1868 ! intermodal coagulation. The mass transfer rate is proportional to
1869 ! transfer rate, C30. The proportionality factor is p/6 times the the
1870 ! density. The average particle density for a species is the species
1871 ! divided by the particle volume concentration, pi/6 times the 3rd m
1872 ! The p/6 coefficients cancel.
1874 ! includes growth from prim
1875 ! print *,'loss',vnu3,c30(l),cblk(l,vnu3)
1876 loss = c30(l)/cblk(l,vnu3)
1878 ! Normalized coagulation transfer r
1879 factrans = loss*dt ! yields an estimate of the amount of mass t
1880 ! the Aitken to the accumulation mode in the
1882 ! Multiplying this factor by the species con
1883 ! print *,'factrans = ',factrans,loss
1884 expdt = exp(-factrans) ! decay term is common to all Aitken mode
1885 ! print *,'factrans = ',factrans,loss,expdt
1886 ! variable name is re-used here. This expo
1887 lossinv = 1.0/loss
1888 ! *** now advance mass concentrations one time step.
1890 ! *** update sulfuric acid vapor concentration by removing mass concent
1891 ! condensed sulfate and newly produced particles.
1892 ! *** The method follows Youngblood and Kreidenweis, Further Development
1893 ! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
1894 ! Atmospheric Science Paper Number 550, April,1994, pp 85-89.
1895 ! set up for multiplication rather than divi
1896 cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
1898 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
1899 ! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
1901 ! *** sulfate:
1902 mstrnsfr = cblk(l,vso4ai)*factrans
1903 prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
1904 pol = prod*lossinv
1905 ! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
1907 cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
1908 cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
1909 cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
1911 ! *** anthropogenic secondary organic:
1912 !bs * anthropogenic secondary organics from aromatic precursors
1913 !!! anthropogenic secondary organics from different precursors
1914 !!! the formulas are the same as in BS's version, only precursors and partition are different!
1916 mstrnsfr = cblk(l,vasoa1i)*factrans
1917 prod = organt1rat(l)*fconcn_org(l)
1918 pol = prod*lossinv
1920 cblk(l,vasoa1i) = pol + (cblk(l,vasoa1i)-pol)*expdt
1921 cblk(l,vasoa1i) = max(conmin,cblk(l,vasoa1i))
1922 cblk(l,vasoa1j) = cblk(l,vasoa1j) + organt1rat(l)*fconca_org(l)*dt + mstrnsfr
1923 !!!!!!!!!!!!!
1925 mstrnsfr = cblk(l,vasoa2i)*factrans
1926 prod = organt2rat(l)*fconcn_org(l)
1927 pol = prod*lossinv
1929 cblk(l,vasoa2i) = pol + (cblk(l,vasoa2i)-pol)*expdt
1930 cblk(l,vasoa2i) = max(conmin,cblk(l,vasoa2i))
1931 cblk(l,vasoa2j) = cblk(l,vasoa2j) + organt2rat(l)*fconca_org(l)*dt + mstrnsfr
1932 !!!!!!!!!!!!!
1934 mstrnsfr = cblk(l,vasoa3i)*factrans
1935 prod = organt3rat(l)*fconcn_org(l)
1936 pol = prod*lossinv
1938 cblk(l,vasoa3i) = pol + (cblk(l,vasoa3i)-pol)*expdt
1939 cblk(l,vasoa3i) = max(conmin,cblk(l,vasoa3i))
1940 cblk(l,vasoa3j) = cblk(l,vasoa3j) + organt3rat(l)*fconca_org(l)*dt + mstrnsfr
1941 !!!!!!!!!!!!!
1943 mstrnsfr = cblk(l,vasoa4i)*factrans
1944 prod = organt4rat(l)*fconcn_org(l)
1945 pol = prod*lossinv
1947 cblk(l,vasoa4i) = pol + (cblk(l,vasoa4i)-pol)*expdt
1948 cblk(l,vasoa4i) = max(conmin,cblk(l,vasoa4i))
1949 cblk(l,vasoa4j) = cblk(l,vasoa4j) + organt4rat(l)*fconca_org(l)*dt + mstrnsfr
1951 ! *** biogenic secondary organic
1952 mstrnsfr = cblk(l,vbsoa1i)*factrans
1953 prod = orgbio1rat(l)*fconcn_org(l)
1954 pol = prod*lossinv
1956 cblk(l,vbsoa1i) = pol + (cblk(l,vbsoa1i)-pol)*expdt
1957 cblk(l,vbsoa1i) = max(conmin,cblk(l,vbsoa1i))
1958 cblk(l,vbsoa1j) = cblk(l,vbsoa1j) + orgbio1rat(l)*fconca_org(l)*dt + mstrnsfr
1959 !!!!!!!!!!!!!
1961 mstrnsfr = cblk(l,vbsoa2i)*factrans
1962 prod = orgbio2rat(l)*fconcn_org(l)
1963 pol = prod*lossinv
1965 cblk(l,vbsoa2i) = pol + (cblk(l,vbsoa2i)-pol)*expdt
1966 cblk(l,vbsoa2i) = max(conmin,cblk(l,vbsoa2i))
1967 cblk(l,vbsoa2j) = cblk(l,vbsoa2j) + orgbio2rat(l)*fconca_org(l)*dt + mstrnsfr
1968 !!!!!!!!!!!!!
1970 mstrnsfr = cblk(l,vbsoa3i)*factrans
1971 prod = orgbio3rat(l)*fconcn_org(l)
1972 pol = prod*lossinv
1974 cblk(l,vbsoa3i) = pol + (cblk(l,vbsoa3i)-pol)*expdt
1975 cblk(l,vbsoa3i) = max(conmin,cblk(l,vbsoa3i))
1976 cblk(l,vbsoa3j) = cblk(l,vbsoa3j) + orgbio3rat(l)*fconca_org(l)*dt + mstrnsfr
1977 !!!!!!!!!!!!!
1979 mstrnsfr = cblk(l,vbsoa4i)*factrans
1980 prod = orgbio4rat(l)*fconcn_org(l)
1981 pol = prod*lossinv
1983 cblk(l,vbsoa4i) = pol + (cblk(l,vbsoa4i)-pol)*expdt
1984 cblk(l,vbsoa4i) = max(conmin,cblk(l,vbsoa4i))
1985 cblk(l,vbsoa4j) = cblk(l,vbsoa4j) + orgbio4rat(l)*fconca_org(l)*dt + mstrnsfr
1987 ! *** primary anthropogenic organic
1988 mstrnsfr = cblk(l,vorgpai)*factrans
1989 prod = eorgi(l)
1990 pol = prod*lossinv
1992 cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
1993 cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
1994 cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
1996 ! *** other anthropogenic PM2.5
1997 mstrnsfr = cblk(l,vp25ai)*factrans
1998 prod = epm25i(l)
1999 pol = prod*lossinv
2001 cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
2002 cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
2003 cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
2005 ! *** elemental carbon
2006 mstrnsfr = cblk(l,veci)*factrans
2007 prod = eeci(l)
2008 pol = prod*lossinv
2010 cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
2011 cblk(l,veci) = max(conmin,cblk(l,veci))
2012 cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
2014 ! *** coarse mode
2015 ! *** soil dust
2016 cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
2017 cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
2019 ! *** sea salt
2020 cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
2021 cblk(l,vseas) = max(conmin,cblk(l,vseas))
2023 ! *** anthropogenic PM10 coarse fraction
2024 cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
2025 cblk(l,vantha) = max(conmin,cblk(l,vantha))
2027 END DO
2030 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
2031 ! then merge modes by renaming.
2033 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
2035 ! end of time-step loop for total mass
2036 DO lcell = 1, numcells
2038 ! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
2039 ! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
2040 IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
2041 lcell,vnu0)>cblk(lcell,vac0)) &
2042 THEN
2044 ! check if mer
2045 aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
2046 dgacc(lcell),xxlsgn,xxlsga,sqrt2)
2048 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2049 ! dd is the diameter at which the Aitken-mode and accumulation-mo
2050 ! distributions intersect (overap).
2052 xnum = max(aaa,xxm3) ! this means that no more than one ha
2053 ! total Aitken mode number may be tra per call.
2055 ! do not let XNUM become negative bec
2056 xm3 = xnum - &
2057 xxm3
2058 ! set up for 3rd moment and mass tran
2059 IF (xm3>0.0) &
2060 THEN
2061 ! do mode merging if overlap is corr
2062 phnum = 0.5*(1.0+erf(xnum))
2063 phm3 = 0.5*(1.0+erf(xm3))
2064 fnum = 0.5*erfc(xnum)
2065 fm3 = 0.5*erfc(xm3)
2067 ! In the Aitken mode:
2069 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2070 ! distributions with diameters greater than dd respectively.
2072 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2073 ! distributions with diameters less than dd.
2075 ! *** rename the Aitken mode particle number as accumulation mode
2076 ! particle number
2078 cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2080 ! *** adjust the Aitken mode number
2082 cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2084 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2085 ! to the accumulation mode is proportional to the amount of 3rd mome
2086 ! transferred, therefore FM3 is used for mass transfer.
2088 cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2090 cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2092 cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2094 !liqy
2095 cblk(lcell,vnaaj) = cblk(lcell,vnaaj) + cblk(lcell,vnaai)*fm3
2096 cblk(lcell,vclaj) = cblk(lcell,vclaj) + cblk(lcell,vclai)*fm3
2097 !liqy-20140617
2099 cblk(lcell,vasoa1j) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)*fm3
2101 cblk(lcell,vasoa2j) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)*fm3
2103 cblk(lcell,vasoa3j) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)*fm3
2105 cblk(lcell,vasoa4j) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)*fm3
2107 cblk(lcell,vbsoa1j) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)*fm3
2109 cblk(lcell,vbsoa2j) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)*fm3
2111 cblk(lcell,vbsoa3j) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)*fm3
2113 cblk(lcell,vbsoa4j) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)*fm3
2115 cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + cblk(lcell,vorgpai)*fm3
2117 cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2119 cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2121 ! *** update Aitken mode for mass loss to accumulation mode
2122 cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2124 cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2126 cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2127 !liqy
2128 cblk(lcell,vnaai) = cblk(lcell,vnaai)*phm3
2129 cblk(lcell,vclai) = cblk(lcell,vclai)*phm3
2130 !liqy-20140617
2132 cblk(lcell,vasoa1i) = cblk(lcell,vasoa1i)*phm3
2134 cblk(lcell,vasoa2i) = cblk(lcell,vasoa2i)*phm3
2136 cblk(lcell,vasoa3i) = cblk(lcell,vasoa3i)*phm3
2138 cblk(lcell,vasoa4i) = cblk(lcell,vasoa4i)*phm3
2140 cblk(lcell,vbsoa1i) = cblk(lcell,vbsoa1i)*phm3
2142 cblk(lcell,vbsoa2i) = cblk(lcell,vbsoa2i)*phm3
2144 cblk(lcell,vbsoa3i) = cblk(lcell,vbsoa3i)*phm3
2146 cblk(lcell,vbsoa4i) = cblk(lcell,vbsoa4i)*phm3
2148 cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2150 cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2152 cblk(lcell,veci) = cblk(lcell,veci)*phm3
2154 END IF
2155 ! end check on whether modal overlap is OK
2157 END IF
2158 ! end check on necessity for merging
2160 END DO
2161 ! set min value for all concentrations
2163 ! loop for merging
2164 DO spc = 1, nspcsda
2165 DO lcell = 1, numcells
2166 cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2167 END DO
2168 END DO
2169 !---------------------------------------------------------------------------------
2171 RETURN
2172 END SUBROUTINE aerostep
2173 !#######################################################################
2175 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2176 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2177 ! mso4,mnh4,mno3 are in microMOLES / cubic meter
2179 ! This version uses polynomials rather than tables, and uses empirical
2180 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2181 ! where:
2183 ! mfs = ms / ( ms + mw)
2184 ! ms is the mass of solute
2185 ! mw is the mass of water.
2187 ! Define y = mw/ ms
2189 ! then mfs = 1 / (1 + y)
2191 ! y can then be obtained from the values of mfs as
2193 ! y = (1 - mfs) / mfs
2196 ! the aerosol is assumed to be in a metastable state if the rh is
2197 ! is below the rh of deliquescence, but above the rh of crystallizat
2199 ! ZSR interpolation is used for sulfates with x ( the molar ratio of
2200 ! ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2201 ! section 1: 0 <= x < 1
2202 ! section 2: 1 <= x < 1.5
2203 ! section 3: 1.5 <= x < 2.0
2204 ! section 4: 2 <= x
2205 ! In sections 1 through 3, only the sulfates can affect the amount o
2206 ! on the particles.
2207 ! In section 4, we have fully neutralized sulfate, and extra ammoniu
2208 ! allows more nitrate to be present. Thus, the ammount of water is c
2209 ! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2210 ! assumed to occur in sections 2,3,and 4. See detailed discussion be
2212 ! definitions:
2213 ! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2214 ! for sulfate, ammonium, and nitrate respectively
2215 ! irhx is the relative humidity (%)
2216 ! wh2o is the returned water amount in micrograms / cubic meter of a
2217 ! x is the molar ratio of ammonium to sulfate
2218 ! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2219 ! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2220 ! y3 is the value of the mass ratio of water to solute for
2221 ! a pure ammonium nitrate solution.
2223 !coded by Dr. Francis S. Binkowski, 4/8/96.
2225 ! IMPLICIT NONE
2226 INTEGER irhx, irh
2227 REAL mso4, mnh4, mno3
2228 REAL tso4, tnh4, tno3, wh2o, x
2229 REAL aw, awc
2230 ! REAL poly4, poly6
2231 REAL mfs0, mfs1, mfs15, mfs2
2232 REAL c0(4), c1(4), c15(4), c2(4)
2233 REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2234 REAL kso4(6), kno3(6), mfsso4, mfsno3
2235 REAL mwso4, mwnh4, mwno3, mw2, mwano3
2237 ! *** molecular weights:
2238 PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2239 mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2241 ! The polynomials use data for aw as a function of mfs from Tang and
2242 ! Munkelwitz, JGR 99: 18801-18808, 1994.
2243 ! The polynomials were fit to Tang's values of water activity as a
2244 ! function of mfs.
2246 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2247 ! now give mfs as a function of water activity.
2249 DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2250 DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2251 DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2253 ! *** the following coefficients are a fit to the data in Table 1 of
2254 ! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2255 ! data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2256 ! *** New data fit to data from
2257 ! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2258 ! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2259 ! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2260 DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2262 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2263 ! Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2265 DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2266 DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2268 ! *** check range of per cent relative humidity
2269 irh = irhx
2270 irh = max(1,irh)
2271 irh = min(irh,100)
2272 aw = float(irh)/ & ! water activity = fractional relative h
2273 100.0
2274 tso4 = max(mso4,0.0)
2275 tnh4 = max(mnh4,0.0)
2276 tno3 = max(mno3,0.0)
2277 x = 0.0
2278 ! *** if there is non-zero sulfate calculate the molar ratio
2279 IF (tso4>0.0) THEN
2280 x = tnh4/tso4
2281 ELSE
2282 ! *** otherwise check for non-zero nitrate and ammonium
2283 IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2284 END IF
2286 ! *** begin screen on x for calculating wh2o
2287 IF (x<1.0) THEN
2289 mfs0 = poly4(c0,aw)
2290 mfs1 = poly4(c1,aw)
2291 y0 = (1.0-mfs0)/mfs0
2292 y1 = (1.0-mfs1)/mfs1
2293 y = (1.0-x)*y0 + x*y1
2295 ELSE IF (x<1.5) THEN
2297 IF (irh>=40) THEN
2298 mfs1 = poly4(c1,aw)
2299 mfs15 = poly4(c15,aw)
2300 y1 = (1.0-mfs1)/mfs1
2301 y15 = (1.0-mfs15)/mfs15
2302 y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2303 ELSE
2304 ! *** set up for crystalization
2306 ! *** Crystallization is done as follows:
2307 ! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2308 ! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2309 ! and since the code does not allow ar rh < 0.01, crystallization
2310 ! is assumed not to occur in this range.
2311 ! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2312 ! from a value of y15 at rh = 0.4 to a value of zero at y1. From
2313 ! point B to point A in the diagram.
2314 ! The algorithm does a double interpolation to calculate the amount
2315 ! water.
2317 ! y1(0.40) y15(0.40)
2318 ! + + Point B
2320 ! +--------------------+
2321 ! x=1 x=1.5
2322 ! Point A
2324 awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2325 y = 0.0
2326 IF (aw>=awc) & ! interpolate using crystalization
2327 THEN
2328 mfs1 = poly4(c1,0.40)
2329 mfs15 = poly4(c15,0.40)
2330 y140 = (1.0-mfs1)/mfs1
2331 y1540 = (1.0-mfs15)/mfs15
2332 y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2333 yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2334 y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2335 ! end of checking for aw
2336 END IF
2338 END IF
2339 ! end of checking on irh
2340 ELSE IF (x<1.9999) THEN
2342 y = 0.0
2343 IF (irh>=40) THEN
2344 mfs15 = poly4(c15,aw)
2345 mfs2 = poly4(c2,aw)
2346 y15 = (1.0-mfs15)/mfs15
2347 y2 = (1.0-mfs2)/mfs2
2348 y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2350 END IF
2352 ! end of check for crystallization
2354 ELSE
2355 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2357 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2358 ! *** check for crystallization here. their data indicate a 40% value
2359 ! is appropriate.
2360 ! 1.9999 < x
2361 y2 = 0.0
2362 y3 = 0.0
2363 IF (irh>=40) THEN
2364 mfsso4 = poly6(kso4,aw)
2365 mfsno3 = poly6(kno3,aw)
2366 y2 = (1.0-mfsso4)/mfsso4
2367 y3 = (1.0-mfsno3)/mfsno3
2369 END IF
2371 END IF
2372 ! *** now set up output of wh2o
2374 ! wh2o units are micrograms (liquid water) / cubic meter of air
2376 ! end of checking on x
2377 IF (x<1.9999) THEN
2379 wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2381 ELSE
2383 ! *** this is the case that all the sulfate is ammonium sulfate
2384 ! and the excess ammonium forms ammonum nitrate
2386 wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2388 END IF
2390 RETURN
2391 END SUBROUTINE awater
2392 !//////////////////////////////////////////////////////////////////////
2394 SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2395 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2396 !***********************************************************************
2397 !** DESCRIPTION: calculates aerosol coagulation rates for unimodal
2398 ! and bimodal coagulation using E. Whitby 1990's prescription.
2400 !....... Rates for coaglulation:
2401 !....... Unimodal Rates:
2402 !....... URN00: nuclei mode 0th moment self-coagulation rate
2403 !....... URA00: accumulation mode 0th moment self-coagulation rate
2405 !....... Bimodal Rates: (only 1st order coeffs appear)
2406 !....... NA-- nuclei with accumulation coagulation rates,
2407 !....... AN-- accumulation with nuclei coagulation rates
2408 !....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term)
2409 !....... BRNA31: 3rd ( d(nuclei mode 3) / dt term)
2410 !** Revision history:
2411 ! prototype 1/95 by Uma and Carlie
2412 ! Revised 8/95 by US for calculation of density from stmt func
2413 ! and collect met variable stmt funcs in one include fil
2414 ! REVISED 7/25/96 by FSB to use block structure
2415 ! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2416 ! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2417 ! changed. All coagulation coefficients
2418 ! returned with positive signs. Their
2419 ! linearization is also abandoned.
2420 ! Fixed values are used for the corrections
2421 ! to the free-molecular coagulation integra
2422 ! The code forces the harmonic means to be
2423 ! evaluated in 64 bit arithmetic on 32 bit
2424 ! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit
2426 ! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa
2427 ! because BRNA31 can become zero on a works
2428 ! because of limited precision. With the ch
2429 ! aerostep to omit update of the 3rd moment
2430 ! C30 is the only variable now needed.
2431 ! the logic using ONE88 to force REAL*8 ari
2432 ! has been removed and all intermediates ar
2433 ! REAL*8.
2434 ! IMPLICIT NONE
2436 ! dimension of arrays
2437 INTEGER blksize
2438 ! actual number of cells in arrays
2439 INTEGER numcells
2441 INTEGER nspcsda
2443 ! nmber of species in CBLK
2444 REAL cblk(blksize,nspcsda) ! main array of variables
2445 REAL blkta(blksize) ! Air temperature [ K ]
2446 REAL pdensn(blksize) ! average particel density in Aitk
2447 REAL pdensa(blksize) ! average particel density in accu
2448 REAL amu(blksize) ! atmospheric dynamic viscosity [
2449 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2450 REAL dgacc(blksize) ! accumulation mode mean diameter
2451 REAL knnuc(blksize) ! Aitken mode Knudsen number
2452 REAL knacc(blksize)
2453 ! *** output:
2455 ! accumulation mode Knudsen number
2456 REAL urn00(blksize) ! intramodal coagulation rate (Ait
2457 REAL ura00(blksize)
2458 ! intramodal coagulation rate (acc
2459 REAL brna01(blksize) ! intermodal coagulaton rate (numb
2460 REAL c30(blksize) ! by inter
2462 ! *** Local variables:
2463 ! intermodal 3rd moment transfer r
2464 REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2465 kncacc
2466 REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2467 kfmacc
2468 REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2469 kfm
2470 REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2471 bencna
2472 REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2473 bencm3n
2474 REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2475 befmna
2476 REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2477 befm3n
2478 REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2479 betana
2480 REAL*8 & ! intermodal coagulation rate for 3rd mo
2481 brna31
2482 REAL*8 & ! scratch subexpression
2483 s1
2484 REAL*8 t1, & ! scratch subexpressions
2485 t2
2486 REAL*8 t16, & ! T1**6, T2**6
2487 t26
2488 REAL*8 rat, & ! ratio of acc to nuc size and its inver
2489 rin
2490 REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2491 rsq4
2492 REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2493 rsqi3
2494 REAL*8 & ! dgnuc**3
2495 dgn3
2496 REAL*8 & ! in 64 bit arithmetic
2497 dga3
2498 ! dgacc**3
2500 INTEGER lcell
2501 ! *** Fixed values for correctionss to coagulation
2502 ! integrals for free-molecular case.
2503 ! loop counter
2504 REAL*8 bm0
2505 PARAMETER (bm0=0.8D0)
2506 REAL*8 bm0i
2507 PARAMETER (bm0i=0.9D0)
2508 REAL*8 bm3i
2509 PARAMETER (bm3i=0.9D0)
2510 REAL*8 & ! approx Cunningham corr. factor
2511 a
2512 PARAMETER (a=1.246D0)
2513 !.......................................................................
2514 ! begin body of subroutine COAGRATE
2516 !........... Main computational grid-traversal loops
2517 !........... for computing coagulation rates.
2519 ! *** Both modes have fixed std devs.
2520 DO lcell = 1, &
2521 numcells
2522 ! *** moment independent factors
2524 ! loop on LCELL
2525 s1 = two3*boltz*blkta(lcell)/amu(lcell)
2527 ! For unimodal coagualtion:
2529 kncnuc = s1
2530 kncacc = s1
2532 kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2533 kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2535 ! For bimodal coagulation:
2537 knc = s1
2538 kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2540 !........... Begin unimodal coagulation rate calculations:
2541 !........... Near-continuum regime.
2543 dgn3 = dgnuc(lcell)**3
2544 dga3 = dgacc(lcell)**3
2546 t1 = sqrt(dgnuc(lcell))
2547 t2 = sqrt(dgacc(lcell))
2548 t16 = & ! = T1**6
2549 dgn3
2550 t26 = &
2551 dga3
2552 !....... Note rationalization of fractions and subsequent cancellation
2553 !....... from the formulation in Whitby et al. (1990)
2555 ! = T2**6
2556 bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2558 bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2560 !........... Free molecular regime. Uses fixed value for correction
2561 ! factor BM0
2563 befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2564 befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2566 !........... Calculate half the harmonic mean between unimodal rates
2567 !........... free molecular and near-continuum regimes
2569 ! FSB 64 bit evaluation
2571 betann = bencnn*befmnn/(bencnn+befmnn)
2572 betana = bencna*befmna/(bencna+befmna)
2574 urn00(lcell) = betann
2575 ura00(lcell) = betana
2577 ! *** End of unimodal coagulation calculations.
2579 !........... Begin bimodal coagulation rate calculations:
2581 rat = dgacc(lcell)/dgnuc(lcell)
2582 rin = 1.0D0/rat
2583 rsqt = sqrt(rat)
2584 rsq4 = rat**2
2586 rsqti = 1.0D0/rsqt
2587 rsqi3 = rin*rsqti
2589 !........... Near-continuum coeffs:
2590 !........... 0th moment nuc mode bimodal coag coefficient
2592 bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2593 )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2595 !........... 3rd moment nuc mode bimodal coag coefficient
2597 bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2598 *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2599 rin*esn64*esa04)
2601 !........... Free molecular regime coefficients:
2602 !........... Uses fixed value for correction
2603 ! factor BM0I, BM3I
2604 !........... 0th moment nuc mode coeff
2606 befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2607 rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2609 !........... 3rd moment nuc mode coeff
2611 befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2612 rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2615 !........... Calculate half the harmonic mean between bimodal rates
2616 !........... free molecular and near-continuum regimes
2618 ! FSB Force 64 bit evaluation
2620 brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2622 brna31 = bencm3n* & ! BRNA31 now is a scala
2623 befm3n/(bencm3n+befm3n)
2624 c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2625 ! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2626 ! 3d moment transfer by intermodal coagula
2627 ! End bimodal coagulation rate.
2629 END DO
2630 ! end of main lop over cells
2631 RETURN
2632 END SUBROUTINE coagrate
2633 !------------------------------------------------------------------
2635 ! subroutine to find the roots of a cubic equation / 3rd order polynomi
2636 ! formulae can be found in numer. recip. on page 145
2637 ! kiran developed this version on 25/4/1990
2638 ! dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2639 ! ***
2640 !234567
2641 ! coagrate
2642 SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2643 ! IMPLICIT NONE
2644 INTEGER nr
2645 REAL*8 a2, a1, a0
2646 REAL crutes(3)
2647 REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2648 REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2649 REAL*8 costh, sinth
2650 DATA sqrt3/1.732050808/, one3rd/0.333333333/
2651 !bs
2652 REAL*8 onebs
2653 PARAMETER (onebs=1.0)
2654 !bs
2655 a2sq = a2*a2
2656 qq = (a2sq-3.*a1)/9.
2657 rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2658 ! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT
2659 dum1 = qq*qq*qq
2660 rrsq = rr*rr
2661 dum2 = dum1 - rrsq
2662 IF (dum2>=0.) THEN
2663 ! NOW WE HAVE THREE REAL ROOTS
2664 phi = sqrt(dum1)
2665 IF (abs(phi)<1.E-20) THEN
2666 print *, ' cubic phi small, phi = ',phi
2667 crutes(1) = 0.0
2668 crutes(2) = 0.0
2669 crutes(3) = 0.0
2670 nr = 0
2671 CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2672 END IF
2673 theta = acos(rr/phi)/3.0
2674 costh = cos(theta)
2675 sinth = sin(theta)
2676 ! *** use trig identities to simplify the expressions
2677 ! *** binkowski's modification
2678 part1 = sqrt(qq)
2679 yy1 = part1*costh
2680 yy2 = yy1 - a2/3.0
2681 yy3 = sqrt3*part1*sinth
2682 crutes(3) = -2.0*yy1 - a2/3.0
2683 crutes(2) = yy2 + yy3
2684 crutes(1) = yy2 - yy3
2685 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2686 IF (crutes(1)<0.0) crutes(1) = 1.0E9
2687 IF (crutes(2)<0.0) crutes(2) = 1.0E9
2688 IF (crutes(3)<0.0) crutes(3) = 1.0E9
2689 ! *** put smallest positive root in crutes(1)
2690 crutes(1) = min(crutes(1),crutes(2),crutes(3))
2691 nr = 3
2692 ! NOW HERE WE HAVE ONLY ONE REAL ROOT
2693 ELSE
2694 ! dum IS NEGATIVE
2695 part1 = sqrt(rrsq-dum1)
2696 part2 = abs(rr)
2697 part3 = (part1+part2)**one3rd
2698 crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2699 !bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2700 crutes(2) = 0.
2701 crutes(3) = 0.
2702 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2703 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2704 ! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2705 nr = 1
2706 END IF
2707 RETURN
2708 END SUBROUTINE cubic
2709 !///////////////////////////////////////////////////////////////////////
2712 SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
2713 !***********************************************************************
2714 !** DESCRIPTION:
2715 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2716 ! and water between the gas and aerosol phases as the total sulfate,
2717 ! ammonia, and nitrate concentrations, relative humidity and
2718 ! temperature change. The evolution of the aerosol mass concentration
2719 ! due to the change in aerosol chemical composition is calculated.
2720 !** REVISION HISTORY:
2721 ! prototype 1/95 by Uma and Carlie
2722 ! Revised 8/95 by US to calculate air density in stmt func
2723 ! and collect met variable stmt funcs in one include fil
2724 ! Revised 7/26/96 by FSB to use block concept.
2725 ! Revise 12/1896 to do do i-mode calculation.
2726 !**********************************************************************
2727 ! IMPLICIT NONE
2729 ! dimension of arrays
2730 INTEGER blksize
2731 ! actual number of cells in arrays
2732 INTEGER numcells
2733 ! nmber of species in CBLK
2734 INTEGER nspcsda
2735 REAL cblk(blksize,nspcsda)
2736 ! *** Meteorological information in blocked arays:
2738 ! main array of variables
2739 REAL blkta(blksize) ! Air temperature [ K ]
2740 REAL blkrh(blksize)
2742 ! Fractional relative humidity
2744 INTEGER lcell
2745 ! loop counter
2746 ! air temperature
2747 REAL temp
2748 !iamodels3
2749 REAL rh
2750 ! relative humidity
2751 REAL so4, no3, nh3, nh4, hno3
2752 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2753 ! Fraction of dry sulfate mass in i-mode
2754 REAL fraci
2755 !.......................................................................
2756 REAL fracj
2757 ! Fraction of dry sulfate mass in j-mode
2758 DO lcell = 1, &
2759 numcells
2760 ! *** Fetch temperature, fractional relative humidity, and
2761 ! air density
2763 ! loop on cells
2764 temp = blkta(lcell)
2765 rh = blkrh(lcell)
2767 ! *** the following is an interim procedure. Assume the i-mode has the
2768 ! same relative mass concentrations as the total mass. Use SO4 as
2769 ! the surrogate. The results of this should be the same as those
2770 ! from the original RPM.
2772 ! *** do total aerosol
2773 so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
2775 !iamodels3
2776 no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
2777 ! & + CBLK(LCELL, VHNO3)
2779 hno3 = cblk(lcell,vhno3)
2781 !iamodels3
2783 nh3 = cblk(lcell,vnh3)
2785 nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
2786 ! & + CBLK(LCELL, VNH3)
2788 !bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
2789 !bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
2790 !bs
2791 !bs * call old version of rpmares
2792 !bs
2793 CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
2794 gnh3,gno3)
2795 !bs
2797 ! *** get modal fraction
2798 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
2799 fracj = 1.0 - fraci
2801 ! *** update do i-mode
2803 cblk(lcell,vh2oai) = fraci*ah2o
2804 cblk(lcell,vnh4ai) = fraci*anh4
2805 cblk(lcell,vno3ai) = fraci*ano3
2807 ! *** update accumulation mode:
2809 cblk(lcell,vh2oaj) = fracj*ah2o
2810 cblk(lcell,vnh4aj) = fracj*anh4
2811 cblk(lcell,vno3aj) = fracj*ano3
2814 ! *** update gas / vapor phase
2815 cblk(lcell,vnh3) = gnh3
2816 cblk(lcell,vhno3) = gno3
2818 END DO
2819 ! end loop on cells
2820 RETURN
2822 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2823 END SUBROUTINE eql4
2824 ! eql4
2826 SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
2827 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2828 !bs !
2829 !bs Description: !
2830 !bs !
2831 !bs Get the Jacobian of the function !
2832 !bs !
2833 !bs ( a1 * X1^2 + b1 * X1 + c1 ) !
2834 !bs ( a2 * X2^2 + b2 * X1 + c2 ) !
2835 !bs ( a3 * X3^2 + b3 * X1 + c3 ) !
2836 !bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. !
2837 !bs ( a5 * X5^2 + b5 * X1 + c5 ) !
2838 !bs ( a6 * X6^2 + b6 * X1 + c6 ) !
2839 !bs !
2840 !bs a_i = IMW_i !
2841 !bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i !
2842 !bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] !
2843 !bs !
2844 !bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j !
2845 !bs J_ij = ----------- = ( !
2846 !bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j !
2847 !bs !
2848 !bs !
2849 !bs Called by: NEWT !
2850 !bs !
2851 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2852 !bs
2853 ! IMPLICIT NONE
2854 !bs
2855 !bs
2856 !dimension of problem
2857 INTEGER n
2858 REAL x(n) !bs
2859 ! INTEGER NP !bs maximum expected value of N
2860 ! PARAMETER (NP = 6)
2861 !bs initial guess of CAER
2862 REAL ct(np)
2863 REAL cs(np)
2864 REAL imw(np)
2865 !bs
2866 REAL fjac(n,n)
2867 !bs
2868 INTEGER i, & !bs loop index
2869 j
2870 REAL a(np)
2871 REAL b(np)
2872 REAL b1(np)
2873 REAL b2(np)
2874 REAL sum_jnei
2875 !bs
2876 DO i = 1, n
2877 a(i) = imw(i)
2878 sum_jnei = 0.
2879 DO j = 1, n
2880 sum_jnei = sum_jnei + x(j)*imw(j)
2881 END DO
2882 b1(i) = sum_jnei - (x(i)*imw(i))
2883 b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
2884 b(i) = b1(i) + b2(i)
2885 END DO
2886 DO j = 1, n
2887 DO i = 1, n
2888 IF (i==j) THEN
2889 fjac(i,j) = 2.*a(i)*x(i) + b(i)
2890 ELSE
2891 fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
2892 END IF
2893 END DO
2894 END DO
2895 !bs
2896 RETURN
2897 END SUBROUTINE fdjac
2898 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2899 FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
2900 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2901 !bs !
2902 !bs Description: !
2903 !bs !
2904 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
2905 !bs !
2906 !bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, !
2907 !bs user-supplied routine that returns the vector of functions at X. !
2908 !bs The common block NEWTV communicates the function values back to !
2909 !bs NEWT. !
2910 !bs !
2911 !bs Called by: NEWT !
2912 !bs !
2913 !bs Calls: FUNCV !
2914 !bs !
2915 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2917 ! IMPLICIT NONE
2919 !bs
2920 !bs
2921 INTEGER n
2922 ! INTEGER NP
2923 ! PARAMETER (NP = 6)
2924 REAL ct(np)
2925 REAL cs(np)
2926 REAL imw(np)
2927 REAL m,fmin
2928 REAL x(*), fvec(np)
2930 INTEGER i
2931 REAL sum
2933 CALL funcv(n,x,fvec,ct,cs,imw,m)
2934 sum = 0.
2935 DO i = 1, n
2936 sum = sum + fvec(i)**2
2937 END DO
2938 fmin = 0.5*sum
2939 RETURN
2940 END FUNCTION fmin
2941 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2942 SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
2943 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2944 !bs !
2945 !bs Description: !
2946 !bs !
2947 !bs Called by: FMIN !
2948 !bs !
2949 !bs Calls: None !
2950 !bs !
2951 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2952 !bs
2953 ! IMPLICIT NONE
2954 !bs
2955 !bs
2956 INTEGER n
2957 REAL x(*)
2958 REAL fvec(n)
2959 !bs
2960 ! INTEGER NP
2961 ! PARAMETER (NP = 6)
2962 REAL ct(np)
2963 REAL cs(np)
2964 REAL imw(np)
2965 REAL m
2966 !bs
2967 INTEGER i, j
2968 REAL sum_jnei
2969 REAL a(np)
2970 REAL b(np)
2971 REAL c(np)
2972 !bs
2973 DO i = 1, n
2974 a(i) = imw(i)
2975 sum_jnei = 0.
2976 DO j = 1, n
2977 sum_jnei = sum_jnei + x(j)*imw(j)
2978 END DO
2979 sum_jnei = sum_jnei - (x(i)*imw(i))
2980 b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
2981 c(i) = -ct(i)*(sum_jnei+m)
2982 fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
2983 END DO
2984 !bs
2985 RETURN
2986 END SUBROUTINE funcv
2987 REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
2988 ! *** set up new processor for renaming of particles from i to j modes
2989 ! IMPLICIT NONE
2990 REAL aa, bb, cc, disc, qq, alfa, l, yji
2991 REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
2993 alfa = xlsgi/xlsgj
2994 yji = log(dgnj/dgni)/(sqrt2*xlsgi)
2995 aa = 1.0 - alfa*alfa
2996 l = log(alfa*nj/ni)
2997 bb = 2.0*yji*alfa*alfa
2998 cc = l - yji*yji*alfa*alfa
2999 disc = bb*bb - 4.0*aa*cc
3000 IF (disc<0.0) THEN
3001 getaf = - & ! error in intersection
3002 5.0
3003 RETURN
3004 END IF
3005 qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3006 getaf = cc/qq
3007 RETURN
3008 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3009 END FUNCTION getaf
3010 ! Parameterization for sulfuric acid/water
3011 ! nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3012 ! April 20, 1998.
3014 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3015 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3017 !ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3018 ! getaf
3019 SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3020 ! IMPLICIT NONE
3022 ! *** Input:
3024 ! ambient temperature [ K ]
3025 REAL temp
3026 ! fractional relative humidity
3027 REAL rh
3028 ! sulfuric acid concentration [ ug / m**3 ]
3029 REAL h2so4
3031 REAL so4rat
3032 ! *** Output:
3034 !sulfuric acid production rate [ ug / ( m**3 s )]
3035 ! particle number production rate [ # / ( m**3 s )]
3036 REAL ndot1
3037 ! particle mass production rate [ ug / ( m**3 s )]
3038 REAL mdot1
3039 ! [ m**2 / ( m**3 s )]
3040 REAL m2dot
3042 ! *** Internal:
3044 ! *** NOTE, all units are cgs internally.
3045 ! particle second moment production rate
3047 REAL ra
3048 ! fractional relative acidity
3049 ! sulfuric acid vaper concentration [ cm ** -3 ]
3050 REAL nav
3051 ! water vapor concentration [ cm ** -3 ]
3052 REAL nwv
3053 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3054 REAL nav0
3055 ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1
3056 REAL nac
3057 ! critical sulfuric acid vapor concentration [ cm ** -3
3058 ! mole fractio of the critical nucleus
3059 REAL xal
3060 REAL nsulf, & ! see usage
3061 delta
3062 REAL*8 & ! factor to calculate Jnuc
3063 chi
3064 REAL*8 &
3065 jnuc
3066 ! nucleation rate [ cm ** -3 s ** -1 ]
3067 REAL tt, & ! dummy variables for statement functions
3068 rr
3069 REAL pi
3070 PARAMETER (pi=3.14159265)
3072 REAL pid6
3073 PARAMETER (pid6=pi/6.0)
3075 ! avogadro's constant [ 1/mol ]
3076 REAL avo
3077 PARAMETER (avo=6.0221367E23)
3079 ! universal gas constant [ j/mol-k ]
3080 REAL rgasuniv
3081 PARAMETER (rgasuniv=8.314510)
3083 ! 1 atmosphere in pascals
3084 REAL atm
3085 PARAMETER (atm=1013.25E+02)
3087 ! formula weight for h2so4 [ g mole **-1 ]
3088 REAL mwh2so4
3089 PARAMETER (mwh2so4=98.07948)
3091 ! diameter of a 3.5 nm particle in cm
3092 REAL d35
3093 PARAMETER (d35=3.5E-07)
3094 REAL d35sq
3095 PARAMETER (d35sq=d35*d35)
3096 ! volume of a 3.5 nm particle in cm**3
3097 REAL v35
3098 PARAMETER (v35=pid6*d35*d35sq)
3099 !ia rev01
3101 REAL mp
3102 ! *** conversion factors:
3103 ! mass of sulfate in a 3.5 nm particle
3104 ! number per cubic cm.
3105 REAL ugm3_ncm3
3106 ! micrograms per cubic meter to
3107 PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3108 !ia rev01
3109 ! molecules to micrograms
3110 REAL nc_ug
3111 PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3113 ! *** statement functions **************
3115 REAL pdens, &
3116 rho_p
3117 ! particle density [ g / cm**3]
3118 REAL ad0, ad1, ad2, &
3119 ad3
3120 ! coefficients for density expression
3121 PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3122 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3123 ! as a function of relative humidity,
3124 ! J. Aerosol Science, 6, pp 265-271, 1975.
3126 !ia rev01
3128 ! fit to Nair & Vohra data
3129 ! the mass of sulfate in a 3.5 nm particle
3130 REAL mp35
3131 ! arithmetic statement function to compute
3132 REAL a0, a1, a2, & ! coefficients for cubic in mp35
3133 a3
3134 PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3136 REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ]
3137 ph2o
3139 ! arithmetic statement functions
3140 pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3142 ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3144 ph2so4(tt) = exp(27.78492066-10156.0/tt)
3146 ! *** both ph2o and ph2so4 are as in Kulmala et al. paper
3148 !ia rev01
3150 ! *** function for the mass of sulfate in a 3.5 nm sphere
3151 ! *** obtained from a fit to the number of sulfate monomers in
3152 ! a 3.5 nm particle. Uses data from Nair & Vohra
3153 mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3155 ! *** begin code:
3157 ! The 1.0e-6 factor in the following converts from MKS to cgs units
3159 ! *** get water vapor concentration [ molecles / cm **3 ]
3161 nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3163 ! *** calculate the equilibrium h2so4 vapor concentration.
3165 ! *** use Kulmala corrections:
3167 ! ***
3168 nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3170 ! *** convert sulfuric acid vapor concentration from micrograms
3171 ! per cubic meter to molecules per cubic centimeter.
3173 nav = ugm3_ncm3*h2so4
3175 ! *** calculate critical concentration of sulfuric acid vapor
3177 nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3179 ! *** calculate relative acidity
3181 ra = nav/nav0
3183 ! *** calculate temperature correction
3185 delta = 1.0 + (temp-273.15)/273.14
3187 ! *** calculate molar fraction
3189 xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3190 0.0016*temp
3192 ! *** calculate Nsulf
3193 nsulf = log(nav/nac)
3195 ! *** calculate particle produtcion rate [ # / cm**3 ]
3197 chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3198 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3200 jnuc = exp(chi)
3201 ! [ # / cm**3 ]
3202 ndot1 = (1.0E06)*jnuc
3203 ! write(91,*) ' inside klpnuc '
3204 ! write(91,*) ' Jnuc = ', Jnuc
3205 ! write(91,*) ' NDOT = ', NDOT1
3207 ! *** calculate particle density
3209 rho_p = pdens(rh)
3211 ! write(91,*) ' rho_p =', rho_p
3213 ! *** get the mass of sulfate in a 3.5 nm particle
3215 mp = mp35(rh) ! in a 3.5 nm particle at ambient RH
3217 ! *** calculate mass production rate [ ug / m**3]
3218 ! assume that the particles are 3.5 nm in diameter.
3220 ! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc
3222 !ia rev01
3224 ! number of micrograms of sulfate
3225 mdot1 = mp*ndot1
3227 !ia rev02
3229 IF (mdot1>so4rat) THEN
3231 mdot1 = &
3232 so4rat
3233 ! limit nucleated mass by available ma
3234 ndot1 = mdot1/ &
3235 mp
3236 ! adjust DNDT to this
3237 END IF
3239 IF (mdot1==0.) ndot1 = 0.
3241 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3243 m2dot = 1.0E-04*d35sq*ndot1
3245 RETURN
3247 END SUBROUTINE klpnuc
3248 !------------------------------------------------------------------------------
3250 SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3251 pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3252 knacc,kncor)
3254 !** DESCRIPTION:
3255 ! Calculates modal parameters and derived variables,
3256 ! log-squared of std deviation, mode mean size, Knudsen number)
3257 ! based on current values of moments for the modes.
3258 ! FSB Now calculates the 3rd moment, mass, and density in all 3 modes.
3259 !**
3260 !** Revision history:
3261 ! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3262 ! Revised 7/23/96 by FSB to use COMMON blocks and small blocks
3263 ! instead of large 3-d arrays, and to assume a fixed std.
3264 ! Revised 12/06/96 by FSB to include coarse mode
3265 ! Revised 1/10/97 by FSB to have arrays passed in call vector
3266 !**********************************************************************
3268 ! IMPLICIT NONE
3270 ! Includes:
3272 ! *** input:
3274 ! dimension of arrays
3275 INTEGER blksize
3276 ! actual number of cells in arrays
3277 INTEGER numcells
3279 INTEGER nspcsda
3281 ! nmber of species in CBLK
3282 REAL cblk(blksize,nspcsda) ! main array of variables
3283 REAL blkta(blksize) ! Air temperature [ K ]
3284 REAL blkprs(blksize)
3285 ! *** output:
3287 ! Air pressure in [ Pa ]
3288 ! concentration lower limit [ ug/m*
3289 ! lowest particle diameter ( m )
3290 REAL dgmin
3291 PARAMETER (dgmin=1.0E-09)
3293 ! lowest particle density ( Kg/m**3
3294 REAL densmin
3295 PARAMETER (densmin=1.0E03)
3297 REAL pmassn(blksize) ! mass concentration in nuclei mode
3298 REAL pmassa(blksize) ! mass concentration in accumulation
3299 REAL pmassc(blksize) ! mass concentration in coarse mode
3300 REAL pdensn(blksize) ! average particel density in Aitken
3301 REAL pdensa(blksize) ! average particel density in accumu
3302 REAL pdensc(blksize) ! average particel density in coarse
3303 REAL xlm(blksize) ! atmospheric mean free path [ m]
3304 REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3305 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3306 REAL dgacc(blksize) ! accumulation
3307 REAL dgcor(blksize) ! coarse mode
3308 REAL knnuc(blksize) ! Aitken mode Knudsen number
3309 REAL knacc(blksize) ! accumulation
3310 REAL kncor(blksize)
3312 ! coarse mode
3314 INTEGER lcell
3315 ! WRITE(20,*) ' IN MODPAR '
3317 ! *** set up aerosol 3rd moment, mass, density
3319 ! loop counter
3320 DO lcell = 1, numcells
3322 ! *** Aitken-mode
3323 ! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3324 cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3325 vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3326 vh2oai)+no3fac*cblk(lcell,vno3ai)+ &
3327 nafac*cblk(lcell,vnaai)+ clfac*cblk(lcell,vclai) + &
3328 !liqy-20140616
3329 orgfac*cblk(lcell, &
3330 vasoa1i)+orgfac*cblk(lcell,vasoa2i)+orgfac*cblk(lcell, &
3331 vasoa3i)+orgfac*cblk(lcell,vasoa4i)+orgfac*cblk(lcell, &
3332 vbsoa1i)+orgfac*cblk(lcell,vbsoa2i)+orgfac*cblk(lcell, &
3333 vbsoa3i)+orgfac*cblk(lcell,vbsoa4i)+orgfac*cblk(lcell, &
3334 vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
3335 ! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan
3337 ! *** Accumulation-mode
3338 ! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3339 cblk(lcell,vac3) = so4fac*cblk(lcell, &
3340 vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
3341 vh2oaj)+no3fac*cblk(lcell,vno3aj) + &
3342 nafac*cblk(lcell,vnaaj)+ clfac*cblk(lcell,vclaj) + &
3343 !liqy-20140616
3344 orgfac*cblk(lcell, &
3345 vasoa1j)+orgfac*cblk(lcell,vasoa2j)+orgfac*cblk(lcell, &
3346 vasoa3j)+orgfac*cblk(lcell,vasoa4j)+orgfac*cblk(lcell, &
3347 vbsoa1j)+orgfac*cblk(lcell,vbsoa2j)+orgfac*cblk(lcell, &
3348 vbsoa3j)+orgfac*cblk(lcell,vbsoa4j)+orgfac*cblk(lcell, &
3349 vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
3350 ! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan
3352 ! *** coarse mode
3353 ! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
3354 ! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
3356 cblk(lcell,vcor3) = soilfac*cblk(lcell, &
3357 vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
3359 ! *** now get particle mass and density
3361 ! *** Aitken-mode:
3362 pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
3363 vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
3364 vasoa1i)+cblk(lcell,vasoa2i)+cblk(lcell,vasoa3i)+cblk(lcell, &
3365 vasoa4i)+cblk(lcell,vbsoa1i)+cblk(lcell,vbsoa2i)+cblk(lcell, &
3366 vbsoa3i)+cblk(lcell,vbsoa4i)+cblk(lcell,vorgpai)+cblk(lcell, &
3367 ! vp25ai)+cblk(lcell,veci)))
3368 !liqy
3369 vp25ai)+cblk(lcell,veci)))
3370 !liqy-20140616
3372 ! *** Accumulation-mode:
3373 pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
3374 vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
3375 vasoa1j)+cblk(lcell,vasoa2j)+cblk(lcell,vasoa3j)+cblk(lcell, &
3376 vasoa4j)+cblk(lcell,vbsoa1j)+cblk(lcell,vbsoa2j)+cblk(lcell, &
3377 vbsoa3j)+cblk(lcell,vbsoa4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
3378 ! vp25aj)+cblk(lcell,vecj)))
3379 !liqy
3380 vp25aj)+cblk(lcell,vecj)))
3381 !liqy-20140616
3382 ! *** coarse mode:
3383 pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
3384 lcell,vantha))
3386 END DO
3387 ! *** now get particle density, mean free path, and dynamic viscosity
3389 ! aerosol 3rd moment and mass
3390 DO lcell = 1, &
3391 numcells
3392 ! *** density in [ kg m**-3 ]
3394 ! Density and mean free path
3395 pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
3396 pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
3397 pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
3399 ! *** Calculate mean free path [ m ]:
3400 xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
3402 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
3403 ! *** on page 10 of U.S. Standard Atmosphere 1962
3405 ! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
3407 ! *** U.S. Standard Atmosphere 1962 page 14 expression
3408 ! for dynamic viscosity is:
3409 ! dynamic viscosity = beta * T * sqrt(T) / ( T + S)
3410 ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
3412 amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
3413 (blkta(lcell)+110.4)
3415 END DO
3416 !............... Standard deviation fixed in both modes, so
3417 !............... diagnose diameter from 3rd moment and number concentr
3419 ! density and mean free path
3420 DO lcell = 1, &
3421 numcells
3423 ! calculate diameters
3424 dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
3425 one3)
3427 dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
3428 one3)
3430 dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
3431 **one3)
3433 ! when running with cloudborne aerosol, apply some very mild bounding
3434 ! to avoid unrealistic dg values
3435 if (cw_phase > 0) then
3436 dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2 ) ! > 0.002 um
3437 dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 ) ! < 0.10 um
3438 dgacc(lcell) = max( dgacc(lcell), dginia*0.2 ) ! > 0.014 um
3439 dgacc(lcell) = min( dgacc(lcell), dginia*10.0 ) ! < 0.7 um
3440 dgcor(lcell) = max( dgcor(lcell), dginic*0.2 ) ! > 0.2 um
3441 dgcor(lcell) = min( dgcor(lcell), dginic*10.0 ) ! < 10.0 um
3442 end if
3444 END DO
3445 ! end loop on diameters
3446 DO lcell = 1, &
3447 numcells
3448 ! Calculate Knudsen numbers
3449 knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
3451 knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
3453 kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
3455 END DO
3457 ! end loop for Knudsen numbers
3458 RETURN
3460 END SUBROUTINE modpar
3461 !------------------------------------------------------------------------------
3463 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
3464 blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
3465 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
3466 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
3468 !***********************************************************************
3469 !** DESCRIPTION: calculates aerosol nucleation and condensational
3470 !** growth rates using Binkowski and Shankar (1995) method.
3472 ! *** In this version, the method od RPM is followed where
3473 ! the diffusivity, the average molecular ve3locity, and
3474 ! the accomodation coefficient for sulfuric acid are used for
3475 ! the organics. This is for consistency.
3476 ! Future versions will use the correct values. FSB 12/12/96
3479 !**
3480 !** Revision history:
3481 ! prototype 1/95 by Uma and Carlie
3482 ! Corrected 7/95 by Uma for condensation of mass not nucleated
3483 ! and mass conservation check
3484 ! Revised 8/95 by US to calculate air density in stmt function
3485 ! and collect met variable stmt funcs in one include fil
3486 ! Revised 7/25/96 by FSB to use block structure.
3487 ! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
3488 ! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units.
3489 ! Revised 1/13/97 by FSB to pass arrays and simplify code.
3490 ! Added 23/03/99 by BS growth factors for organics
3491 !**********************************************************************
3492 ! IMPLICIT NONE
3494 ! Includes:
3495 ! *** arguments
3497 ! *** input;
3498 !USE module_configure, only: grid_config_rec_type
3499 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
3502 ! dimension of arrays
3503 INTEGER blksize
3504 INTEGER layer
3505 ! number of species in CBLK
3506 INTEGER nspcsda
3507 ! actual number of cells in arrays
3508 INTEGER numcells
3509 INTEGER igrid,jgrid,kgrid
3511 INTEGER ldrog_vbs
3512 ! # of organic aerosol precursor
3513 REAL cblk(blksize,nspcsda) ! main array of variables
3514 ! model time step in SECONDS
3515 REAL dt
3516 REAL blkta(blksize) ! Air temperature [ K ]
3517 REAL blkprs(blksize) ! Air pressure in [ Pa ]
3518 REAL blkrh(blksize) ! Fractional relative humidity
3519 REAL so4rat(blksize) ! rate [ ug/m**3 /s ]
3520 REAL brrto
3521 !bs
3522 ! sulfate gas-phase production
3523 ! total # of cond. vapors & SOA spe
3524 INTEGER ncv
3525 !bs
3526 INTEGER nacv
3527 !bs * anthropogenic organic condensable vapor production rate
3528 ! # of anthrop. cond. vapors & SOA
3529 REAL drog(blksize,ldrog_vbs) !bs
3530 ! Delta ROG conc. [ppm]
3532 ! anthropogenic vapor production rates
3533 REAL organt1rat(blksize)
3534 REAL organt2rat(blksize)
3535 REAL organt3rat(blksize)
3536 REAL organt4rat(blksize)
3538 ! biogenic vapor production rates
3539 REAL orgbio1rat(blksize)
3540 REAL orgbio2rat(blksize)
3541 REAL orgbio3rat(blksize)
3542 REAL orgbio4rat(blksize)
3544 ! biogenic organic aerosol production
3545 REAL dgnuc(blksize) ! accumulation
3546 REAL dgacc(blksize)
3547 ! *** output:
3549 ! coarse mode
3550 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
3551 ! reciprocal condensation rate
3552 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
3553 ! reciprocal condensation rate
3554 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
3555 ! reciprocal condensation rate
3556 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
3557 ! reciprocal condensation rate
3558 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
3559 ! rate of production of new mass concent
3560 REAL dndt(blksize) ! concentration by particle formation [#
3561 ! rate of producton of new particle numb
3562 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
3563 ! increment of concentration added to
3564 REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ]
3565 ! growth rate for 3rd moment for
3566 REAL cgra3(blksize) ! Accumulation mode
3568 !........... SCRATCH local variables and their descriptions:
3570 ! growth rate for 3rd moment for
3572 INTEGER lcell
3574 ! LOOP INDEX
3575 ! conv rate so2 --> so4 [mom-3/g/s]
3576 REAL chemrat
3577 ! conv rate for organics [mom-3/g/s]
3578 REAL chemrat_org
3579 REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
3580 am1a
3581 REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
3582 am2a
3583 REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
3584 gnc3a
3585 REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den
3586 gfm3a
3587 ! total reciprocal condensation rate
3588 REAL fconc
3590 REAL td
3591 ! d * tinf (cgs)
3592 REAL*8 & ! Cnstant to force 64 bit evaluation of
3593 one88
3594 PARAMETER (one88=1.0D0)
3595 ! *** variables to set up sulfate and organic condensation rates
3597 ! sulfuric acid vapor at current time step
3598 REAL vapor1
3599 ! chemistry and emissions
3600 REAL vapor2
3601 ! Sulfuric acid vapor prior to addition from
3602 !bs
3603 REAL deltavap
3604 !bs * start update
3605 !bs
3606 ! change to vapor at previous time step
3607 REAL diffcorr
3609 !bs *
3610 REAL csqt_org
3611 !bs * end update
3612 !bs
3613 REAL csqt
3614 !.......................................................................
3615 ! begin body of subroutine NUCLCOND
3618 !........... Main computational grid-traversal loop nest
3619 !........... for computing condensation and nucleation:
3621 DO lcell = 1, &
3622 numcells
3623 ! *** First moment:
3625 ! 1st loop over NUMCELLS
3626 am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
3627 am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
3629 !.............. near-continuum factors [ 1 / sec ]
3630 !bs
3631 !bs * adopted from code of FSB
3632 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
3633 !bs
3634 diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
3635 !bs
3636 gnc3n = cconc*am1n*diffcorr
3637 gnc3a = cconc*am1a*diffcorr
3639 ! *** Second moment:
3641 am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
3642 am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
3644 csqt = ccofm*sqrt(blkta(lcell))
3645 !............... free molecular factors [ 1 / sec ]
3647 ! put in temperature fac
3648 gfm3n = csqt*am2n
3649 gfm3a = csqt*am2a
3651 ! *** Condensation factors in [ s**-1] for h2so4
3652 ! *** In the future, separate factors for condensing organics will
3653 ! be included. In this version, the h2so4 values are used.
3655 !............... Twice the harmonic mean of fm, nc functions:
3656 ! *** Force 64 bit evaluation:
3658 fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
3659 fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
3660 fconc = fconcn(lcell) + fconca(lcell)
3662 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
3663 !bs
3664 !bs * start modifications for organcis
3665 !bs
3666 gnc3n = cconc_org*am1n*diffcorr
3667 gnc3a = cconc_org*am1a*diffcorr
3668 !bs
3669 csqt_org = ccofm_org*sqrt(blkta(lcell))
3670 gfm3n = csqt_org*am2n
3671 gfm3a = csqt_org*am2a
3672 !bs
3673 fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
3674 fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
3675 !bs
3676 !bs * end modifications for organics
3677 !bs
3678 ! *** calculate the total change to sulfuric acid vapor from production
3679 ! and condensation
3681 vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
3682 vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
3683 dt
3684 ! vapor at prev
3685 vapor2 = max(0.0,vapor2)
3686 deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
3688 ! *** Calculate increment in total sufate aerosol mass concentration
3690 ! *** This follows the method of Youngblood & Kreidenweis.!bs
3691 !bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
3692 !bs
3693 !bs * allow DELTASO4A to be negative, but the change must not be larger
3694 !bs * than the amount of vapor available.
3695 !bs
3696 deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
3697 so4rat(lcell)*dt-deltavap)
3699 ! *** zero out growth coefficients
3700 cgrn3(lcell) = 0.0
3701 cgra3(lcell) = 0.0
3703 END DO
3705 ! *** Select method of nucleation
3706 ! End 1st loop over NUMCELLS
3707 IF (inucl==1) THEN
3709 ! *** Do Youngblood & Kreidenweis Nucleation
3711 ! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
3712 ! & DNDT,DMDT,NUMCELLS,BLKSIZE,
3713 ! & VAPOR1)
3714 ! IF (firstime) THEN
3715 ! WRITE (6,*)
3716 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3717 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3718 ! firstime = .FALSE.
3719 ! END IF
3721 ELSE IF (inucl==0) THEN
3723 ! *** Do Kerminen & Wexler Nucleation
3725 ! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
3726 ! & DNDT,DMDT,NUMCELLS,BLKSIZE)
3727 ! IF (firstime) THEN
3728 ! WRITE (6,*)
3729 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3730 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3731 ! firstime = .FALSE.
3732 ! END IF
3734 ELSE IF (inucl==2) THEN
3736 !bs ** Do Kulmala et al. Nucleation
3737 ! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
3739 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
3740 CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
3741 else
3742 dndt(1)=0.
3743 dmdt(1)=0.
3744 endif
3746 ! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
3747 ! if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
3748 IF (dndt(1)==0.) dmdt(1) = 0.
3749 IF (dmdt(1)==0.) dndt(1) = 0.
3750 ! IF (firstime) THEN
3751 ! WRITE (6,*)
3752 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3753 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3754 ! firstime = .FALSE.
3755 ! END IF
3756 ! ELSE
3757 ! WRITE (6,'(a)') '*************************************'
3758 ! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!'
3759 ! WRITE (6,'(a)') ' PROGRAM TERMINATED !!'
3760 ! WRITE (6,'(a)') '*************************************'
3761 ! STOP
3763 END IF
3764 !bs
3765 !bs * Secondary organic aerosol module (SOA_VBS)
3766 !bs
3767 ! end of selection of nucleation method
3769 CALL soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
3770 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
3771 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto )
3772 !bs
3773 !bs * Secondary organic aerosol module (SOA_VBS)
3774 !bs
3775 DO lcell = 1, numcells
3777 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
3778 ! condensation factors
3780 td = 1.0/(fconcn(lcell)+fconca(lcell))
3781 fconcn(lcell) = td*fconcn(lcell)
3782 fconca(lcell) = td*fconca(lcell)
3783 !bs
3784 td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
3785 fconcn_org(lcell) = td*fconcn_org(lcell)
3786 fconca_org(lcell) = td*fconca_org(lcell)
3787 !bs
3788 END DO
3790 ! *** Begin second loop over cells
3792 DO lcell = 1,numcells
3793 ! *** note CHEMRAT includes species other than sulfate.
3795 ! 3rd loop on NUMCELLS
3796 chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
3797 chemrat_org = orgfac*(organt1rat(lcell)+organt2rat(lcell)+organt3rat( &
3798 lcell)+organt4rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
3799 orgbio3rat(lcell)+orgbio4rat(lcell))
3801 ! *** Calculate the production rates for new particle
3802 ! [mom3 m**-3 s-
3803 cgrn3(lcell) = so4fac*dmdt(lcell)
3804 ! Rate of increase of 3rd
3805 chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro
3807 !bs Remove the rate of new pa
3808 chemrat = max(chemrat,0.0)
3809 ! *** Now calculate the rate of condensation on existing particles.
3811 ! Prevent CHEMRAT from being negativ
3812 cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
3813 chemrat_org*fconcn_org(lcell)
3814 cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
3815 ! ***
3816 END DO
3817 ! end 2nd loop over NUMCELLS
3818 RETURN
3820 END SUBROUTINE nuclcond
3821 !------------------------------------------------------------------------------
3823 ! nuclcond
3824 REAL FUNCTION poly4(a,x)
3825 REAL a(4), x
3827 poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
3828 RETURN
3829 END FUNCTION poly4
3830 REAL FUNCTION poly6(a,x)
3831 REAL a(6), x
3833 poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
3834 RETURN
3835 END FUNCTION poly6
3836 !-----------------------------------------------------------------------
3838 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
3839 gnh3,gno3)
3840 ! Description:
3842 ! ARES calculates the chemical composition of a sulfate/nitrate/
3843 ! ammonium/water aerosol based on equilibrium thermodynamics.
3845 ! This code considers two regimes depending upon the molar ratio
3846 ! of ammonium to sulfate.
3848 ! For values of this ratio less than 2,the code solves a cubic for
3849 ! hydrogen ion molality, HPLUS, and if enough ammonium and liquid
3850 ! water are present calculates the dissolved nitric acid. For molal
3851 ! ionic strengths greater than 50, nitrate is assumed not to be present
3853 ! For values of the molar ratio of 2 or greater, all sulfate is assumed
3854 ! to be ammonium sulfate and a calculation is made for the presence of
3855 ! ammonium nitrate.
3857 ! The Pitzer multicomponent approach is used in subroutine ACTCOF to
3858 ! obtain the activity coefficients. Abandoned -7/30/97 FSB
3860 ! The Bromley method of calculating the activity coefficients is used in this version
3862 ! The calculation of liquid water is done in subroutine water. Details for both calculations are given
3863 ! in the respective subroutines.
3865 ! Based upon MARS due to
3866 ! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
3867 ! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
3869 ! and SCAPE due to
3870 ! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
3871 ! Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
3873 ! NOTE: All concentrations supplied to this subroutine are TOTAL
3874 ! over gas and aerosol phases
3876 ! Parameters:
3878 ! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
3879 ! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
3880 ! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
3881 ! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
3882 ! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
3883 ! RH : Fractional relative humidity (IN)
3884 ! TEMP : Temperature in Kelvin (IN)
3885 ! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
3886 ! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
3887 ! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
3888 ! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
3889 ! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
3890 ! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT)
3891 ! NITR : Number of iterations for obtaining activity coefficients (OU
3892 ! NR : Number of real roots to the cubic in the low ammonia case (OU
3894 ! Revision History:
3895 ! Who When Detailed description of changes
3896 ! --------- -------- -------------------------------------------
3897 ! S.Roselle 11/10/87 Received the first version of the MARS code
3898 ! S.Roselle 12/30/87 Restructured code
3899 ! S.Roselle 2/12/88 Made correction to compute liquid-phase
3900 ! concentration of H2O2.
3901 ! S.Roselle 5/26/88 Made correction as advised by SAI, for
3902 ! computing H+ concentration.
3903 ! S.Roselle 3/1/89 Modified to operate with EM2
3904 ! S.Roselle 5/19/89 Changed the maximum ionic strength from
3905 ! 100 to 20, for numerical stability.
3906 ! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case
3907 ! using equations for nitrate budget.
3908 ! F.Binkowski 6/18/91 New ammonia poor case which
3909 ! omits letovicite.
3910 ! F.Binkowski 7/25/91 Rearranged entire code, restructured
3911 ! ammonia poor case.
3912 ! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output
3913 ! as SO4--
3914 ! F.Binkowski 12/6/91 Changed the ammonia defficient case so that
3915 ! there is only neutralized sulfate (ammonium
3916 ! sulfate) and sulfuric acid.
3917 ! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen
3918 ! with the Cohen et al. (1987) maximum molalit
3919 ! of 36.2 in Table III.( J. Phys Chem (91) page
3920 ! 4569, and Table IV p 4587.)
3921 ! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem
3922 ! possibility for denomenator becoming zero;
3923 ! this involved solving for HPLUS first.
3924 ! Note that for a relative humidity
3925 ! less than 50%, the model assumes that there i
3926 ! aerosol nitrate.
3927 ! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System
3928 ! Redid logic as follows
3929 ! 1. Water algorithm now follows Spann & Richard
3930 ! 2. Pitzer Multicomponent method used
3931 ! 3. Multicomponent practical osmotic coefficien
3932 ! use to close iterations.
3933 ! 4. The model now assumes that for a water
3934 ! mass fraction WFRAC less than 50% there is
3935 ! no aerosol nitrate.
3936 ! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p
3937 ! case, and changed the WFRAC criterion to 40%.
3938 ! For ammonium to sulfate ratio less than 1.0
3939 ! all ammonium is aerosol and no nitrate aerosol
3940 ! exists.
3941 ! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case
3942 ! allow gas-phase ammonia to exist.
3943 ! F.Binkowski 7/26/95 Changed equilibrium constants to values from
3944 ! Kim et al. (1993)
3945 ! F.Binkowski 6/27/96 Changed to new water format
3946 ! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent
3947 ! activity coefficients. The binary activity coe
3948 ! are the same as the previous version
3949 ! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
3950 ! 1 picogram per cubic meter
3952 !-----------------------------------------------------------------------
3953 ! IMPLICIT NONE
3954 !...........INCLUDES and their descriptions
3955 !cc INCLUDE SUBST_CONST ! constants
3956 !...........PARAMETERS and their descriptions:
3958 ! molecular weight for NaCl
3959 REAL mwnacl
3960 PARAMETER (mwnacl=58.44277)
3962 ! molecular weight for NO3
3963 REAL mwno3
3964 PARAMETER (mwno3=62.0049)
3966 ! molecular weight for HNO3
3967 REAL mwhno3
3968 PARAMETER (mwhno3=63.01287)
3970 ! molecular weight for SO4
3971 REAL mwso4
3972 PARAMETER (mwso4=96.0576)
3974 ! molecular weight for HSO4
3975 REAL mwhso4
3976 PARAMETER (mwhso4=mwso4+1.0080)
3978 ! molecular weight for H2SO4
3979 REAL mh2so4
3980 PARAMETER (mh2so4=98.07354)
3982 ! molecular weight for NH3
3983 REAL mwnh3
3984 PARAMETER (mwnh3=17.03061)
3986 ! molecular weight for NH4
3987 REAL mwnh4
3988 PARAMETER (mwnh4=18.03858)
3990 ! molecular weight for Organic Species
3991 REAL mworg
3992 PARAMETER (mworg=16.0)
3994 ! molecular weight for Chloride
3995 REAL mwcl
3996 PARAMETER (mwcl=35.453)
3998 ! molecular weight for AIR
3999 REAL mwair
4000 PARAMETER (mwair=28.964)
4002 ! molecular weight for Letovicite
4003 REAL mwlct
4004 PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4006 ! molecular weight for Ammonium Sulfa
4007 REAL mwas
4008 PARAMETER (mwas=2.0*mwnh4+mwso4)
4010 ! molecular weight for Ammonium Bisul
4011 REAL mwabs
4012 PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4014 !...........ARGUMENTS and their descriptions
4016 !iamodels3
4017 REAL so4
4018 ! Total sulfate in micrograms / m**3
4019 ! Total nitric acid in micrograms / m
4020 REAL hno3
4021 ! Total nitrate in micrograms / m**3
4022 REAL no3
4023 ! Total ammonia in micrograms / m**3
4024 REAL nh3
4025 ! Total ammonium in micrograms / m**3
4026 REAL nh4
4027 ! Fractional relative humidity
4028 REAL rh
4029 ! Temperature in Kelvin
4030 REAL temp
4031 ! Aerosol sulfate in micrograms / m**
4032 REAL aso4
4033 ! Aerosol nitrate in micrograms / m**
4034 REAL ano3
4035 ! Aerosol liquid water content water
4036 REAL ah2o
4037 ! Aerosol ammonium in micrograms / m*
4038 REAL anh4
4039 ! Gas-phase nitric acid in micrograms
4040 REAL gno3
4041 REAL gnh3
4042 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4044 ! Gas-phase ammonia in micrograms / m
4045 ! Index set to percent relative humid
4046 INTEGER irh
4047 ! Number of iterations for activity c
4048 INTEGER nitr
4049 ! Loop index for iterations
4050 INTEGER nnn
4051 INTEGER nr
4052 ! Number of roots to cubic equation f
4053 REAL*8 & ! Coefficients and roots of
4054 a0
4055 REAL*8 & ! Coefficients and roots of
4056 a1
4057 REAL*8 & ! Coefficients and roots of
4058 a2
4059 ! Coefficients and discriminant for q
4060 REAL aa
4061 ! internal variables ( high ammonia c
4062 REAL bal
4063 ! Coefficients and discriminant for q
4064 REAL bb
4065 ! Variables used for ammonia solubili
4066 REAL bhat
4067 ! Coefficients and discriminant for q
4068 REAL cc
4069 ! Factor for conversion of units
4070 REAL convt
4071 ! Coefficients and discriminant for q
4072 REAL dd
4073 ! Coefficients and discriminant for q
4074 REAL disc
4075 ! Relative error used for convergence
4076 REAL eror
4077 ! Free ammonia concentration , that
4078 REAL fnh3
4079 ! Activity Coefficient for (NH4+, HSO
4080 REAL gamaab
4081 ! Activity coefficient for (NH4+, NO3
4082 REAL gamaan
4083 ! Variables used for ammonia solubili
4084 REAL gamahat
4085 ! Activity coefficient for (H+ ,NO3-)
4086 REAL gamana
4087 ! Activity coefficient for (2H+, SO4-
4088 REAL gamas1
4089 ! Activity coefficient for (H+, HSO4-
4090 REAL gamas2
4091 ! used for convergence of iteration
4092 REAL gamold
4093 ! internal variables ( high ammonia c
4094 REAL gasqd
4095 ! Hydrogen ion (low ammonia case) (mo
4096 REAL hplus
4097 ! Equilibrium constant for ammoniua t
4098 REAL k1a
4099 ! Equilibrium constant for sulfate-bi
4100 REAL k2sa
4101 ! Dissociation constant for ammonium
4102 REAL k3
4103 ! Equilibrium constant for ammonium n
4104 REAL kan
4105 ! Variables used for ammonia solubili
4106 REAL khat
4107 ! Equilibrium constant for nitric aci
4108 REAL kna
4109 ! Henry's Law Constant for ammonia
4110 REAL kph
4111 ! Equilibrium constant for water diss
4112 REAL kw
4113 ! Internal variable using KAN
4114 REAL kw2
4115 ! Nitrate (high ammonia case) (moles
4116 REAL man
4117 ! Sulfate (high ammonia case) (moles
4118 REAL mas
4119 ! Bisulfate (low ammonia case) (moles
4120 REAL mhso4
4121 ! Nitrate (low ammonia case) (moles /
4122 REAL mna
4123 ! Ammonium (moles / kg water)
4124 REAL mnh4
4125 ! Total number of moles of all ions
4126 REAL molnu
4127 ! Sulfate (low ammonia case) (moles /
4128 REAL mso4
4129 ! Practical osmotic coefficient
4130 REAL phibar
4131 ! Previous value of practical osmotic
4132 REAL phiold
4133 ! Molar ratio of ammonium to sulfate
4134 REAL ratio
4135 ! Internal variable using K2SA
4136 REAL rk2sa
4137 ! Internal variables using KNA
4138 REAL rkna
4139 ! Internal variables using KNA
4140 REAL rknwet
4141 REAL rr1
4142 REAL rr2
4143 ! Ionic strength
4144 REAL stion
4145 ! Internal variables for temperature
4146 REAL t1
4147 ! Internal variables for temperature
4148 REAL t2
4149 ! Internal variables of convenience (
4150 REAL t21
4151 ! Internal variables of convenience (
4152 REAL t221
4153 ! Internal variables for temperature
4154 REAL t3
4155 ! Internal variables for temperature
4156 REAL t4
4157 ! Internal variables for temperature
4158 REAL t6
4159 ! Total ammonia and ammonium in micro
4160 REAL tnh4
4161 ! Total nitrate in micromoles / meter
4162 REAL tno3
4163 ! Tolerances for convergence test
4164 REAL toler1
4165 ! Tolerances for convergence test
4166 REAL toler2
4167 ! Total sulfate in micromoles / meter
4168 REAL tso4
4169 ! 2.0 * TSO4 (high ammonia case) (mo
4170 REAL twoso4
4171 ! Water mass fraction
4172 REAL wfrac
4173 ! micrograms / meter **3 on output
4174 REAL wh2o
4175 ! internally it is 10 ** (-6) kg (wat
4176 ! the conversion factor (1000 g = 1 k
4177 ! for AH2O output
4178 ! Aerosol liquid water content (inter
4179 ! internal variables ( high ammonia c
4180 REAL wsqd
4181 ! Nitrate aerosol concentration in mi
4182 REAL xno3
4183 ! Variable used in quadratic solution
4184 REAL xxq
4185 ! Ammonium aerosol concentration in m
4186 REAL ynh4
4187 ! Water variable saved in case ionic
4188 REAL zh2o
4190 REAL zso4
4191 ! Total sulfate molality - mso4 + mhs
4192 REAL cat(2) ! Array for cations (1, H+); (2, NH4+
4193 REAL an(3) ! Array for anions (1, SO4--); (2, NO
4194 REAL crutes(3) ! Coefficients and roots of
4195 REAL gams(2,3) ! Array of activity coefficients
4196 ! Minimum value of sulfate laerosol c
4197 REAL minso4
4198 PARAMETER (minso4=1.0E-6/mwso4)
4199 REAL floor
4200 PARAMETER (floor=1.0E-30)
4201 !-----------------------------------------------------------------------
4202 ! begin body of subroutine RPMARES
4204 !...convert into micromoles/m**3
4205 !cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
4206 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
4207 ! minimum concentration
4208 tso4 = max(0.0,so4/mwso4)
4209 tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
4210 tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
4211 !cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
4213 !...now set humidity index IRH as a percent
4215 irh = nint(100.0*rh)
4217 !...Check for valid IRH
4219 irh = max(1,irh)
4220 irh = min(99,irh)
4221 !cc WRITE(10,*)'RH,IRH ',RH,IRH
4223 !...Specify the equilibrium constants at correct
4224 !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA
4225 !... KPH, and K3 )
4226 !... Values from Kim et al. (1993) except as noted.
4228 convt = 1.0/(0.082*temp)
4229 t6 = 0.082E-9*temp
4230 t1 = 298.0/temp
4231 t2 = alog(t1)
4232 t3 = t1 - 1.0
4233 t4 = 1.0 + t2 - t1
4234 kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
4235 k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
4236 k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
4237 kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
4238 kph = 57.639*exp(13.79*t3-5.39*t4)*t6
4239 !cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6
4240 khat = kph*k1a/kw
4241 kan = kna*khat
4243 !...Compute temperature dependent equilibrium constant for NH4NO3
4244 !... ( from Mozurkewich, 1993)
4245 k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
4247 !...Convert to (micromoles/m**3) **2
4248 k3 = k3*convt*convt
4249 wh2o = 0.0
4250 stion = 0.0
4251 ah2o = 0.0
4252 mas = 0.0
4253 man = 0.0
4254 hplus = 0.0
4255 toler1 = 0.00001
4256 toler2 = 0.001
4257 nitr = 0
4258 nr = 0
4259 ratio = 0.0
4260 gamaan = 1.0
4261 gamold = 1.0
4263 !...set the ratio according to the amount of sulfate and nitrate
4264 IF (tso4>minso4) THEN
4265 ratio = tnh4/tso4
4267 !...If there is no sulfate and no nitrate, there can be no ammonium
4268 !... under the current paradigm. Organics are ignored in this version.
4270 ELSE
4272 IF (tno3==0.0) THEN
4274 ! *** If there is very little sulfate and no nitrate set concentrations
4275 ! to a very small value and return.
4276 aso4 = max(floor,aso4)
4277 ano3 = max(floor,ano3)
4278 wh2o = 0.0
4279 ah2o = 0.0
4280 gnh3 = max(floor,gnh3)
4281 gno3 = max(floor,gno3)
4282 RETURN
4283 END IF
4285 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
4286 !... to send the code to the high ammonia case
4288 ratio = 5.0
4289 END IF
4291 !....................................
4292 !......... High Ammonia Case ........
4293 !....................................
4295 IF (ratio>2.0) THEN
4297 gamaan = 0.1
4299 !...Set up twice the sulfate for future use.
4301 twoso4 = 2.0*tso4
4302 xno3 = 0.0
4303 ynh4 = twoso4
4305 !...Treat different regimes of relative humidity
4307 !...ZSR relationship is used to set water levels. Units are
4308 !... 10**(-6) kg water/ (cubic meter of air)
4309 !... start with ammomium sulfate solution without nitrate
4311 CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
4312 wh2o = 1.0E-3*ah2o
4313 aso4 = tso4*mwso4
4314 ano3 = 0.0
4315 anh4 = ynh4*mwnh4
4316 wfrac = ah2o/(aso4+anh4+ah2o)
4317 !cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water
4318 IF (wfrac<0.2) THEN
4320 !... dry ammonium sulfate and ammonium nitrate
4321 !... compute free ammonia
4323 fnh3 = tnh4 - twoso4
4324 cc = tno3*fnh3 - k3
4326 !...check for not enough to support aerosol
4328 IF (cc<=0.0) THEN
4329 xno3 = 0.0
4330 ELSE
4331 aa = 1.0
4332 bb = -(tno3+fnh3)
4333 disc = bb*bb - 4.0*cc
4335 !...Check for complex roots of the quadratic
4336 !... set nitrate to zero and RETURN if complex roots are found
4338 IF (disc<0.0) THEN
4339 xno3 = 0.0
4340 ah2o = 1000.0*wh2o
4341 ynh4 = twoso4
4342 gno3 = tno3*mwhno3
4343 gnh3 = (tnh4-ynh4)*mwnh3
4344 aso4 = tso4*mwso4
4345 ano3 = 0.0
4346 anh4 = ynh4*mwnh4
4347 RETURN
4348 END IF
4350 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
4352 dd = sqrt(disc)
4353 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4355 !...Since both roots are positive, select smaller root.
4357 xno3 = min(xxq/aa,cc/xxq)
4359 END IF
4360 ah2o = 1000.0*wh2o
4361 ynh4 = 2.0*tso4 + xno3
4362 gno3 = (tno3-xno3)*mwhno3
4363 gnh3 = (tnh4-ynh4)*mwnh3
4364 aso4 = tso4*mwso4
4365 ano3 = xno3*mwno3
4366 anh4 = ynh4*mwnh4
4367 RETURN
4369 END IF
4371 !...liquid phase containing completely neutralized sulfate and
4372 !... some nitrate. Solve for composition and quantity.
4374 mas = tso4/wh2o
4375 man = 0.0
4376 xno3 = 0.0
4377 ynh4 = twoso4
4378 phiold = 1.0
4380 !...Start loop for iteration
4382 !...The assumption here is that all sulfate is ammonium sulfate,
4383 !... and is supersaturated at lower relative humidities.
4385 DO nnn = 1, 150
4386 nitr = nnn
4387 gasqd = gamaan*gamaan
4388 wsqd = wh2o*wh2o
4389 kw2 = kan*wsqd/gasqd
4390 aa = 1.0 - kw2
4391 bb = twoso4 + kw2*(tno3+tnh4-twoso4)
4392 cc = -kw2*tno3*(tnh4-twoso4)
4394 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
4396 disc = bb*bb - 4.0*aa*cc
4398 !...Check for complex roots, if so set nitrate to zero and RETURN
4400 IF (disc<0.0) THEN
4401 xno3 = 0.0
4402 ah2o = 1000.0*wh2o
4403 ynh4 = twoso4
4404 gno3 = tno3*mwhno3
4405 gnh3 = (tnh4-ynh4)*mwnh3
4406 aso4 = tso4*mwso4
4407 ano3 = 0.0
4408 anh4 = ynh4*mwnh4
4409 !cc WRITE( 10, * ) ' COMPLEX ROOTS '
4410 RETURN
4411 END IF
4413 dd = sqrt(disc)
4414 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4415 rr1 = xxq/aa
4416 rr2 = cc/xxq
4418 !...Check for two non-positive roots, if so set nitrate to zero and RETURN
4419 IF (rr1 <= 0.0 .AND. rr2 <= 0.0) THEN
4420 xno3 = 0.0
4421 ah2o = 1000.0*wh2o
4422 ynh4 = twoso4
4423 gno3 = tno3*mwhno3
4424 gnh3 = (tnh4-ynh4)*mwnh3
4425 aso4 = tso4*mwso4
4426 ano3 = 0.0
4427 anh4 = ynh4*mwnh4
4428 ! WRITE(*,*) 'TWO NON-POSITIVE ROOTS!!! '
4429 RETURN
4430 END IF
4432 !...choose minimum positve root
4434 IF ((rr1*rr2)<0.0) THEN
4435 xno3 = max(rr1,rr2)
4436 ELSE
4437 xno3 = min(rr1,rr2)
4438 END IF
4439 xno3 = min(xno3,tno3)
4441 !...This version assumes no solid sulfate forms (supersaturated )
4442 !... Now update water
4444 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4446 !...ZSR relationship is used to set water levels. Units are
4447 !... 10**(-6) kg water/ (cubic meter of air)
4448 !... The conversion from micromoles to moles is done by the units of WH
4450 wh2o = 1.0E-3*ah2o
4452 !...Ionic balance determines the ammonium in solution.
4454 man = xno3/wh2o
4455 mas = tso4/wh2o
4456 mnh4 = 2.0*mas + man
4457 ynh4 = mnh4*wh2o
4459 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
4460 !... and ammonium in molal units (moles/(kg water) ).
4462 stion = 3.0*mas + man
4463 cat(1) = 0.0
4464 cat(2) = mnh4
4465 an(1) = mas
4466 an(2) = man
4467 an(3) = 0.0
4468 CALL actcof(cat,an,gams,molnu,phibar)
4469 gamaan = gams(2,2)
4471 !...Use GAMAAN for convergence control
4473 eror = abs(gamold-gamaan)/gamold
4474 gamold = gamaan
4476 !...Check to see if we have a solution
4478 IF (eror<=toler1) THEN
4479 !cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
4480 !cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
4482 aso4 = tso4*mwso4
4483 ano3 = xno3*mwno3
4484 anh4 = ynh4*mwnh4
4485 gno3 = (tno3-xno3)*mwhno3
4486 gnh3 = (tnh4-ynh4)*mwnh3
4487 ah2o = 1000.0*wh2o
4488 RETURN
4489 END IF
4491 END DO
4493 !...If after NITR iterations no solution is found, then:
4495 aso4 = tso4*mwso4
4496 ano3 = 0.0
4497 ynh4 = twoso4
4498 anh4 = ynh4*mwnh4
4499 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4500 gno3 = tno3*mwhno3
4501 gnh3 = (tnh4-ynh4)*mwnh3
4502 RETURN
4504 ELSE
4505 !......................................
4506 !......... Low Ammonia Case ...........
4507 !......................................
4509 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
4511 !...All cases covered by this logic
4512 wh2o = 0.0
4513 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4514 wh2o = 1.0E-3*ah2o
4515 zh2o = ah2o
4516 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4517 !... per cubic meter of air (1000 g = 1 kg)
4519 aso4 = tso4*mwso4
4520 anh4 = tnh4*mwnh4
4521 ano3 = 0.0
4522 gno3 = tno3*mwhno3
4523 gnh3 = 0.0
4525 !...Check for zero water.
4526 IF (wh2o==0.0) RETURN
4527 zso4 = tso4/wh2o
4529 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
4531 !cc IF ( ZSO4 .GT. 11.0 ) THEN
4533 !...do not solve for aerosol nitrate for total sulfate molality
4534 !... greater than 11.0 because the model parameters break down
4535 !... greater than 9.0 because the model parameters break down
4537 IF (zso4>9.0) & ! 18 June 97
4538 THEN
4539 RETURN
4540 END IF
4542 !...First solve with activity coeffs of 1.0, then iterate.
4543 phiold = 1.0
4544 gamana = 1.0
4545 gamas1 = 1.0
4546 gamas2 = 1.0
4547 gamaab = 1.0
4548 gamold = 1.0
4550 !...All ammonia is considered to be aerosol ammonium.
4551 mnh4 = tnh4/wh2o
4553 !...MNH4 is the molality of ammonium ion.
4554 ynh4 = tnh4
4556 !...loop for iteration
4557 DO nnn = 1, 150
4558 nitr = nnn
4560 !...set up equilibrium constants including activities
4561 !... solve the system for hplus first then sulfate & nitrate
4562 ! print*,'gamas,gamana',gamas1,gamas2,gamana
4563 rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
4564 rkna = kna/(gamana*gamana)
4565 rknwet = rkna*wh2o
4566 t21 = zso4 - mnh4
4567 t221 = zso4 + t21
4569 !...set up coefficients for cubic
4571 a2 = rk2sa + rknwet - t21
4572 a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
4573 a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
4575 CALL cubic(a2,a1,a0,nr,crutes)
4577 !...Code assumes the smallest positive root is in CRUTES(1)
4579 hplus = crutes(1)
4580 bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
4581 mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
4582 mhso4 = zso4 - & ! molality of bisulf
4583 mso4
4584 mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
4585 mna = max(0.0,mna)
4586 mna = min(mna,tno3/wh2o)
4587 xno3 = mna*wh2o
4588 ano3 = mna*wh2o*mwno3
4589 gno3 = (tno3-xno3)*mwhno3
4591 !...Calculate ionic strength
4592 stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
4594 !...Update water
4595 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4597 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4598 !... per cubic meter of air (1000 g = 1 kg)
4600 wh2o = 1.0E-3*ah2o
4601 cat(1) = hplus
4602 cat(2) = mnh4
4603 an(1) = mso4
4604 an(2) = mna
4605 an(3) = mhso4
4606 ! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
4607 CALL actcof(cat,an,gams,molnu,phibar)
4609 gamana = gams(1,2)
4610 gamas1 = gams(1,1)
4611 gamas2 = gams(1,3)
4612 gamaan = gams(2,2)
4614 gamahat = (gamas2*gamas2/(gamaab*gamaab))
4615 bhat = khat*gamahat
4616 !cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
4617 !cc PHIOLD = PHIBAR
4618 eror = abs(gamold-gamahat)/gamold
4619 gamold = gamahat
4621 !...write out molalities and activity coefficient
4622 !... and return with good solution
4624 IF (eror<=toler2) THEN
4625 !cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
4626 !cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
4627 !cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
4628 RETURN
4629 END IF
4631 END DO
4633 !...after NITR iterations, failure to solve the system, no ANO3
4635 gno3 = tno3*mwhno3
4636 ano3 = 0.0
4637 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4638 RETURN
4640 END IF
4641 ! ratio .gt. 2.0
4642 END SUBROUTINE rpmares_old
4644 !ia*********************************************************
4645 !ia *
4646 !ia BEGIN OF AEROSOL ROUTINE *
4647 !ia *
4648 !ia*********************************************************
4650 !***********************************************************************
4651 ! BEGIN OF AEROSOL CALCULATIONS
4652 !***********************************************************************
4653 !ia *
4654 !ia MAIN AEROSOL DYNAMICS ROUTINE *
4655 !ia based on MODELS3 formulation by FZB *
4656 !ia Modified by IA in May 97 *
4657 !ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
4658 !ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
4659 !ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
4660 !ia CALCULATIONS.
4661 !ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
4662 !ia ONE GRID CELL!!!!
4663 !ia and passed to dynamics calcs. subroutines.
4664 !ia *
4665 !ia Revision history *
4666 !ia When WHO WHAT *
4667 !ia ---- ---- ---- *
4668 !ia ???? FZB BEGIN *
4669 !ia 05/97 IA Adapted for use in CTM2-S *
4670 !ia Modified renaming/bug fixing *
4671 !ia 11/97 IA Modified for new model version
4672 !ia see comments under iarev02
4673 !ia 03/98 IA corrected error on pressure units
4674 !ia *
4675 !ia Called BY: CHEM *
4676 !ia *
4677 !ia Calls to: OUTPUT1,AEROPRC *
4678 !ia *
4679 !ia*********************************************************************
4681 ! end RPMares
4682 ! convapr_in is removed, it wasn't used indeed
4683 SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
4684 nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv, &
4685 nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, &
4686 soilrat_in,cblk,igrid,jgrid,kgrid,brrto)
4688 !USE module_configure, only: grid_config_rec_type
4689 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
4691 ! IMPLICIT NONE
4693 ! Includes:
4694 !iarev02 INCLUDE AEROINCL.EXT
4695 ! block size, set to 1 in column model ciarev0
4696 INTEGER blksize
4697 !ia kept to 1 in current version of column model
4698 ! actual number of cells in arrays ( default is
4699 INTEGER, PARAMETER :: numcells=1
4701 INTEGER layer
4702 ! number of layer (default is 1 in
4704 ! index for cell in blocked array (default is 1 in
4705 INTEGER, PARAMETER :: ncell=1
4706 ! *** inputs
4707 ! Input temperature [ K ]
4708 REAL temp
4709 ! Input relative humidity [ fraction ]
4710 REAL relhum
4711 ! Input pressure [ hPa ]
4712 REAL pres
4713 ! Input number for Aitken mode [ m**-3 ]
4714 REAL numnuc_in
4715 ! Input number for accumulation mode [ m**-3 ]
4716 REAL numacc_in
4717 ! Input number for coarse mode [ m**-3 ]
4718 REAL numcor_in
4719 ! sulfuric acid [ ug m**-3 ]
4720 REAL vsulf_in
4721 ! total sulfate vapor as sulfuric acid as
4722 ! sulfuric acid [ ug m**-3 ]
4723 REAL asulf_in
4724 ! total sulfate aerosol as sulfuric acid as
4725 ! i-mode sulfate input as sulfuric acid [ ug m*
4726 REAL asulfi_in
4727 ! ammonia gas [ ug m**-3 ]
4728 REAL nh3_in
4729 ! input value of nitric acid vapor [ ug m**-3 ]
4730 REAL nitrate_in
4731 ! Production rate of sulfuric acid [ ug m**-3
4732 REAL so4rat_in
4733 ! aerosol [ ug m**-3 s**-1 ]
4734 REAL soilrat_in
4735 ! Production rate of soil derived coarse
4736 ! Emission rate of i-mode EC [ug m**-3 s**-1]
4737 REAL eeci_in
4738 ! Emission rate of j-mode EC [ug m**-3 s**-1]
4739 REAL eecj_in
4740 ! Emission rate of j-mode org. aerosol [ug m**-
4741 REAL eorgi_in
4742 REAL eorgj_in
4743 ! Emission rate of j-mode org. aerosol [ug m**-
4744 ! total # of cond. vapors & SOA species
4745 INTEGER ncv
4746 ! # of anthrop. cond. vapors & SOA speci
4747 INTEGER nacv
4748 ! # of organic aerosol precursor
4749 INTEGER ldrog_vbs
4750 REAL drog_in(ldrog_vbs) ! organic aerosol precursor [ppm]
4751 ! Input delta ROG concentration of
4752 REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
4753 REAL drog(blksize,ldrog_vbs) ! organic aerosol precursor [ppm]
4755 REAL brrto
4756 !bs
4757 ! *** Primary emissions rates: [ ug / m**3 s ]
4759 ! *** emissions rates for unidentified PM2.5 mass
4760 ! Delta ROG concentration of
4761 REAL epm25i(blksize) ! Aitken mode
4762 REAL epm25j(blksize)
4763 ! *** emissions rates for primary organic aerosol
4764 ! Accumululaton mode
4765 REAL eorgi(blksize) ! Aitken mode
4766 REAL eorgj(blksize)
4767 ! *** emissions rates for elemental carbon
4768 ! Accumululaton mode
4769 REAL eeci(blksize) ! Aitken mode
4770 REAL eecj(blksize)
4771 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
4773 ! Accumululaton mode
4774 REAL epm25(blksize) ! emissions rate for PM2.5 mass
4775 REAL esoil(blksize) ! emissions rate for soil derived coarse a
4776 REAL eseas(blksize) ! emissions rate for marine coarse aerosol
4777 REAL epmcoarse(blksize)
4778 ! emissions rate for anthropogenic coarse
4780 REAL dtsec
4781 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
4783 REAL newm3
4784 REAL totaersulf
4785 ! total aerosol sulfate
4786 ! loop index for time steps
4787 INTEGER numsteps
4788 REAL step
4790 ! *** arrays for aerosol model codes:
4792 ! synchronization time [s]
4794 INTEGER nspcsda
4796 ! number of species in CBLK ciarev02
4797 REAL cblk(blksize,nspcsda)
4799 ! *** Meteorological information in blocked arays:
4801 ! *** Thermodynamic variables:
4803 ! main array of variables
4804 REAL blkta(blksize) ! Air temperature [ K ]
4805 REAL blkprs(blksize) ! Air pressure in [ Pa ]
4806 REAL blkdens(blksize) ! Air density [ kg m^-3 ]
4807 REAL blkrh(blksize)
4809 ! *** Chemical production rates [ ug m**-3 s -1 ] :
4811 ! Fractional relative humidity
4812 REAL so4rat(blksize) ! rate [ug/m^3/s]
4813 ! sulfuric acid vapor-phase production
4814 REAL organt1rat(blksize) ! production rate from aromatics [ ug /
4815 ! anthropogenic organic aerosol mass
4816 REAL organt2rat(blksize) ! production rate from aromatics [ ug /
4817 ! anthropogenic organic aerosol mass
4818 REAL organt3rat(blksize) ! rate from alkanes & others [ ug / m^3
4819 ! anthropogenic organic aerosol mass pro
4820 REAL organt4rat(blksize) ! rate from alkanes & others [ ug / m^3
4821 ! anthropogenic organic aerosol mass pro
4822 REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ]
4823 ! biogenic organic aerosol production
4824 REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ]
4825 ! biogenic organic aerosol production
4826 REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ]
4827 ! biogenic organic aerosol production
4828 REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ]
4829 !bs
4830 ! *** atmospheric properties
4832 ! biogenic organic aerosol production
4833 REAL xlm(blksize) ! atmospheric mean free path [ m ]
4834 REAL amu(blksize)
4835 ! *** aerosol properties:
4837 ! *** modal diameters:
4839 ! atmospheric dynamic viscosity [ kg
4840 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
4841 REAL dgacc(blksize) ! accumulation geometric mean diamet
4842 REAL dgcor(blksize)
4844 ! *** Modal mass concentrations [ ug m**3 ]
4846 ! coarse mode geometric mean diamete
4847 REAL pmassn(blksize) ! mass concentration in Aitken mode
4848 REAL pmassa(blksize) ! mass concentration in accumulation
4849 REAL pmassc(blksize)
4850 ! *** average modal particle densities [ kg/m**3 ]
4852 ! mass concentration in coarse mode
4853 REAL pdensn(blksize) ! average particle density in nuclei
4854 REAL pdensa(blksize) ! average particle density in accumu
4855 REAL pdensc(blksize)
4856 ! *** average modal Knudsen numbers
4858 ! average particle density in coarse
4859 REAL knnuc(blksize) ! nuclei mode Knudsen number
4860 REAL knacc(blksize) ! accumulation Knudsen number
4861 REAL kncor(blksize)
4862 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
4864 ! coarse mode Knudsen number
4865 REAL fconcn(blksize)
4866 ! reciprocal condensation rate Aitke
4867 REAL fconca(blksize) !bs
4868 ! reciprocal condensation rate acclu
4869 REAL fconcn_org(blksize)
4870 REAL fconca_org(blksize)
4872 ! *** Rates for secondary particle formation:
4874 ! *** production of new mass concentration [ ug/m**3 s ]
4875 REAL dmdt(blksize) ! by particle formation
4877 ! *** production of new number concentration [ number/m**3 s ]
4879 ! rate of production of new mass concen
4880 REAL dndt(blksize) ! by particle formation
4881 ! *** growth rate for third moment by condensation of precursor
4882 ! vapor on existing particles [ 3rd mom/m**3 s ]
4884 ! rate of producton of new particle num
4885 REAL cgrn3(blksize) ! Aitken mode
4886 REAL cgra3(blksize)
4887 ! *** Rates for coaglulation: [ m**3/s ]
4889 ! *** Unimodal Rates:
4891 ! Accumulation mode
4892 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
4893 REAL ura00(blksize)
4895 ! *** Bimodal Rates: Aitken mode with accumulation mode ( Aitken mode)
4896 ! accumulation mode 0th moment self-coagulat
4897 REAL brna01(blksize) ! rate for 0th moment
4898 REAL brna31(blksize)
4899 ! *** other processes
4901 ! rate for 3rd moment
4902 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
4904 ! *** housekeeping variables:
4905 ! increment of concentration added to
4906 INTEGER unit
4907 PARAMETER (unit=30)
4908 CHARACTER*16 pname
4909 PARAMETER (pname=' BOX ')
4910 INTEGER isp,igrid,jgrid,kgrid
4912 ! loop index for species.
4913 INTEGER ii, iimap(8)
4914 DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
4916 ! begin body of program box
4918 ! *** Set up files and other info
4919 ! *** set up experimental conditions
4920 ! *** initialize model variables
4921 !ia *** not required any more
4923 !ia DO ISP = 1, NSPCSDA
4924 !ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
4925 !ia END DO
4927 step = dtsec ! set time step
4929 blkta(blksize) = temp ! T in Kelvin
4931 blkprs(blksize)= pres*100. ! P in Pa (pres is given in
4933 blkrh(blksize) = relhum ! fractional RH
4935 blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in
4937 !rs CBLK(BLKSIZE,VHNO3) = nitrate_in
4938 !rs CBLK(BLKSIZE,VNH3) = nh3_in
4939 !bs
4940 !rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
4941 !rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
4942 !rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
4943 !rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
4944 !rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
4945 !rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
4946 !rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
4947 !rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
4949 DO isp = 1, ldrog_vbs
4950 drog(blksize,isp) = drog_in(isp)
4951 END DO
4953 ! print*,'drog in rpm',drog
4954 !bs
4955 !ia *** 27/05/97 the following variables are transported quantities
4956 !ia *** of the column-model now and thuse do not need this init.
4957 !ia *** step.
4959 ! CBLK(BLKSIZE,VNU0) = numnuc_in
4960 ! CBLK(BLKSIZE,VAC0) = numacc_in
4961 ! CBLK(BLKSIZE,VSO4A) = asulf_in
4962 ! CBLK(BLKSIZE,VSO4AI) = asulfi_in
4963 ! CBLK(BLKSIZE, VCORN) = numcor_in
4965 so4rat(blksize) = so4rat_in
4967 !...INITIALISE EMISSION RATES
4969 ! epm25i(blksize) = & ! unidentified PM2.5 mass
4970 ! 0.0
4971 ! epm25j(blksize) = &
4972 ! 0.0
4973 ! unidentified PM2.5 m
4974 eorgi(blksize) = & ! primary organic
4975 eorgi_in
4976 eorgj(blksize) = &
4977 eorgj_in
4978 ! primary organic
4979 eeci(blksize) = & ! elemental carbon
4980 eeci_in
4981 eecj(blksize) = &
4982 eecj_in
4983 ! elemental carbon
4984 epm25(blksize) = & !currently from input file ACTIONIA
4985 0.0
4986 esoil(blksize) = & ! ACTIONIA
4987 soilrat_in
4988 eseas(blksize) = & !currently from input file ACTIONIA
4989 0.0
4990 ! epmcoarse(blksize) = & !currently from input file ACTIONIA
4991 ! 0.0
4992 dgnuc(blksize) = dginin
4993 dgacc(blksize) = dginia
4994 dgcor(blksize) = dginic
4995 newm3 = 0.0
4997 ! *** Set up initial total 3rd moment factors
4999 totaersulf = 0.0
5000 newm3 = 0.0
5001 ! *** time loop
5002 ! write(50,*) ' numsteps dgnuc dgacc ', ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5004 ! *** Call aerosol routines
5005 CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5006 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat, &
5007 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5008 nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5009 amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5010 knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5011 urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid,brrto)
5013 ! *** write output
5014 ! WRITE(UNIT,*) ' AFTER AEROPROC '
5015 ! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5017 ! *** Write out file for graphing.
5019 ! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5022 ! *** update sulfuric acid vapor
5023 !ia 21.04.98 this update is not required here
5024 !ia artefact from box model
5025 ! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5026 ! & SO4RAT(BLKSIZE) * STEP
5028 RETURN
5029 END SUBROUTINE rpmmod3
5030 !---------------------------------------------------------------------------
5031 SUBROUTINE soa_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
5032 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5033 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto)
5035 !***** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM *!
5036 !bs Description: !
5037 !bs !
5038 !bs SOA_VBS calculates the formation and partitioning of secondary !
5039 !bs organic aerosol based on (pseudo-)ideal solution thermodynamics. !
5040 !bs !
5041 !sam The original Schell model (JGR, vol. 106, D22, 28275-28293, 2001) !
5042 !sam is modified drastically to incorporate the SOA vapor-pressure !
5043 !sam basis set approach developed by Carnegie Mellon folks. !
5044 !sam Recommended changes according to Allen Robinson, 9/15/09 !
5045 !sam The treatment is done very similar to Lane et al., Atmos. Envrn., !
5046 !sam vol 42, 7439-7451, 2008. !
5047 !sam Four basis vapor-pressures for anthropogenic and 4 basis vp's !
5048 !sam for biogenic SOA are used. The SAPRC-99 yield information for !
5049 !sam low and high NOx conditions (Lane, Donahue and Pandis, ES&T, !
5050 !sam vol. 42, 6022-6027, 2008) are mapped to RADM2/RACM species. !
5051 !sam !
5052 !sam Basis vapor pressures (@ 300K) !
5053 !sam Anthro (1 ug/m3) - asoa1 Biogenic (1 ug/m3) - bsoa1 !
5054 !sam Anthro (10 ug/m3) - asoa2 Biogenic (10 ug/m3) - bsoa2 !
5055 !sam Anthro (100 ug/m3) - asoa3 Biogenic (100 ug/m3) - bsoa3 !
5056 !sam Anthro (1000 ug/m3)- asoa4 Biogenic (1000 ug/m3)- bsoa4 !
5057 !bs !
5058 !bs This code considers two cases: !
5059 !bs i) initil absorbing mass is existend in the aerosol phase !
5060 !bs ii) a threshold has to be exeeded before partitioning (even below !
5061 !bs saturation) will take place. !
5062 !bs !
5063 !bs The temperature dependence of the saturation concentrations are !
5064 !bs calculated using the Clausius-Clapeyron equation. !
5065 !bs !
5066 !bs If there is no absorbing mass at all the Pandis method is applied !
5067 !bs for the first steps. !
5068 !bs !
5069 !bs References: !
5070 !bs Pankow (1994): !
5071 !bs An absorption model of the gas/aerosol !
5072 !bs partitioning involved in the formation of !
5073 !bs secondary organic aerosol, Atmos. Environ. 28(2), !
5074 !bs 189-193. !
5075 !bs Odum et al. (1996): !
5076 !bs Gas/particle partitioning and secondary organic !
5077 !bs aerosol yields, Environ. Sci. Technol. 30, !
5078 !bs 2580-2585. !
5079 !bs see also !
5080 !bs Bowman et al. (1997): !
5081 !bs Mathematical model for gas-particle partitioning !
5082 !bs of secondary organic aerosols, Atmos. Environ. !
5083 !bs 31(23), 3921-3931. !
5084 !bs Seinfeld and Pandis (1998): !
5085 !bs Atmospheric Chemistry and Physics (0-471-17816-0) !
5086 !bs chapter 13.5.2 Formation of binary ideal solution !
5087 !bs with -- preexisting aerosol !
5088 !bs -- other organic vapor !
5089 !bs !
5090 !bs Called by: SOA_VBS !
5091 !bs !
5092 !bs Calls: None !
5093 !bs !
5094 !bs Arguments: LAYER, !
5095 !bs BLKTA, BLKPRS, !
5096 !bs ORGARO1RAT, ORGARO2RAT, !
5097 !bs ORGALK1RAT, ORGOLE1RAT, !
5098 !bs ORGBIO1RAT, ORGBIO2RAT, !
5099 !bs ORGBIO3RAT, ORGBIO4RAT, !
5100 !bs DROG, LDROG, NCV, NACV, !
5101 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
5102 !bs DT !
5103 !bs !
5104 !bs Include files: AEROSTUFF.EXT !
5105 !bs AERO_internal.EXT !
5106 !bs !
5107 !bs Data: None !
5108 !bs !
5109 !bs Input files: None !
5110 !bs !
5111 !bs Output files: None !
5112 !bs !
5113 !bs--------------------------------------------------------------------!
5114 !bs !
5115 !bs History: !
5116 !bs No Date Author Change !
5117 !bs ____ ______ ________________ _________________________________ !
5118 ! 01 052011 McKeen/Ahmadov Subroutine development !
5120 USE module_configure, only: grid_config_rec_type
5122 ! model layer
5123 INTEGER layer
5124 ! dimension of arrays
5125 INTEGER blksize
5126 ! number of species in CBLK
5127 INTEGER nspcsda ! actual number of cells in arrays
5128 INTEGER numcells ! # of organic aerosol precursor
5129 INTEGER ldrog_vbs ! total # of cond. vapors & SOA sp
5130 INTEGER ncv ! # of anthrop. cond. vapors & SOA
5131 INTEGER nacv
5132 INTEGER igrid,jgrid,kgrid
5134 REAL cblk(blksize,nspcsda) ! main array of variables
5135 REAL dt ! model time step in SECONDS
5136 REAL blkta(blksize) ! Air temperature [ K ]
5137 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5139 REAL, INTENT(OUT) :: brrto ! branching ratio for NOx conditions
5141 ! anthropogenic organic vapor production rates
5143 REAL organt1rat(blksize) ! rates from
5144 REAL organt2rat(blksize) ! rates from
5145 REAL organt3rat(blksize) ! rates from
5146 REAL organt4rat(blksize) ! rates from
5148 ! biogenic organic vapor production rates
5149 REAL orgbio1rat(blksize)
5150 REAL orgbio2rat(blksize)
5151 REAL orgbio3rat(blksize)
5152 REAL orgbio4rat(blksize)
5153 REAL drog(blksize,ldrog_vbs) !blksize=1, ldrog_vbs=9+1, the last ldrog_vbs is actually is the branching ratio
5155 !bs * local variable declaration
5156 ! Delta ROG conc. [ppm]
5157 !bs numerical value for a minimum thresh
5158 REAL,PARAMETER :: thrsmin=1.E-19
5159 !bs numerical value for a minimum thresh
5160 !bs
5161 !bs universal gas constant [J/mol-K]
5162 REAL, PARAMETER :: rgas=8.314510
5164 !sam reference temperature T0 = 300 K, a change from original 298K
5165 REAL, PARAMETER :: tnull=300.
5167 !bs molecular weight for C
5168 REAL, PARAMETER :: mwc=12.0
5169 !bs molecular weight for organic species
5170 REAL, PARAMETER :: mworg=175.0
5171 !bs molecular weight for SO4
5172 REAL, PARAMETER :: mwso4=96.0576
5173 !bs molecular weight for NH4
5174 REAL, PARAMETER :: mwnh4=18.03858
5175 !bs molecular weight for NO3
5176 REAL, PARAMETER :: mwno3=62.01287
5177 ! molecular weight for AIR
5179 ! REAL mwair
5180 ! PARAMETER (mwair=28.964)
5181 !bs relative tolerance for mass check
5182 REAL, PARAMETER :: CABSMIN=.00001 ! Minimum amount of absorbing material - needed in iteration method
5183 !sm number of basis set variables in CMU partitioning scheme
5184 INTEGER, PARAMETER :: nbin=4 ! we use 4 bin volatility according to Robinson A. et al.
5186 ! we have 2 type of SOA - anthropogenic and biogenic
5187 !sm number of SAPRC species variables in CMU lumped partitioning table
5188 !sm 1=ALK4(hc5),2=ALK5(hc8),3=OLE1(ol2),4=OLE2(oli),5=ARO1(tol)
5189 !sm 6=AOR2(xyl),7=ISOP(iso),8=SESQ(?),9=TERP(alp)
5190 INTEGER, PARAMETER :: nsaprc=9 ! number of precursor classes
5192 !bs loop indices
5193 INTEGER lcell, n, l, ll, bn, cls
5194 !bs conversion factor ppm --> ug/m^3
5195 REAL convfac
5196 !bs difference of inverse temperatures
5197 REAL ttinv
5198 !bs initial organic absorbing mass [ug/m^3]
5199 REAL minit
5200 !bs inorganic mass [ug/m^3]
5201 REAL mnono
5202 !bs total organic mass [ug/m^3]
5203 REAL mtot
5205 ! REAL msum(ncv) !bs input total mass [ug/m^3]
5206 REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
5207 REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
5208 REAL dhvap(ncv) !bs heat of vaporisation of compound i [
5209 REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]
5210 REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
5211 REAL cgas(ncv) !bs gasphase concentration of cond. vapors
5212 REAL caer(ncv) !bs aerosolphase concentration of cond.
5213 REAL asav(ncv) !bs saved CAER for iteration
5214 REAL aold(ncv) !bs saved CAER for rate determination
5215 REAL csat(ncv) !bs saturation conc. of cond. vapor ug/,
5217 ! in basis set approach we need only 4 csat
5218 REAL ccsat(nbin)
5219 REAL ccaer(nbin)
5220 REAL cctot(nbin)
5221 REAL w1(nbin), w2(nbin)
5223 REAL prod(ncv) !bs production of condensable vapor ug/
5224 REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]
5225 REAL f(ldrog_vbs) !bs scaling factor for ind. oxidant
5227 REAL alphlowN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors low NOx condition
5228 REAL alphhiN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors high NOx condition
5229 REAL alphai(nbin,nsaprc) ! mass-based stoichometric yield for product i and csti is the effective saturation
5230 ! concentration in ug m^-3
5231 REAL mwvoc(nsaprc) ! molecular weight of the SOA precusors
5233 REAL PnGtotal,DUM,FMTOT,FMTOT2,DUM2 ! Real constants used in Newton iteration
5234 integer, save :: icall
5236 ! this is a correction factor to take into account the density of aerosols, from Murphy et al. (2009)
5237 ! Now it's determined by namelist
5239 ! in the preliminary version we use alphlowN only to check what would be the maximum yeild
5240 ! SAM: from Murphy et al. 2009
5241 DATA alphlowN / &
5242 0.0000, 0.0750, 0.0000, 0.0000, & ! ALK4
5243 0.0000, 0.3000, 0.0000, 0.0000, & ! ALK5
5244 0.0045, 0.0090, 0.0600, 0.2250, & ! OLE1
5245 0.0225, 0.0435, 0.1290, 0.3750, & ! OLE2
5246 0.0750, 0.2250, 0.3750, 0.5250, & ! ARO1
5247 0.0750, 0.3000, 0.3750, 0.5250, & ! ARO2
5248 0.0090, 0.0300, 0.0150, 0.0000, & ! ISOP
5249 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5250 0.1073, 0.0918, 0.3587, 0.6075/ ! TERP
5252 DATA alphhiN / &
5253 0.0000, 0.0375, 0.0000, 0.0000, & ! ALK4
5254 0.0000, 0.1500, 0.0000, 0.0000, & ! ALK5
5255 0.0008, 0.0045, 0.0375, 0.1500, & ! OLE1
5256 0.0030, 0.0255, 0.0825, 0.2700, & ! OLE2
5257 0.0030, 0.1650, 0.3000, 0.4350, & ! ARO1
5258 0.0015, 0.1950, 0.3000, 0.4350, & ! ARO2
5259 0.0003, 0.0225, 0.0150, 0.0000, & ! ISOP
5260 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5261 0.0120, 0.1215, 0.2010, 0.5070/ ! TERP
5263 DATA mwvoc / &
5264 73.23, & ! ALK4
5265 106.97, & ! ALK5
5266 61.68, & ! OLE1
5267 79.05, & ! OLE2
5268 100.47, & ! ARO1
5269 113.93, & ! ARO2
5270 68.12, & ! ISOP
5271 204.0, & ! SESQ
5272 136.24 / ! TERP
5274 !bs * initialisation
5275 !bs
5276 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
5277 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5278 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5279 !bs * average value is 156 kJ/mol
5280 !
5281 !sam changed 156kJ/mol to 30.kJ/mol as in Lane et al., AE, 2008
5282 dhvap(pasoa1) = 30.0E03
5283 dhvap(pasoa2) = 30.0E03
5284 dhvap(pasoa3) = 30.0E03
5285 dhvap(pasoa4) = 30.0E03
5287 dhvap(pbsoa1) = 30.0E03
5288 dhvap(pbsoa2) = 30.0E03
5289 dhvap(pbsoa3) = 30.0E03
5290 dhvap(pbsoa4) = 30.0E03
5291 !----------------------------------------------------------------
5292 !bs
5293 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
5294 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5295 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5296 !bs * average value is 222.5 g/mol
5297 !bs *
5298 !bs * molecular weights used are estimates taking the origin (reactants)
5299 !bs * into account. This should be updated if more information about
5300 !bs * the products is available.
5301 !bs * First hints are taken from Forstner et al. (1997), Environ. S
5302 !bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmos.
5303 !bs * Environ. 31(13), 1953-1964.
5304 !bs *
5305 ! Molecular weights of OCVs as in Murphy and Pandis, 2009
5306 mwcv(pasoa1) = 150.
5307 mwcv(pasoa2) = 150.
5308 mwcv(pasoa3) = 150.
5309 mwcv(pasoa4) = 150.
5311 mwcv(pbsoa1) = 180.
5312 mwcv(pbsoa2) = 180.
5313 mwcv(pbsoa3) = 180.
5314 mwcv(pbsoa4) = 180.
5316 ! In Shell partitioned aerosols according to their precursors, but we do as Allen due to the saturation concentrations
5317 ! We have 2 sets for anthropogenic and biogenic and therefore we use the same denotation
5318 pnull(pasoa1) = 1.
5319 pnull(pasoa2) = 10.
5320 pnull(pasoa3) = 100.
5321 pnull(pasoa4) = 1000.
5323 pnull(pbsoa1) = 1.
5324 pnull(pbsoa2) = 10.
5325 pnull(pbsoa3) = 100.
5326 pnull(pbsoa4) = 1000.
5328 ! scaling factors, for testing purposes, check TOL and ISO only
5329 ! 05/23/2011: for testing all are zero!
5330 f(palk4) = 1.
5331 f(palk5) = 1.
5332 f(pole1) = 1.
5333 f(pole2) = 1.
5334 f(paro1) = 1.
5335 f(paro2) = 1.
5336 f(pisop) = 1.
5337 f(pterp) = 1.
5338 f(psesq) = 1.
5340 loop_cells: DO lcell = 1, numcells ! numcells=1
5341 DO l= 1, ldrog_vbs-1
5342 drog(lcell,l) = f(l)*drog(lcell,l)
5343 END DO
5345 ! calculation of the yields using the branching ratio
5346 brrto= drog(lcell,pbrch) ! temporary variable for the branching ratio
5347 DO bn=1,nbin ! bins
5348 DO cls=1,nsaprc ! classes
5349 alphai(bn,cls)= mwvoc(cls)*( alphhiN(bn,cls)*brrto + alphlowN(bn,cls)*(1.-brrto) )
5350 ENDDO
5351 ENDDO
5353 ttinv = 1./tnull - 1./blkta(lcell)
5354 convfac = blkprs(lcell)/(rgas*blkta(lcell))
5356 ! cblk for gases comes in ppmv, we get the density in ug/m3 (microgram/m3)
5357 ! by multiplying it by (convfac=rho_air/mu_air)x mwcv
5358 cgas(pasoa1) = cblk(lcell,vcvasoa1)*convfac*mwcv(pasoa1)
5359 cgas(pasoa2) = cblk(lcell,vcvasoa2)*convfac*mwcv(pasoa2)
5360 cgas(pasoa3) = cblk(lcell,vcvasoa3)*convfac*mwcv(pasoa3)
5361 cgas(pasoa4) = cblk(lcell,vcvasoa4)*convfac*mwcv(pasoa4)
5363 cgas(pbsoa1) = cblk(lcell,vcvbsoa1)*convfac*mwcv(pbsoa1)
5364 cgas(pbsoa2) = cblk(lcell,vcvbsoa2)*convfac*mwcv(pbsoa2)
5365 cgas(pbsoa3) = cblk(lcell,vcvbsoa3)*convfac*mwcv(pbsoa3)
5366 cgas(pbsoa4) = cblk(lcell,vcvbsoa4)*convfac*mwcv(pbsoa4)
5368 ! cblk for aerosols come in density (ug/m3), converted already in soa_vbs_driver
5369 caer(pasoa1) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)
5370 caer(pasoa2) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)
5371 caer(pasoa3) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)
5372 caer(pasoa4) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)
5374 caer(pbsoa1) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)
5375 caer(pbsoa2) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)
5376 caer(pbsoa3) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)
5377 caer(pbsoa4) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)
5379 ! #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
5380 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5381 !SAM diagnostics
5382 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5383 ! if (igrid .eq. 1 .AND. jgrid .eq. 18) then
5384 ! if (kgrid .eq. 1 )then
5385 ! write(6,*)'drog', drog
5386 ! write(6,*)'caer(pasoa1)',caer(pasoa1)
5387 ! write(6,*)'caer(pasoa4)',caer(pasoa4)
5388 ! write(6,*)'caer(pbsoa1)',caer(pbsoa1)
5389 ! endif
5390 ! endif
5391 !SAM end print of aerosol physical parameter diagnostics
5392 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5393 ! #endif
5394 ! Production of SOA by oxidation of VOCs
5395 ! There are 6 classes of the precursors for ansthropogenic SOA
5396 prod(pasoa1) = alphai(1,1)*drog(lcell,palk4) + alphai(1,2)*drog(lcell,palk5) + &
5397 alphai(1,3)*drog(lcell,pole1) + alphai(1,4)*drog(lcell,pole2) + &
5398 alphai(1,5)*drog(lcell,paro1) + alphai(1,6)*drog(lcell,paro2)
5400 prod(pasoa2) = alphai(2,1)*drog(lcell,palk4) + alphai(2,2)*drog(lcell,palk5) + &
5401 alphai(2,3)*drog(lcell,pole1) + alphai(2,4)*drog(lcell,pole2) + &
5402 alphai(2,5)*drog(lcell,paro1) + alphai(2,6)*drog(lcell,paro2)
5404 prod(pasoa3) = alphai(3,1)*drog(lcell,palk4) + alphai(3,2)*drog(lcell,palk5) + &
5405 alphai(3,3)*drog(lcell,pole1) + alphai(3,4)*drog(lcell,pole2) + &
5406 alphai(3,5)*drog(lcell,paro1) + alphai(3,6)*drog(lcell,paro2)
5408 prod(pasoa4) = alphai(4,1)*drog(lcell,palk4) + alphai(4,2)*drog(lcell,palk5) + &
5409 alphai(4,3)*drog(lcell,pole1) + alphai(4,4)*drog(lcell,pole2) + &
5410 alphai(4,5)*drog(lcell,paro1) + alphai(4,6)*drog(lcell,paro2)
5412 ! There are 3 classes of the precursors for biogenic SOA
5413 prod(pbsoa1) = alphai(1,7)*drog(lcell,pisop) + alphai(1,8)*drog(lcell,psesq) + &
5414 alphai(1,9)*drog(lcell,pterp)
5416 prod(pbsoa2) = alphai(2,7)*drog(lcell,pisop) + alphai(2,8)*drog(lcell,psesq) + &
5417 alphai(2,9)*drog(lcell,pterp)
5419 prod(pbsoa3) = alphai(3,7)*drog(lcell,pisop) + alphai(3,8)*drog(lcell,psesq) + &
5420 alphai(3,9)*drog(lcell,pterp)
5422 prod(pbsoa4) = alphai(4,7)*drog(lcell,pisop) + alphai(4,8)*drog(lcell,psesq) + &
5423 alphai(4,9)*drog(lcell,pterp)
5425 !bs * calculate actual production from gasphase reactions [ug/m^3]
5426 !bs * calculate vapor pressure of pure compound as a liquid using the Clausius-Clapeyron equation and the actual saturation concentration.
5427 !bs * calculate the threshold for partitioning if no initial mass is present to partition into.
5429 loop_cc: DO l = 1,ncv ! we've total ncv=4*2 bins, no alpha is needed here
5430 prod(l) = convfac*prod(l) ! get in density units (ug/m3) from ppmv, (convfac=rho_air/mu_air)
5431 ctot(l) = prod(l) + cgas(l) + caer(l)
5432 aold(l) = caer(l)
5434 ! csat should be calculated 4 times, since pnull is the same for biogenic!
5435 csat(l) = pnull(l)*tnull/blkta(lcell)*exp(dhvap(l)/rgas*ttinv)
5436 END DO loop_cc
5438 ! when we solve the nonlinear equation to determine "caer" we need to combine
5439 ! asoa(n) and bsoa(n), since they have the same saturation concentrations, hence the equilibrium should cover the same bins
5441 PnGtotal=0. ! track total Condensed Vapors&SOA over bins for limits on Newton Iteration of total SOA mass
5442 do ll=1,nbin
5443 ccsat(ll)= csat(ll)
5444 ccaer(ll)= caer(ll) + caer(ll+4)
5445 cctot(ll)= ctot(ll) + ctot(ll+4)
5446 PnGtotal=PnGtotal+cctot(ll)
5447 w1(ll)= ctot(ll)/cctot(ll) ! Anthropogenic fraction to total
5448 w2(ll)= 1. - w1(ll) ! Biogenic fraction of total
5449 end do
5451 !bs
5452 !bs * small amount of non-volatile absorbing mass is assumed to be
5453 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
5454 !bs * mass in each size section, here mode)
5455 !bs
5456 ! inorganic mass isn't needed here
5457 !mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+ cblk(lcell,vno3aj))
5458 !mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+ cblk(lcell,vno3ai))
5460 ! they're assigned to zero at the next step
5461 ! test with minit=0
5462 ! minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) !+ mnono
5463 minit= 1.4*( cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) ) ! exclude EC from absorbing mass
5465 ! minit is taken into account
5467 !bs * If MINIT is set to zero partitioning will occur if the pure
5468 !bs * saturation concentation is exceeded (Pandis et al. 1992).
5469 !bs * If some amount of absorbing organic mass is formed gas/particle
5470 !bs * partitioning will follow the ideal solution approach.
5471 !bs
5472 !SAM 9/8/09 - Include absorbing SOA material within aerosols in calculation !
5474 minit = AMAX1(minit,CABSMIN)
5476 ! mtot is initial guess to SOA mass (aerosol plus extra absorbing mass (minit))
5477 mtot = 0.
5478 DO L=1,NBIN
5479 mtot = mtot + AMIN1(1.,CCTOT(L)/CCSAT(L))*CCTOT(L)
5480 ENDDO
5481 mtot = mtot + minit
5482 !
5483 ! debugging
5484 !if (igrid .eq. 8 .AND. jgrid .eq. 18) then
5485 ! if (kgrid .eq. 1 )then
5486 ! write(6,*)'before Newton iteration'
5487 ! write(6,*)'MTOT=',MTOT
5488 ! write(6,*)'minit=',minit
5489 ! write(6,*)'w1=',w1,'w2=',w2
5490 ! write(6,*)'cctot=',cctot
5491 ! write(6,*)'ccaer=',ccaer
5492 ! write(6,*)'ccsat=',ccsat
5493 ! write(6,*)'nbin=',nbin
5494 ! endif
5495 !endif
5497 !SAM: Find total SOA mass from newton iteration, needs only 5 iterations for exact solution
5498 loop_newt: DO LL=1,5 ! Fixed Newton iteration number
5499 FMTOT=0.
5500 FMTOT2=0.
5501 DO L=1,NBIN
5502 DUM=CCTOT(L)/(1.+CCSAT(L)/MTOT)
5503 FMTOT=FMTOT+DUM
5504 FMTOT2=FMTOT2+DUM**2
5505 ENDDO
5506 FMTOT=FMTOT+MINIT ! Forecast total SOA mass
5507 DUM=MTOT-FMTOT
5508 DUM2=((FMTOT-MINIT)/MTOT)-MTOT*FMTOT2
5509 MTOT=MTOT-DUM/(1.-DUM2)
5510 MTOT=AMAX1(MTOT,MINIT) ! Limit MTOT to min possible in case of instability
5511 MTOT=AMIN1(MTOT,PnGtotal+minit) ! Limit MTOT to max possible in case of instability
5512 END DO loop_newt ! LL iteration number loop
5514 ! Have total mass MTOT, get aerosol mass from semi-ideal partitioning equation
5515 DO L=1,NBIN
5516 CCAER(L)=CCTOT(L)*MTOT/(MTOT+CCSAT(L))
5517 ENDDO
5518 !
5520 do ll=1,nbin
5521 caer(ll)= AMAX1(w1(ll)*ccaer(ll),CONMIN)
5522 caer(ll+4)= AMAX1(w2(ll)*ccaer(ll),CONMIN)
5523 cgas(ll)= w1(ll)*(cctot(ll) - ccaer(ll))
5524 cgas(ll+4)= w2(ll)*(cctot(ll) - ccaer(ll))
5525 end do
5527 ! assigning values to CBLK array (gases), convert to ppm since it goes to chem
5528 cblk(lcell,vcvasoa1) = max(cgas(pasoa1),conmin)/convfac/mwcv(pasoa1)
5529 cblk(lcell,vcvasoa2) = max(cgas(pasoa2),conmin)/convfac/mwcv(pasoa2)
5530 cblk(lcell,vcvasoa3) = max(cgas(pasoa3),conmin)/convfac/mwcv(pasoa3)
5531 cblk(lcell,vcvasoa4) = max(cgas(pasoa4),conmin)/convfac/mwcv(pasoa4)
5533 cblk(lcell,vcvbsoa1) = max(cgas(pbsoa1),conmin)/convfac/mwcv(pbsoa1)
5534 cblk(lcell,vcvbsoa2) = max(cgas(pbsoa2),conmin)/convfac/mwcv(pbsoa2)
5535 cblk(lcell,vcvbsoa3) = max(cgas(pbsoa3),conmin)/convfac/mwcv(pbsoa3)
5536 cblk(lcell,vcvbsoa4) = max(cgas(pbsoa4),conmin)/convfac/mwcv(pbsoa4)
5538 organt1rat(lcell) = (caer(pasoa1)-aold(pasoa1))/dt
5539 organt2rat(lcell) = (caer(pasoa2)-aold(pasoa2))/dt
5540 organt3rat(lcell) = (caer(pasoa3)-aold(pasoa3))/dt
5541 organt4rat(lcell) = (caer(pasoa4)-aold(pasoa4))/dt
5543 orgbio1rat(lcell) = (caer(pbsoa1)-aold(pbsoa1))/dt
5544 orgbio2rat(lcell) = (caer(pbsoa2)-aold(pbsoa2))/dt
5545 orgbio3rat(lcell) = (caer(pbsoa3)-aold(pbsoa3))/dt
5546 orgbio4rat(lcell) = (caer(pbsoa4)-aold(pbsoa4))/dt
5547 END DO loop_cells
5548 RETURN
5549 END SUBROUTINE soa_vbs
5550 !
5551 ! *** this routine calculates the dry deposition and sedimentation
5552 ! velocities for the three modes.
5553 ! coded 1/23/97 by Dr. Francis S. Binkowski. Follows
5554 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
5555 ! velocity but includes Marv Wesely's wstar contribution.
5556 !ia eliminated Stokes term for coarse mode deposition calcs.,
5557 !ia see comments below
5559 SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, &
5560 LAYER, &
5561 CBLK, &
5562 BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, &
5563 DGNUC, DGACC, DGCOR, &
5564 KNNUC, KNACC,KNCOR, &
5565 PDENSN, PDENSA, PDENSC, &
5566 VSED, VDEP )
5568 ! *** calculate size-averaged particle dry deposition and
5569 ! size-averaged sedimentation velocities.
5572 ! IMPLICIT NONE
5574 INTEGER BLKSIZE ! dimension of arrays
5575 INTEGER NSPCSDA ! number of species in CBLK
5576 INTEGER NUMCELLS ! actual number of cells in arrays
5577 INTEGER LAYER ! number of layer
5579 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
5580 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
5581 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
5582 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
5583 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
5584 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
5585 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
5586 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
5587 REAL DGACC( BLKSIZE ) ! accumulation
5588 REAL DGCOR( BLKSIZE ) ! coarse mode
5589 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
5590 REAL KNACC( BLKSIZE ) ! accumulation
5591 REAL KNCOR( BLKSIZE ) ! coarse mode
5592 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
5593 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
5594 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
5597 ! *** modal particle diffusivities for number and 3rd moment, or mass:
5599 REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
5600 REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
5602 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
5604 REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
5605 REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
5607 ! *** deposition and sedimentation velocities
5609 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
5610 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
5613 INTEGER LCELL
5614 REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
5615 REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
5616 REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
5617 REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
5618 REAL ST0N, ST0A, ST0C ! Stokes numbers for number
5619 REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
5620 REAL RD0N, RD0A, RD0C ! canopy resistance for number
5621 REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment
5622 REAL UTSCALE ! scratch function of USTAR and WSTAR.
5623 REAL NU !kinematic viscosity [ m**2 s**-1 ]
5624 REAL USTFAC ! scratch function of USTAR, NU, and GRAV
5625 REAL BHAT
5626 PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction.
5629 ! *** check layer value.
5631 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
5632 ! sedimentation velocities
5634 DO LCELL = 1, NUMCELLS
5636 DCONST1 = BOLTZ * BLKTA(LCELL) / &
5637 ( THREEPI * AMU(LCELL) )
5638 DCONST1N = DCONST1 / DGNUC( LCELL )
5639 DCONST1A = DCONST1 / DGACC( LCELL )
5640 DCONST1C = DCONST1 / DGCOR( LCELL )
5641 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
5642 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
5643 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
5644 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
5646 ! *** i-mode
5648 DCHAT0N(LCELL) = DCONST1N &
5649 * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
5651 DCHAT3N(LCELL) = DCONST1N &
5652 * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
5654 VGHAT0N(LCELL) = DCONST3N &
5655 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
5657 VGHAT3N(LCELL) = DCONST3N &
5658 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
5660 ! *** j-mode
5662 DCHAT0A(LCELL) = DCONST1A &
5663 * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
5665 DCHAT3A(LCELL) = DCONST1A &
5666 * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
5668 VGHAT0A(LCELL) = DCONST3A &
5669 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
5671 VGHAT3A(LCELL) = DCONST3A &
5672 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
5675 ! *** coarse mode
5677 DCHAT0C(LCELL)= DCONST1C &
5678 * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
5680 DCHAT3C(LCELL) = DCONST1C &
5681 * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
5683 VGHAT0C(LCELL) = DCONST3C &
5684 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
5686 VGHAT3C(LCELL) = DCONST3C &
5687 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
5689 END DO
5691 ! *** now calculate the deposition and sedmentation velocities
5693 !ia 07.05.98
5694 ! *** NOTE In the deposition velocity for coarse mode,
5695 ! the impaction term 10.0 ** (-3.0 / st) is eliminated because
5696 ! coarse particles are likely to bounce on impact and the current
5697 ! formulation does not account for this.
5700 DO LCELL = 1, NUMCELLS
5702 NU = AMU(LCELL) / BLKDENS(LCELL)
5703 USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
5704 UTSCALE = USTAR(LCELL) + &
5705 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
5707 ! *** first do number
5709 ! *** nuclei or Aitken mode ( no sedimentation velocity )
5711 SC0N = NU / DCHAT0N(LCELL)
5712 ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
5713 RD0N = 1.0 / ( UTSCALE * &
5714 ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
5716 VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + &
5717 1.0 / ( &
5718 RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
5720 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
5722 ! *** accumulation mode
5724 SC0A = NU / DCHAT0A(LCELL)
5725 ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
5726 RD0A = 1.0 / ( UTSCALE * &
5727 ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
5729 VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + &
5730 1.0 / ( &
5731 RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
5733 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
5735 ! *** coarse mode
5737 SC0C = NU / DCHAT0C(LCELL)
5738 !ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
5739 !ia RD0C = 1.0 / ( UTSCALE *
5740 !ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
5742 RD0C = 1.0 / ( UTSCALE * &
5743 ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term
5745 VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + &
5746 1.0 / ( &
5747 RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
5749 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
5751 ! *** now do m3 for the deposition of mass
5753 ! *** nuclei or Aitken mode
5755 SC3N = NU / DCHAT3N(LCELL)
5756 ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
5757 RD3N = 1.0 / ( UTSCALE * &
5758 ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
5760 VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + &
5761 1.0 / ( &
5762 RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
5764 VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
5766 ! *** accumulation mode
5768 SC3A = NU / DCHAT3A(LCELL)
5769 ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
5770 RD3A = 1.0 / ( UTSCALE * &
5771 ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
5773 VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + &
5774 1.0 / ( &
5775 RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
5778 ! *** fine mass deposition velocity: combine Aitken and accumulation
5779 ! mode deposition velocities. Assume density is the same
5780 ! for both modes.
5783 ! VDEP(LCELL,VDMFINE) = (
5784 ! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
5785 ! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
5786 ! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
5789 ! *** fine mass sedimentation velocity
5791 ! VSED( LCELL, VSMFINE) = (
5792 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
5793 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
5794 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
5796 VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
5798 ! *** coarse mode
5800 SC3C = NU / DCHAT3C(LCELL)
5801 !ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
5802 !ia RD3C = 1.0 / ( UTSCALE *
5803 !ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
5805 RD3C = 1.0 / ( UTSCALE * &
5806 ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
5807 VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + &
5808 1.0 / ( &
5809 RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
5811 ! *** coarse mode sedmentation velocity
5813 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
5817 END DO
5819 ELSE ! LAYER greater than 1
5821 ! *** for layer greater than 1 calculate sedimentation velocities only
5823 DO LCELL = 1, NUMCELLS
5825 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
5827 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
5828 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
5829 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
5831 VGHAT0N(LCELL) = DCONST3N &
5832 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
5834 ! *** nucleation mode number sedimentation velocity
5836 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
5838 VGHAT3N(LCELL) = DCONST3N &
5839 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
5841 ! *** nucleation mode volume sedimentation velocity
5843 VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
5845 VGHAT0A(LCELL) = DCONST3A &
5846 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
5848 ! *** accumulation mode number sedimentation velocity
5850 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
5852 VGHAT3A(LCELL) = DCONST3A &
5853 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
5855 ! *** fine mass sedimentation velocity
5857 ! VSED( LCELL, VSMFINE) = (
5858 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
5859 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
5860 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
5862 VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
5864 VGHAT0C(LCELL) = DCONST3C &
5865 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
5867 ! *** coarse mode sedimentation velocity
5869 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
5872 VGHAT3C(LCELL) = DCONST3C &
5873 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
5875 ! *** coarse mode mass sedimentation velocity
5877 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
5879 END DO
5881 END IF ! check on layer
5883 END SUBROUTINE VDVG
5884 !
5885 !---------------------------------------------------------------------------
5886 !
5887 ! *** this routine calculates the dry deposition and sedimentation
5888 ! velocities for the three modes.
5889 ! Stu McKeen 10/13/08
5890 ! Gaussian Quadrature numerical integration over diameter range for each mode.
5891 ! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10
5892 ! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv
5893 ! Numerical Integration allows more complete discription of the
5894 ! Cunningham Slip correction factor, Interception Term (not included previously),
5895 ! and the correction due to rebound for higher diameter particles.
5896 ! Sedimentation velocities the same as original Binkowski code, also the
5897 ! Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the
5898 ! same as Binkowski.
5899 ! Stokes number, and efficiency dependence on Stokes number now according to
5900 ! Peters and Eiden (1992). Interception term taken from Slinn (1982) with
5901 ! efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy
5902 ! for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction
5903 ! term is that of Slinn (1982)
5904 !
5905 ! Original code 1/23/97 by Dr. Francis S. Binkowski. Follows
5906 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
5907 ! velocity but includes Marv Wesely's wstar contribution.
5908 !ia eliminated Stokes term for coarse mode deposition calcs.,
5909 !ia see comments below
5911 ! CBLK is eliminated since the subroutine doesn't use it!
5912 SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, &
5913 LAYER, &
5914 BLKTA, BLKDENS, &
5915 RA, USTAR, PBLH, ZNTT, RMOLM, AMU, &
5916 DGNUC, DGACC, DGCOR, XLM, &
5917 KNNUC, KNACC,KNCOR, &
5918 PDENSN, PDENSA, PDENSC, &
5919 VSED, VDEP)
5921 ! *** calculate size-averaged particle dry deposition and
5922 ! size-averaged sedimentation velocities.
5923 ! IMPLICIT NONE
5925 INTEGER BLKSIZE ! dimension of arrays
5926 INTEGER NSPCSDA ! number of species in CBLK
5927 INTEGER NUMCELLS ! actual number of cells in arrays
5928 INTEGER LAYER ! number of layer
5929 INTEGER, PARAMETER :: iprnt = 0
5931 ! REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
5932 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
5933 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
5934 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
5935 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
5936 REAL PBLH( BLKSIZE ) ! PBL height (m)
5937 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
5938 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
5939 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
5940 REAL XLM( BLKSIZE ) ! mean free path of dry air [ m ]
5941 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
5942 REAL DGACC( BLKSIZE ) ! accumulation
5943 REAL DGCOR( BLKSIZE ) ! coarse mode
5944 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
5945 REAL KNACC( BLKSIZE ) ! accumulation
5946 REAL KNCOR( BLKSIZE ) ! coarse mode
5947 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode [ kg / m**3 ]
5948 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode [ kg / m**3 ]
5949 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode [ kg / m**3 ]
5951 ! *** deposition and sedimentation velocities
5953 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimentation velocity [ m s**-1 ]
5954 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
5956 INTEGER LCELL,N
5957 REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C
5958 REAL UTSCALE,CZH ! scratch functions of USTAR and WSTAR.
5959 REAL NU !kinematic viscosity [ m**2 s**-1 ]
5960 REAL BHAT
5961 PARAMETER( BHAT = 1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction.
5962 REAL COLCTR_BIGD,COLCTR_SMALD
5963 PARAMETER ( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6 ) ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest)
5964 REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim
5965 REAL Eff_dif, Eff_imp, Eff_int, RBcor
5966 INTEGER ISTOPvd0,IdoWesCor
5967 PARAMETER (ISTOPvd0 = 0) ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs.
5969 ! no Wesley deposition, otherwise EC is too low
5970 PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means don't do correction
5971 IF (ISTOPvd0.EQ.1)THEN
5972 RETURN
5973 ENDIF
5974 ! *** check layer value.
5976 IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER
5977 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and sedimentation velocities
5979 DO LCELL = 1, NUMCELLS
5980 DCONST1 = BOLTZ * BLKTA(LCELL) / &
5981 ( THREEPI * AMU(LCELL) )
5982 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
5983 DCONST3 = USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD)
5985 ! *** now calculate the deposition velocities at layer 1
5987 NU = AMU(LCELL) / BLKDENS(LCELL)
5989 UTSCALE = 1.
5990 IF (IdoWesCor.EQ.1)THEN
5991 ! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08)
5992 IF(RMOLM(LCELL).LT.0.)THEN
5993 CZH = -1.*PBLH(LCELL)*RMOLM(LCELL)
5994 IF(CZH.GT.30.0)THEN
5995 UTSCALE=0.45*CZH**0.6667
5996 ELSE
5997 UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667
5998 ENDIF
5999 ENDIF
6000 ENDIF ! end of (IdoWesCor.EQ.1) test
6002 UTSCALE = USTAR(LCELL)*UTSCALE
6003 IF(iprnt.eq.1)THEN
6004 print *,'NGAUSdv,xxlsga,USTAR,UTSCALE'
6005 print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE
6006 print *,'DCONST2,PDENSA,DGACC,GRAV,AMU'
6007 print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL)
6008 endif
6010 ! *** nuclei mode
6012 SUM0=0.
6013 SUM3=0.
6014 DO N=1,NGAUSdv
6015 DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn) ! Diameter (m) at quadrature point
6016 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6017 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6018 VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6019 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6020 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6021 STQ=DCONST3*PDENSN(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6022 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6023 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6024 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
6025 RBcor=1. ! Rebound correction factor
6026 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6027 ! vdplim=.002*UTSCALE
6028 vdplim=min(vdplim,.02)
6029 RSURFQ=RA(LCELL)+1./vdplim
6030 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6031 !
6032 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6033 !
6034 ! RSURFQ=max(RSURFQ,50.)
6035 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6036 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6037 ENDDO
6038 VDEP(LCELL, VDNNUC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6039 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
6041 ! *** accumulation mode
6043 SUM0=0.
6044 SUM3=0.
6045 DO N=1,NGAUSdv
6046 DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga) ! Diameter (m) at quadrature point
6047 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6048 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6049 VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6050 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6051 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6052 STQ=DCONST3*PDENSA(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6053 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6054 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6055 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
6056 RBcor=1. ! Rebound correction factor
6057 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6058 vdplim=min(vdplim,.02)
6059 RSURFQ=RA(LCELL)+1./vdplim
6060 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6061 !
6062 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6063 !
6064 ! RSURFQ=max(RSURFQ,50.)
6065 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6066 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6067 IF(iprnt.eq.1)THEN
6068 print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ'
6069 print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ
6070 print *,'N,Eff_dif,imp,int,SUM0,SUM3'
6071 print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3
6072 endif
6073 ENDDO
6074 VDEP(LCELL, VDNACC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6075 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
6077 ! *** coarse mode
6079 SUM0=0.
6080 SUM3=0.
6081 DO N=1,NGAUSdv
6082 DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc) ! Diameter (m) at quadrature point
6083 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6084 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6085 VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6086 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6087 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6088 STQ=DCONST3*PDENSC(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6089 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6090 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6091 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
6092 EFF_int=min(1.,EFF_int)
6093 RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982)
6094 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6095 vdplim=min(vdplim,.02)
6096 RSURFQ=RA(LCELL)+1./vdplim
6097 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6098 !
6099 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6100 !
6101 ! RSURFQ=max(RSURFQ,50.)
6102 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6103 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6104 ENDDO
6105 VDEP(LCELL, VDNCOR) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6106 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
6107 END DO
6109 ENDIF ! ENDOF LAYER = 1 test
6111 ! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995)
6113 DO LCELL = 1, NUMCELLS
6115 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6116 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6117 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6118 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6120 ! *** nucleation mode number and mass sedimentation velociticies
6121 VSED( LCELL, VSNNUC) = DCONST3N &
6122 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6123 VSED( LCELL, VSMNUC) = DCONST3N &
6124 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6126 ! *** accumulation mode number and mass sedimentation velociticies
6127 VSED( LCELL, VSNACC) = DCONST3A &
6128 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6129 VSED( LCELL, VSMACC) = DCONST3A &
6130 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6132 ! *** coarse mode number and mass sedimentation velociticies
6133 VSED( LCELL, VSNCOR) = DCONST3C &
6134 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6135 VSED( LCELL, VSMCOR) = DCONST3C &
6136 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6137 END DO
6138 END SUBROUTINE VDVG_2
6139 !------------------------------------------------------------------------------
6141 SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, &
6142 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
6143 chem_in_opt,aer_ic_opt, is_aerosol, &
6144 ids,ide, jds,jde, kds,kde, &
6145 ims,ime, jms,jme, kms,kme, &
6146 its,ite, jts,jte, kts,kte, config_flags )
6148 USE module_configure, only: grid_config_rec_type
6149 !!! TUCCELLA (BUG, commented the line below)
6150 !USE module_prep_wetscav_sorgam,only: aerosols_soa_vbs_init_aercld_ptrs
6152 implicit none
6153 INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt
6154 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
6155 ims,ime, jms,jme, kms,kme, &
6156 its,ite, jts,jte, kts,kte
6157 LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
6158 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , &
6159 INTENT(INOUT ) :: &
6160 chem
6161 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6162 INTENT(INOUT ) :: &
6163 pm2_5_dry,pm2_5_water,pm2_5_dry_ec
6164 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6165 INTENT(IN ) :: &
6166 convfac
6167 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6168 INTENT(IN ) :: &
6169 z_at_w
6170 TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
6173 integer i,j,k,l,ii,jj,kk
6174 real tempfac,mwso4,zz
6175 ! real,dimension(its:ite,kts:kte,jts:jte) :: convfac
6176 REAL splitfac
6177 !between gas and aerosol phase
6178 REAL so4vaptoaer
6179 !factor for splitting initial conc. of SO4
6180 !3rd moment i-mode [3rd moment/m^3]
6181 REAL m3nuc
6182 !3rd MOMENT j-mode [3rd moment/m^3]
6183 REAL m3acc
6184 ! REAL ESN36
6185 REAL m3cor
6186 DATA splitfac/.98/
6187 DATA so4vaptoaer/.999/
6189 ! *** Compute these once and they will all be saved in COMMON
6190 xxlsgn = log(sginin)
6191 xxlsga = log(sginia)
6192 xxlsgc = log(sginic)
6194 l2sginin = xxlsgn**2
6195 l2sginia = xxlsga**2
6196 l2sginic = xxlsgc**2
6198 en1 = exp(0.125*l2sginin)
6199 ea1 = exp(0.125*l2sginia)
6200 ec1 = exp(0.125*l2sginic)
6202 esn04 = en1**4
6203 esa04 = ea1**4
6204 esc04 = ec1**4
6206 esn05 = esn04*en1
6207 esa05 = esa04*ea1
6209 esn08 = esn04*esn04
6210 esa08 = esa04*esa04
6211 esc08 = esc04*esc04
6213 esn09 = esn04*esn05
6214 esa09 = esa04*esa05
6216 esn12 = esn04*esn04*esn04
6217 esa12 = esa04*esa04*esa04
6218 esc12 = esc04*esc04*esc04
6220 esn16 = esn08*esn08
6221 esa16 = esa08*esa08
6222 esc16 = esc08*esc08
6224 esn20 = esn16*esn04
6225 esa20 = esa16*esa04
6226 esc20 = esc16*esc04
6228 esn24 = esn12*esn12
6229 esa24 = esa12*esa12
6230 esc24 = esc12*esc12
6232 esn25 = esn16*esn09
6233 esa25 = esa16*esa09
6235 esn28 = esn20*esn08
6236 esa28 = esa20*esa08
6237 esc28 = esc20*esc08
6240 esn32 = esn16*esn16
6241 esa32 = esa16*esa16
6242 esc32 = esc16*esc16
6244 esn36 = esn16*esn20
6245 esa36 = esa16*esa20
6246 esc36 = esc16*esc20
6248 esn49 = esn25*esn20*esn04
6249 esa49 = esa25*esa20*esa04
6251 esn52 = esn16*esn36
6252 esa52 = esa16*esa36
6254 esn64 = esn32*esn32
6255 esa64 = esa32*esa32
6256 esc64 = esc32*esc32
6258 esn100 = esn36*esn64
6260 esnm20 = 1.0/esn20
6261 esam20 = 1.0/esa20
6262 escm20 = 1.0/esc20
6264 esnm32 = 1.0/esn32
6265 esam32 = 1.0/esa32
6266 escm32 = 1.0/esc32
6268 xxm3 = 3.0*xxlsgn/ sqrt2
6269 ! factor used in error function cal
6270 nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
6272 nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
6274 nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
6276 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
6277 ! size distribution , then
6279 ! vol = (p/6) * density * num * (dgemv_xx**3) *
6280 ! exp(- 4.5 * log( sgem_xx)**2 ) )
6281 ! note minus sign!!
6283 factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
6284 factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
6285 factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
6286 ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
6287 ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
6288 mwso4=96.03
6290 ! initialize pointers used by aerosol-cloud-interaction routines
6291 ! TUCCELLA (BUG, now aerosols_soa_vbs_aercld_ptrs is called chemics_init.F !
6292 ! and was moved to module_prep_wetscav_sorgam.F)
6294 !call aerosols_soa_vbs_init_aercld_ptrs( &
6295 ! num_chem, is_aerosol, config_flags )
6297 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
6298 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
6299 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
6301 !SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv
6303 Y_GQ(1)=-2.651961356835233
6304 WGAUS(1)=0.0009717812450995
6305 Y_GQ(2)=-1.673551628767471
6306 WGAUS(2)=0.05451558281913
6307 Y_GQ(3)=-0.816287882858965
6308 WGAUS(3)=0.4256072526101
6309 Y_GQ(4)=-0.0
6310 WGAUS(4)=0.8102646175568
6311 Y_GQ(5)=0.816287882858965
6312 WGAUS(5)=WGAUS(3)
6313 Y_GQ(6)=1.673551628767471
6314 WGAUS(6)=WGAUS(2)
6315 Y_GQ(7)=2.651961356835233
6316 WGAUS(7)=WGAUS(1)
6317 !
6318 ! IF USING OLD SIMULATION, DO NOT REINITIALIZE!
6319 !
6320 if(chem_in_opt == 1 .OR. config_flags%restart) return
6321 do l=p_so4aj,num_chem
6322 chem(ims:ime,kms:kme,jms:jme,l)=epsilc
6323 enddo
6324 chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
6325 chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
6326 do j=jts,jte
6327 jj=min(jde-1,j)
6328 do k=kts,kte-1
6329 kk=min(kde-1,k)
6330 do i=its,ite
6331 ii=min(ide-1,i)
6333 !Option for alternate ic's
6334 if( aer_ic_opt == AER_IC_DEFAULT ) then
6335 chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer
6336 chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*(1.-splitfac)*so4vaptoaer
6337 chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
6338 chem(i,k,j,p_nh4aj) = 10.E-05
6339 chem(i,k,j,p_nh4ai) = 10.E-05
6340 chem(i,k,j,p_no3aj) = 10.E-05
6341 chem(i,k,j,p_no3ai) = 10.E-05
6342 chem(i,k,j,p_naaj) = 10.E-05
6343 chem(i,k,j,p_naai) = 10.E-05
6344 chem(i,k,j,p_claj) = 10.E-05
6345 chem(i,k,j,p_clai) = 10.E-05
6346 !liqy
6347 !liqy-20140619
6348 ! elseif( aer_ic_opt == AER_IC_PNNL ) then
6349 ! zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5
6350 ! call soa_vbs_init_aer_ic_pnnl( &
6351 ! chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
6352 else
6353 call wrf_error_fatal( &
6354 "aerosols_soa_vbs_init: unable to parse aer_ic_opt" )
6355 end if
6357 !... i-mode
6358 m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
6359 no3fac*chem(i,k,j,p_no3ai) + &
6360 nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) + &
6361 !liqy-20140619
6362 orgfac*chem(i,k,j,p_asoa1i) + &
6363 orgfac*chem(i,k,j,p_asoa2i) + orgfac*chem(i,k,j,p_asoa3i) + &
6364 orgfac*chem(i,k,j,p_asoa4i) + orgfac*chem(i,k,j,p_bsoa1i) + &
6365 orgfac*chem(i,k,j,p_bsoa2i) + orgfac*chem(i,k,j,p_bsoa3i) + &
6366 orgfac*chem(i,k,j,p_bsoa4i) + orgfac*chem(i,k,j,p_orgpai) + &
6367 anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)
6369 !... j-mode
6370 m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + &
6371 no3fac*chem(i,k,j,p_no3aj) + &
6372 nafac*chem(i,k,j,p_naaj) + clfac*chem(i,k,j,p_claj) + &
6373 !liqy-20140619
6374 orgfac*chem(i,k,j,p_asoa1j) + &
6375 orgfac*chem(i,k,j,p_asoa2j) + orgfac*chem(i,k,j,p_asoa3j) + &
6376 orgfac*chem(i,k,j,p_asoa4j) + orgfac*chem(i,k,j,p_bsoa1j) + &
6377 orgfac*chem(i,k,j,p_bsoa2j) + orgfac*chem(i,k,j,p_bsoa3j) + &
6378 orgfac*chem(i,k,j,p_bsoa4j) + orgfac*chem(i,k,j,p_orgpaj) + &
6379 anthfac*chem(i,k,j,p_p25j) + anthfac*chem(i,k,j,p_ecj)
6381 !...c-mode
6382 m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
6383 anthfac*chem(i,k,j,p_antha)
6385 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
6386 chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
6388 chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
6390 chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
6392 enddo
6393 enddo
6394 enddo
6396 return
6397 END SUBROUTINE aerosols_soa_vbs_init
6399 !
6400 SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, &
6401 ebu, &
6402 slai,ust,smois,ivgtyp,isltyp, &
6403 emis_ant,dust_emiss_active, &
6404 seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, &
6405 dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, &
6406 ids,ide, jds,jde, kds,kde, &
6407 ims,ime, jms,jme, kms,kme, &
6408 its,ite, jts,jte, kts,kte )
6409 !
6410 ! Routine to apply aerosol emissions for MADE/SOA_VBS...
6411 ! William.Gustafson@pnl.gov; 3-May-2007
6412 ! Modified by
6413 ! steven.peckham@noaa.gov; 8-Jan-2008
6414 !------------------------------------------------------------------------
6416 USE module_state_description, only: num_chem
6418 INTEGER, INTENT(IN ) :: seasalt_emiss_active,kemit,emissopt, &
6419 dust_emiss_active,num_soil_layers,id, &
6420 ktau,dust_opt,biom, &
6421 ids,ide, jds,jde, kds,kde, &
6422 ims,ime, jms,jme, kms,kme, &
6423 its,ite, jts,jte, kts,kte
6425 REAL, INTENT(IN ) :: dtstep
6427 ! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air)
6428 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
6429 INTENT(INOUT ) :: chem
6430 !
6431 ! aerosol emissions arrays ((ug/m3)*m/s)
6432 !
6433 REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), &
6434 INTENT(IN ) :: emis_ant
6436 ! biomass burning aerosol emissions arrays ((ug/m3)*m/s)
6437 REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), &
6438 INTENT(IN ) :: ebu
6440 ! 1/(dry air density) and layer thickness (m)
6441 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
6442 INTENT(IN ) :: &
6443 alt, dz8w
6445 ! add for gocart dust
6446 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
6447 INTENT(IN ) :: p8w,u_phy,v_phy,rho_phy
6448 REAL, INTENT(IN ) :: dx, g
6449 REAL, DIMENSION( ims:ime, jms:jme, 3 ), &
6450 INTENT(IN ) :: erod
6452 REAL, DIMENSION( ims:ime , jms:jme ), &
6453 INTENT(IN ) :: &
6454 u10, v10, xland, slai, ust
6455 INTEGER, DIMENSION( ims:ime , jms:jme ), &
6456 INTENT(IN ) :: ivgtyp, isltyp
6457 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ), &
6458 INTENT(INOUT) :: smois
6460 ! Local variables...
6461 real, dimension(its:ite,kts:kte,jts:jte) :: factor
6462 !
6463 ! Get the emissions unit conversion factor including the time step.
6464 ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep]
6465 !
6466 factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ &
6467 dz8w(its:ite,kts:kte,jts:jte)
6468 !
6469 ! Increment the aerosol numbers...
6470 !
6471 ! Increment the aerosol numbers...
6472 if(emissopt .lt. 5 )then
6473 !
6474 ! Aitken mode first...
6476 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
6477 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
6478 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
6479 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + &
6480 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + &
6481 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + &
6482 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) )
6484 ! Accumulation mode next...
6486 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
6487 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
6488 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
6489 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + &
6490 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + &
6491 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + &
6492 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) )
6494 ! And now the coarse mode...
6496 chem(its:ite,kts:kemit,jts:jte,p_corn) = &
6497 chem(its:ite,kts:kemit,jts:jte,p_corn) + &
6498 factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac* &
6499 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)
6500 !
6501 ! Increment the aerosol masses...
6502 !
6503 chem(its:ite,kts:kemit,jts:jte,p_antha) = &
6504 chem(its:ite,kts:kemit,jts:jte,p_antha) + &
6505 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte)
6507 chem(its:ite,kts:kemit,jts:jte,p_p25j) = &
6508 chem(its:ite,kts:kemit,jts:jte,p_p25j) + &
6509 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte)
6511 chem(its:ite,kts:kemit,jts:jte,p_p25i) = &
6512 chem(its:ite,kts:kemit,jts:jte,p_p25i) + &
6513 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte)
6515 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
6516 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
6517 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte)
6519 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
6520 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
6521 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte)
6522 chem(its:ite,kts:kemit,jts:jte,p_naaj) = &
6523 chem(its:ite,kts:kemit,jts:jte,p_naaj) + &
6524 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte)
6525 chem(its:ite,kts:kemit,jts:jte,p_naai) = &
6526 chem(its:ite,kts:kemit,jts:jte,p_naai) + &
6527 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte)
6529 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
6530 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
6531 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte)
6533 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
6534 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
6535 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte)
6537 chem(its:ite,kts:kemit,jts:jte,p_so4aj) = &
6538 chem(its:ite,kts:kemit,jts:jte,p_so4aj) + &
6539 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte)
6541 chem(its:ite,kts:kemit,jts:jte,p_so4ai) = &
6542 chem(its:ite,kts:kemit,jts:jte,p_so4ai) + &
6543 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte)
6545 chem(its:ite,kts:kemit,jts:jte,p_no3aj) = &
6546 chem(its:ite,kts:kemit,jts:jte,p_no3aj) + &
6547 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte)
6549 chem(its:ite,kts:kemit,jts:jte,p_no3ai) = &
6550 chem(its:ite,kts:kemit,jts:jte,p_no3ai) + &
6551 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte)
6552 !liqy
6553 chem(its:ite,kts:kemit,jts:jte,p_claj) = &
6554 chem(its:ite,kts:kemit,jts:jte,p_claj) + &
6555 emis_ant(its:ite,kts:kemit,jts:jte,p_e_clj)*factor(its:ite,kts:kemit,jts:jte)
6557 chem(its:ite,kts:kemit,jts:jte,p_clai) = &
6558 chem(its:ite,kts:kemit,jts:jte,p_clai) + &
6559 emis_ant(its:ite,kts:kemit,jts:jte,p_e_cli)*factor(its:ite,kts:kemit,jts:jte)
6560 !liqy-20150625
6561 elseif(emissopt == 5)then
6562 !
6563 ! Aitken mode first...
6565 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
6566 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
6567 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
6568 anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
6569 orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
6571 ! Accumulation mode next...
6573 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
6574 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
6575 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
6576 anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
6577 orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
6579 !
6580 ! Increment the aerosol masses...
6581 !
6583 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
6584 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
6585 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
6587 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
6588 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
6589 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
6591 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
6592 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
6593 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
6595 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
6596 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
6597 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
6599 endif
6600 ! add biomass burning emissions if present
6601 !
6602 if(biom == 1 )then
6603 !
6604 ! Aitken mode first...
6606 chem(its:ite,kts:kte,jts:jte,p_nu0) = &
6607 chem(its:ite,kts:kte,jts:jte,p_nu0) + &
6608 factor(its:ite,kts:kte,jts:jte)*factnumn*( &
6609 anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
6610 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
6611 orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
6613 ! Accumulation mode next...
6615 chem(its:ite,kts:kte,jts:jte,p_ac0) = &
6616 chem(its:ite,kts:kte,jts:jte,p_ac0) + &
6617 factor(its:ite,kts:kte,jts:jte)*factnuma*( &
6618 anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
6619 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
6620 orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
6621 ! coarse
6622 chem(its:ite,kts:kte,jts:jte,p_corn) = &
6623 chem(its:ite,kts:kte,jts:jte,p_corn) + &
6624 factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* &
6625 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)
6627 !
6628 ! Increment the aerosol masses...
6629 !
6631 chem(its:ite,kts:kte,jts:jte,p_ecj) = &
6632 chem(its:ite,kts:kte,jts:jte,p_ecj) + &
6633 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
6635 chem(its:ite,kts:kte,jts:jte,p_eci) = &
6636 chem(its:ite,kts:kte,jts:jte,p_eci) + &
6637 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
6639 chem(its:ite,kts:kte,jts:jte,p_orgpaj) = &
6640 chem(its:ite,kts:kte,jts:jte,p_orgpaj) + &
6641 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
6643 chem(its:ite,kts:kte,jts:jte,p_orgpai) = &
6644 chem(its:ite,kts:kte,jts:jte,p_orgpai) + &
6645 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
6647 chem(its:ite,kts:kte,jts:jte,p_antha) = &
6648 chem(its:ite,kts:kte,jts:jte,p_antha) + &
6649 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte)
6651 chem(its:ite,kts:kte,jts:jte,p_p25j) = &
6652 chem(its:ite,kts:kte,jts:jte,p_p25j) + &
6653 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
6655 chem(its:ite,kts:kte,jts:jte,p_p25i) = &
6656 chem(its:ite,kts:kte,jts:jte,p_p25i) + &
6657 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
6659 endif !end biomass burning
6660 !
6661 ! Get the sea salt emissions...
6662 !
6663 if( seasalt_emiss_active == 1 ) then
6664 call soa_vbs_seasalt_emiss( &
6665 dtstep, u10, v10, alt, dz8w, xland, chem, &
6666 ids,ide, jds,jde, kds,kde, &
6667 ims,ime, jms,jme, kms,kme, &
6668 its,ite, jts,jte, kts,kte )
6669 end if
6670 ! if( seasalt_emiss_active == 2 ) then
6671 ! end if
6672 if( dust_opt == 2 ) then
6673 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")
6674 call soa_vbs_dust_emiss( &
6675 slai, ust, smois, ivgtyp, isltyp, &
6676 id, dtstep, u10, v10, alt, dz8w, &
6677 xland, num_soil_layers, chem, &
6678 ids,ide, jds,jde, kds,kde, &
6679 ims,ime, jms,jme, kms,kme, &
6680 its,ite, jts,jte, kts,kte )
6681 end if
6682 ! dust_opt changed to 13 since it conflicts with gocart/afwa
6683 if( dust_opt == 13 ) then
6684 !czhao --------------------------
6685 call soa_vbs_dust_gocartemis( &
6686 ktau,dtstep,num_soil_layers,alt,u_phy, &
6687 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
6688 ivgtyp,isltyp,xland,dx,g, &
6689 ids,ide, jds,jde, kds,kde, &
6690 ims,ime, jms,jme, kms,kme, &
6691 its,ite, jts,jte, kts,kte )
6692 end if
6694 END SUBROUTINE soa_vbs_addemiss
6696 !------------------------------------------------------------------------
6697 SUBROUTINE soa_vbs_seasalt_emiss( &
6698 dtstep, u10, v10, alt, dz8w, xland, chem, &
6699 ids,ide, jds,jde, kds,kde, &
6700 ims,ime, jms,jme, kms,kme, &
6701 its,ite, jts,jte, kts,kte )
6702 !
6703 ! Routine to calculate seasalt emissions for SOA_VBS over the time
6704 ! dtstep...
6705 ! William.Gustafson@pnl.gov; 10-May-2007
6706 !------------------------------------------------------------------------
6708 USE module_mosaic_addemiss, only: seasalt_emitfactors_1bin
6710 IMPLICIT NONE
6712 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
6713 ims,ime, jms,jme, kms,kme, &
6714 its,ite, jts,jte, kts,kte
6716 REAL, INTENT(IN ) :: dtstep
6718 ! 10-m wind speed components (m/s)
6719 REAL, DIMENSION( ims:ime , jms:jme ), &
6720 INTENT(IN ) :: u10, v10, xland
6722 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
6723 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
6724 INTENT(INOUT ) :: chem
6726 ! alt = 1.0/(dry air density) in (m3/kg)
6727 ! dz8w = layer thickness in (m)
6728 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
6729 INTENT(IN ) :: alt, dz8w
6731 ! local variables
6732 integer :: i, j, k, l, l_na, l_cl, n
6733 integer :: p1st
6735 real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
6736 real :: factaa, factbb, fraccl, fracna
6737 !liqy
6738 real :: fracca, frack, fracmg, fracso4
6739 !liqy-20140709
6741 real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c
6742 real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c
6745 ! Compute emissions factors for the Aitken mode...
6746 ! Nope, we won't because the parameterization is only valid down to
6747 ! 0.1 microns.
6748 ! Setup in units of cm.
6749 ! dumdlo = 0.039e-4
6750 ! dumdhi = 0.078e-4
6751 ssemfact_numb_i = 0.
6752 ssemfact_mass_i = 0.
6754 ! Compute emissions factors for the accumulation mode...
6755 ! Potentially, we could go down to 0.078 microns to match the bin
6756 ! boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end
6757 ! has been chosen to match the MOSAIC bin boundary closest to two
6758 ! standard deviations from the default bin mean diameter for the coarse
6759 ! mode.
6760 dumdlo = 0.1e-4
6761 dumdhi = 1.250e-4
6762 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
6763 ssemfact_numb_j, dum, ssemfact_mass_j )
6765 ! Compute emissions factors for the coarse mode...
6766 dumdlo = 1.25e-4
6767 dumdhi = 10.0e-4
6768 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
6769 ssemfact_numb_c, dum, ssemfact_mass_c )
6771 ! Convert mass emissions factor from (g/m2/s) to (ug/m2/s)
6772 ssemfact_mass_i = ssemfact_mass_i*1.0e6
6773 ssemfact_mass_j = ssemfact_mass_j*1.0e6
6774 ssemfact_mass_c = ssemfact_mass_c*1.0e6
6776 ! Loop over i,j and apply seasalt emissions
6777 k = kts
6778 do j = jts, jte
6779 do i = its, ite
6781 !Skip this point if over land. xland=1 for land and 2 for water.
6782 !Also, there is no way to differentiate fresh from salt water.
6783 !Currently, this assumes all water is salty.
6784 if( xland(i,j) < 1.5 ) cycle
6786 !wig: As far as I can tell, only real.exe knows the fractional breakdown
6787 ! of land use. So, in wrf.exe, dumoceanfrac will always be 1.
6788 dumoceanfrac = 1. !fraction of grid i,j that is salt water
6789 dumspd10 = dumoceanfrac* &
6790 ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
6792 ! factaa is (s*m2/kg-air)
6793 ! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air
6794 ! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air
6795 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
6796 factbb = factaa * dumspd10
6798 !liqy
6799 !comment out the old assumption, i.e. "Apportion seasalt mass emissions
6800 !assumming that seasalt is pure NaCl".
6801 ! fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
6802 ! fraccl = 1.0 - fracna
6803 fracna = 10.7838/35.171
6804 fraccl = 19.3529/35.171
6805 fracca = 0.4121/35.171
6806 frack = 0.3991/35.171
6807 fracmg = 1.2837/35.171
6808 fracso4 = 0.0 !2.7124/35.171
6810 ! Add the emissions into the chem array...
6811 chem(i,k,j,p_naai) = chem(i,k,j,p_naai) + &
6812 factbb * ssemfact_mass_i * fracna
6813 chem(i,k,j,p_clai) = chem(i,k,j,p_clai) + &
6814 factbb * ssemfact_mass_i * fraccl
6815 ! chem(i,k,j,p_so4ai) = chem(i,k,j,p_so4ai) + &
6816 ! factbb * ssemfact_mass_i * fracso4
6817 chem(i,k,j,p_nu0) = chem(i,k,j,p_nu0) + &
6818 factbb * ssemfact_numb_i
6820 !-------------------------------------------------------------------------
6822 !-------------------------------------------------------------------------
6823 chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) + &
6824 factbb * ssemfact_mass_j * fracna
6825 chem(i,k,j,p_claj) = chem(i,k,j,p_claj) + &
6826 factbb * ssemfact_mass_j * fraccl
6827 ! chem(i,k,j,p_so4aj) = chem(i,k,j,p_so4aj) + &
6828 ! factbb * ssemfact_mass_j * fracso4
6829 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + &
6830 factbb * ssemfact_numb_j
6832 !-------------------------------------------------------------------------
6833 chem(i,k,j,p_seas) = chem(i,k,j,p_seas) + &
6834 factbb * ssemfact_mass_c
6835 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + &
6836 factbb * ssemfact_numb_c
6837 !liqy-20140709
6839 end do !i
6840 end do !j
6841 END SUBROUTINE soa_vbs_seasalt_emiss
6842 !----------------------------------------------------------------------
6844 subroutine soa_vbs_dust_emiss( slai,ust, smois, ivgtyp, isltyp, &
6845 id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers, &
6846 chem, &
6847 ids,ide, jds,jde, kds,kde, &
6848 ims,ime, jms,jme, kms,kme, &
6849 its,ite, jts,jte, kts,kte )
6850 !
6851 ! adds dust emissions for mosaic aerosol species (i.e. emission tendencies
6852 ! over time dtstep are applied to the aerosol mixing ratios)
6853 !
6854 ! This is a simple dust scheme based on Shaw et al. (2008) to appear in
6855 ! Atmospheric Environment, recoded by Jerome Fast
6856 !
6857 ! NOTE:
6858 ! 1) This version only works with the 8-bin version of MOSAIC.
6859 ! 2) Dust added to MOSAIC's other inorganic specie, OIN. If Ca and CO3 are
6860 ! activated in the Registry, a small fraction also added to Ca and CO3.
6861 ! 3) The main departure from Shaw et al., is now alphamask is computed since
6862 ! the land-use categories in that paper and in WRF differ. WRF currently
6863 ! does not have that many land-use categories and adhoc assumptions had to
6864 ! be made. This version was tested for Mexico in the dry season. The main
6865 ! land-use categories in WRF that are likely dust sources are grass, shrub,
6866 ! and savannna (that WRF has in the desert regions of NW Mexico). Having
6867 ! dust emitted from these types for other locations and other times of the
6868 ! year is not likely to be valid.
6869 ! 4) An upper bound on ustar was placed because the surface parameterizations
6870 ! in WRF can produce unrealistically high values that lead to very high
6871 ! dust emission rates.
6872 ! 5) Other departures' from Shaw et al. noted below, but are probably not as
6873 ! important as 2) and 3).
6874 !
6875 USE module_configure, only: grid_config_rec_type
6876 USE module_state_description, only: num_chem, param_first_scalar
6877 USE module_data_mosaic_asect
6879 IMPLICIT NONE
6881 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
6883 INTEGER, INTENT(IN ) :: id,num_soil_layers, &
6884 ids,ide, jds,jde, kds,kde, &
6885 ims,ime, jms,jme, kms,kme, &
6886 its,ite, jts,jte, kts,kte
6888 REAL, INTENT(IN ) :: dtstep
6890 ! 10-m wind speed components (m/s)
6891 REAL, DIMENSION( ims:ime , jms:jme ), &
6892 INTENT(IN ) :: u10, v10, xland, slai, ust
6893 INTEGER, DIMENSION( ims:ime , jms:jme ), &
6894 INTENT(IN ) :: ivgtyp, isltyp
6896 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
6897 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
6898 INTENT(INOUT ) :: chem
6900 ! alt = 1.0/(dry air density) in (m3/kg)
6901 ! dz8w = layer thickness in (m)
6902 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6903 INTENT(IN ) :: alt, dz8w
6905 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
6906 INTENT(INOUT) :: smois
6908 ! local variables
6909 integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
6910 integer iphase, itype, izob
6911 integer p1st
6913 real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
6914 real factaa, factbb, fracoin, fracca, fracco3, fractot
6915 !liqy
6916 real dstfracna, dstfraccl, dstfracca, dstfrack, dstfracmg,dstfrac
6917 !liqy-20140709
6918 real ustart, ustar1, ustart0
6919 real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
6920 real smois_grav, wp, pclay
6921 real :: beta(4,7)
6922 real :: gamma(4), delta(4)
6923 real :: sz(8)
6924 real :: dustflux, densdust, mass1part
6925 real :: dp_meanvol_tmp
6926 !
6927 ! from Nickovic et al., JGR, 2001 and Shaw et al. 2007
6928 ! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7)
6929 ! beta (1,*) for 0.5-1 um
6930 ! beta (2,*) for 1-10 um
6931 ! beta (3,*) for 10-25 um
6932 ! beta (4,*) for 25-50 um
6933 !
6934 beta(1,1)=0.12
6935 beta(2,1)=0.04
6936 beta(3,1)=0.04
6937 beta(4,1)=0.80
6938 beta(1,2)=0.34
6939 beta(2,2)=0.28
6940 beta(3,2)=0.28
6941 beta(4,2)=0.10
6942 beta(1,3)=0.45
6943 beta(2,3)=0.15
6944 beta(3,3)=0.15
6945 beta(4,3)=0.25
6946 beta(1,4)=0.12
6947 beta(2,4)=0.09
6948 beta(3,4)=0.09
6949 beta(4,4)=0.70
6950 beta(1,5)=0.40
6951 beta(2,5)=0.05
6952 beta(3,5)=0.05
6953 beta(4,5)=0.50
6954 beta(1,6)=0.34
6955 beta(2,6)=0.18
6956 beta(3,6)=0.18
6957 beta(4,6)=0.30
6958 beta(1,7)=0.22
6959 beta(2,7)=0.09
6960 beta(3,7)=0.09
6961 beta(4,7)=0.60
6962 gamma(1)=0.08
6963 gamma(2)=1.00
6964 gamma(3)=1.00
6965 gamma(4)=0.12
6966 !
6967 ! * Mass fractions for each size bin. These values were recommended by
6968 ! Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM.
6969 ! * Changed slightly since Natelie's estimates do not add up to 1.0
6970 ! * This would need to be made more generic for other bin sizes.
6971 ! sz(1)=0
6972 ! sz(2)=1.78751e-06
6973 ! sz(3)=0.000273786
6974 ! sz(4)=0.00847978
6975 ! sz(5)=0.056055
6976 ! sz(6)=0.0951896
6977 ! sz(7)=0.17
6978 ! sz(8)=0.67
6979 sz(1)=0.0
6980 sz(2)=0.0
6981 sz(3)=0.0005
6982 sz(4)=0.0095
6983 sz(5)=0.03
6984 sz(6)=0.10
6985 sz(7)=0.18
6986 sz(8)=0.68
6988 ! for now just do itype=1
6989 itype = 1
6990 iphase = ai_phase
6992 ! loop over i,j and apply dust emissions
6993 k = kts
6994 do 1830 j = jts, jte
6995 do 1820 i = its, ite
6997 if( xland(i,j) > 1.5 ) cycle
6999 ! compute wind speed anyway, even though ustar is used below
7001 dumlandfrac = 1.
7002 dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
7003 if(dumspd10 >= 5.0) then
7004 dumspd10 = dumlandfrac* &
7005 ( dumspd10*dumspd10*(dumspd10-5.0))
7006 else
7007 dumspd10=0.
7008 endif
7010 ! part1 - compute vegetation mask
7011 !
7012 ! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories
7013 ! for desert, sand desert, grass aemi-desert, and shrub semi-desert
7014 ! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna
7015 ! that are dominate types in Mexico and probably have some erodable surface
7016 ! during the dry season
7017 ! * currently modified these values so that only a small fraction of cell
7018 ! area is erodable
7019 ! * these values are highly tuneable!
7021 alphamask=0.001
7022 if (ivgtyp(i,j) .eq. 7) then
7023 f8=0.005
7024 f50=0.00
7025 f51=0.10
7026 f52=0.00
7027 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7028 endif
7029 if (ivgtyp(i,j) .eq. 8) then
7030 f8=0.010
7031 f50=0.00
7032 f51=0.00
7033 f52=0.15
7034 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7035 endif
7036 if (ivgtyp(i,j) .eq. 10) then
7037 f8=0.00
7038 f50=0.00
7039 f51=0.01
7040 f52=0.00
7041 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7042 endif
7044 ! part2 - zobler
7045 !
7046 ! * in Shaw's paper, dust is computed for 4 size ranges:
7047 ! 0.5-1 um
7048 ! 1-10 um
7049 ! 10-25 um
7050 ! 25-50 um
7051 ! * Shaw's paper also accounts for sub-grid variability in soil
7052 ! texture, but here we just assume the same soil texture for each
7053 ! grid cell
7054 ! * since MOSAIC is currently has a maximum size range up to 10 um,
7055 ! neglect upper 2 size ranges and lowest size range (assume small)
7056 ! * map WRF soil classes arbitrarily to Zolber soil textural classes
7057 ! * skip dust computations for WRF soil classes greater than 13, i.e.
7058 ! do not compute dust over water, bedrock, and other surfaces
7059 ! * should be skipping for water surface at this point anyway
7060 !
7061 izob=0
7062 if(isltyp(i,j).eq.1) izob=1
7063 if(isltyp(i,j).eq.2) izob=1
7064 if(isltyp(i,j).eq.3) izob=4
7065 if(isltyp(i,j).eq.4) izob=2
7066 if(isltyp(i,j).eq.5) izob=2
7067 if(isltyp(i,j).eq.6) izob=2
7068 if(isltyp(i,j).eq.7) izob=7
7069 if(isltyp(i,j).eq.8) izob=2
7070 if(isltyp(i,j).eq.9) izob=6
7071 if(isltyp(i,j).eq.10) izob=5
7072 if(isltyp(i,j).eq.11) izob=2
7073 if(isltyp(i,j).eq.12) izob=3
7074 if(isltyp(i,j).ge.13) izob=0
7075 if(izob.eq.0) goto 1840
7076 !
7077 ! part3 - dustprod
7078 !
7079 do ii=1,4
7080 delta(ii)=0.0
7081 enddo
7082 sumdelta=0.0
7083 do ii=1,4
7084 delta(ii)=beta(ii,izob)*gamma(ii)
7085 if(ii.lt.4) then
7086 sumdelta=sumdelta+delta(ii)
7087 endif
7088 enddo
7089 do ii=1,4
7090 delta(ii)=delta(ii)/sumdelta
7091 enddo
7093 ! part4 - wetness
7094 !
7095 ! * assume dry for now, have passed in soil moisture to this routine
7096 ! but needs to be included here
7097 ! * wetfactor less than 1 would reduce dustflux
7098 ! * convert model soil moisture (m3/m3) to gravimetric soil moisture
7099 ! (mass of water / mass of soil in %) assuming a constant density
7100 ! for soil
7101 pclay=beta(1,izob)*100.
7102 wp=0.0014*pclay*pclay+0.17*pclay
7103 smois_grav=(smois(i,1,j)/2.6)*100.
7104 if(smois_grav.gt.wp) then
7105 wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
7106 else
7107 wetfactor=1.0
7108 endif
7109 ! wetfactor=1.0
7111 ! part5 - dustflux
7112 ! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper
7113 ! bound to 100 cm/s
7115 ustar1=ust(i,j)*100.0
7116 if(ustar1.gt.100.0) ustar1=100.0
7117 ustart0=20.0
7118 ustart=ustart0*wetfactor
7119 if(ustar1.le.ustart) then
7120 dustflux=0.0
7121 else
7122 dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1))
7123 endif
7124 dustflux=dustflux*10.0
7125 ! units kg m-2 s-1
7126 ftot=0.0
7127 do ii=1,2
7128 ftot=ftot+dustflux*alphamask*delta(ii)
7129 enddo
7130 ! convert to ug m-2 s-1
7131 ftot=ftot*1.0e+09
7133 ! apportion other inorganics only
7134 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7135 factbb = factaa * ftot
7136 fracoin = 1.00
7137 ! fracca = 0.03*0.4
7138 ! fracco3 = 0.03*0.6
7139 fracca = 0.0
7140 fracco3 = 0.0
7141 fractot = fracoin + fracca + fracco3
7143 !liqy
7145 dstfracna = 0.0236
7146 dstfraccl = 0.0
7147 dstfracca = 0.0385
7148 dstfrack = 0.0214
7149 dstfracmg = 0.0220
7150 dstfrac = 1.0-(dstfracna+dstfraccl+dstfracca+dstfrack+dstfracmg)
7152 ! if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot
7154 chem(i,k,j,p_naaj)=chem(i,k,j,p_naaj) + &
7155 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfracna
7156 ! chem(i,k,j,p_claj)=chem(i,k,j,p_claj) + &
7157 ! factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfraccl
7159 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + &
7160 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot * dstfrac
7161 !liqy-20140709
7163 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot
7164 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + &
7165 factbb * (sz(7)+sz(8)) * fractot
7166 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot
7167 ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3
7168 densdust=2.5
7169 dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
7170 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7171 chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) + &
7172 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part
7173 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part
7174 dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
7175 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
7176 chem(i,k,j,p_corn)=chem(i,k,j,p_corn) + &
7177 factbb * (sz(7)+sz(8)) * fractot / mass1part
7178 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part
7180 1840 continue
7182 1820 continue
7183 1830 continue
7185 return
7187 END subroutine soa_vbs_dust_emiss
7189 !====================================================================================
7190 !add another dust emission scheme following GOCART mechanism --czhao 09/17/2009
7191 !====================================================================================
7192 subroutine soa_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, &
7193 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
7194 ivgtyp,isltyp,xland,dx,g, &
7195 ids,ide, jds,jde, kds,kde, &
7196 ims,ime, jms,jme, kms,kme, &
7197 its,ite, jts,jte, kts,kte )
7198 USE module_data_gocart_dust
7199 USE module_configure
7200 USE module_state_description
7201 USE module_model_constants, ONLY: mwdry
7202 USE module_data_mosaic_asect
7203 IMPLICIT NONE
7205 INTEGER, INTENT(IN ) :: ktau, num_soil_layers, &
7206 ids,ide, jds,jde, kds,kde, &
7207 ims,ime, jms,jme, kms,kme, &
7208 its,ite, jts,jte, kts,kte
7209 INTEGER,DIMENSION( ims:ime , jms:jme ) , &
7210 INTENT(IN ) :: &
7211 ivgtyp, &
7212 isltyp
7213 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7214 INTENT(INOUT ) :: chem
7215 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
7216 INTENT(INOUT) :: smois
7217 REAL, DIMENSION( ims:ime , jms:jme, 3 ) , &
7218 INTENT(IN ) :: erod
7219 REAL, DIMENSION( ims:ime , jms:jme ) , &
7220 INTENT(IN ) :: &
7221 u10, &
7222 v10, &
7223 xland
7224 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7225 INTENT(IN ) :: &
7226 alt, &
7227 dz8w,p8w, &
7228 u_phy,v_phy,rho_phy
7230 REAL, INTENT(IN ) :: dt,dx,g
7231 !
7232 ! local variables
7233 !
7234 integer :: nmx,i,j,k,ndt,imx,jmx,lmx
7235 integer ilwi, start_month
7236 real*8, DIMENSION (3) :: erodin
7237 real*8, DIMENSION (5) :: bems
7238 real*8 w10m,gwet,airden,airmas
7239 real*8 cdustemis,jdustemis,cdustcon,jdustcon
7240 real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
7241 real*8 dxy
7242 real*8 conver,converi
7243 real dttt
7244 real soilfacj,rhosoilj,rhosoilc
7245 real totalemis,accfrac,corfrac,rscale1,rscale2
7247 accfrac=0.07 ! assign 7% to accumulation mode
7248 corfrac=0.93 ! assign 93% to coarse mode
7249 rscale1=1.00 ! to account for the dust larger than 10um in radius
7250 rscale2=1.02 ! to account for the dust larger than 10um in radius
7251 accfrac=accfrac*rscale1
7252 corfrac=corfrac*rscale2
7254 rhosoilj=2.5e3
7255 rhosoilc=2.6e3
7256 soilfacj=soilfac*rhosoilj/rhosoilc
7258 conver=1.e-9
7259 converi=1.e9
7260 !
7261 ! number of dust bins
7262 nmx=5
7263 k=kts
7264 do j=jts,jte
7265 do i=its,ite
7266 !
7267 ! don't do dust over water!!!
7268 if(xland(i,j).lt.1.5)then
7270 ilwi=1
7271 start_month = 3 ! it doesn't matter, ch_dust is not a month dependent now, a constant
7272 w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
7273 airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! kg
7275 ! we don't trust the u10,v10 values, if model layers are very thin near surface
7276 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))
7277 !erodin(1)=erod(i,j,1)/dx/dx ! czhao erod shouldn't be scaled to the area, because it's a fraction
7278 !erodin(2)=erod(i,j,2)/dx/dx
7279 !erodin(3)=erod(i,j,3)/dx/dx
7280 erodin(1)=erod(i,j,1)
7281 erodin(2)=erod(i,j,2)
7282 erodin(3)=erod(i,j,3)
7283 !
7284 ! volumetric soil moisture over porosity
7285 gwet=smois(i,1,j)/porosity(isltyp(i,j))
7286 ndt=ifix(dt)
7287 airden=rho_phy(i,kts,j)
7288 dxy=dx*dx
7290 call soa_vbs_source_du( nmx, dt,i,j, &
7291 erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
7292 bems,start_month,g)
7294 !bems: kg/timestep/cell
7295 !sum up the dust emission from 0.1-10 um in radius
7296 ! unit change from kg/timestep/cell to ug/m2/s
7297 totalemis=(sum(bems(1:5))/dt)*converi/dxy
7298 ! to account for the particles larger than 10 um radius
7299 ! based on assumed size distribution
7300 jdustemis = totalemis*accfrac ! accumulation mode
7301 cdustemis = totalemis*corfrac ! coarse mode
7303 cdustcon = sum(bems(1:5))*corfrac/airmas ! kg/kg-dryair
7304 cdustcon = cdustcon * converi ! ug/kg-dryair
7305 jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair
7306 jdustcon = jdustcon * converi ! ug/kg-dryair
7308 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon
7309 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon
7311 ! czhao doing dust number emission following pm10
7312 ! use soilfacj for accumulation mode because GOCART assign a less dense dust in
7313 ! accumulation mode
7314 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj
7315 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac
7317 endif
7318 enddo
7319 enddo
7321 end subroutine soa_vbs_dust_gocartemis
7323 SUBROUTINE soa_vbs_source_du( nmx, dt1,i,j, &
7324 erod, ilwi, dxy, w10m, gwet, airden, airmas, &
7325 bems,month,g0)
7327 ! ****************************************************************************
7328 ! * Evaluate the source of each dust particles size classes (kg/m3)
7329 ! * by soil emission.
7330 ! * Input:
7331 ! * EROD Fraction of erodible grid cell (-)
7332 ! * for 1: Sand, 2: Silt, 3: Clay
7333 ! * DUSTDEN Dust density (kg/m3)
7334 ! * DXY Surface of each grid cell (m2)
7335 ! * AIRVOL Volume occupy by each grid boxes (m3)
7336 ! * NDT1 Time step (s)
7337 ! * W10m Velocity at the anemometer level (10meters) (m/s)
7338 ! * u_tresh Threshold velocity for particule uplifting (m/s)
7339 ! * CH_dust Constant to fudge the total emission of dust (s2/m2)
7340 ! *
7341 ! * Output:
7342 ! * DSRC Source of each dust type (kg/timestep/cell)
7343 ! *
7344 ! * Working:
7345 ! * SRC Potential source (kg/m/timestep/cell)
7346 ! *
7347 ! ****************************************************************************
7349 USE module_data_gocart_dust
7351 INTEGER, INTENT(IN) :: nmx
7352 REAL*8, INTENT(IN) :: erod(ndcls)
7353 INTEGER, INTENT(IN) :: ilwi,month
7355 REAL*8, INTENT(IN) :: w10m, gwet
7356 REAL*8, INTENT(IN) :: dxy
7357 REAL*8, INTENT(IN) :: airden, airmas
7358 REAL*8, INTENT(OUT) :: bems(nmx)
7360 REAL*8 :: den(nmx), diam(nmx)
7361 REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce
7362 REAL, intent(in) :: g0
7363 REAL :: rhoa, g,dt1
7364 INTEGER :: i, j, n, m, k
7366 ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5
7367 !ch_dust(:,:)=0.8D-9 ! ch_dust is defined here instead of in the chemics_ini.F if with SOA_VBS -czhao
7368 ch_dust(:,:)=1.0D-9 ! default
7369 !ch_dust(:,:)=0.65D-9 ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara
7370 !ch_dust(:,:)=1.0D-9*0.36 ! ch_dust is scaled to soa_vbs total dust emission
7372 ! executable statemenst
7373 DO n = 1, nmx
7374 ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941)
7375 den(n) = den_dust(n)*1.0D-3
7376 diam(n) = 2.0*reff_dust(n)*1.0D2
7377 g = g0*1.0E2
7378 ! Pointer to the 3 classes considered in the source data files
7379 m = ipoint(n)
7380 tsrc = 0.0
7381 rhoa = airden*1.0D-3
7382 u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
7383 SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
7384 SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
7386 ! Case of surface dry enough to erode
7387 IF (gwet < 0.5) THEN ! Pete's modified value
7388 ! IF (gwet < 0.2) THEN
7389 u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
7390 ELSE
7391 ! Case of wet surface, no erosion
7392 u_ts = 100.0
7393 END IF
7394 srce = frac_s(n)*erod(m)*dxy ! (m2)
7395 IF (ilwi == 1 ) THEN
7396 dsrc = ch_dust(n,month)*srce*w10m**2 &
7397 * (w10m - u_ts)*dt1 ! (kg)
7398 ELSE
7399 dsrc = 0.0
7400 END IF
7401 IF (dsrc < 0.0) dsrc = 0.0
7403 ! Update dust mixing ratio at first model level.
7404 !tc(n) = tc(n) + dsrc / airmas !kg/kg-dryair -czhao
7405 bems(n) = dsrc ! kg/timestep/cell
7407 ENDDO
7409 END SUBROUTINE soa_vbs_source_du
7411 !===========================================================================
7413 !!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F)
7415 !===========================================================================
7416 ! subroutine wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags, &
7417 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
7418 ! qlsink,precr,preci,precs,precg,qsrflx, &
7419 ! gas_aqfrac, numgas_aqfrac, &
7420 ! ids,ide, jds,jde, kds,kde, &
7421 ! ims,ime, jms,jme, kms,kme, &
7422 ! its,ite, jts,jte, kts,kte )
7424 ! wet removal by grid-resolved precipitation
7425 ! scavenging of cloud-phase aerosols and gases by collection, freezing, ...
7426 ! scavenging of interstitial-phase aerosols by impaction
7427 ! scavenging of gas-phase gases by mass transfer and reaction
7429 !----------------------------------------------------------------------
7430 ! USE module_configure
7431 ! USE module_state_description
7432 ! USE module_data_soa_vbs
7433 ! USE module_mosaic_wetscav,only: wetscav
7435 !----------------------------------------------------------------------
7436 ! IMPLICIT NONE
7438 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
7440 ! INTEGER, INTENT(IN ) :: &
7441 ! ids,ide, jds,jde, kds,kde, &
7442 ! ims,ime, jms,jme, kms,kme, &
7443 ! its,ite, jts,jte, kts,kte, &
7444 ! id, ktau, ktauc, numgas_aqfrac
7445 ! REAL, INTENT(IN ) :: dtstep,dtstepc
7447 ! all advected chemical species
7448 !
7449 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7450 ! INTENT(INOUT ) :: chem
7452 ! fraction of gas species in cloud water
7453 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), &
7454 ! INTENT(IN ) :: gas_aqfrac
7456 !
7457 !
7458 ! input from meteorology
7459 ! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7460 ! INTENT(IN ) :: &
7461 ! alt, &
7462 ! t_phy, &
7463 ! p_phy, &
7464 ! t8w,p8w, &
7465 ! qlsink,precr,preci,precs,precg, &
7466 ! rho_phy,cldfra
7467 ! REAL, DIMENSION( ims:ime, jms:jme, num_chem ), &
7468 ! INTENT(OUT ) :: qsrflx ! column change due to scavening
7470 ! call wetscav (id,ktau,dtstep,ktauc,config_flags, &
7471 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
7472 ! qlsink,precr,preci,precs,precg,qsrflx, &
7473 ! gas_aqfrac, numgas_aqfrac, &
7474 ! ntype_aer, nsize_aer, ncomp_aer, &
7475 ! massptr_aer, dens_aer, numptr_aer, &
7476 ! maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, &
7477 ! volumcen_sect, volumlo_sect, volumhi_sect, &
7478 ! waterptr_aer, dens_water_aer, &
7479 ! scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, &
7480 ! ids,ide, jds,jde, kds,kde, &
7481 ! ims,ime, jms,jme, kms,kme, &
7482 ! its,ite, jts,jte, kts,kte )
7484 ! end subroutine wetscav_soa_vbs_driver
7485 !===========================================================================
7487 END Module module_aerosols_soa_vbs