| blob | 227ba4a64d47f40459794a4b4a5c57029f9a0787 |
1 MODULE module_aerosols_sorgam_vbs
2 !
3 ! 10/08/2014: This module is a modified version of the "module_aerosols_soa_vbs" based on the work of Ahmadov et al. (2012).
4 ! This module treats the major aerosol processes related to chemical option CB05-MADE/VBS, which is implemented by NCSU
5 !
6 ! References:
7 ! 1) Wang, K., Y. Zhang, K. Yahya, S.-Y. Wu, and G. Grell (2014), Implementation and initial application of new chemistry-aerosol ! options in WRF/Chem for simulating secondary organic aerosols and aerosol indirect effects, Atmos. Environ., under review.
8 ! 2) Ahmadov R., McKeen S.A., Robinson A.L., Bahreini R., Middlebrook A., deGouw J., Meagher J., Hsie E.-Y.,
9 ! Edgerton E., Shaw S., Trainer M. (2012), A volatility basis set model for summertime secondary organic aerosols
10 ! over the eastern U.S. in 2006. J. Geophys. Res.,117, D06301, doi:10.1029/2011JD016831.
11 ! 3) Murphy, B. N. and S. N. Pandis (2009). "Simulating the Formation of Semivolatile Primary and Secondary Organic Aerosol
12 ! in a Regional Chemical Transport Model." Environmental Science & Technology 43(13): 4722-4728.
13 ! 4) Donahue, N. M., A. L. Robinson, et al. (2006). "Coupled partitioning, dilution, and chemical aging of semivolatile
14 ! organics." Environmental Science & Technology 40(8): 2635-2643.
15 !
16 ! A reference for the MADE aerosol parameterization:
17 ! Ackermann, I. J., H. Hass, M. Memmesheimer, A. Ebel, F. S. Binkowski, and U. Shankar (1998),
18 ! Modal aerosol dynamics model for Europe: Development and first applications, Atmos. Environ., 32(17), 2981-2999.
19 !
20 !!WARNING! The deposition of organic condensable vapours (cvasoa* and cvbsoa*) are highly uncertain due to lack of observations.
21 ! Currently this process is parameterized using modeled dry deposition velocities of HNO3 (multiplied by "depo_fact" for OCVs).
22 ! Paper by Ahmadov et al. (2012) desribes this approach. The default value for "depo_fact" in WRF-CHEM is 0.25.
23 ! A user can set a different value for "depo_fact" in namelist.input.
24 !
25 !!WARNING! Another uncertainty is wet removal of OCVs! This is neglected in the current version of the WRF-CHEM code.
26 !
27 !
28 !
29 USE module_state_description
30 ! USE module_data_radm2
31 USE module_data_sorgam_vbs
32 ! USE module_radm
34 IMPLICIT NONE
35 #define cw_species_are_in_registry
37 CONTAINS
39 SUBROUTINE sorgam_vbs_driver ( id,ktau,dtstep,t_phy,moist,aerwrf,p8w, &
40 t8w,alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
41 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
42 vcsulf_old, &
43 vdrog3, &
44 kemit,brch_ratio, &
45 ids,ide, jds,jde, kds,kde, &
46 ims,ime, jms,jme, kms,kme, &
47 its,ite, jts,jte, kts,kte )
49 ! USE module_configure, only: grid_config_rec_type
50 ! TYPE (grid_config_rec_type), INTENT (in) :: config_flags
52 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
53 ims,ime, jms,jme, kms,kme, &
54 its,ite, jts,jte, kts,kte, &
55 kemit, id, ktau
57 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
58 INTENT(IN ) :: moist
60 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
61 INTENT(INOUT ) :: chem
62 !
63 ! following are aerosol arrays that are not advected
64 !
65 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
66 INTENT(INOUT ) :: &
67 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
69 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
70 INTENT(INOUT ) :: brch_ratio
72 ! cvasoa1,cvasoa2, &
73 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4
75 REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog_vbs), &
76 INTENT(IN ) :: VDROG3
77 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
78 INTENT(IN ) :: t_phy, &
79 alt, &
80 p_phy, &
81 dz8w, &
82 rh, & ! fractional relative humidity
83 z, &
84 t8w,p8w,z_at_w , &
85 aerwrf , &
86 rho_phy
87 REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , &
88 INTENT(IN ) :: vcsulf_old
89 REAL, INTENT(IN ) :: dtstep
91 REAL drog_in(ldrog_vbs) ! anthropogenic AND biogenic organic aerosol precursors [ug m**-3 s**-1]
93 ! REAL condvap_in(lspcv) ! condensable vapors [ug m**-3]
94 REAL, PARAMETER :: rgas=8.314510
95 REAL convfac,convfac2
97 !...BLKSIZE set to one in column model ciarev02
98 INTEGER, PARAMETER :: blksize=1
100 !...number of aerosol species
101 ! number of species (gas + aerosol)
102 INTEGER nspcsda
103 PARAMETER (nspcsda=l1ae) !bs
104 ! (internal aerosol dynamics)
105 !bs # of anth. cond. vapors in SOA_VBS
106 INTEGER nacv
107 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
108 !bs total # of cond. vapors in SOA_VBS
109 INTEGER ncv
110 PARAMETER (ncv=lspcv) !bs
111 !bs total # of cond. vapors in CTM
112 REAL cblk(blksize,nspcsda) ! main array of variables
113 ! particles [ug/m^3/s]
114 REAL soilrat_in
115 ! emission rate of soil derived coars
116 ! input HNO3 to CBLK [ug/m^3]
117 REAL nitrate_in
118 ! input NH3 to CBLK [ug/m^3]
119 REAL nh3_in
120 ! input SO4 vapor [ug/m^3]
121 REAL hcl_in
123 REAL vsulf_in
125 REAL so4rat_in
126 ! input SO4 formation[ug/m^3/sec]
127 REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
128 ! Emission rate of i-mode EC [ug m**-3 s**-1]
129 REAL eeci_in
130 ! Emission rate of j-mode EC [ug m**-3 s**-1]
131 REAL eecj_in
132 ! Emission rate of j-mode org. aerosol [ug m**-
133 REAL eorgi_in
135 REAL eorgj_in ! Emission rate of j-mode org. aerosol [ug m**-
136 REAL pres ! pressure in cb
137 REAL temp ! temperature in K
138 ! REAL relhum ! rel. humidity (0,1)
139 REAL brrto
141 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
143 !...molecular weights ciarev02
144 ! these molecular weights aren't used at all
146 ! molecular weight for SO4
147 REAL mwso4
148 PARAMETER (mwso4=96.0576)
150 ! molecular weight for HNO3
151 REAL mwhno3
152 PARAMETER (mwhno3=63.01287)
154 ! molecular weight for NH3
155 REAL mwnh3
156 PARAMETER (mwnh3=17.03061)
158 ! molecular weight for HCL
159 REAL mwhcl
160 PARAMETER (mwhcl=36.46100)
162 !bs molecular weight for Organic Spec
163 !mworg uncommented
164 REAL mworg
165 PARAMETER (mworg=175.0)
167 !bs molecular weight for Elemental Carbon
168 REAL mwec
169 PARAMETER (mwec=12.0)
171 ! they aren't used
172 !!rs molecular weight
173 ! REAL mwaro1
174 ! PARAMETER (mwaro1=150.0)
175 !
176 !!rs molecular weight
177 ! REAL mwaro2
178 ! PARAMETER (mwaro2=150.0)
179 !
180 !!rs molecular weight
181 ! REAL mwalk1
182 ! PARAMETER (mwalk1=140.0)
183 !
184 !!rs molecular weight
185 ! REAL mwalk2
186 ! PARAMETER (mwalk2=140.0)
187 !
188 !!rs molecular weight
189 ! REAL mwole1
190 ! PARAMETER (mwole1=140.0)
191 !
192 !!rs molecular weight
193 ! REAL mwapi1
194 ! PARAMETER (mwapi1=200.0)
195 !
196 !!rs molecular weight
197 ! REAL mwapi2
198 ! PARAMETER (mwapi2=200.0)
199 !
200 !!rs molecular weight
201 ! REAL mwlim1
202 ! PARAMETER (mwlim1=200.0)
203 !
204 !!rs molecular weight
205 ! REAL mwlim2
206 ! PARAMETER (mwlim2=200.0)
208 INTEGER :: i,j,k,l,debug_level
209 ! convert advected aerosol variables to ug/m3 from mixing ratio
210 ! they will be converted back at the end of this driver
211 !
212 do l=p_so4aj,num_chem
213 do j=jts,jte
214 do k=kts,kte
215 do i=its,ite
216 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j))
217 enddo
218 enddo
219 enddo
220 enddo
222 ! Use RH from phys/???
223 do 100 j=jts,jte
224 do 100 i=its,ite
225 debug_level=0
227 ! t(k) = t_phy(i,k,j)
228 ! p(k) = .001*p_phy(i,k,j)
229 ! rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / &
230 ! (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
231 ! (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) )
232 ! rh(k)=max(.1,0.01*rh(k))
233 ! ! rh(k) = .10
234 ! enddo
236 k_loop: do k=kts,kte
238 ! added here
239 t(k) = t_phy(i,k,j)
240 p(k) = .001*p_phy(i,k,j)
241 rh0(k) = rh(i,k,j)
243 cblk=0.
245 ! do l=1,ldrog
246 ! drog_in(l)=0.
247 ! enddo
249 ! do l=1,lspcv
250 ! condvap_in(l)=0.
251 ! enddo
253 convfac = p(k)/rgas/t(k)*1000.
254 so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
255 soilrat_in = 0.
256 nitrate_in = max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
257 nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
258 hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
259 !KW hcl_in = 0.
260 vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
262 ! * organic aerosol precursors DeltaROG and SOA production
263 drog_in(PALK4) = VDROG3(i,k,j,PALK4)
264 drog_in(PALK5) = VDROG3(i,k,j,PALK5)
265 drog_in(POLE1) = VDROG3(i,k,j,POLE1)
266 drog_in(POLE2) = VDROG3(i,k,j,POLE2)
267 drog_in(PARO1) = VDROG3(i,k,j,PARO1)
268 drog_in(PARO2) = VDROG3(i,k,j,PARO2)
269 drog_in(PISOP) = VDROG3(i,k,j,PISOP)
270 drog_in(PTERP) = VDROG3(i,k,j,PTERP)
271 drog_in(PSESQ) = VDROG3(i,k,j,PSESQ)
272 drog_in(PBRCH) = VDROG3(i,k,j,PBRCH)
274 cblk(1,VASOA1J) = chem(i,k,j,p_asoa1j)
275 cblk(1,VASOA1I) = chem(i,k,j,p_asoa1i)
276 cblk(1,VASOA2J) = chem(i,k,j,p_asoa2j)
277 cblk(1,VASOA2I) = chem(i,k,j,p_asoa2i)
278 cblk(1,VASOA3J) = chem(i,k,j,p_asoa3j)
279 cblk(1,VASOA3I) = chem(i,k,j,p_asoa3i)
280 cblk(1,VASOA4J) = chem(i,k,j,p_asoa4j)
281 cblk(1,VASOA4I) = chem(i,k,j,p_asoa4i)
283 cblk(1,VBSOA1J) = chem(i,k,j,p_bsoa1j)
284 cblk(1,VBSOA1I) = chem(i,k,j,p_bsoa1i)
285 cblk(1,VBSOA2J) = chem(i,k,j,p_bsoa2j)
286 cblk(1,VBSOA2I) = chem(i,k,j,p_bsoa2i)
287 cblk(1,VBSOA3J) = chem(i,k,j,p_bsoa3j)
288 cblk(1,VBSOA3I) = chem(i,k,j,p_bsoa3i)
289 cblk(1,VBSOA4J) = chem(i,k,j,p_bsoa4j)
290 cblk(1,VBSOA4I) = chem(i,k,j,p_bsoa4i)
292 ! Comment out the old code
293 ! condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
294 ! condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
295 ! condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
296 ! condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
297 ! cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j)
298 ! cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i)
299 ! cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j)
300 ! cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i)
301 ! cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j)
302 ! cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i)
303 ! cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j)
304 ! cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i)
305 ! cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j)
306 ! cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i)
307 ! cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j)
308 ! cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i)
309 ! cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j)
310 ! cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i)
311 ! cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j)
312 ! cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i)
314 cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj)
315 cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai)
316 cblk(1,VECJ ) = chem(i,k,j,p_ecj)
317 cblk(1,VECI ) = chem(i,k,j,p_eci)
318 cblk(1,VP25AJ ) = chem(i,k,j,p_p25j)
319 cblk(1,VP25AI ) = chem(i,k,j,p_p25i)
320 cblk(1,VANTHA ) = chem(i,k,j,p_antha)
321 cblk(1,VSEAS ) = chem(i,k,j,p_seas)
322 cblk(1,VSOILA ) = chem(i,k,j,p_soila)
323 cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j))
324 cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j))
325 cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j))
326 cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j))
328 cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j))
330 cblk(1,vcvasoa1) = chem(i,k,j,p_cvasoa1)
331 cblk(1,vcvasoa2) = chem(i,k,j,p_cvasoa2)
332 cblk(1,vcvasoa3) = chem(i,k,j,p_cvasoa3)
333 cblk(1,vcvasoa4) = chem(i,k,j,p_cvasoa4)
335 cblk(1,vcvbsoa1) = chem(i,k,j,p_cvbsoa1)
336 cblk(1,vcvbsoa2) = chem(i,k,j,p_cvbsoa2)
337 cblk(1,vcvbsoa3) = chem(i,k,j,p_cvbsoa3)
338 cblk(1,vcvbsoa4) = chem(i,k,j,p_cvbsoa4)
339 !
340 ! Set emissions to zero
341 epmcoarse(1) = 0.
342 epm25i(1) = 0.
343 epm25j(1) = 0.
344 eeci_in = 0.
345 eecj_in = 0.
346 eorgi_in = 0.
347 eorgj_in = 0.
348 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
349 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
350 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
351 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
352 cblk(1,VNAAJ ) = chem(i,k,j,p_naaj)
353 cblk(1,VNAAI ) = chem(i,k,j,p_naai)
354 cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
355 cblk(1,VCLAI ) = chem(i,k,j,p_clai)
356 !KW cblk(1,VCLAJ ) = 0.
357 !KW cblk(1,VCLAI ) = 0.
358 !
359 !rs. nitrate, nh3, sulf
360 cblk(1,vsulf) = vsulf_in
361 cblk(1,vhno3) = nitrate_in
362 cblk(1,vnh3) = nh3_in
363 cblk(1,vhcl) = hcl_in
364 cblk(1,VNH4AJ) = chem(i,k,j,p_nh4aj)
365 cblk(1,VNH4AI) = chem(i,k,j,p_nh4ai)
366 cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0))
367 cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0))
368 cblk(1,VCORN ) = chem(i,k,j,p_corn)
370 ! the following operation updates cblk, which includes the vapors and SOA species
371 ! condvap_in is removed
372 CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh0(k),nitrate_in,nh3_in, &
373 vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv,nacv,eeci_in,eecj_in, &
374 eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k,brrto)
376 ! calculation of brch_ratio
377 brch_ratio(i,k,j)= brrto
378 !------------------------------------------------------------------------
380 chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
381 chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
382 chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
383 chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
384 chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
385 chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
386 chem(i,k,j,p_naaj) = cblk(1,VNAAJ )
387 chem(i,k,j,p_naai) = cblk(1,VNAAI )
388 !KW
389 chem(i,k,j,p_claj) = cblk(1,VCLAJ )
390 chem(i,k,j,p_clai) = cblk(1,VCLAI )
392 chem(i,k,j,p_asoa1j) = cblk(1,VASOA1J)
393 chem(i,k,j,p_asoa1i) = cblk(1,VASOA1I)
394 chem(i,k,j,p_asoa2j) = cblk(1,VASOA2J)
395 chem(i,k,j,p_asoa2i) = cblk(1,VASOA2I)
396 chem(i,k,j,p_asoa3j) = cblk(1,VASOA3J)
397 chem(i,k,j,p_asoa3i) = cblk(1,VASOA3I)
398 chem(i,k,j,p_asoa4j) = cblk(1,VASOA4J)
399 chem(i,k,j,p_asoa4i) = cblk(1,VASOA4I)
401 chem(i,k,j,p_bsoa1j) = cblk(1,VBSOA1J)
402 chem(i,k,j,p_bsoa1i) = cblk(1,VBSOA1I)
403 chem(i,k,j,p_bsoa2j) = cblk(1,VBSOA2J)
404 chem(i,k,j,p_bsoa2i) = cblk(1,VBSOA2I)
405 chem(i,k,j,p_bsoa3j) = cblk(1,VBSOA3J)
406 chem(i,k,j,p_bsoa3i) = cblk(1,VBSOA3I)
407 chem(i,k,j,p_bsoa4j) = cblk(1,VBSOA4J)
408 chem(i,k,j,p_bsoa4i) = cblk(1,VBSOA4I)
410 ! chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
411 ! chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
412 ! chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
413 ! chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
414 ! chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
415 ! chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
416 ! chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
417 ! chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
418 ! chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
419 ! chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
420 ! chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
421 ! chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
422 ! chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
423 ! chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
424 ! chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
425 ! chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
427 chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ )
428 chem(i,k,j,p_orgpai) = cblk(1,VORGPAI )
429 chem(i,k,j,p_ecj) = cblk(1,VECJ )
430 chem(i,k,j,p_eci) = cblk(1,VECI )
431 chem(i,k,j,p_p25j) = cblk(1,VP25AJ )
432 chem(i,k,j,p_p25i) = cblk(1,VP25AI )
433 chem(i,k,j,p_antha) = cblk(1,VANTHA )
434 chem(i,k,j,p_seas) = cblk(1,VSEAS )
435 chem(i,k,j,p_soila) = cblk(1,VSOILA )
436 chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 ))
437 chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 ))
439 chem(i,k,j,p_corn) = cblk(1,VCORN )
440 h2oaj(i,k,j) = cblk(1,VH2OAJ )
441 h2oai(i,k,j) = cblk(1,VH2OAI )
442 nu3(i,k,j) = cblk(1,VNU3 )
443 ac3(i,k,j) = cblk(1,VAC3 )
444 cor3(i,k,j) = cblk(1,VCOR3 )
446 chem(i,k,j,p_cvasoa1)= cblk(1,VCVASOA1 )
447 chem(i,k,j,p_cvasoa2)= cblk(1,VCVASOA2 )
448 chem(i,k,j,p_cvasoa3)= cblk(1,VCVASOA3 )
449 chem(i,k,j,p_cvasoa4)= cblk(1,VCVASOA4 )
451 chem(i,k,j,p_cvbsoa1)= cblk(1,VCVBSOA1 )
452 chem(i,k,j,p_cvbsoa2)= cblk(1,VCVBSOA2 )
453 chem(i,k,j,p_cvbsoa3)= cblk(1,VCVBSOA3 )
454 chem(i,k,j,p_cvbsoa4)= cblk(1,VCVBSOA4 )
456 !---------------------------------------------------------------------------
458 ! cvbsoa1(i,k,j) = 0.
459 ! cvbsoa2(i,k,j) = 0.
460 ! cvbsoa3(i,k,j) = 0.
461 ! cvbsoa4(i,k,j) = 0.
463 ! cvaro1(i,k,j) = cblk(1,VCVARO1 )
464 ! cvaro2(i,k,j) = cblk(1,VCVARO2 )
465 ! cvalk1(i,k,j) = cblk(1,VCVALK1 )
466 ! cvole1(i,k,j) = cblk(1,VCVOLE1 )
467 ! cvapi1(i,k,j) = 0.
468 ! cvapi2(i,k,j) = 0.
469 ! cvlim1(i,k,j) = 0.
470 ! cvlim2(i,k,j) = 0.
472 chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
473 chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
474 chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
475 chem(i,k,j,p_hcl)=max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL)
477 enddo k_loop ! k-loop
478 100 continue ! i,j-loop ends
480 ! convert aerosol variables back to mixing ratio from ug/m3
481 do l=p_so4aj,num_chem
482 do j=jts,jte
483 do k=kts,kte
484 do i=its,ite
485 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j))
486 enddo
487 enddo
488 enddo
489 enddo
491 END SUBROUTINE sorgam_vbs_driver
492 ! ///////////////////////////////////////////////////
494 SUBROUTINE sum_pm_sorgam_vbs ( &
495 alt, chem, h2oaj, h2oai, &
496 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, &
497 !KW
498 tsoa,asoa,bsoa, &
499 !KW
500 dust_opt, &
501 ids,ide, jds,jde, kds,kde, &
502 ims,ime, jms,jme, kms,kme, &
503 its,ite, jts,jte, kts,kte )
505 INTEGER, INTENT(IN ) :: dust_opt, &
506 ids,ide, jds,jde, kds,kde, &
507 ims,ime, jms,jme, kms,kme, &
508 its,ite, jts,jte, kts,kte
510 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
511 INTENT(IN ) :: chem
513 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
514 INTENT(IN ) :: alt,h2oaj,h2oai
516 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
517 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10, &
518 !KW
519 tsoa,asoa,bsoa
520 !KW
522 INTEGER :: i,ii,j,jj,k,n
523 !
524 ! sum up pm2_5 and pm10 output
525 !
526 pm2_5_dry(its:ite, kts:kte, jts:jte) = 0.
527 pm2_5_water(its:ite, kts:kte, jts:jte) = 0.
528 pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0.
529 tsoa(its:ite, kts:kte, jts:jte) = 0.
530 asoa(its:ite, kts:kte, jts:jte) = 0.
531 bsoa(its:ite, kts:kte, jts:jte) = 0.
532 do j=jts,jte
533 jj=min(jde-1,j)
534 do k=kts,kte
535 do i=its,ite
536 ii=min(ide-1,i)
537 do n=p_so4aj,p_p25i
538 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
539 enddo
540 !KW adding cloud aerosols
541 if( p_p25cwi .gt. p_p25i) then
542 do n=p_so4cwj,p_p25cwi
543 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
544 enddo
545 endif
546 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) &
547 + chem(ii,k,jj,p_eci)
548 pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) &
549 + h2oai(i,k,j)
550 !KW calculating SOA concentration
551 do n=p_asoa1j,p_bsoa4i
552 tsoa(i,k,j) = tsoa(i,k,j)+chem(ii,k,jj,n)
553 enddo
554 do n=p_asoa1j,p_asoa4i
555 asoa(i,k,j) = asoa(i,k,j)+chem(ii,k,jj,n)
556 enddo
557 do n=p_bsoa1j,p_bsoa4i
558 bsoa(i,k,j) = bsoa(i,k,j)+chem(ii,k,jj,n)
559 enddo
560 if( p_p25cwi .gt. p_p25i) then
561 do n=p_asoa1cwj,p_bsoa4cwi
562 tsoa(i,k,j) = tsoa(i,k,j)+chem(ii,k,jj,n)
563 enddo
564 do n=p_asoa1cwj,p_asoa4cwi
565 asoa(i,k,j) = asoa(i,k,j)+chem(ii,k,jj,n)
566 enddo
567 do n=p_bsoa1cwj,p_bsoa4cwi
568 bsoa(i,k,j) = bsoa(i,k,j)+chem(ii,k,jj,n)
569 enddo
570 endif
571 !Convert the units from mixing ratio to concentration (ug m^-3)
572 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,k,jj)
573 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj)
574 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,k,jj)
575 tsoa(i,k,j) = tsoa(i,k,j) / alt(ii,k,jj)
576 asoa(i,k,j) = asoa(i,k,j) / alt(ii,k,jj)
577 bsoa(i,k,j) = bsoa(i,k,j) / alt(ii,k,jj)
578 enddo
579 enddo
580 enddo
581 do j=jts,jte
582 jj=min(jde-1,j)
583 do k=kts,kte
584 do i=its,ite
585 ii=min(ide-1,i)
586 pm10(i,k,j) = pm2_5_dry(i,k,j) &
587 + ( chem(ii,k,jj,p_antha) &
588 + chem(ii,k,jj,p_soila) &
589 + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj)
590 !KW adding cloud aerosols
591 if( p_p25cwi .gt. p_p25i) then
592 pm10(i,k,j) = pm10(i,k,j) &
593 + ( chem(ii,k,jj,p_anthcw) &
594 + chem(ii,k,jj,p_soilcw) &
595 + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj)
596 endif
597 enddo
598 enddo
599 enddo
600 END SUBROUTINE sum_pm_sorgam_vbs
601 ! ///////////////////////////////////////////////////
603 SUBROUTINE sorgam_vbs_depdriver (id,config_flags,ktau,dtstep, &
604 ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, &
605 alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, &
606 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, &
608 ! the vapors are part of chem array
609 ! cvasoa1,cvasoa2, &
610 ! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4, &
612 aer_res,vgsa, &
613 !KW
614 numgas,ddflx, &
615 !KW
616 numaer, &
617 ids,ide, jds,jde, kds,kde, &
618 ims,ime, jms,jme, kms,kme, &
619 its,ite, jts,jte, kts,kte )
621 USE module_configure,only: grid_config_rec_type
622 TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags
624 INTEGER, INTENT(IN ) :: numgas, & !KW
625 numaer, &
626 ids,ide, jds,jde, kds,kde, &
627 ims,ime, jms,jme, kms,kme, &
628 its,ite, jts,jte, kts,kte, &
629 id,ktau
631 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
632 INTENT(IN ) :: moist
633 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
634 INTENT(INOUT ) :: chem
635 !
636 ! following are aerosol arrays that are not advected
637 !
638 REAL, DIMENSION( its:ite, jts:jte, numaer ), &
639 INTENT(INOUT ) :: &
640 vgsa
641 !KW
642 real, intent(inout), &
643 dimension( ims:ime, jms:jme, numgas+1:num_chem ) :: &
644 ddflx
645 !KW
646 REAL, DIMENSION( its:ite, jts:jte ), &
647 INTENT(INOUT ) :: &
648 aer_res
650 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
651 INTENT(INOUT ) :: &
652 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3
654 ! no vapors
655 !cvaro1,cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
657 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
658 INTENT(IN ) :: t_phy, &
659 alt, &
660 p_phy, &
661 dz8w, &
662 rh, &
663 z, &
664 t8w,p8w,z_at_w , &
665 rho_phy
666 REAL, DIMENSION( ims:ime , jms:jme ) , &
667 INTENT(IN ) :: ust,rmol, pbl, znt
668 REAL, INTENT(IN ) :: dtstep
670 REAL, PARAMETER :: rgas=8.314510
671 REAL convfac,convfac2
672 !...BLKSIZE set to one in column model ciarev02
674 INTEGER, PARAMETER :: blksize=1
676 !...number of aerosol species
677 ! number of species (gas + aerosol)
678 INTEGER nspcsda
679 PARAMETER (nspcsda=l1ae) !bs
680 ! (internal aerosol dynamics)
681 !bs # of anth. cond. vapors in SOA_VBS
682 INTEGER nacv
683 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
684 !bs total # of cond. vapors in SOA_VBS
685 INTEGER, PARAMETER :: ncv=lspcv ! number of bins=8
686 !bs total # of cond. vapors in CTM
687 REAL cblk(blksize,nspcsda) ! main array of variables
688 ! particles [ug/m^3/s]
689 REAL soilrat_in
690 ! emission rate of soil derived coars
691 ! input HNO3 to CBLK [ug/m^3]
692 REAL nitrate_in
693 ! input NH3 to CBLK [ug/m^3]
694 REAL nh3_in
695 !KW
696 !hcl_in added
697 REAL hcl_in
698 ! input SO4 vapor [ug/m^3]
699 REAL vsulf_in
701 REAL so4rat_in
702 ! input SO4 formation[ug/m^3/sec]
703 ! pressure in cb
704 REAL pres
705 ! temperature in K
706 REAL temp
707 !bs
708 REAL relhum
709 ! rel. humidity (0,1)
710 REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte)
712 !...molecular weights ciarev02
714 ! molecular weight for SO4
715 REAL mwso4
716 PARAMETER (mwso4=96.0576)
718 ! molecular weight for HNO3
719 REAL mwhno3
720 PARAMETER (mwhno3=63.01287)
722 !KW
723 !molecular weight for HCL added
724 REAL mwhcl
725 PARAMETER (mwhcl=36.46100)
727 ! molecular weight for NH3
728 REAL mwnh3
729 PARAMETER (mwnh3=17.03061)
731 !bs molecular weight for Organic Spec
732 REAL mworg
733 PARAMETER (mworg=175.0)
735 !bs molecular weight for Elemental Ca
736 REAL mwec
737 PARAMETER (mwec=12.0)
739 ! they aren't used
740 !!rs molecular weight
741 ! REAL mwaro1
742 ! PARAMETER (mwaro1=150.0)
743 !
744 !!rs molecular weight
745 ! REAL mwaro2
746 ! PARAMETER (mwaro2=150.0)
747 !
748 !!rs molecular weight
749 ! REAL mwalk1
750 ! PARAMETER (mwalk1=140.0)
751 !
752 !!rs molecular weight
753 ! REAL mwalk2
754 ! PARAMETER (mwalk2=140.0)
755 !
756 !!rs molecular weight
757 !!rs molecular weight
758 ! REAL mwole1
759 ! PARAMETER (mwole1=140.0)
760 !
761 !!rs molecular weight
762 ! REAL mwapi1
763 ! PARAMETER (mwapi1=200.0)
764 !
765 !!rs molecular weight
766 ! REAL mwapi2
767 ! PARAMETER (mwapi2=200.0)
768 !
769 !!rs molecular weight
770 ! REAL mwlim1
771 ! PARAMETER (mwlim1=200.0)
772 !
773 ! REAL mwlim2
774 ! PARAMETER (mwlim2=200.0)
776 INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model)
777 !ia kept to 1 in current version of column model
778 PARAMETER( NUMCELLS = 1)
780 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
781 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
782 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
783 REAL PBLH( BLKSIZE ) ! PBL height (m)
784 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
785 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
787 REAL BLKPRS(BLKSIZE) ! pressure in cb
788 REAL BLKTA(BLKSIZE) ! temperature in K
789 REAL BLKDENS(BLKSIZE) ! Air density in kg/m3
790 !
791 ! *** OUTPUT:
792 !
793 ! *** atmospheric properties
795 REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ]
796 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ]
798 ! *** followng is for future version
799 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
800 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
802 ! *** modal diameters: [ m ]
803 REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ]
804 REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ]
805 REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ]
807 ! *** aerosol properties:
808 ! *** Modal mass concentrations [ ug m**3 ]
809 REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode
810 REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode
811 REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode
813 ! *** average modal particle densities [ kg/m**3 ]
814 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode
815 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode
816 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode
818 ! *** average modal Knudsen numbers
819 REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number
820 REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number
821 REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number
822 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
824 INTEGER :: i,j,k,l
825 !
826 ! print *,'in sorgdepdriver ',its,ite,jts,jte
827 do l=1,numaer
828 do i=its,ite
829 do j=jts,jte
830 vgsa(i,j,l)=0.
831 enddo
832 enddo
833 enddo
834 vdep=0.
836 do 100 j=jts,jte
837 do 100 i=its,ite
838 cblk=epsilc
839 do k=kts,kte
840 t(k) = t_phy(i,k,j)
841 p(k) = .001*p_phy(i,k,j)
842 rh0(k) = rh(i,k,j)
843 end do
845 k=kts
846 convfac = p(k)/rgas/t(k)*1000.
847 nitrate_in = chem(i,k,j,p_hno3)*convfac*mwhno3
848 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
849 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4
850 hcl_in = chem(i,k,j,p_hcl)*convfac*mwhcl !KW
852 !rs. nitrate, nh3, sulf
853 BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa
854 BLKTA(BLKSIZE) = T(K) ! temperature in K
855 USTAR(BLKSIZE) = max(1.e-1,UST(i,j))
856 WSTAR(BLKSIZE) = 0.
857 pblh(blksize) = pbl(i,j)
858 zntt(blksize) = znt(i,j)
859 rmolm(blksize)= rmol(i,j)
860 convfac2=1./alt(i,k,j) ! density of dry air
861 BLKDENS(BLKSIZE)=convfac2
862 cblk(1,vsulf) = max(epsilc,vsulf_in)
863 cblk(1,vhno3) = max(epsilc,nitrate_in)
864 cblk(1,vnh3) = max(epsilc,nh3_in)
865 cblk(1,vhcl) = max(epsilc,hcl_in)
866 cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
867 cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
868 cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
869 cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
870 cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
871 cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
873 if (p_naai >= param_first_scalar) &
874 cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2)
875 if (p_naaj >= param_first_scalar) &
876 cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2)
877 if (p_clai >= param_first_scalar) &
878 cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2)
879 if (p_claj >= param_first_scalar) &
880 cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2)
882 cblk(1,VASOA1J) = max(epsilc,chem(i,k,j,p_asoa1j)*convfac2) ! ug/kg-air to ug/m3
883 cblk(1,VASOA1I) = max(epsilc,chem(i,k,j,p_asoa1i)*convfac2)
884 cblk(1,VASOA2J) = max(epsilc,chem(i,k,j,p_asoa2j)*convfac2)
885 cblk(1,VASOA2I) = max(epsilc,chem(i,k,j,p_asoa2i)*convfac2)
886 cblk(1,VASOA3J) = max(epsilc,chem(i,k,j,p_asoa3j)*convfac2)
887 cblk(1,VASOA3I) = max(epsilc,chem(i,k,j,p_asoa3i)*convfac2)
888 cblk(1,VASOA4J) = max(epsilc,chem(i,k,j,p_asoa4j)*convfac2)
889 cblk(1,VASOA4I) = max(epsilc,chem(i,k,j,p_asoa4i)*convfac2)
891 cblk(1,VBSOA1J) = max(epsilc,chem(i,k,j,p_bsoa1j)*convfac2)
892 cblk(1,VBSOA1I) = max(epsilc,chem(i,k,j,p_bsoa1i)*convfac2)
893 cblk(1,VBSOA2J) = max(epsilc,chem(i,k,j,p_bsoa2j)*convfac2)
894 cblk(1,VBSOA2I) = max(epsilc,chem(i,k,j,p_bsoa2i)*convfac2)
895 cblk(1,VBSOA3J) = max(epsilc,chem(i,k,j,p_bsoa3j)*convfac2)
896 cblk(1,VBSOA3I) = max(epsilc,chem(i,k,j,p_bsoa3i)*convfac2)
897 cblk(1,VBSOA4J) = max(epsilc,chem(i,k,j,p_bsoa4j)*convfac2)
898 cblk(1,VBSOA4I) = max(epsilc,chem(i,k,j,p_bsoa4i)*convfac2)
900 ! cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
901 ! cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
902 ! cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
903 ! cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
904 ! cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
905 ! cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
906 ! cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
907 ! cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
908 ! cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
909 ! cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
910 ! cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
911 ! cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
912 ! cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
913 ! cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
914 ! cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
915 ! cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
917 cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
918 cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
919 cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2)
920 cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2)
921 cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2)
922 cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2)
924 cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2)
925 cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2)
926 cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2)
928 cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2)
929 cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2)
931 cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2)
932 cblk(1,VH2OAJ ) = h2oaj(i,k,j)
933 cblk(1,VH2OAI ) = h2oai(i,k,j)
934 cblk(1,VNU3 ) = nu3(i,k,j)
935 cblk(1,VAC3 ) = ac3(i,k,j)
936 cblk(1,VCOR3 ) = cor3(i,k,j)
938 ! here cblk is used to call modpar, however modpar doesn't need vapors!
939 ! cblk(1,vcvasoa1 ) = cvasoa1(i,k,j)
940 ! cblk(1,vcvasoa2 ) = cvasoa2(i,k,j)
941 ! cblk(1,vcvasoa3 ) = cvasoa3(i,k,j)
942 ! cblk(1,vcvasoa4 ) = cvasoa4(i,k,j)
943 ! cblk(1,vcvbsoa1) = 0.
944 ! cblk(1,vcvbsoa2) = 0.
945 ! cblk(1,vcvbsoa3) = 0.
946 ! cblk(1,vcvbsoa4) = 0.
948 ! cblk(1,VCVARO1 ) = cvaro1(i,k,j)
949 ! cblk(1,VCVARO2 ) = cvaro2(i,k,j)
950 ! cblk(1,VCVALK1 ) = cvalk1(i,k,j)
951 ! cblk(1,VCVOLE1 ) = cvole1(i,k,j)
952 ! cblk(1,VCVAPI1 ) = 0.
953 ! cblk(1,VCVAPI2 ) = 0.
954 ! cblk(1,VCVLIM1 ) = 0.
955 ! cblk(1,VCVLIM2 ) = 0.
957 ! cblk(1,VCVAPI1 ) = cvapi1(i,k,j)
958 ! cblk(1,VCVAPI2 ) = cvapi2(i,k,j)
959 ! cblk(1,VCVLIM1 ) = cvlim1(i,k,j)
960 ! cblk(1,VCVLIM2 ) = cvlim2(i,k,j)
961 !
962 !rs. get size distribution information
963 ! if(i.eq.126.and.j.eq.99)then
964 ! print *,'in modpar ',i,j
965 ! print *,cblk,BLKTA,BLKPRS,USTAR
966 ! print *,'BLKSIZE, NSPCSDA, NUMCELLS'
967 ! print *,BLKSIZE, NSPCSDA, NUMCELLS
968 ! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
969 ! print *,XLM, AMU,PDENSN, PDENSA, PDENSC
970 ! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
971 ! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
972 ! endif
974 CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, &
975 CBLK, &
976 BLKTA, BLKPRS, &
977 PMASSN, PMASSA, PMASSC, &
978 PDENSN, PDENSA, PDENSC, &
979 XLM, AMU, &
980 DGNUC, DGACC, DGCOR, &
981 KNNUC, KNACC,KNCOR )
983 if (config_flags%aer_drydep_opt == 11) then
984 CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
985 BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, &
986 DGNUC, DGACC, DGCOR, &
987 KNNUC, KNACC,KNCOR, &
988 PDENSN, PDENSA, PDENSC, &
989 VSED, VDEP )
990 else
991 ! for aerosol dry deposition, no CBLK in VDVG_2
992 CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k, &
993 BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,&
994 ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,&
995 KNNUC, KNACC,KNCOR, &
996 PDENSN, PDENSA, PDENSC, &
997 VSED, VDEP )
998 endif
1000 VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC )
1001 VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC )
1002 VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ )
1003 VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI )
1004 VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ )
1005 VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI )
1007 if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI )
1008 if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ )
1009 if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI )
1010 if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ )
1012 VGSA(i, j, VASOA1J ) = VGSA(i, j, VSO4AJ )
1013 VGSA(i, j, VASOA1I ) = VGSA(i, j, VSO4AI )
1014 VGSA(i, j, VASOA2J ) = VGSA(i, j, VSO4AJ )
1015 VGSA(i, j, VASOA2I ) = VGSA(i, j, VSO4AI )
1016 VGSA(i, j, VASOA3J ) = VGSA(i, j, VSO4AJ )
1017 VGSA(i, j, VASOA3I ) = VGSA(i, j, VSO4AI )
1018 VGSA(i, j, VASOA4J ) = VGSA(i, j, VSO4AJ )
1019 VGSA(i, j, VASOA4I ) = VGSA(i, j, VSO4AI )
1021 VGSA(i, j, VBSOA1J ) = VGSA(i, j, VSO4AJ )
1022 VGSA(i, j, VBSOA1I ) = VGSA(i, j, VSO4AI )
1023 VGSA(i, j, VBSOA2J ) = VGSA(i, j, VSO4AJ )
1024 VGSA(i, j, VBSOA2I ) = VGSA(i, j, VSO4AI )
1025 VGSA(i, j, VBSOA3J ) = VGSA(i, j, VSO4AJ )
1026 VGSA(i, j, VBSOA3I ) = VGSA(i, j, VSO4AI )
1027 VGSA(i, j, VBSOA4J ) = VGSA(i, j, VSO4AJ )
1028 VGSA(i, j, VBSOA4I ) = VGSA(i, j, VSO4AI )
1029 !----------------------------------------------------------------------
1031 ! VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ )
1032 ! VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI )
1033 ! VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ )
1034 ! VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI )
1035 ! VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ )
1036 ! VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI )
1037 ! VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ )
1038 ! VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI )
1039 ! VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ )
1040 ! VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI )
1041 ! VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ )
1042 ! VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI )
1043 ! VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ )
1044 ! VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI )
1045 ! VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ )
1046 ! VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI )
1048 VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ )
1049 VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI )
1050 VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ )
1051 VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI )
1052 VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ )
1053 VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI )
1055 VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR )
1056 VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA )
1057 VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA )
1058 VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC )
1059 VGSA(i, j, VAC0 ) = VDEP(1, VDNACC )
1060 VGSA(i, j, VCORN ) = VDEP(1, VDNCOR )
1062 !KW
1063 if( config_flags%diagnostic_dep == 1) then
1064 ddflx(i,j,p_so4aj)=ddflx(i,j,p_so4aj)+chem(i,k,j,p_so4aj)/alt(i,k,j)*VGSA(i,j,VSO4AJ)*dtstep
1065 ddflx(i,j,p_so4ai)=ddflx(i,j,p_so4ai)+chem(i,k,j,p_so4ai)/alt(i,k,j)*VGSA(i,j,VSO4AI)*dtstep
1066 ddflx(i,j,p_nh4aj)=ddflx(i,j,p_nh4aj)+chem(i,k,j,p_nh4aj)/alt(i,k,j)*VGSA(i,j,VNH4AJ)*dtstep
1067 ddflx(i,j,p_nh4ai)=ddflx(i,j,p_nh4ai)+chem(i,k,j,p_nh4ai)/alt(i,k,j)*VGSA(i,j,VNH4Ai)*dtstep
1068 ddflx(i,j,p_no3aj)=ddflx(i,j,p_no3aj)+chem(i,k,j,p_no3aj)/alt(i,k,j)*VGSA(i,j,VNO3AJ)*dtstep
1069 ddflx(i,j,p_no3ai)=ddflx(i,j,p_no3ai)+chem(i,k,j,p_no3ai)/alt(i,k,j)*VGSA(i,j,VNO3AI)*dtstep
1070 ddflx(i,j,p_asoa1j)=ddflx(i,j,p_asoa1j)+chem(i,k,j,p_asoa1j)/alt(i,k,j)*VGSA(i,j,VASOA1J)*dtstep
1071 ddflx(i,j,p_asoa1i)=ddflx(i,j,p_asoa1i)+chem(i,k,j,p_asoa1i)/alt(i,k,j)*VGSA(i,j,VASOA1I)*dtstep
1072 ddflx(i,j,p_asoa2j)=ddflx(i,j,p_asoa2j)+chem(i,k,j,p_asoa2j)/alt(i,k,j)*VGSA(i,j,VASOA2J)*dtstep
1073 ddflx(i,j,p_asoa2i)=ddflx(i,j,p_asoa2i)+chem(i,k,j,p_asoa2i)/alt(i,k,j)*VGSA(i,j,VASOA2I)*dtstep
1074 ddflx(i,j,p_asoa3j)=ddflx(i,j,p_asoa3j)+chem(i,k,j,p_asoa3j)/alt(i,k,j)*VGSA(i,j,VASOA3J)*dtstep
1075 ddflx(i,j,p_asoa3i)=ddflx(i,j,p_asoa3i)+chem(i,k,j,p_asoa3i)/alt(i,k,j)*VGSA(i,j,VASOA3I)*dtstep
1076 ddflx(i,j,p_asoa4j)=ddflx(i,j,p_asoa4j)+chem(i,k,j,p_asoa4j)/alt(i,k,j)*VGSA(i,j,VASOA4J)*dtstep
1077 ddflx(i,j,p_asoa4i)=ddflx(i,j,p_asoa4i)+chem(i,k,j,p_asoa4i)/alt(i,k,j)*VGSA(i,j,VASOA4I)*dtstep
1078 ddflx(i,j,p_bsoa1j)=ddflx(i,j,p_bsoa1j)+chem(i,k,j,p_bsoa1j)/alt(i,k,j)*VGSA(i,j,VBSOA1J)*dtstep
1079 ddflx(i,j,p_bsoa1i)=ddflx(i,j,p_bsoa1i)+chem(i,k,j,p_bsoa1i)/alt(i,k,j)*VGSA(i,j,VBSOA1I)*dtstep
1080 ddflx(i,j,p_bsoa2j)=ddflx(i,j,p_bsoa2j)+chem(i,k,j,p_bsoa2j)/alt(i,k,j)*VGSA(i,j,VBSOA2J)*dtstep
1081 ddflx(i,j,p_bsoa2i)=ddflx(i,j,p_bsoa2i)+chem(i,k,j,p_bsoa2i)/alt(i,k,j)*VGSA(i,j,VBSOA2I)*dtstep
1082 ddflx(i,j,p_bsoa3j)=ddflx(i,j,p_bsoa3j)+chem(i,k,j,p_bsoa3j)/alt(i,k,j)*VGSA(i,j,VBSOA3J)*dtstep
1083 ddflx(i,j,p_bsoa3i)=ddflx(i,j,p_bsoa3i)+chem(i,k,j,p_bsoa3i)/alt(i,k,j)*VGSA(i,j,VBSOA3I)*dtstep
1084 ddflx(i,j,p_bsoa4j)=ddflx(i,j,p_bsoa4j)+chem(i,k,j,p_bsoa4j)/alt(i,k,j)*VGSA(i,j,VBSOA4J)*dtstep
1085 ddflx(i,j,p_bsoa4i)=ddflx(i,j,p_bsoa4i)+chem(i,k,j,p_bsoa4i)/alt(i,k,j)*VGSA(i,j,VBSOA4I)*dtstep
1086 ddflx(i,j,p_orgpaj)=ddflx(i,j,p_orgpaj)+chem(i,k,j,p_orgpaj)/alt(i,k,j)*VGSA(i,j,VORGPAJ)*dtstep
1087 ddflx(i,j,p_orgpai)=ddflx(i,j,p_orgpai)+chem(i,k,j,p_orgpai)/alt(i,k,j)*VGSA(i,j,VORGPAI)*dtstep
1088 ddflx(i,j,p_ecj)=ddflx(i,j,p_ecj)+chem(i,k,j,p_ecj)/alt(i,k,j)*VGSA(i,j,VECJ)*dtstep
1089 ddflx(i,j,p_eci)=ddflx(i,j,p_eci)+chem(i,k,j,p_eci)/alt(i,k,j)*VGSA(i,j,VECI)*dtstep
1090 ddflx(i,j,p_p25j)=ddflx(i,j,p_p25j)+chem(i,k,j,p_p25j)/alt(i,k,j)*VGSA(i,j,VP25AJ)*dtstep
1091 ddflx(i,j,p_p25i)=ddflx(i,j,p_p25i)+chem(i,k,j,p_p25i)/alt(i,k,j)*VGSA(i,j,VP25AI)*dtstep
1092 ddflx(i,j,p_naaj)=ddflx(i,j,p_naaj)+chem(i,k,j,p_naaj)/alt(i,k,j)*VGSA(i,j,VNAAJ)*dtstep
1093 ddflx(i,j,p_naai)=ddflx(i,j,p_naai)+chem(i,k,j,p_naai)/alt(i,k,j)*VGSA(i,j,VNAAI)*dtstep
1094 ddflx(i,j,p_claj)=ddflx(i,j,p_claj)+chem(i,k,j,p_claj)/alt(i,k,j)*VGSA(i,j,VCLAJ)*dtstep
1095 ddflx(i,j,p_clai)=ddflx(i,j,p_clai)+chem(i,k,j,p_clai)/alt(i,k,j)*VGSA(i,j,VCLAI)*dtstep
1096 ddflx(i,j,p_antha)=ddflx(i,j,p_antha)+chem(i,k,j,p_antha)/alt(i,k,j)*VGSA(i,j,VANTHA)*dtstep
1097 ddflx(i,j,p_seas)=ddflx(i,j,p_seas)+chem(i,k,j,p_seas)/alt(i,k,j)*VGSA(i,j,VSEAS)*dtstep
1098 ddflx(i,j,p_soila)=ddflx(i,j,p_soila)+chem(i,k,j,p_soila)/alt(i,k,j)*VGSA(i,j,VSOILA)*dtstep
1099 ddflx(i,j,p_nu0)=ddflx(i,j,p_nu0)+chem(i,k,j,p_nu0)/alt(i,k,j)*VGSA(i,j,VNU0)*dtstep
1100 ddflx(i,j,p_ac0)=ddflx(i,j,p_ac0)+chem(i,k,j,p_ac0)/alt(i,k,j)*VGSA(i,j,VAC0)*dtstep
1101 ddflx(i,j,p_corn)=ddflx(i,j,p_corn)+chem(i,k,j,p_corn)/alt(i,k,j)*VGSA(i,j,VCORN)*dtstep
1102 end if
1103 !KW
1104 ! enddo ! k-loop
1105 100 continue ! i,j-loop
1107 END SUBROUTINE sorgam_vbs_depdriver
1108 ! ///////////////////////////////////////////////////
1110 SUBROUTINE actcof(cat,an,gama,molnu,phimult)
1111 ! DESCRIPTION:
1112 ! This subroutine computes the activity coefficients of (2NH4+,SO4--),
1113 ! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
1114 ! multicomponent solution, using Bromley's model and Pitzer's method.
1116 ! REFERENCES:
1117 ! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
1118 ! in aqueous solutions. AIChE J. 19, 313-320.
1120 ! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of
1121 ! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
1123 ! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
1124 ! of strong acids over saline solutions - I HNO3,
1125 ! Atmos. Environ. (22): 91-100
1127 ! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
1128 ! and mean activity and osmotic coefficients of 0-100% nitric acid
1129 ! as a function of temperature, J. Phys. Chem (94): 5369 - 5380
1131 ! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
1132 ! general equilibrium model for inorganic multicomponent atmospheric
1133 ! aerosols. Atmos. Environ. 21(11), 2453-2466.
1135 ! ARGUMENT DESCRIPTION:
1136 ! CAT(1) : conc. of H+ (moles/kg)
1137 ! CAT(2) : conc. of NH4+ (moles/kg)
1138 ! AN(1) : conc. of SO4-- (moles/kg)
1139 ! AN(2) : conc. of NO3- (moles/kg)
1140 ! AN(3) : conc. of HSO4- (moles/kg)
1141 ! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--)
1142 ! GAMA(2,2) : (NH4+,NO3-)
1143 ! GAMA(2,3) : (NH4+. HSO4-)
1144 ! GAMA(1,1) : (2H+,SO4--)
1145 ! GAMA(1,2) : (H+,NO3-)
1146 ! GAMA(1,3) : (H+,HSO4-)
1147 ! MOLNU : the total number of moles of all ions.
1148 ! PHIMULT : the multicomponent paractical osmotic coefficient.
1150 ! REVISION HISTORY:
1151 ! Who When Detailed description of changes
1152 ! --------- -------- -------------------------------------------
1153 ! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this
1154 ! new routine using a method described by Pilini
1155 ! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
1156 ! S.Roselle 7/30/97 Modified for use in Models-3
1157 ! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA
1159 !-----------------------------------------------------------------------
1160 !...........INCLUDES and their descriptions
1161 ! INCLUDE SUBST_XSTAT ! M3EXIT status codes
1162 !....................................................................
1164 ! Normal, successful completion
1165 INTEGER xstat0
1166 PARAMETER (xstat0=0)
1167 ! File I/O error
1168 INTEGER xstat1
1169 PARAMETER (xstat1=1)
1170 ! Execution error
1171 INTEGER xstat2
1172 PARAMETER (xstat2=2)
1173 ! Special error
1174 INTEGER xstat3
1175 PARAMETER (xstat3=3)
1176 CHARACTER*120 xmsg
1178 !...........PARAMETERS and their descriptions:
1179 ! number of cations
1180 INTEGER ncat
1181 PARAMETER (ncat=2)
1183 ! number of anions
1184 INTEGER nan
1185 PARAMETER (nan=3)
1187 !...........ARGUMENTS and their descriptions
1188 ! tot # moles of all ions
1189 REAL molnu
1190 ! multicomponent paractical osmo
1191 REAL phimult
1192 REAL cat(ncat) ! cation conc in moles/kg (input
1193 REAL an(nan) ! anion conc in moles/kg (input)
1194 REAL gama(ncat,nan)
1195 !...........SCRATCH LOCAL VARIABLES and their descriptions:
1196 ! mean molal ionic activity coef
1197 CHARACTER*16 & ! driver program name
1198 pname
1199 SAVE pname
1201 ! anion indX
1202 INTEGER ian
1204 INTEGER icat
1205 ! cation indX
1207 REAL fgama
1208 ! ionic strength
1209 REAL i
1210 REAL r
1211 REAL s
1212 REAL ta
1213 REAL tb
1214 REAL tc
1215 REAL texpv
1216 REAL trm
1217 ! 2*ionic strength
1218 REAL twoi
1219 ! 2*sqrt of ionic strength
1220 REAL twosri
1221 REAL zbar
1222 REAL zbar2
1223 REAL zot1
1224 ! square root of ionic strength
1225 REAL sri
1226 REAL f2(ncat)
1227 REAL f1(nan)
1228 REAL zp(ncat) ! absolute value of charges of c
1229 REAL zm(nan) ! absolute value of charges of a
1230 REAL bgama(ncat,nan)
1231 REAL x(ncat,nan)
1232 REAL m(ncat,nan) ! molality of each electrolyte
1233 REAL lgama0(ncat,nan) ! binary activity coefficients
1234 REAL y(nan,ncat)
1235 REAL beta0(ncat,nan) ! binary activity coefficient pa
1236 REAL beta1(ncat,nan) ! binary activity coefficient pa
1237 REAL cgama(ncat,nan) ! binary activity coefficient pa
1238 REAL v1(ncat,nan) ! number of cations in electroly
1239 REAL v2(ncat,nan)
1240 ! number of anions in electrolyt
1241 DATA zp/1.0, 1.0/
1242 DATA zm/2.0, 1.0, 1.0/
1243 DATA xmsg/' '/
1244 DATA pname/'ACTCOF'/
1246 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1248 ! *** (1,1);(1,3) - Clegg & Brimblecombe (1988)
1249 ! *** (2,3) - Pilinis & Seinfeld (1987), cgama different
1250 ! *** (1,2) - Clegg & Brimblecombe (1990)
1251 ! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992)
1253 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1255 DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 / ! 2H+SO4
1256 DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 / ! HNO3
1257 DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 / ! H+HSO4
1258 DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/,cgama(2,1)/ -1.2683E-3/ ! (NH4)2
1259 DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/,cgama(2,2)/3.51217E-5/ ! NH4NO3
1260 DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 &
1261 /
1262 ! NH4HSO
1263 DATA v1(1,1), v2(1,1)/2.0, 1.0/ ! 2H+SO4-
1264 DATA v1(2,1), v2(2,1)/2.0, 1.0/ ! (NH4)2SO4
1265 DATA v1(1,2), v2(1,2)/1.0, 1.0/ ! HNO3
1266 DATA v1(2,2), v2(2,2)/1.0, 1.0/ ! NH4NO3
1267 DATA v1(1,3), v2(1,3)/1.0, 1.0/ ! H+HSO4-
1268 DATA v1(2,3), v2(2,3)/1.0, 1.0/
1269 !-----------------------------------------------------------------------
1270 ! begin body of subroutine ACTCOF
1272 !...compute ionic strength
1273 ! NH4HSO4
1274 i = 0.0
1275 DO icat = 1, ncat
1276 i = i + cat(icat)*zp(icat)*zp(icat)
1277 END DO
1279 DO ian = 1, nan
1280 i = i + an(ian)*zm(ian)*zm(ian)
1281 END DO
1283 i = 0.5*i
1284 !...check for problems in the ionic strength
1285 IF (i==0.0) THEN
1286 DO ian = 1, nan
1287 DO icat = 1, ncat
1288 gama(icat,ian) = 0.0
1289 END DO
1290 END DO
1292 ! xmsg = 'Ionic strength is zero...returning zero activities'
1293 ! WRITE (6,*) xmsg
1294 RETURN
1296 ELSE IF (i<0.0) THEN
1297 ! xmsg = 'Ionic strength below zero...negative concentrations'
1298 ! CALL wrf_error_fatal ( xmsg )
1299 ! KW
1300 DO ian = 1, nan
1301 DO icat = 1, ncat
1302 gama(icat,ian) = 0.0
1303 END DO
1304 END DO
1305 xmsg = 'Ionic strength is below zero...returning zero activities'
1306 WRITE (6,*) xmsg
1307 RETURN
1308 END IF
1310 !...compute some essential expressions
1311 sri = sqrt(i)
1312 twosri = 2.0*sri
1313 twoi = 2.0*i
1314 texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1315 r = 1.0 + 0.75*i
1316 s = 1.0 + 1.5*i
1317 zot1 = 0.511*sri/(1.0+sri)
1319 !...Compute binary activity coeffs
1320 fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1321 DO icat = 1, ncat
1322 DO ian = 1, nan
1324 bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1325 )*texpv
1327 !...compute the molality of each electrolyte for given ionic strength
1329 m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1330 (1.0/(v1(icat,ian)+v2(icat,ian)))
1332 !...calculate the binary activity coefficients
1334 lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1335 ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1336 ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1337 v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1338 ian)))/2.302585093
1340 END DO
1341 END DO
1343 !...prepare variables for computing the multicomponent activity coeffs
1345 DO ian = 1, nan
1346 DO icat = 1, ncat
1347 zbar = (zp(icat)+zm(ian))*0.5
1348 zbar2 = zbar*zbar
1349 y(ian,icat) = zbar2*an(ian)/i
1350 x(icat,ian) = zbar2*cat(icat)/i
1351 END DO
1352 END DO
1354 DO ian = 1, nan
1355 f1(ian) = 0.0
1356 DO icat = 1, ncat
1357 f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1358 zot1*zp(icat)*zm(ian)*x(icat,ian)
1359 END DO
1360 END DO
1362 DO icat = 1, ncat
1363 f2(icat) = 0.0
1364 DO ian = 1, nan
1365 f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1366 zot1*zp(icat)*zm(ian)*y(ian,icat)
1367 END DO
1368 END DO
1370 !...now calculate the multicomponent activity coefficients
1372 DO ian = 1, nan
1373 DO icat = 1, ncat
1375 ta = -zot1*zp(icat)*zm(ian)
1376 tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1377 tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1378 trm = ta + tb*tc
1380 IF (trm>30.0) THEN
1381 gama(icat,ian) = 1.0E+30
1382 ! xmsg = 'Multicomponent activity coefficient is extremely large'
1383 ! WRITE (6,*) xmsg
1384 ELSE
1385 gama(icat,ian) = 10.0**trm
1386 END IF
1388 END DO
1389 END DO
1391 RETURN
1392 !ia*********************************************************************
1393 END SUBROUTINE actcof
1395 !ia
1396 !ia AEROSOL DYNAMICS DRIVER ROUTINE *
1397 !ia based on MODELS3 formulation by FZB
1398 !ia Modified by IA in November 97
1399 !ia
1400 !ia Revision history
1401 !ia When WHO WHAT
1402 !ia ---- ---- ----
1403 !ia ???? FZB BEGIN
1404 !ia 05/97 IA Adapted for use in CTM2-S
1405 !ia 11/97 IA Modified for new model version
1406 !ia see comments under iarev02
1407 !ia
1408 !ia Called BY: RPMMOD3
1409 !ia
1410 !ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1411 !ia GETVSED
1412 !ia
1413 !ia*********************************************************************
1415 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1416 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat, &
1417 orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,epm25i, &
1418 epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1419 dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1420 kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1421 ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid,brrto)
1423 !USE module_configure, only: grid_config_rec_type
1424 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
1426 ! IMPLICIT NONE
1427 ! dimension of arrays
1428 INTEGER blksize
1429 ! number of species in CBLK
1430 INTEGER nspcsda
1431 ! actual number of cells in arrays
1432 INTEGER numcells
1433 ! number of k-level
1434 INTEGER layer
1435 ! of organic aerosol precursor
1436 INTEGER ldrog_vbs
1437 REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1439 REAL dt
1440 ! *** Meteorological information:
1442 ! synchronization time [s]
1443 REAL blkta(blksize) ! Air temperature [ K ]
1444 REAL blkprs(blksize) ! Air pressure in [ Pa ]
1445 REAL blkdens(blksize) ! Air density [ kg/ m**3 ]
1446 REAL blkrh(blksize)
1447 ! *** Chemical production rates: [ ug / m**3 s ]
1449 ! Fractional relative humidity
1450 REAL so4rat(blksize)
1451 ! sulfate gas-phase production rate
1452 ! total # of cond. vapors & SOA species
1453 INTEGER ncv
1454 INTEGER nacv
1455 !bs * organic condensable vapor production rate
1456 ! # of anthrop. cond. vapors & SOA speci
1457 REAL drog(blksize,ldrog_vbs) !bs
1458 ! *** anthropogenic organic aerosol mass production rates from aromatics
1459 ! Delta ROG conc. [ppm]
1460 REAL organt1rat(blksize)
1462 ! *** anthropogenic organic aerosol mass production rates from aromatics
1463 REAL organt2rat(blksize)
1465 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1466 REAL organt3rat(blksize)
1468 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1469 REAL organt4rat(blksize)
1471 ! *** biogenic organic aerosol production rates
1472 REAL orgbio1rat(blksize)
1474 ! *** biogenic organic aerosol production rates
1475 REAL orgbio2rat(blksize)
1477 ! *** biogenic organic aerosol production rates
1478 REAL orgbio3rat(blksize)
1480 ! *** biogenic organic aerosol production rates
1481 REAL orgbio4rat(blksize)
1483 ! *** Primary emissions rates: [ ug / m**3 s ]
1484 ! *** emissions rates for unidentified PM2.5 mass
1485 REAL epm25i(blksize) ! Aitken mode
1486 REAL epm25j(blksize)
1487 ! *** emissions rates for primary organic aerosol
1488 ! Accumululaton mode
1489 REAL eorgi(blksize) ! Aitken mode
1490 REAL eorgj(blksize)
1491 ! *** emissions rates for elemental carbon
1492 ! Accumululaton mode
1493 REAL eeci(blksize) ! Aitken mode
1494 REAL eecj(blksize)
1495 ! *** emissions rates for coarse mode particles
1496 ! Accumululaton mode
1497 REAL esoil(blksize) ! soil derived coarse aerosols
1498 REAL eseas(blksize) ! marine coarse aerosols
1499 REAL epmcoarse(blksize)
1501 ! *** OUTPUT:
1502 ! *** atmospheric properties
1503 ! anthropogenic coarse aerosols
1504 REAL xlm(blksize) ! atmospheric mean free path [ m ]
1505 REAL amu(blksize)
1506 ! *** modal diameters: [ m ]
1508 ! atmospheric dynamic viscosity [ kg
1509 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1510 REAL dgacc(blksize) ! accumulation geometric mean diamet
1511 REAL dgcor(blksize)
1513 ! *** aerosol properties:
1514 ! *** Modal mass concentrations [ ug m**3 ]
1515 ! coarse mode geometric mean diamete
1516 REAL pmassn(blksize) ! mass concentration in Aitken mode
1517 REAL pmassa(blksize) ! mass concentration in accumulation
1518 REAL pmassc(blksize)
1519 ! *** average modal particle densities [ kg/m**3 ]
1521 ! mass concentration in coarse mode
1522 REAL pdensn(blksize) ! average particle density in nuclei
1523 REAL pdensa(blksize) ! average particle density in accumu
1524 REAL pdensc(blksize)
1525 ! *** average modal Knudsen numbers
1527 ! average particle density in coarse
1528 REAL knnuc(blksize) ! nuclei mode Knudsen number
1529 REAL knacc(blksize) ! accumulation Knudsen number
1530 REAL kncor(blksize)
1531 ! *** modal condensation factors ( see comments in NUCLCOND )
1533 ! coarse mode Knudsen number
1534 REAL fconcn(blksize)
1535 REAL fconca(blksize)
1536 !bs
1537 REAL fconcn_org(blksize)
1538 REAL fconca_org(blksize)
1539 !bs
1541 ! *** Rates for secondary particle formation:
1543 ! *** production of new mass concentration [ ug/m**3 s ]
1544 REAL dmdt(blksize) ! by particle formation
1546 ! *** production of new number concentration [ number/m**3 s ]
1548 ! rate of production of new mass concen
1549 REAL dndt(blksize) ! by particle formation
1551 ! *** growth rate for third moment by condensation of precursor
1552 ! vapor on existing particles [ 3rd mom/m**3 s ]
1554 ! rate of producton of new particle num
1555 REAL cgrn3(blksize) ! Aitken mode
1556 REAL cgra3(blksize)
1557 ! *** Rates for coaglulation: [ m**3/s ]
1559 ! *** Unimodal Rates:
1561 ! Accumulation mode
1562 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1563 REAL ura00(blksize)
1565 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
1567 ! accumulation mode 0th moment self-coagulat
1568 REAL brna01(blksize)
1569 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1570 ! rate for 0th moment
1571 REAL c30(blksize) ! by intermodal c
1572 REAL brrto
1574 ! *** other processes
1576 ! intermodal 3rd moment transfer r
1577 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
1579 ! INTEGER NN, VV ! loop indICES
1580 ! increment of concentration added to
1582 ! ////////////////////// Begin code ///////////////////////////////////
1583 ! concentration lower limit
1584 CHARACTER*16 pname
1585 PARAMETER (pname=' AEROPROC ')
1587 INTEGER unit
1588 PARAMETER (unit=20)
1589 integer igrid,jgrid,kgrid,isorop
1590 !KW isorop=0
1591 !KW Originally isorop=0 but changed isorop=1
1592 isorop=1
1594 ! *** get water, ammonium and nitrate content:
1595 ! for now, don't call if temp is below -40C (humidity
1596 ! for this wrf version is already limited to 10 percent)
1598 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then
1599 CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
1600 else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then
1601 CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1602 endif
1604 ! *** get size distribution information:
1606 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1607 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1608 kncor)
1610 ! *** Calculate coagulation rates for fine particles:
1612 CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1613 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1615 ! *** get condensation and particle formation (nucleation) rates:
1617 CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1618 so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
1619 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
1620 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
1622 ! *** advance forward in time DT seconds:
1623 CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,organt1rat, &
1624 organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1625 orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1626 dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1627 dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1629 ! *** get new distribution information:
1630 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1631 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1632 kncor)
1634 RETURN
1635 END SUBROUTINE aeroproc
1636 !//////////////////////////////////////////////////////////////////
1638 ! *** Time stepping code advances the aerosol moments one timestep;
1639 SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat &
1640 ,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat &
1641 ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1642 ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn &
1643 ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1644 igrid,jgrid,kgrid)
1646 ! *** DESCRIPTION: Integrate the Number and Mass equations
1647 ! for each mode over the time interval DT.
1648 ! PRECONDITIONS:
1649 ! AEROSTEP() must follow calls to all other dynamics routines.
1651 ! *** Revision history:
1652 ! Adapted 3/95 by UAS and CJC from EAM2's code.
1653 ! Revised 7/29/96 by FSB to use block structure
1654 ! Revised 11/15/96 by FSB dropped flow-through and cast
1655 ! number solver into Riccati equation form.
1656 ! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mode
1657 ! each predicted rather than total mass and
1658 ! Aitken mode mass. Also used a local approximation
1659 ! the error function. Also added coarse mode.
1660 ! Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1661 ! accumulation mode by coagulation
1662 ! Revised 10/27/97 by FSB to modify code to use primay emissions
1663 ! and to correct 3rd moment updates.
1664 ! Also added coarse mode.
1665 ! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1666 ! Revised 11/5/97 by FSB to fix error in MSTRNSFR
1667 ! Revised 11/6/97 FSB to correct the expression for FACTRANS to
1668 ! remove the 6/pi coefficient. UAS found this.
1669 ! Revised 12/15/97 by FSB to change equations for mass concentratin
1670 ! to a chemical production form with analytic
1671 ! solutions for the Aitken mode and to remove
1672 ! time stepping of the 3rd moments. The mass concentration
1673 ! in the accumulation mode is updated with a forward
1674 ! Eulerian step.
1675 ! Revised 1/6/98 by FSB Lowered minimum concentration for
1676 ! sulfate aerosol to 0.1 [ ng / m**3 ].
1677 ! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represents
1678 ! intermodal transfer rate of 3rd moment in place
1679 ! of 3rd moment coagulation rate.
1680 ! Revised 5/5/98 added new renaming criterion based on diameters
1681 ! Added 3/23/98 by BS condensational groth factors for organics
1683 !**********************************************************************
1684 ! IMPLICIT NONE
1686 ! *** ARGUMENTS:
1688 ! dimension of arrays
1689 INTEGER blksize
1690 ! actual number of cells in arrays
1691 INTEGER numcells
1692 ! nmber of species in CBLK
1693 INTEGER nspcsda
1694 ! model layer
1695 INTEGER layer
1696 REAL cblk(blksize,nspcsda) ! main array of variables
1697 INTEGER igrid,jgrid,kgrid
1698 REAL dt
1699 ! *** Chemical production rates: [ ug / m**3 s ]
1701 ! time step [sec]
1702 REAL so4rat(blksize) ! sulfate gas-phase production rate
1704 ! anthropogenic organic aerosol mass production rates
1705 REAL organt1rat(blksize)
1706 REAL organt2rat(blksize)
1707 REAL organt3rat(blksize)
1708 REAL organt4rat(blksize)
1710 ! biogenic organic aerosol production rates
1711 REAL orgbio1rat(blksize)
1712 REAL orgbio2rat(blksize)
1713 REAL orgbio3rat(blksize)
1714 REAL orgbio4rat(blksize)
1716 ! *** Primary emissions rates: [ ug / m**3 s ]
1717 ! *** emissions rates for unidentified PM2.5 mass
1718 REAL epm25i(blksize) ! Aitken mode
1719 REAL epm25j(blksize)
1720 ! *** emissions rates for primary organic aerosol
1721 ! Accumululaton mode
1722 REAL eorgi(blksize) ! Aitken mode
1723 REAL eorgj(blksize)
1724 ! *** emissions rates for elemental carbon
1725 ! Accumululaton mode
1726 REAL eeci(blksize) ! Aitken mode
1727 REAL eecj(blksize)
1728 ! *** emissions rates for coarse mode particles
1729 ! Accumululaton mode
1730 REAL esoil(blksize) ! soil derived coarse aerosols
1731 REAL eseas(blksize) ! marine coarse aerosols
1732 REAL epmcoarse(blksize)
1733 ! anthropogenic coarse aerosols
1734 REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1735 REAL dgacc(blksize)
1736 ! accumulation
1737 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
1738 ! reciprocal condensation rate
1739 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
1740 ! reciprocal condensation rate
1741 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
1742 ! reciprocal condensation rate for organ
1743 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
1744 ! reciprocal condensation rate for organ
1745 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
1746 ! rate of production of new mass concent
1747 REAL dndt(blksize) ! by particle formation [ number/m**3 /s
1748 ! rate of producton of new particle numb
1749 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
1750 ! increment of concentration added to
1751 REAL urn00(blksize) ! Aitken intramodal coagulation rate
1752 REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1753 REAL brna01(blksize) ! bimodal coagulation rate for number
1754 REAL c30(blksize) ! by intermodal coagulation
1755 ! intermodal 3rd moment transfer rate by
1756 REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1757 REAL cgra3(blksize)
1758 ! *** Modal mass concentrations [ ug m**3 ]
1760 ! growth rate for 3rd moment for Accumul
1761 REAL pmassn(blksize) ! mass concentration in Aitken mode
1762 REAL pmassa(blksize) ! mass concentration in accumulation
1763 REAL pmassc(blksize)
1765 ! *** Local Variables
1767 ! mass concentration in coarse mode
1768 INTEGER l, lcell, spc
1769 ! ** following scratch variables are used for solvers
1771 ! *** variables needed for modal dynamics solvers:
1772 ! Loop indices
1773 REAL*8 a, b, c
1774 REAL*8 m1, m2, y0, y
1775 REAL*8 dhat, p, pexpdt, expdt
1776 REAL*8 loss, prod, pol, lossinv
1777 ! mass intermodal transfer by coagulation
1778 REAL mstrnsfr
1780 REAL factrans
1782 ! *** CODE additions for renaming
1783 REAL getaf2
1784 REAL aaa, xnum, xm3, fnum, fm3, phnum, phm3 ! Defined below
1785 REAL erf, & ! Error and complementary error function
1786 erfc
1788 REAL xx
1789 ! dummy argument for ERF and ERFC
1790 ! a numerical value for a minimum concentration
1792 ! *** This value is smaller than any reported tropospheric concentration
1794 ! *** Statement function given for error function. Source is
1795 ! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1796 ! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1797 ! 20:253-265. They cite Reasearch & Education Asociation (REA), (19
1798 ! Handbook of Mathematical, Scientific, and Engineering Formulas,
1799 ! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1801 erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1802 erfc(xx) = 1.0 - erf(xx)
1803 ! ::::::::::::::::::::::::::::::::::::::::
1805 ! ///// begin code
1806 ! *** set up time-step integration
1808 DO l = 1, numcells
1810 ! *** code to move number forward by one time step.
1811 ! *** solves the Ricatti equation:
1813 ! dY/dt = C - A * Y ** 2 - B * Y
1815 ! Coded 11/21/96 by Dr. Francis S. Binkowski
1817 ! *** Aitken mode:
1818 ! *** coefficients
1819 a = urn00(l)
1820 b = brna01(l)*cblk(l,vac0)
1821 c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1823 ! includes primary emissions
1824 y0 = cblk(l,vnu0)
1825 ! *** trap on C = 0
1827 ! initial condition
1828 IF (c>0.0D0) THEN
1830 dhat = sqrt(b*b+4.0D0*a*c)
1832 m1 = 2.0D0*a*c/(b+dhat)
1834 m2 = -0.5D0*(b+dhat)
1836 p = -(m1-a*y0)/(m2-a*y0)
1838 pexpdt = p*exp(-dhat*dt)
1840 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1841 ! solution
1842 ELSE
1844 ! *** rearrange solution for NUMERICAL stability
1845 ! note If B << A * Y0, the following form, although
1846 ! seemingly awkward gives the correct answer.
1848 expdt = exp(-b*dt)
1849 IF (expdt<1.0D0) THEN
1850 y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1851 ELSE
1852 y = y0
1853 END IF
1855 END IF
1856 ! if(y.lt.nummin_i)then
1857 ! print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
1858 ! print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
1859 ! print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
1860 ! endif
1862 cblk(l,vnu0) = max(nummin_i,y)
1864 ! *** now do accumulation mode number
1866 ! *** coefficients
1868 ! update
1869 a = ura00(l)
1870 b = & ! NOTE B = 0.0
1871 0.0D0
1872 c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
1873 ! includes primary emissi
1874 y0 = cblk(l,vac0)
1875 ! *** this equation requires special handling, because C can be zero.
1876 ! if this happens, the form of the equation is different:
1878 ! initial condition
1879 ! print *,vac0,y0,c,nummin_j,a
1880 IF (c>0.0D0) THEN
1882 dhat = sqrt(4.0D0*a*c)
1884 m1 = 2.0D0*a*c/dhat
1886 m2 = -0.5D0*dhat
1888 p = -(m1-a*y0)/(m2-a*y0)
1890 ! print *,p,-dhat,dt,-dhat*dt
1891 ! print *,exp(-dhat*dt)
1892 pexpdt = p*exp(-dhat*dt)
1894 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1895 ! solution
1896 ELSE
1898 y = y0/(1.0D0+dt*a*y0)
1899 ! print *,dhat,y0,dt,a
1900 y = y0/(1.+dt*a*y0)
1901 ! print *,y
1902 ! correct solution to equation
1903 END IF
1905 cblk(l,vac0) = max(nummin_j,y)
1906 ! *** now do coarse mode number neglecting coagulation
1907 ! update
1908 ! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
1909 prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
1911 ! print *,cblk(l,vcorn),factnumc,prod
1912 cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
1914 ! *** Prepare to advance modal mass concentration one time step.
1916 ! *** Set up production and and intermodal transfer terms terms:
1917 ! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
1918 cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
1920 ! includes growth from pri
1921 cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
1922 orgfac*eorgj(l) ! and transfer of 3rd momen
1923 ! intermodal coagulation
1925 ! *** set up transfer coefficients for coagulation between Aitken and ac
1928 ! *** set up special factors for mass transfer from the Aitken to accumulation
1929 ! intermodal coagulation. The mass transfer rate is proportional to
1930 ! transfer rate, C30. The proportionality factor is p/6 times the the
1931 ! density. The average particle density for a species is the species
1932 ! divided by the particle volume concentration, pi/6 times the 3rd m
1933 ! The p/6 coefficients cancel.
1935 ! includes growth from prim
1936 ! print *,'loss',vnu3,c30(l),cblk(l,vnu3)
1937 loss = c30(l)/cblk(l,vnu3)
1939 ! Normalized coagulation transfer r
1940 factrans = loss*dt ! yields an estimate of the amount of mass t
1941 ! the Aitken to the accumulation mode in the
1943 ! Multiplying this factor by the species con
1944 ! print *,'factrans = ',factrans,loss
1945 expdt = exp(-factrans) ! decay term is common to all Aitken mode
1946 ! print *,'factrans = ',factrans,loss,expdt
1947 ! variable name is re-used here. This expo
1948 lossinv = 1.0/loss
1949 ! *** now advance mass concentrations one time step.
1951 ! *** update sulfuric acid vapor concentration by removing mass concent
1952 ! condensed sulfate and newly produced particles.
1953 ! *** The method follows Youngblood and Kreidenweis, Further Development
1954 ! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
1955 ! Atmospheric Science Paper Number 550, April,1994, pp 85-89.
1956 ! set up for multiplication rather than divi
1957 cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
1959 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
1960 ! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
1962 ! *** sulfate:
1963 mstrnsfr = cblk(l,vso4ai)*factrans
1964 prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
1965 pol = prod*lossinv
1966 ! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
1968 cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
1969 cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
1970 cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
1972 ! *** anthropogenic secondary organic:
1973 !bs * anthropogenic secondary organics from aromatic precursors
1974 !!! anthropogenic secondary organics from different precursors
1975 !!! the formulas are the same as in BS's version, only precursors and partition are different!
1977 mstrnsfr = cblk(l,vasoa1i)*factrans
1978 prod = organt1rat(l)*fconcn_org(l)
1979 pol = prod*lossinv
1981 cblk(l,vasoa1i) = pol + (cblk(l,vasoa1i)-pol)*expdt
1982 cblk(l,vasoa1i) = max(conmin,cblk(l,vasoa1i))
1983 cblk(l,vasoa1j) = cblk(l,vasoa1j) + organt1rat(l)*fconca_org(l)*dt + mstrnsfr
1984 !!!!!!!!!!!!!
1986 mstrnsfr = cblk(l,vasoa2i)*factrans
1987 prod = organt2rat(l)*fconcn_org(l)
1988 pol = prod*lossinv
1990 cblk(l,vasoa2i) = pol + (cblk(l,vasoa2i)-pol)*expdt
1991 cblk(l,vasoa2i) = max(conmin,cblk(l,vasoa2i))
1992 cblk(l,vasoa2j) = cblk(l,vasoa2j) + organt2rat(l)*fconca_org(l)*dt + mstrnsfr
1993 !!!!!!!!!!!!!
1995 mstrnsfr = cblk(l,vasoa3i)*factrans
1996 prod = organt3rat(l)*fconcn_org(l)
1997 pol = prod*lossinv
1999 cblk(l,vasoa3i) = pol + (cblk(l,vasoa3i)-pol)*expdt
2000 cblk(l,vasoa3i) = max(conmin,cblk(l,vasoa3i))
2001 cblk(l,vasoa3j) = cblk(l,vasoa3j) + organt3rat(l)*fconca_org(l)*dt + mstrnsfr
2002 !!!!!!!!!!!!!
2004 mstrnsfr = cblk(l,vasoa4i)*factrans
2005 prod = organt4rat(l)*fconcn_org(l)
2006 pol = prod*lossinv
2008 cblk(l,vasoa4i) = pol + (cblk(l,vasoa4i)-pol)*expdt
2009 cblk(l,vasoa4i) = max(conmin,cblk(l,vasoa4i))
2010 cblk(l,vasoa4j) = cblk(l,vasoa4j) + organt4rat(l)*fconca_org(l)*dt + mstrnsfr
2012 ! *** biogenic secondary organic
2013 mstrnsfr = cblk(l,vbsoa1i)*factrans
2014 prod = orgbio1rat(l)*fconcn_org(l)
2015 pol = prod*lossinv
2017 cblk(l,vbsoa1i) = pol + (cblk(l,vbsoa1i)-pol)*expdt
2018 cblk(l,vbsoa1i) = max(conmin,cblk(l,vbsoa1i))
2019 cblk(l,vbsoa1j) = cblk(l,vbsoa1j) + orgbio1rat(l)*fconca_org(l)*dt + mstrnsfr
2020 !!!!!!!!!!!!!
2022 mstrnsfr = cblk(l,vbsoa2i)*factrans
2023 prod = orgbio2rat(l)*fconcn_org(l)
2024 pol = prod*lossinv
2026 cblk(l,vbsoa2i) = pol + (cblk(l,vbsoa2i)-pol)*expdt
2027 cblk(l,vbsoa2i) = max(conmin,cblk(l,vbsoa2i))
2028 cblk(l,vbsoa2j) = cblk(l,vbsoa2j) + orgbio2rat(l)*fconca_org(l)*dt + mstrnsfr
2029 !!!!!!!!!!!!!
2031 mstrnsfr = cblk(l,vbsoa3i)*factrans
2032 prod = orgbio3rat(l)*fconcn_org(l)
2033 pol = prod*lossinv
2035 cblk(l,vbsoa3i) = pol + (cblk(l,vbsoa3i)-pol)*expdt
2036 cblk(l,vbsoa3i) = max(conmin,cblk(l,vbsoa3i))
2037 cblk(l,vbsoa3j) = cblk(l,vbsoa3j) + orgbio3rat(l)*fconca_org(l)*dt + mstrnsfr
2038 !!!!!!!!!!!!!
2040 mstrnsfr = cblk(l,vbsoa4i)*factrans
2041 prod = orgbio4rat(l)*fconcn_org(l)
2042 pol = prod*lossinv
2044 cblk(l,vbsoa4i) = pol + (cblk(l,vbsoa4i)-pol)*expdt
2045 cblk(l,vbsoa4i) = max(conmin,cblk(l,vbsoa4i))
2046 cblk(l,vbsoa4j) = cblk(l,vbsoa4j) + orgbio4rat(l)*fconca_org(l)*dt + mstrnsfr
2048 ! *** primary anthropogenic organic
2049 mstrnsfr = cblk(l,vorgpai)*factrans
2050 prod = eorgi(l)
2051 pol = prod*lossinv
2053 cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
2054 cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
2055 cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
2057 ! *** other anthropogenic PM2.5
2058 mstrnsfr = cblk(l,vp25ai)*factrans
2059 prod = epm25i(l)
2060 pol = prod*lossinv
2062 cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
2063 cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
2064 cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
2066 ! *** elemental carbon
2067 mstrnsfr = cblk(l,veci)*factrans
2068 prod = eeci(l)
2069 pol = prod*lossinv
2071 cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
2072 cblk(l,veci) = max(conmin,cblk(l,veci))
2073 cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
2075 ! *** coarse mode
2076 ! *** soil dust
2077 cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
2078 cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
2080 ! *** sea salt
2081 cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
2082 cblk(l,vseas) = max(conmin,cblk(l,vseas))
2084 ! *** anthropogenic PM10 coarse fraction
2085 cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
2086 cblk(l,vantha) = max(conmin,cblk(l,vantha))
2088 END DO
2091 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
2092 ! then merge modes by renaming.
2094 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
2096 ! end of time-step loop for total mass
2097 DO lcell = 1, numcells
2099 ! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
2100 ! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
2101 IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
2102 lcell,vnu0)>cblk(lcell,vac0)) &
2103 THEN
2105 ! check if mer
2106 aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
2107 dgacc(lcell),xxlsgn,xxlsga,sqrt2)
2109 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2110 ! dd is the diameter at which the Aitken-mode and accumulation-mo
2111 ! distributions intersect (overap).
2113 xnum = max(aaa,xxm3) ! this means that no more than one ha
2114 ! total Aitken mode number may be tra per call.
2116 ! do not let XNUM become negative bec
2117 xm3 = xnum - &
2118 xxm3
2119 ! set up for 3rd moment and mass tran
2120 IF (xm3>0.0) &
2121 THEN
2122 ! do mode merging if overlap is corr
2123 phnum = 0.5*(1.0+erf(xnum))
2124 phm3 = 0.5*(1.0+erf(xm3))
2125 fnum = 0.5*erfc(xnum)
2126 fm3 = 0.5*erfc(xm3)
2128 ! In the Aitken mode:
2130 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2131 ! distributions with diameters greater than dd respectively.
2133 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2134 ! distributions with diameters less than dd.
2136 ! *** rename the Aitken mode particle number as accumulation mode
2137 ! particle number
2139 cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2141 ! *** adjust the Aitken mode number
2143 cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2145 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2146 ! to the accumulation mode is proportional to the amount of 3rd mome
2147 ! transferred, therefore FM3 is used for mass transfer.
2149 cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2151 cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2153 cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2155 cblk(lcell,vasoa1j) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)*fm3
2157 cblk(lcell,vasoa2j) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)*fm3
2159 cblk(lcell,vasoa3j) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)*fm3
2161 cblk(lcell,vasoa4j) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)*fm3
2163 cblk(lcell,vbsoa1j) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)*fm3
2165 cblk(lcell,vbsoa2j) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)*fm3
2167 cblk(lcell,vbsoa3j) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)*fm3
2169 cblk(lcell,vbsoa4j) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)*fm3
2171 cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + cblk(lcell,vorgpai)*fm3
2173 cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2175 cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2177 ! *** update Aitken mode for mass loss to accumulation mode
2178 cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2180 cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2182 cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2184 cblk(lcell,vasoa1i) = cblk(lcell,vasoa1i)*phm3
2186 cblk(lcell,vasoa2i) = cblk(lcell,vasoa2i)*phm3
2188 cblk(lcell,vasoa3i) = cblk(lcell,vasoa3i)*phm3
2190 cblk(lcell,vasoa4i) = cblk(lcell,vasoa4i)*phm3
2192 cblk(lcell,vbsoa1i) = cblk(lcell,vbsoa1i)*phm3
2194 cblk(lcell,vbsoa2i) = cblk(lcell,vbsoa2i)*phm3
2196 cblk(lcell,vbsoa3i) = cblk(lcell,vbsoa3i)*phm3
2198 cblk(lcell,vbsoa4i) = cblk(lcell,vbsoa4i)*phm3
2200 cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2202 cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2204 cblk(lcell,veci) = cblk(lcell,veci)*phm3
2206 END IF
2207 ! end check on whether modal overlap is OK
2209 END IF
2210 ! end check on necessity for merging
2212 END DO
2213 ! set min value for all concentrations
2215 ! loop for merging
2216 DO spc = 1, nspcsda
2217 DO lcell = 1, numcells
2218 cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2219 END DO
2220 END DO
2221 !---------------------------------------------------------------------------------
2223 RETURN
2224 END SUBROUTINE aerostep
2225 !#######################################################################
2227 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2228 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2229 ! mso4,mnh4,mno3 are in microMOLES / cubic meter
2231 ! This version uses polynomials rather than tables, and uses empirical
2232 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2233 ! where:
2235 ! mfs = ms / ( ms + mw)
2236 ! ms is the mass of solute
2237 ! mw is the mass of water.
2239 ! Define y = mw/ ms
2241 ! then mfs = 1 / (1 + y)
2243 ! y can then be obtained from the values of mfs as
2245 ! y = (1 - mfs) / mfs
2248 ! the aerosol is assumed to be in a metastable state if the rh is
2249 ! is below the rh of deliquescence, but above the rh of crystallizat
2251 ! ZSR interpolation is used for sulfates with x ( the molar ratio of
2252 ! ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2253 ! section 1: 0 <= x < 1
2254 ! section 2: 1 <= x < 1.5
2255 ! section 3: 1.5 <= x < 2.0
2256 ! section 4: 2 <= x
2257 ! In sections 1 through 3, only the sulfates can affect the amount o
2258 ! on the particles.
2259 ! In section 4, we have fully neutralized sulfate, and extra ammoniu
2260 ! allows more nitrate to be present. Thus, the ammount of water is c
2261 ! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2262 ! assumed to occur in sections 2,3,and 4. See detailed discussion be
2264 ! definitions:
2265 ! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2266 ! for sulfate, ammonium, and nitrate respectively
2267 ! irhx is the relative humidity (%)
2268 ! wh2o is the returned water amount in micrograms / cubic meter of a
2269 ! x is the molar ratio of ammonium to sulfate
2270 ! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2271 ! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2272 ! y3 is the value of the mass ratio of water to solute for
2273 ! a pure ammonium nitrate solution.
2275 !coded by Dr. Francis S. Binkowski, 4/8/96.
2277 ! IMPLICIT NONE
2278 INTEGER irhx, irh
2279 REAL mso4, mnh4, mno3
2280 REAL tso4, tnh4, tno3, wh2o, x
2281 REAL aw, awc
2282 ! REAL poly4, poly6
2283 REAL mfs0, mfs1, mfs15, mfs2
2284 REAL c0(4), c1(4), c15(4), c2(4)
2285 REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2286 REAL kso4(6), kno3(6), mfsso4, mfsno3
2287 REAL mwso4, mwnh4, mwno3, mw2, mwano3
2289 ! *** molecular weights:
2290 PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2291 mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2293 ! The polynomials use data for aw as a function of mfs from Tang and
2294 ! Munkelwitz, JGR 99: 18801-18808, 1994.
2295 ! The polynomials were fit to Tang's values of water activity as a
2296 ! function of mfs.
2298 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2299 ! now give mfs as a function of water activity.
2301 DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2302 DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2303 DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2305 ! *** the following coefficients are a fit to the data in Table 1 of
2306 ! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2307 ! data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2308 ! *** New data fit to data from
2309 ! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2310 ! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2311 ! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2312 DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2314 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2315 ! Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2317 DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2318 DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2320 ! *** check range of per cent relative humidity
2321 irh = irhx
2322 irh = max(1,irh)
2323 irh = min(irh,100)
2324 aw = float(irh)/ & ! water activity = fractional relative h
2325 100.0
2326 tso4 = max(mso4,0.0)
2327 tnh4 = max(mnh4,0.0)
2328 tno3 = max(mno3,0.0)
2329 x = 0.0
2330 ! *** if there is non-zero sulfate calculate the molar ratio
2331 IF (tso4>0.0) THEN
2332 x = tnh4/tso4
2333 ELSE
2334 ! *** otherwise check for non-zero nitrate and ammonium
2335 IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2336 END IF
2338 ! *** begin screen on x for calculating wh2o
2339 IF (x<1.0) THEN
2341 mfs0 = poly4(c0,aw)
2342 mfs1 = poly4(c1,aw)
2343 y0 = (1.0-mfs0)/mfs0
2344 y1 = (1.0-mfs1)/mfs1
2345 y = (1.0-x)*y0 + x*y1
2347 ELSE IF (x<1.5) THEN
2349 IF (irh>=40) THEN
2350 mfs1 = poly4(c1,aw)
2351 mfs15 = poly4(c15,aw)
2352 y1 = (1.0-mfs1)/mfs1
2353 y15 = (1.0-mfs15)/mfs15
2354 y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2355 ELSE
2356 ! *** set up for crystalization
2358 ! *** Crystallization is done as follows:
2359 ! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2360 ! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2361 ! and since the code does not allow ar rh < 0.01, crystallization
2362 ! is assumed not to occur in this range.
2363 ! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2364 ! from a value of y15 at rh = 0.4 to a value of zero at y1. From
2365 ! point B to point A in the diagram.
2366 ! The algorithm does a double interpolation to calculate the amount
2367 ! water.
2369 ! y1(0.40) y15(0.40)
2370 ! + + Point B
2372 ! +--------------------+
2373 ! x=1 x=1.5
2374 ! Point A
2376 awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2377 y = 0.0
2378 IF (aw>=awc) & ! interpolate using crystalization
2379 THEN
2380 mfs1 = poly4(c1,0.40)
2381 mfs15 = poly4(c15,0.40)
2382 y140 = (1.0-mfs1)/mfs1
2383 y1540 = (1.0-mfs15)/mfs15
2384 y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2385 yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2386 y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2387 ! end of checking for aw
2388 END IF
2390 END IF
2391 ! end of checking on irh
2392 ELSE IF (x<1.9999) THEN
2394 y = 0.0
2395 IF (irh>=40) THEN
2396 mfs15 = poly4(c15,aw)
2397 mfs2 = poly4(c2,aw)
2398 y15 = (1.0-mfs15)/mfs15
2399 y2 = (1.0-mfs2)/mfs2
2400 y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2402 END IF
2404 ! end of check for crystallization
2406 ELSE
2407 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2409 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2410 ! *** check for crystallization here. their data indicate a 40% value
2411 ! is appropriate.
2412 ! 1.9999 < x
2413 y2 = 0.0
2414 y3 = 0.0
2415 IF (irh>=40) THEN
2416 mfsso4 = poly6(kso4,aw)
2417 mfsno3 = poly6(kno3,aw)
2418 y2 = (1.0-mfsso4)/mfsso4
2419 y3 = (1.0-mfsno3)/mfsno3
2421 END IF
2423 END IF
2424 ! *** now set up output of wh2o
2426 ! wh2o units are micrograms (liquid water) / cubic meter of air
2428 ! end of checking on x
2429 IF (x<1.9999) THEN
2431 wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2433 ELSE
2435 ! *** this is the case that all the sulfate is ammonium sulfate
2436 ! and the excess ammonium forms ammonum nitrate
2438 wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2440 END IF
2442 RETURN
2443 END SUBROUTINE awater
2444 !//////////////////////////////////////////////////////////////////////
2446 SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2447 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2448 !***********************************************************************
2449 !** DESCRIPTION: calculates aerosol coagulation rates for unimodal
2450 ! and bimodal coagulation using E. Whitby 1990's prescription.
2452 !....... Rates for coaglulation:
2453 !....... Unimodal Rates:
2454 !....... URN00: nuclei mode 0th moment self-coagulation rate
2455 !....... URA00: accumulation mode 0th moment self-coagulation rate
2457 !....... Bimodal Rates: (only 1st order coeffs appear)
2458 !....... NA-- nuclei with accumulation coagulation rates,
2459 !....... AN-- accumulation with nuclei coagulation rates
2460 !....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term)
2461 !....... BRNA31: 3rd ( d(nuclei mode 3) / dt term)
2462 !** Revision history:
2463 ! prototype 1/95 by Uma and Carlie
2464 ! Revised 8/95 by US for calculation of density from stmt func
2465 ! and collect met variable stmt funcs in one include fil
2466 ! REVISED 7/25/96 by FSB to use block structure
2467 ! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2468 ! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2469 ! changed. All coagulation coefficients
2470 ! returned with positive signs. Their
2471 ! linearization is also abandoned.
2472 ! Fixed values are used for the corrections
2473 ! to the free-molecular coagulation integra
2474 ! The code forces the harmonic means to be
2475 ! evaluated in 64 bit arithmetic on 32 bit
2476 ! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit
2478 ! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa
2479 ! because BRNA31 can become zero on a works
2480 ! because of limited precision. With the ch
2481 ! aerostep to omit update of the 3rd moment
2482 ! C30 is the only variable now needed.
2483 ! the logic using ONE88 to force REAL*8 ari
2484 ! has been removed and all intermediates ar
2485 ! REAL*8.
2486 ! IMPLICIT NONE
2488 ! dimension of arrays
2489 INTEGER blksize
2490 ! actual number of cells in arrays
2491 INTEGER numcells
2493 INTEGER nspcsda
2495 ! nmber of species in CBLK
2496 REAL cblk(blksize,nspcsda) ! main array of variables
2497 REAL blkta(blksize) ! Air temperature [ K ]
2498 REAL pdensn(blksize) ! average particel density in Aitk
2499 REAL pdensa(blksize) ! average particel density in accu
2500 REAL amu(blksize) ! atmospheric dynamic viscosity [
2501 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2502 REAL dgacc(blksize) ! accumulation mode mean diameter
2503 REAL knnuc(blksize) ! Aitken mode Knudsen number
2504 REAL knacc(blksize)
2505 ! *** output:
2507 ! accumulation mode Knudsen number
2508 REAL urn00(blksize) ! intramodal coagulation rate (Ait
2509 REAL ura00(blksize)
2510 ! intramodal coagulation rate (acc
2511 REAL brna01(blksize) ! intermodal coagulaton rate (numb
2512 REAL c30(blksize) ! by inter
2514 ! *** Local variables:
2515 ! intermodal 3rd moment transfer r
2516 REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2517 kncacc
2518 REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2519 kfmacc
2520 REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2521 kfm
2522 REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2523 bencna
2524 REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2525 bencm3n
2526 REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2527 befmna
2528 REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2529 befm3n
2530 REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2531 betana
2532 REAL*8 & ! intermodal coagulation rate for 3rd mo
2533 brna31
2534 REAL*8 & ! scratch subexpression
2535 s1
2536 REAL*8 t1, & ! scratch subexpressions
2537 t2
2538 REAL*8 t16, & ! T1**6, T2**6
2539 t26
2540 REAL*8 rat, & ! ratio of acc to nuc size and its inver
2541 rin
2542 REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2543 rsq4
2544 REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2545 rsqi3
2546 REAL*8 & ! dgnuc**3
2547 dgn3
2548 REAL*8 & ! in 64 bit arithmetic
2549 dga3
2550 ! dgacc**3
2552 INTEGER lcell
2553 ! *** Fixed values for correctionss to coagulation
2554 ! integrals for free-molecular case.
2555 ! loop counter
2556 REAL*8 bm0
2557 PARAMETER (bm0=0.8D0)
2558 REAL*8 bm0i
2559 PARAMETER (bm0i=0.9D0)
2560 REAL*8 bm3i
2561 PARAMETER (bm3i=0.9D0)
2562 REAL*8 & ! approx Cunningham corr. factor
2563 a
2564 PARAMETER (a=1.246D0)
2565 !.......................................................................
2566 ! begin body of subroutine COAGRATE
2568 !........... Main computational grid-traversal loops
2569 !........... for computing coagulation rates.
2571 ! *** Both modes have fixed std devs.
2572 DO lcell = 1, &
2573 numcells
2574 ! *** moment independent factors
2576 ! loop on LCELL
2577 s1 = two3*boltz*blkta(lcell)/amu(lcell)
2579 ! For unimodal coagualtion:
2581 kncnuc = s1
2582 kncacc = s1
2584 kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2585 kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2587 ! For bimodal coagulation:
2589 knc = s1
2590 kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2592 !........... Begin unimodal coagulation rate calculations:
2593 !........... Near-continuum regime.
2595 dgn3 = dgnuc(lcell)**3
2596 dga3 = dgacc(lcell)**3
2598 t1 = sqrt(dgnuc(lcell))
2599 t2 = sqrt(dgacc(lcell))
2600 t16 = & ! = T1**6
2601 dgn3
2602 t26 = &
2603 dga3
2604 !....... Note rationalization of fractions and subsequent cancellation
2605 !....... from the formulation in Whitby et al. (1990)
2607 ! = T2**6
2608 bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2610 bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2612 !........... Free molecular regime. Uses fixed value for correction
2613 ! factor BM0
2615 befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2616 befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2618 !........... Calculate half the harmonic mean between unimodal rates
2619 !........... free molecular and near-continuum regimes
2621 ! FSB 64 bit evaluation
2623 betann = bencnn*befmnn/(bencnn+befmnn)
2624 betana = bencna*befmna/(bencna+befmna)
2626 urn00(lcell) = betann
2627 ura00(lcell) = betana
2629 ! *** End of unimodal coagulation calculations.
2631 !........... Begin bimodal coagulation rate calculations:
2633 rat = dgacc(lcell)/dgnuc(lcell)
2634 rin = 1.0D0/rat
2635 rsqt = sqrt(rat)
2636 rsq4 = rat**2
2638 rsqti = 1.0D0/rsqt
2639 rsqi3 = rin*rsqti
2641 !........... Near-continuum coeffs:
2642 !........... 0th moment nuc mode bimodal coag coefficient
2644 bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2645 )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2647 !........... 3rd moment nuc mode bimodal coag coefficient
2649 bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2650 *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2651 rin*esn64*esa04)
2653 !........... Free molecular regime coefficients:
2654 !........... Uses fixed value for correction
2655 ! factor BM0I, BM3I
2656 !........... 0th moment nuc mode coeff
2658 befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2659 rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2661 !........... 3rd moment nuc mode coeff
2663 befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2664 rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2667 !........... Calculate half the harmonic mean between bimodal rates
2668 !........... free molecular and near-continuum regimes
2670 ! FSB Force 64 bit evaluation
2672 brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2674 brna31 = bencm3n* & ! BRNA31 now is a scala
2675 befm3n/(bencm3n+befm3n)
2676 c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2677 ! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2678 ! 3d moment transfer by intermodal coagula
2679 ! End bimodal coagulation rate.
2681 END DO
2682 ! end of main lop over cells
2683 RETURN
2684 END SUBROUTINE coagrate
2685 !------------------------------------------------------------------
2687 ! subroutine to find the roots of a cubic equation / 3rd order polynomi
2688 ! formulae can be found in numer. recip. on page 145
2689 ! kiran developed this version on 25/4/1990
2690 ! dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2691 ! ***
2692 !234567
2693 ! coagrate
2694 SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2695 ! IMPLICIT NONE
2696 INTEGER nr
2697 REAL*8 a2, a1, a0
2698 REAL crutes(3)
2699 REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2700 REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2701 REAL*8 costh, sinth
2702 DATA sqrt3/1.732050808/, one3rd/0.333333333/
2703 !bs
2704 REAL*8 onebs
2705 PARAMETER (onebs=1.0)
2706 !bs
2707 a2sq = a2*a2
2708 qq = (a2sq-3.*a1)/9.
2709 rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2710 ! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT
2711 dum1 = qq*qq*qq
2712 rrsq = rr*rr
2713 dum2 = dum1 - rrsq
2714 IF (dum2>=0.) THEN
2715 ! NOW WE HAVE THREE REAL ROOTS
2716 phi = sqrt(dum1)
2717 IF (abs(phi)<1.E-20) THEN
2718 print *, ' cubic phi small, phi = ',phi
2719 crutes(1) = 0.0
2720 crutes(2) = 0.0
2721 crutes(3) = 0.0
2722 nr = 0
2723 CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2724 END IF
2725 theta = acos(rr/phi)/3.0
2726 costh = cos(theta)
2727 sinth = sin(theta)
2728 ! *** use trig identities to simplify the expressions
2729 ! *** binkowski's modification
2730 part1 = sqrt(qq)
2731 yy1 = part1*costh
2732 yy2 = yy1 - a2/3.0
2733 yy3 = sqrt3*part1*sinth
2734 crutes(3) = -2.0*yy1 - a2/3.0
2735 crutes(2) = yy2 + yy3
2736 crutes(1) = yy2 - yy3
2737 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2738 IF (crutes(1)<0.0) crutes(1) = 1.0E9
2739 IF (crutes(2)<0.0) crutes(2) = 1.0E9
2740 IF (crutes(3)<0.0) crutes(3) = 1.0E9
2741 ! *** put smallest positive root in crutes(1)
2742 crutes(1) = min(crutes(1),crutes(2),crutes(3))
2743 nr = 3
2744 ! NOW HERE WE HAVE ONLY ONE REAL ROOT
2745 ELSE
2746 ! dum IS NEGATIVE
2747 part1 = sqrt(rrsq-dum1)
2748 part2 = abs(rr)
2749 part3 = (part1+part2)**one3rd
2750 crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2751 !bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2752 crutes(2) = 0.
2753 crutes(3) = 0.
2754 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2755 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2756 ! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2757 nr = 1
2758 END IF
2759 RETURN
2760 END SUBROUTINE cubic
2761 !///////////////////////////////////////////////////////////////////////
2763 ! Calculate the aerosol chemical speciation and water content.
2764 ! cubic
2765 SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
2766 !***********************************************************************
2767 !** DESCRIPTION:
2768 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2769 ! and water between the gas and aerosol phases as the total sulfate,
2770 ! ammonia, and nitrate concentrations, relative humidity and
2771 ! temperature change. The evolution of the aerosol mass concentration
2772 ! due to the change in aerosol chemical composition is calculated.
2773 !** REVISION HISTORY:
2774 ! prototype 1/95 by Uma and Carlie
2775 ! Revised 8/95 by US to calculate air density in stmt func
2776 ! and collect met variable stmt funcs in one include fil
2777 ! Revised 7/26/96 by FSB to use block concept.
2778 ! Revise 12/1896 to do do i-mode calculation.
2779 !**********************************************************************
2780 ! IMPLICIT NONE
2782 ! dimension of arrays
2783 INTEGER blksize
2784 ! actual number of cells in arrays
2785 INTEGER numcells
2786 ! nmber of species in CBLK
2787 INTEGER nspcsda,igrid,jgrid,kgrid
2788 REAL cblk(blksize,nspcsda)
2789 ! *** Meteorological information in blocked arays:
2791 ! main array of variables
2792 REAL blkta(blksize) ! Air temperature [ K ]
2793 REAL blkrh(blksize)
2795 ! Fractional relative humidity
2797 INTEGER lcell
2798 ! loop counter
2799 ! air temperature
2800 REAL temp
2801 !iamodels3
2802 REAL rh
2803 ! relative humidity
2804 REAL so4, no3, nh3, nh4, hno3
2805 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2806 ! Fraction of dry sulfate mass in i-mode
2807 REAL fraci
2808 !.......................................................................
2809 REAL fracj
2810 !
2811 ! ISOROPIA variables double precision
2812 !
2813 real(kind=8) wi(5),wt(5),wt_save(5)
2814 real(kind=8) rhi,tempi,cntrl(2)
2815 real(kind=8) gas(3),aerliq(12),aersld(9),other(6)
2816 character*15 scasi
2818 ! WRITE(20,*) ' IN EQL 3 '
2820 ! Fraction of dry sulfate mass in j-mode
2821 DO lcell = 1, &
2822 numcells
2823 ! *** Fetch temperature, fractional relative humidity, and
2824 ! air density
2826 ! loop on cells
2827 temp = blkta(lcell)
2828 rh = blkrh(lcell)
2830 rhi = amin1( rh,0.995 )
2831 tempi = temp
2832 cntrl(1) = 0.d0 ! 0 = forward problem
2833 cntrl(2) = 0.d0 ! 0 = solids and liquid allowed
2835 wi(1) = (cblk(lcell,vnaaj) + cblk(lcell,vnaai))/mw_na_aer*1.e-6 ! sodium
2837 wi(2) = (cblk(lcell,vsulf)/(mw_so4_aer+2.) + &
2838 (cblk(lcell,vso4aj) + cblk(lcell,vso4ai))/mw_so4_aer)*1.e-6 ! sulfate
2840 wi(3) = (cblk(lcell,vnh3)/(mw_nh4_aer-1.) + &
2841 (cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai))/mw_nh4_aer)*1.e-6 ! ammoinum
2843 wi(4) = (cblk(lcell,vhno3)/(mw_no3_aer+1.) + &
2844 (cblk(lcell,vno3aj) + cblk(lcell,vno3ai))/mw_no3_aer)*1.e-6 ! nitrate
2846 !KW wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer-1.) + &
2847 !KW (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6 ! chloride
2848 !KW wi(5) equation according to WRFV3.1
2849 wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer+1.) + &
2850 (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6
2852 !KW
2853 ! Following added: wi should be positive
2854 wi(1) = max(wi(1),0.)
2855 wi(2) = max(wi(2),0.)
2856 wi(3) = max(wi(3),0.)
2857 wi(4) = max(wi(4),0.)
2858 wi(5) = max(wi(5),0.)
2860 wt_save(1) = wi(1) ! sodium
2861 wt_save(2) = wi(2) ! sulfate
2862 wt_save(3) = wi(3) ! ammoinum
2863 wt_save(4) = wi(4) ! nitrate
2864 wt_save(5) = wi(5) ! chloride
2865 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
2866 print *,vhcl,vclai
2867 print *,wi(1),wi(2),wi(3),wi(4),wi(5)
2868 endif
2870 !KW Originally isoropia not used
2871 call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other)
2873 ! *** the following is an interim procedure. Assume the i-mode has the
2874 ! same relative mass concentrations as the total mass. Use SO4 as
2875 ! the surrogate.
2877 ! *** update gas / vapor phase
2879 !KW Added the following: gas has to be positive and within input value
2881 gas(1) = min(gas(1),wt_save(3))
2882 gas(2) = min(gas(2),wt_save(4))
2883 gas(3) = min(gas(3),wt_save(5))
2885 gas(1) = max(gas(1),0.)
2886 gas(2) = max(gas(2),0.)
2887 gas(3) = max(gas(3),0.)
2889 !KW Original code starts here
2891 cblk(lcell,vnh3) = gas(1)*1.e6*(mw_nh4_aer-1.)
2892 cblk(lcell,vhno3) = gas(2)*1.e6*(mw_no3_aer+1.)
2893 cblk(lcell,vhcl) = gas(3)*1.e6*(mw_cl_aer+1.)
2894 !KW cblk(lcell,vnh3) = gas(1)*1.e6*17.
2895 !KW cblk(lcell,vhno3) = gas(2)*1.e6*63.
2896 !KW cblk(lcell,vhcl) = gas(3)*1.e6*36.
2897 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
2898 print *,vhcl,vnh3,vhno3
2899 print *,cblk(lcell,vnh3),cblk(lcell,vhno3),cblk(lcell,vhcl)
2900 endif
2902 ! *** get modal fraction
2903 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
2905 !KW Restrict fraci from between 0 to 1
2906 fraci = min(fraci,1.0)
2907 fraci = max(fraci,0.0)
2909 fracj = 1.0 - fraci
2911 !KW correct mapping from (mol m-3) to (ug m-3)
2913 aerliq(8) = max(aerliq(8),0.)
2915 ! *** update do i-mode
2916 cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6
2917 cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6
2918 cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))*mw_no3_aer*1.e6
2919 cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))*mw_cl_aer*1.e6
2920 cblk(lcell,vnaai) = fraci*wi(1)*mw_na_aer*1.e6
2922 !KW cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))
2923 !KW cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))
2924 !KW cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))
2925 !KW cblk(lcell,vnaai) = fraci*wi(1)
2927 ! *** update accumulation mode:
2928 !KW ! correct mapping from (mol m-3) to (ug m-3)
2930 cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6
2931 cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6
2932 cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))*mw_no3_aer*1.e6
2933 cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))*mw_cl_aer*1.e6
2934 cblk(lcell,vnaaj) = fracj*wi(1)*mw_na_aer*1.e6
2936 !KW cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))
2937 !KW cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))
2938 !KW cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))
2939 !KW cblk(lcell,vnaaj) = fracj*wi(1)
2941 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
2942 print *,vh2oaj,vnh4aj,vno3aj,vclaj,vnaaj
2943 print *,cblk(lcell,vnh4aj),cblk(lcell,vno3aj),cblk(lcell,vclaj),aerliq(8)
2944 endif
2946 END DO
2947 ! end loop on cells
2949 RETURN
2951 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2952 END SUBROUTINE eql3
2953 ! eql3
2954 ! Calculate the aerosol chemical speciation and water content.
2956 ! cubic
2957 SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
2958 !***********************************************************************
2959 !** DESCRIPTION:
2960 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2961 ! and water between the gas and aerosol phases as the total sulfate,
2962 ! ammonia, and nitrate concentrations, relative humidity and
2963 ! temperature change. The evolution of the aerosol mass concentration
2964 ! due to the change in aerosol chemical composition is calculated.
2965 !** REVISION HISTORY:
2966 ! prototype 1/95 by Uma and Carlie
2967 ! Revised 8/95 by US to calculate air density in stmt func
2968 ! and collect met variable stmt funcs in one include fil
2969 ! Revised 7/26/96 by FSB to use block concept.
2970 ! Revise 12/1896 to do do i-mode calculation.
2971 !**********************************************************************
2972 ! IMPLICIT NONE
2974 ! dimension of arrays
2975 INTEGER blksize
2976 ! actual number of cells in arrays
2977 INTEGER numcells
2978 ! nmber of species in CBLK
2979 INTEGER nspcsda
2980 REAL cblk(blksize,nspcsda)
2981 ! *** Meteorological information in blocked arays:
2983 ! main array of variables
2984 REAL blkta(blksize) ! Air temperature [ K ]
2985 REAL blkrh(blksize)
2987 ! Fractional relative humidity
2989 INTEGER lcell
2990 ! loop counter
2991 ! air temperature
2992 REAL temp
2993 !iamodels3
2994 REAL rh
2995 ! relative humidity
2996 REAL so4, no3, nh3, nh4, hno3
2997 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2998 ! Fraction of dry sulfate mass in i-mode
2999 REAL fraci
3000 !.......................................................................
3001 REAL fracj
3002 ! Fraction of dry sulfate mass in j-mode
3003 DO lcell = 1, &
3004 numcells
3005 ! *** Fetch temperature, fractional relative humidity, and
3006 ! air density
3008 ! loop on cells
3009 temp = blkta(lcell)
3010 rh = blkrh(lcell)
3012 ! *** the following is an interim procedure. Assume the i-mode has the
3013 ! same relative mass concentrations as the total mass. Use SO4 as
3014 ! the surrogate. The results of this should be the same as those
3015 ! from the original RPM.
3017 ! *** do total aerosol
3018 so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
3020 !iamodels3
3021 no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
3022 ! & + CBLK(LCELL, VHNO3)
3024 hno3 = cblk(lcell,vhno3)
3026 !iamodels3
3028 nh3 = cblk(lcell,vnh3)
3030 nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
3031 ! & + CBLK(LCELL, VNH3)
3033 !bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
3034 !bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
3035 !bs
3036 !bs * call old version of rpmares
3037 !bs
3038 CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
3039 gnh3,gno3)
3040 !bs
3042 ! *** get modal fraction
3043 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3044 fracj = 1.0 - fraci
3046 ! *** update do i-mode
3048 cblk(lcell,vh2oai) = fraci*ah2o
3049 cblk(lcell,vnh4ai) = fraci*anh4
3050 cblk(lcell,vno3ai) = fraci*ano3
3052 ! *** update accumulation mode:
3054 cblk(lcell,vh2oaj) = fracj*ah2o
3055 cblk(lcell,vnh4aj) = fracj*anh4
3056 cblk(lcell,vno3aj) = fracj*ano3
3059 ! *** update gas / vapor phase
3060 cblk(lcell,vnh3) = gnh3
3061 cblk(lcell,vhno3) = gno3
3063 END DO
3064 ! end loop on cells
3065 RETURN
3067 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3068 END SUBROUTINE eql4
3069 ! eql4
3071 SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
3072 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3073 !bs !
3074 !bs Description: !
3075 !bs !
3076 !bs Get the Jacobian of the function !
3077 !bs !
3078 !bs ( a1 * X1^2 + b1 * X1 + c1 ) !
3079 !bs ( a2 * X2^2 + b2 * X1 + c2 ) !
3080 !bs ( a3 * X3^2 + b3 * X1 + c3 ) !
3081 !bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. !
3082 !bs ( a5 * X5^2 + b5 * X1 + c5 ) !
3083 !bs ( a6 * X6^2 + b6 * X1 + c6 ) !
3084 !bs !
3085 !bs a_i = IMW_i !
3086 !bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i !
3087 !bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] !
3088 !bs !
3089 !bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j !
3090 !bs J_ij = ----------- = ( !
3091 !bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j !
3092 !bs !
3093 !bs !
3094 !bs Called by: NEWT !
3095 !bs !
3096 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3097 !bs
3098 ! IMPLICIT NONE
3099 !bs
3100 !bs
3101 !dimension of problem
3102 INTEGER n
3103 REAL x(n) !bs
3104 ! INTEGER NP !bs maximum expected value of N
3105 ! PARAMETER (NP = 6)
3106 !bs initial guess of CAER
3107 REAL ct(np)
3108 REAL cs(np)
3109 REAL imw(np)
3110 !bs
3111 REAL fjac(n,n)
3112 !bs
3113 INTEGER i, & !bs loop index
3114 j
3115 REAL a(np)
3116 REAL b(np)
3117 REAL b1(np)
3118 REAL b2(np)
3119 REAL sum_jnei
3120 !bs
3121 DO i = 1, n
3122 a(i) = imw(i)
3123 sum_jnei = 0.
3124 DO j = 1, n
3125 sum_jnei = sum_jnei + x(j)*imw(j)
3126 END DO
3127 b1(i) = sum_jnei - (x(i)*imw(i))
3128 b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
3129 b(i) = b1(i) + b2(i)
3130 END DO
3131 DO j = 1, n
3132 DO i = 1, n
3133 IF (i==j) THEN
3134 fjac(i,j) = 2.*a(i)*x(i) + b(i)
3135 ELSE
3136 fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
3137 END IF
3138 END DO
3139 END DO
3140 !bs
3141 RETURN
3142 END SUBROUTINE fdjac
3143 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3144 FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
3145 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3146 !bs !
3147 !bs Description: !
3148 !bs !
3149 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3150 !bs !
3151 !bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, !
3152 !bs user-supplied routine that returns the vector of functions at X. !
3153 !bs The common block NEWTV communicates the function values back to !
3154 !bs NEWT. !
3155 !bs !
3156 !bs Called by: NEWT !
3157 !bs !
3158 !bs Calls: FUNCV !
3159 !bs !
3160 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3162 ! IMPLICIT NONE
3164 !bs
3165 !bs
3166 INTEGER n
3167 ! INTEGER NP
3168 ! PARAMETER (NP = 6)
3169 REAL ct(np)
3170 REAL cs(np)
3171 REAL imw(np)
3172 REAL m,fmin
3173 REAL x(*), fvec(np)
3175 INTEGER i
3176 REAL sum
3178 CALL funcv(n,x,fvec,ct,cs,imw,m)
3179 sum = 0.
3180 DO i = 1, n
3181 sum = sum + fvec(i)**2
3182 END DO
3183 fmin = 0.5*sum
3184 RETURN
3185 END FUNCTION fmin
3186 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3187 SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
3188 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3189 !bs !
3190 !bs Description: !
3191 !bs !
3192 !bs Called by: FMIN !
3193 !bs !
3194 !bs Calls: None !
3195 !bs !
3196 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3197 !bs
3198 ! IMPLICIT NONE
3199 !bs
3200 !bs
3201 INTEGER n
3202 REAL x(*)
3203 REAL fvec(n)
3204 !bs
3205 ! INTEGER NP
3206 ! PARAMETER (NP = 6)
3207 REAL ct(np)
3208 REAL cs(np)
3209 REAL imw(np)
3210 REAL m
3211 !bs
3212 INTEGER i, j
3213 REAL sum_jnei
3214 REAL a(np)
3215 REAL b(np)
3216 REAL c(np)
3217 !bs
3218 DO i = 1, n
3219 a(i) = imw(i)
3220 sum_jnei = 0.
3221 DO j = 1, n
3222 sum_jnei = sum_jnei + x(j)*imw(j)
3223 END DO
3224 sum_jnei = sum_jnei - (x(i)*imw(i))
3225 b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
3226 c(i) = -ct(i)*(sum_jnei+m)
3227 fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
3228 END DO
3229 !bs
3230 RETURN
3231 END SUBROUTINE funcv
3232 REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
3233 ! *** set up new processor for renaming of particles from i to j modes
3234 ! IMPLICIT NONE
3235 REAL aa, bb, cc, disc, qq, alfa, l, yji
3236 REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
3238 alfa = xlsgi/xlsgj
3239 yji = log(dgnj/dgni)/(sqrt2*xlsgi)
3240 aa = 1.0 - alfa*alfa
3241 l = log(alfa*nj/ni)
3242 bb = 2.0*yji*alfa*alfa
3243 cc = l - yji*yji*alfa*alfa
3244 disc = bb*bb - 4.0*aa*cc
3245 IF (disc<0.0) THEN
3246 getaf = - & ! error in intersection
3247 5.0
3248 RETURN
3249 END IF
3250 qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3251 getaf = cc/qq
3252 RETURN
3253 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3254 END FUNCTION getaf
3255 ! Parameterization for sulfuric acid/water
3256 ! nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3257 ! April 20, 1998.
3259 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3260 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3262 !ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3263 ! getaf
3264 SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3265 ! IMPLICIT NONE
3267 ! *** Input:
3269 ! ambient temperature [ K ]
3270 REAL temp
3271 ! fractional relative humidity
3272 REAL rh
3273 ! sulfuric acid concentration [ ug / m**3 ]
3274 REAL h2so4
3276 REAL so4rat
3277 ! *** Output:
3279 !sulfuric acid production rate [ ug / ( m**3 s )]
3280 ! particle number production rate [ # / ( m**3 s )]
3281 REAL ndot1
3282 ! particle mass production rate [ ug / ( m**3 s )]
3283 REAL mdot1
3284 ! [ m**2 / ( m**3 s )]
3285 REAL m2dot
3287 ! *** Internal:
3289 ! *** NOTE, all units are cgs internally.
3290 ! particle second moment production rate
3292 REAL ra
3293 ! fractional relative acidity
3294 ! sulfuric acid vaper concentration [ cm ** -3 ]
3295 REAL nav
3296 ! water vapor concentration [ cm ** -3 ]
3297 REAL nwv
3298 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3299 REAL nav0
3300 ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1
3301 REAL nac
3302 ! critical sulfuric acid vapor concentration [ cm ** -3
3303 ! mole fractio of the critical nucleus
3304 REAL xal
3305 REAL nsulf, & ! see usage
3306 delta
3307 REAL*8 & ! factor to calculate Jnuc
3308 chi
3309 REAL*8 &
3310 jnuc
3311 ! nucleation rate [ cm ** -3 s ** -1 ]
3312 REAL tt, & ! dummy variables for statement functions
3313 rr
3314 REAL pi
3315 PARAMETER (pi=3.14159265)
3317 REAL pid6
3318 PARAMETER (pid6=pi/6.0)
3320 ! avogadro's constant [ 1/mol ]
3321 REAL avo
3322 PARAMETER (avo=6.0221367E23)
3324 ! universal gas constant [ j/mol-k ]
3325 REAL rgasuniv
3326 PARAMETER (rgasuniv=8.314510)
3328 ! 1 atmosphere in pascals
3329 REAL atm
3330 PARAMETER (atm=1013.25E+02)
3332 ! formula weight for h2so4 [ g mole **-1 ]
3333 REAL mwh2so4
3334 PARAMETER (mwh2so4=98.07948)
3336 ! diameter of a 3.5 nm particle in cm
3337 REAL d35
3338 PARAMETER (d35=3.5E-07)
3339 REAL d35sq
3340 PARAMETER (d35sq=d35*d35)
3341 ! volume of a 3.5 nm particle in cm**3
3342 REAL v35
3343 PARAMETER (v35=pid6*d35*d35sq)
3344 !ia rev01
3346 REAL mp
3347 ! *** conversion factors:
3348 ! mass of sulfate in a 3.5 nm particle
3349 ! number per cubic cm.
3350 REAL ugm3_ncm3
3351 ! micrograms per cubic meter to
3352 PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3353 !ia rev01
3354 ! molecules to micrograms
3355 REAL nc_ug
3356 PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3358 ! *** statement functions **************
3360 REAL pdens, &
3361 rho_p
3362 ! particle density [ g / cm**3]
3363 REAL ad0, ad1, ad2, &
3364 ad3
3365 ! coefficients for density expression
3366 PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3367 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3368 ! as a function of relative humidity,
3369 ! J. Aerosol Science, 6, pp 265-271, 1975.
3371 !ia rev01
3373 ! fit to Nair & Vohra data
3374 ! the mass of sulfate in a 3.5 nm particle
3375 REAL mp35
3376 ! arithmetic statement function to compute
3377 REAL a0, a1, a2, & ! coefficients for cubic in mp35
3378 a3
3379 PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3381 REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ]
3382 ph2o
3384 ! arithmetic statement functions
3385 pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3387 ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3389 ph2so4(tt) = exp(27.78492066-10156.0/tt)
3391 ! *** both ph2o and ph2so4 are as in Kulmala et al. paper
3393 !ia rev01
3395 ! *** function for the mass of sulfate in a 3.5 nm sphere
3396 ! *** obtained from a fit to the number of sulfate monomers in
3397 ! a 3.5 nm particle. Uses data from Nair & Vohra
3398 mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3400 ! *** begin code:
3402 ! The 1.0e-6 factor in the following converts from MKS to cgs units
3404 ! *** get water vapor concentration [ molecles / cm **3 ]
3406 nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3408 ! *** calculate the equilibrium h2so4 vapor concentration.
3410 ! *** use Kulmala corrections:
3412 ! ***
3413 nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3415 ! *** convert sulfuric acid vapor concentration from micrograms
3416 ! per cubic meter to molecules per cubic centimeter.
3418 nav = ugm3_ncm3*h2so4
3420 ! *** calculate critical concentration of sulfuric acid vapor
3422 nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3424 ! *** calculate relative acidity
3426 ra = nav/nav0
3428 ! *** calculate temperature correction
3430 delta = 1.0 + (temp-273.15)/273.14
3432 ! *** calculate molar fraction
3434 xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3435 0.0016*temp
3437 ! *** calculate Nsulf
3438 nsulf = log(nav/nac)
3440 ! *** calculate particle produtcion rate [ # / cm**3 ]
3442 chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3443 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3445 jnuc = exp(chi)
3446 ! [ # / cm**3 ]
3447 ndot1 = (1.0E06)*jnuc
3448 ! write(91,*) ' inside klpnuc '
3449 ! write(91,*) ' Jnuc = ', Jnuc
3450 ! write(91,*) ' NDOT = ', NDOT1
3452 ! *** calculate particle density
3454 rho_p = pdens(rh)
3456 ! write(91,*) ' rho_p =', rho_p
3458 ! *** get the mass of sulfate in a 3.5 nm particle
3460 mp = mp35(rh) ! in a 3.5 nm particle at ambient RH
3462 ! *** calculate mass production rate [ ug / m**3]
3463 ! assume that the particles are 3.5 nm in diameter.
3465 ! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc
3467 !ia rev01
3469 ! number of micrograms of sulfate
3470 mdot1 = mp*ndot1
3472 !ia rev02
3474 IF (mdot1>so4rat) THEN
3476 mdot1 = &
3477 so4rat
3478 ! limit nucleated mass by available ma
3479 ndot1 = mdot1/ &
3480 mp
3481 ! adjust DNDT to this
3482 END IF
3484 IF (mdot1==0.) ndot1 = 0.
3486 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3488 m2dot = 1.0E-04*d35sq*ndot1
3490 RETURN
3492 END SUBROUTINE klpnuc
3493 !------------------------------------------------------------------------------
3495 SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3496 pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3497 knacc,kncor)
3499 !** DESCRIPTION:
3500 ! Calculates modal parameters and derived variables,
3501 ! log-squared of std deviation, mode mean size, Knudsen number)
3502 ! based on current values of moments for the modes.
3503 ! FSB Now calculates the 3rd moment, mass, and density in all 3 modes.
3504 !**
3505 !** Revision history:
3506 ! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3507 ! Revised 7/23/96 by FSB to use COMMON blocks and small blocks
3508 ! instead of large 3-d arrays, and to assume a fixed std.
3509 ! Revised 12/06/96 by FSB to include coarse mode
3510 ! Revised 1/10/97 by FSB to have arrays passed in call vector
3511 !**********************************************************************
3513 ! IMPLICIT NONE
3515 ! Includes:
3517 ! *** input:
3519 ! dimension of arrays
3520 INTEGER blksize
3521 ! actual number of cells in arrays
3522 INTEGER numcells
3524 INTEGER nspcsda
3526 ! nmber of species in CBLK
3527 REAL cblk(blksize,nspcsda) ! main array of variables
3528 REAL blkta(blksize) ! Air temperature [ K ]
3529 REAL blkprs(blksize)
3530 ! *** output:
3532 ! Air pressure in [ Pa ]
3533 ! concentration lower limit [ ug/m*
3534 ! lowest particle diameter ( m )
3535 REAL dgmin
3536 PARAMETER (dgmin=1.0E-09)
3538 ! lowest particle density ( Kg/m**3
3539 REAL densmin
3540 PARAMETER (densmin=1.0E03)
3542 REAL pmassn(blksize) ! mass concentration in nuclei mode
3543 REAL pmassa(blksize) ! mass concentration in accumulation
3544 REAL pmassc(blksize) ! mass concentration in coarse mode
3545 REAL pdensn(blksize) ! average particel density in Aitken
3546 REAL pdensa(blksize) ! average particel density in accumu
3547 REAL pdensc(blksize) ! average particel density in coarse
3548 REAL xlm(blksize) ! atmospheric mean free path [ m]
3549 REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3550 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3551 REAL dgacc(blksize) ! accumulation
3552 REAL dgcor(blksize) ! coarse mode
3553 REAL knnuc(blksize) ! Aitken mode Knudsen number
3554 REAL knacc(blksize) ! accumulation
3555 REAL kncor(blksize)
3557 ! coarse mode
3559 INTEGER lcell
3560 ! WRITE(20,*) ' IN MODPAR '
3562 ! *** set up aerosol 3rd moment, mass, density
3564 ! loop counter
3565 DO lcell = 1, numcells
3567 ! *** Aitken-mode
3568 ! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3569 cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3570 vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3571 vh2oai)+no3fac*cblk(lcell,vno3ai)+ &
3572 nafac*cblk(lcell,vnaai)+ clfac*cblk(lcell,vclai)+ &
3573 orgfac*cblk(lcell, &
3574 vasoa1i)+orgfac*cblk(lcell,vasoa2i)+orgfac*cblk(lcell, &
3575 vasoa3i)+orgfac*cblk(lcell,vasoa4i)+orgfac*cblk(lcell, &
3576 vbsoa1i)+orgfac*cblk(lcell,vbsoa2i)+orgfac*cblk(lcell, &
3577 vbsoa3i)+orgfac*cblk(lcell,vbsoa4i)+orgfac*cblk(lcell, &
3578 vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
3579 ! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan
3581 ! *** Accumulation-mode
3582 ! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3583 cblk(lcell,vac3) = so4fac*cblk(lcell, &
3584 vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
3585 vh2oaj)+no3fac*cblk(lcell,vno3aj) + &
3586 nafac*cblk(lcell,vnaaj)+ clfac*cblk(lcell,vclaj)+ &
3587 orgfac*cblk(lcell, &
3588 vasoa1j)+orgfac*cblk(lcell,vasoa2j)+orgfac*cblk(lcell, &
3589 vasoa3j)+orgfac*cblk(lcell,vasoa4j)+orgfac*cblk(lcell, &
3590 vbsoa1j)+orgfac*cblk(lcell,vbsoa2j)+orgfac*cblk(lcell, &
3591 vbsoa3j)+orgfac*cblk(lcell,vbsoa4j)+orgfac*cblk(lcell, &
3592 vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
3593 ! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan
3595 ! *** coarse mode
3596 ! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
3597 ! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
3599 cblk(lcell,vcor3) = soilfac*cblk(lcell, &
3600 vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
3602 ! *** now get particle mass and density
3604 ! *** Aitken-mode:
3605 !KW Na and Cl added to aitken mode mass conc
3607 pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
3608 vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+ &
3609 cblk(lcell,vnaai)+cblk(lcell,vclai)+cblk(lcell, &
3610 vasoa1i)+cblk(lcell,vasoa2i)+cblk(lcell,vasoa3i)+cblk(lcell, &
3611 vasoa4i)+cblk(lcell,vbsoa1i)+cblk(lcell,vbsoa2i)+cblk(lcell, &
3612 vbsoa3i)+cblk(lcell,vbsoa4i)+cblk(lcell,vorgpai)+cblk(lcell, &
3613 vp25ai)+cblk(lcell,veci)))
3615 ! *** Accumulation-mode:
3616 !KW Na and Cl added to accum mode mass conc
3618 pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
3619 vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+ &
3620 cblk(lcell,vnaaj)+cblk(lcell,vclaj)+cblk(lcell, &
3621 vasoa1j)+cblk(lcell,vasoa2j)+cblk(lcell,vasoa3j)+cblk(lcell, &
3622 vasoa4j)+cblk(lcell,vbsoa1j)+cblk(lcell,vbsoa2j)+cblk(lcell, &
3623 vbsoa3j)+cblk(lcell,vbsoa4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
3624 vp25aj)+cblk(lcell,vecj)))
3626 ! *** coarse mode:
3627 pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
3628 lcell,vantha))
3630 END DO
3631 ! *** now get particle density, mean free path, and dynamic viscosity
3633 ! aerosol 3rd moment and mass
3634 DO lcell = 1, &
3635 numcells
3636 ! *** density in [ kg m**-3 ]
3638 ! Density and mean free path
3639 pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
3640 pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
3641 pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
3643 ! *** Calculate mean free path [ m ]:
3644 xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
3646 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
3647 ! *** on page 10 of U.S. Standard Atmosphere 1962
3649 ! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
3651 ! *** U.S. Standard Atmosphere 1962 page 14 expression
3652 ! for dynamic viscosity is:
3653 ! dynamic viscosity = beta * T * sqrt(T) / ( T + S)
3654 ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
3656 amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
3657 (blkta(lcell)+110.4)
3659 END DO
3660 !............... Standard deviation fixed in both modes, so
3661 !............... diagnose diameter from 3rd moment and number concentr
3663 ! density and mean free path
3664 DO lcell = 1, &
3665 numcells
3667 ! calculate diameters
3668 dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
3669 one3)
3671 dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
3672 one3)
3674 dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
3675 **one3)
3677 ! when running with cloudborne aerosol, apply some very mild bounding
3678 ! to avoid unrealistic dg values
3679 if (cw_phase > 0) then
3680 dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2 ) ! > 0.002 um
3681 dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 ) ! < 0.10 um
3682 dgacc(lcell) = max( dgacc(lcell), dginia*0.2 ) ! > 0.014 um
3683 dgacc(lcell) = min( dgacc(lcell), dginia*10.0 ) ! < 0.7 um
3684 dgcor(lcell) = max( dgcor(lcell), dginic*0.2 ) ! > 0.2 um
3685 dgcor(lcell) = min( dgcor(lcell), dginic*10.0 ) ! < 10.0 um
3686 end if
3688 END DO
3689 ! end loop on diameters
3690 DO lcell = 1, &
3691 numcells
3692 ! Calculate Knudsen numbers
3693 knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
3695 knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
3697 kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
3699 END DO
3701 ! end loop for Knudsen numbers
3702 RETURN
3704 END SUBROUTINE modpar
3705 !------------------------------------------------------------------------------
3707 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
3708 blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, &
3709 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, &
3710 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto)
3712 !***********************************************************************
3713 !** DESCRIPTION: calculates aerosol nucleation and condensational
3714 !** growth rates using Binkowski and Shankar (1995) method.
3716 ! *** In this version, the method od RPM is followed where
3717 ! the diffusivity, the average molecular ve3locity, and
3718 ! the accomodation coefficient for sulfuric acid are used for
3719 ! the organics. This is for consistency.
3720 ! Future versions will use the correct values. FSB 12/12/96
3723 !**
3724 !** Revision history:
3725 ! prototype 1/95 by Uma and Carlie
3726 ! Corrected 7/95 by Uma for condensation of mass not nucleated
3727 ! and mass conservation check
3728 ! Revised 8/95 by US to calculate air density in stmt function
3729 ! and collect met variable stmt funcs in one include fil
3730 ! Revised 7/25/96 by FSB to use block structure.
3731 ! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
3732 ! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units.
3733 ! Revised 1/13/97 by FSB to pass arrays and simplify code.
3734 ! Added 23/03/99 by BS growth factors for organics
3735 !**********************************************************************
3736 ! IMPLICIT NONE
3738 ! Includes:
3739 ! *** arguments
3741 ! *** input;
3742 !USE module_configure, only: grid_config_rec_type
3743 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
3746 ! dimension of arrays
3747 INTEGER blksize
3748 INTEGER layer
3749 ! number of species in CBLK
3750 INTEGER nspcsda
3751 ! actual number of cells in arrays
3752 INTEGER numcells
3753 INTEGER igrid,jgrid,kgrid
3755 INTEGER ldrog_vbs
3756 ! # of organic aerosol precursor
3757 REAL cblk(blksize,nspcsda) ! main array of variables
3758 ! model time step in SECONDS
3759 REAL dt
3760 REAL blkta(blksize) ! Air temperature [ K ]
3761 REAL blkprs(blksize) ! Air pressure in [ Pa ]
3762 REAL blkrh(blksize) ! Fractional relative humidity
3763 REAL so4rat(blksize) ! rate [ ug/m**3 /s ]
3764 REAL brrto
3765 !bs
3766 ! sulfate gas-phase production
3767 ! total # of cond. vapors & SOA spe
3768 INTEGER ncv
3769 !bs
3770 INTEGER nacv
3771 !bs * anthropogenic organic condensable vapor production rate
3772 ! # of anthrop. cond. vapors & SOA
3773 REAL drog(blksize,ldrog_vbs) !bs
3774 ! Delta ROG conc. [ppm]
3776 ! anthropogenic vapor production rates
3777 REAL organt1rat(blksize)
3778 REAL organt2rat(blksize)
3779 REAL organt3rat(blksize)
3780 REAL organt4rat(blksize)
3782 ! biogenic vapor production rates
3783 REAL orgbio1rat(blksize)
3784 REAL orgbio2rat(blksize)
3785 REAL orgbio3rat(blksize)
3786 REAL orgbio4rat(blksize)
3788 ! biogenic organic aerosol production
3789 REAL dgnuc(blksize) ! accumulation
3790 REAL dgacc(blksize)
3791 ! *** output:
3793 ! coarse mode
3794 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
3795 ! reciprocal condensation rate
3796 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
3797 ! reciprocal condensation rate
3798 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
3799 ! reciprocal condensation rate
3800 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
3801 ! reciprocal condensation rate
3802 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
3803 ! rate of production of new mass concent
3804 REAL dndt(blksize) ! concentration by particle formation [#
3805 ! rate of producton of new particle numb
3806 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
3807 ! increment of concentration added to
3808 REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ]
3809 ! growth rate for 3rd moment for
3810 REAL cgra3(blksize) ! Accumulation mode
3812 !........... SCRATCH local variables and their descriptions:
3814 ! growth rate for 3rd moment for
3816 INTEGER lcell
3818 ! LOOP INDEX
3819 ! conv rate so2 --> so4 [mom-3/g/s]
3820 REAL chemrat
3821 ! conv rate for organics [mom-3/g/s]
3822 REAL chemrat_org
3823 REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
3824 am1a
3825 REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
3826 am2a
3827 REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
3828 gnc3a
3829 REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den
3830 gfm3a
3831 ! total reciprocal condensation rate
3832 REAL fconc
3834 REAL td
3835 ! d * tinf (cgs)
3836 REAL*8 & ! Cnstant to force 64 bit evaluation of
3837 one88
3838 PARAMETER (one88=1.0D0)
3839 ! *** variables to set up sulfate and organic condensation rates
3841 ! sulfuric acid vapor at current time step
3842 REAL vapor1
3843 ! chemistry and emissions
3844 REAL vapor2
3845 ! Sulfuric acid vapor prior to addition from
3846 !bs
3847 REAL deltavap
3848 !bs * start update
3849 !bs
3850 ! change to vapor at previous time step
3851 REAL diffcorr
3853 !bs *
3854 REAL csqt_org
3855 !bs * end update
3856 !bs
3857 REAL csqt
3858 !.......................................................................
3859 ! begin body of subroutine NUCLCOND
3862 !........... Main computational grid-traversal loop nest
3863 !........... for computing condensation and nucleation:
3865 DO lcell = 1, &
3866 numcells
3867 ! *** First moment:
3869 ! 1st loop over NUMCELLS
3870 am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
3871 am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
3873 !.............. near-continuum factors [ 1 / sec ]
3874 !bs
3875 !bs * adopted from code of FSB
3876 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
3877 !bs
3878 diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
3879 !bs
3880 gnc3n = cconc*am1n*diffcorr
3881 gnc3a = cconc*am1a*diffcorr
3883 ! *** Second moment:
3885 am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
3886 am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
3888 csqt = ccofm*sqrt(blkta(lcell))
3889 !............... free molecular factors [ 1 / sec ]
3891 ! put in temperature fac
3892 gfm3n = csqt*am2n
3893 gfm3a = csqt*am2a
3895 ! *** Condensation factors in [ s**-1] for h2so4
3896 ! *** In the future, separate factors for condensing organics will
3897 ! be included. In this version, the h2so4 values are used.
3899 !............... Twice the harmonic mean of fm, nc functions:
3900 ! *** Force 64 bit evaluation:
3902 fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
3903 fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
3904 fconc = fconcn(lcell) + fconca(lcell)
3906 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
3907 !bs
3908 !bs * start modifications for organcis
3909 !bs
3910 gnc3n = cconc_org*am1n*diffcorr
3911 gnc3a = cconc_org*am1a*diffcorr
3912 !bs
3913 csqt_org = ccofm_org*sqrt(blkta(lcell))
3914 gfm3n = csqt_org*am2n
3915 gfm3a = csqt_org*am2a
3916 !bs
3917 fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
3918 fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
3919 !bs
3920 !bs * end modifications for organics
3921 !bs
3922 ! *** calculate the total change to sulfuric acid vapor from production
3923 ! and condensation
3925 vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
3926 vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
3927 dt
3928 ! vapor at prev
3929 vapor2 = max(0.0,vapor2)
3930 deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
3932 ! *** Calculate increment in total sufate aerosol mass concentration
3934 ! *** This follows the method of Youngblood & Kreidenweis.!bs
3935 !bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
3936 !bs
3937 !bs * allow DELTASO4A to be negative, but the change must not be larger
3938 !bs * than the amount of vapor available.
3939 !bs
3940 deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
3941 so4rat(lcell)*dt-deltavap)
3943 ! *** zero out growth coefficients
3944 cgrn3(lcell) = 0.0
3945 cgra3(lcell) = 0.0
3947 END DO
3949 ! *** Select method of nucleation
3950 ! End 1st loop over NUMCELLS
3951 IF (inucl==1) THEN
3953 ! *** Do Youngblood & Kreidenweis Nucleation
3955 ! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
3956 ! & DNDT,DMDT,NUMCELLS,BLKSIZE,
3957 ! & VAPOR1)
3958 ! IF (firstime) THEN
3959 ! WRITE (6,*)
3960 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3961 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3962 ! firstime = .FALSE.
3963 ! END IF
3965 ELSE IF (inucl==0) THEN
3967 ! *** Do Kerminen & Wexler Nucleation
3969 ! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
3970 ! & DNDT,DMDT,NUMCELLS,BLKSIZE)
3971 ! IF (firstime) THEN
3972 ! WRITE (6,*)
3973 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3974 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3975 ! firstime = .FALSE.
3976 ! END IF
3978 ELSE IF (inucl==2) THEN
3980 !bs ** Do Kulmala et al. Nucleation
3981 ! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
3983 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
3984 CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
3985 else
3986 dndt(1)=0.
3987 dmdt(1)=0.
3988 endif
3990 ! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
3991 ! if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
3992 IF (dndt(1)==0.) dmdt(1) = 0.
3993 IF (dmdt(1)==0.) dndt(1) = 0.
3994 ! IF (firstime) THEN
3995 ! WRITE (6,*)
3996 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
3997 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
3998 ! firstime = .FALSE.
3999 ! END IF
4000 ! ELSE
4001 ! WRITE (6,'(a)') '*************************************'
4002 ! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!'
4003 ! WRITE (6,'(a)') ' PROGRAM TERMINATED !!'
4004 ! WRITE (6,'(a)') '*************************************'
4005 ! STOP
4007 END IF
4008 !bs
4009 !bs * Secondary organic aerosol module (SOA_VBS)
4010 !bs
4011 ! end of selection of nucleation method
4013 CALL sorgam_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
4014 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
4015 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto )
4016 !bs
4017 !bs * Secondary organic aerosol module (SOA_VBS)
4018 !bs
4019 DO lcell = 1, numcells
4021 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
4022 ! condensation factors
4024 td = 1.0/(fconcn(lcell)+fconca(lcell))
4025 fconcn(lcell) = td*fconcn(lcell)
4026 fconca(lcell) = td*fconca(lcell)
4027 !bs
4028 td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
4029 fconcn_org(lcell) = td*fconcn_org(lcell)
4030 fconca_org(lcell) = td*fconca_org(lcell)
4031 !bs
4032 END DO
4034 ! *** Begin second loop over cells
4036 DO lcell = 1,numcells
4037 ! *** note CHEMRAT includes species other than sulfate.
4039 ! 3rd loop on NUMCELLS
4040 chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
4041 chemrat_org = orgfac*(organt1rat(lcell)+organt2rat(lcell)+organt3rat( &
4042 lcell)+organt4rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
4043 orgbio3rat(lcell)+orgbio4rat(lcell))
4045 ! *** Calculate the production rates for new particle
4046 ! [mom3 m**-3 s-
4047 cgrn3(lcell) = so4fac*dmdt(lcell)
4048 ! Rate of increase of 3rd
4049 chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro
4051 !bs Remove the rate of new pa
4052 chemrat = max(chemrat,0.0)
4053 ! *** Now calculate the rate of condensation on existing particles.
4055 ! Prevent CHEMRAT from being negativ
4056 cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
4057 chemrat_org*fconcn_org(lcell)
4058 cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
4059 ! ***
4060 END DO
4061 ! end 2nd loop over NUMCELLS
4062 RETURN
4064 END SUBROUTINE nuclcond
4065 !------------------------------------------------------------------------------
4067 ! nuclcond
4068 REAL FUNCTION poly4(a,x)
4069 REAL a(4), x
4071 poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
4072 RETURN
4073 END FUNCTION poly4
4074 REAL FUNCTION poly6(a,x)
4075 REAL a(6), x
4077 poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
4078 RETURN
4079 END FUNCTION poly6
4080 !-----------------------------------------------------------------------
4082 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
4083 gnh3,gno3)
4084 ! Description:
4086 ! ARES calculates the chemical composition of a sulfate/nitrate/
4087 ! ammonium/water aerosol based on equilibrium thermodynamics.
4089 ! This code considers two regimes depending upon the molar ratio
4090 ! of ammonium to sulfate.
4092 ! For values of this ratio less than 2,the code solves a cubic for
4093 ! hydrogen ion molality, HPLUS, and if enough ammonium and liquid
4094 ! water are present calculates the dissolved nitric acid. For molal
4095 ! ionic strengths greater than 50, nitrate is assumed not to be present
4097 ! For values of the molar ratio of 2 or greater, all sulfate is assumed
4098 ! to be ammonium sulfate and a calculation is made for the presence of
4099 ! ammonium nitrate.
4101 ! The Pitzer multicomponent approach is used in subroutine ACTCOF to
4102 ! obtain the activity coefficients. Abandoned -7/30/97 FSB
4104 ! The Bromley method of calculating the activity coefficients is used in this version
4106 ! The calculation of liquid water is done in subroutine water. Details for both calculations are given
4107 ! in the respective subroutines.
4109 ! Based upon MARS due to
4110 ! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
4111 ! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
4113 ! and SCAPE due to
4114 ! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
4115 ! Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
4117 ! NOTE: All concentrations supplied to this subroutine are TOTAL
4118 ! over gas and aerosol phases
4120 ! Parameters:
4122 ! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
4123 ! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
4124 ! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
4125 ! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
4126 ! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
4127 ! RH : Fractional relative humidity (IN)
4128 ! TEMP : Temperature in Kelvin (IN)
4129 ! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
4130 ! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
4131 ! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
4132 ! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
4133 ! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
4134 ! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT)
4135 ! NITR : Number of iterations for obtaining activity coefficients (OU
4136 ! NR : Number of real roots to the cubic in the low ammonia case (OU
4138 ! Revision History:
4139 ! Who When Detailed description of changes
4140 ! --------- -------- -------------------------------------------
4141 ! S.Roselle 11/10/87 Received the first version of the MARS code
4142 ! S.Roselle 12/30/87 Restructured code
4143 ! S.Roselle 2/12/88 Made correction to compute liquid-phase
4144 ! concentration of H2O2.
4145 ! S.Roselle 5/26/88 Made correction as advised by SAI, for
4146 ! computing H+ concentration.
4147 ! S.Roselle 3/1/89 Modified to operate with EM2
4148 ! S.Roselle 5/19/89 Changed the maximum ionic strength from
4149 ! 100 to 20, for numerical stability.
4150 ! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case
4151 ! using equations for nitrate budget.
4152 ! F.Binkowski 6/18/91 New ammonia poor case which
4153 ! omits letovicite.
4154 ! F.Binkowski 7/25/91 Rearranged entire code, restructured
4155 ! ammonia poor case.
4156 ! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output
4157 ! as SO4--
4158 ! F.Binkowski 12/6/91 Changed the ammonia defficient case so that
4159 ! there is only neutralized sulfate (ammonium
4160 ! sulfate) and sulfuric acid.
4161 ! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen
4162 ! with the Cohen et al. (1987) maximum molalit
4163 ! of 36.2 in Table III.( J. Phys Chem (91) page
4164 ! 4569, and Table IV p 4587.)
4165 ! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem
4166 ! possibility for denomenator becoming zero;
4167 ! this involved solving for HPLUS first.
4168 ! Note that for a relative humidity
4169 ! less than 50%, the model assumes that there i
4170 ! aerosol nitrate.
4171 ! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System
4172 ! Redid logic as follows
4173 ! 1. Water algorithm now follows Spann & Richard
4174 ! 2. Pitzer Multicomponent method used
4175 ! 3. Multicomponent practical osmotic coefficien
4176 ! use to close iterations.
4177 ! 4. The model now assumes that for a water
4178 ! mass fraction WFRAC less than 50% there is
4179 ! no aerosol nitrate.
4180 ! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p
4181 ! case, and changed the WFRAC criterion to 40%.
4182 ! For ammonium to sulfate ratio less than 1.0
4183 ! all ammonium is aerosol and no nitrate aerosol
4184 ! exists.
4185 ! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case
4186 ! allow gas-phase ammonia to exist.
4187 ! F.Binkowski 7/26/95 Changed equilibrium constants to values from
4188 ! Kim et al. (1993)
4189 ! F.Binkowski 6/27/96 Changed to new water format
4190 ! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent
4191 ! activity coefficients. The binary activity coe
4192 ! are the same as the previous version
4193 ! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
4194 ! 1 picogram per cubic meter
4196 !-----------------------------------------------------------------------
4197 ! IMPLICIT NONE
4198 !...........INCLUDES and their descriptions
4199 !cc INCLUDE SUBST_CONST ! constants
4200 !...........PARAMETERS and their descriptions:
4202 ! molecular weight for NaCl
4203 REAL mwnacl
4204 PARAMETER (mwnacl=58.44277)
4206 ! molecular weight for NO3
4207 REAL mwno3
4208 PARAMETER (mwno3=62.0049)
4210 ! molecular weight for HNO3
4211 REAL mwhno3
4212 PARAMETER (mwhno3=63.01287)
4214 ! molecular weight for SO4
4215 REAL mwso4
4216 PARAMETER (mwso4=96.0576)
4218 ! molecular weight for HSO4
4219 REAL mwhso4
4220 PARAMETER (mwhso4=mwso4+1.0080)
4222 ! molecular weight for H2SO4
4223 REAL mh2so4
4224 PARAMETER (mh2so4=98.07354)
4226 ! molecular weight for NH3
4227 REAL mwnh3
4228 PARAMETER (mwnh3=17.03061)
4230 ! molecular weight for NH4
4231 REAL mwnh4
4232 PARAMETER (mwnh4=18.03858)
4234 ! molecular weight for Organic Species
4235 REAL mworg
4236 PARAMETER (mworg=175.0)
4238 ! molecular weight for Chloride
4239 REAL mwcl
4240 PARAMETER (mwcl=35.453)
4242 ! molecular weight for AIR
4243 REAL mwair
4244 PARAMETER (mwair=28.964)
4246 ! molecular weight for Letovicite
4247 REAL mwlct
4248 PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4250 ! molecular weight for Ammonium Sulfa
4251 REAL mwas
4252 PARAMETER (mwas=2.0*mwnh4+mwso4)
4254 ! molecular weight for Ammonium Bisul
4255 REAL mwabs
4256 PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4258 !...........ARGUMENTS and their descriptions
4260 !iamodels3
4261 REAL so4
4262 ! Total sulfate in micrograms / m**3
4263 ! Total nitric acid in micrograms / m
4264 REAL hno3
4265 ! Total nitrate in micrograms / m**3
4266 REAL no3
4267 ! Total ammonia in micrograms / m**3
4268 REAL nh3
4269 ! Total ammonium in micrograms / m**3
4270 REAL nh4
4271 ! Fractional relative humidity
4272 REAL rh
4273 ! Temperature in Kelvin
4274 REAL temp
4275 ! Aerosol sulfate in micrograms / m**
4276 REAL aso4
4277 ! Aerosol nitrate in micrograms / m**
4278 REAL ano3
4279 ! Aerosol liquid water content water
4280 REAL ah2o
4281 ! Aerosol ammonium in micrograms / m*
4282 REAL anh4
4283 ! Gas-phase nitric acid in micrograms
4284 REAL gno3
4285 REAL gnh3
4286 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4288 ! Gas-phase ammonia in micrograms / m
4289 ! Index set to percent relative humid
4290 INTEGER irh
4291 ! Number of iterations for activity c
4292 INTEGER nitr
4293 ! Loop index for iterations
4294 INTEGER nnn
4295 INTEGER nr
4296 ! Number of roots to cubic equation f
4297 REAL*8 & ! Coefficients and roots of
4298 a0
4299 REAL*8 & ! Coefficients and roots of
4300 a1
4301 REAL*8 & ! Coefficients and roots of
4302 a2
4303 ! Coefficients and discriminant for q
4304 REAL aa
4305 ! internal variables ( high ammonia c
4306 REAL bal
4307 ! Coefficients and discriminant for q
4308 REAL bb
4309 ! Variables used for ammonia solubili
4310 REAL bhat
4311 ! Coefficients and discriminant for q
4312 REAL cc
4313 ! Factor for conversion of units
4314 REAL convt
4315 ! Coefficients and discriminant for q
4316 REAL dd
4317 ! Coefficients and discriminant for q
4318 REAL disc
4319 ! Relative error used for convergence
4320 REAL eror
4321 ! Free ammonia concentration , that
4322 REAL fnh3
4323 ! Activity Coefficient for (NH4+, HSO
4324 REAL gamaab
4325 ! Activity coefficient for (NH4+, NO3
4326 REAL gamaan
4327 ! Variables used for ammonia solubili
4328 REAL gamahat
4329 ! Activity coefficient for (H+ ,NO3-)
4330 REAL gamana
4331 ! Activity coefficient for (2H+, SO4-
4332 REAL gamas1
4333 ! Activity coefficient for (H+, HSO4-
4334 REAL gamas2
4335 ! used for convergence of iteration
4336 REAL gamold
4337 ! internal variables ( high ammonia c
4338 REAL gasqd
4339 ! Hydrogen ion (low ammonia case) (mo
4340 REAL hplus
4341 ! Equilibrium constant for ammoniua t
4342 REAL k1a
4343 ! Equilibrium constant for sulfate-bi
4344 REAL k2sa
4345 ! Dissociation constant for ammonium
4346 REAL k3
4347 ! Equilibrium constant for ammonium n
4348 REAL kan
4349 ! Variables used for ammonia solubili
4350 REAL khat
4351 ! Equilibrium constant for nitric aci
4352 REAL kna
4353 ! Henry's Law Constant for ammonia
4354 REAL kph
4355 ! Equilibrium constant for water diss
4356 REAL kw
4357 ! Internal variable using KAN
4358 REAL kw2
4359 ! Nitrate (high ammonia case) (moles
4360 REAL man
4361 ! Sulfate (high ammonia case) (moles
4362 REAL mas
4363 ! Bisulfate (low ammonia case) (moles
4364 REAL mhso4
4365 ! Nitrate (low ammonia case) (moles /
4366 REAL mna
4367 ! Ammonium (moles / kg water)
4368 REAL mnh4
4369 ! Total number of moles of all ions
4370 REAL molnu
4371 ! Sulfate (low ammonia case) (moles /
4372 REAL mso4
4373 ! Practical osmotic coefficient
4374 REAL phibar
4375 ! Previous value of practical osmotic
4376 REAL phiold
4377 ! Molar ratio of ammonium to sulfate
4378 REAL ratio
4379 ! Internal variable using K2SA
4380 REAL rk2sa
4381 ! Internal variables using KNA
4382 REAL rkna
4383 ! Internal variables using KNA
4384 REAL rknwet
4385 REAL rr1
4386 REAL rr2
4387 ! Ionic strength
4388 REAL stion
4389 ! Internal variables for temperature
4390 REAL t1
4391 ! Internal variables for temperature
4392 REAL t2
4393 ! Internal variables of convenience (
4394 REAL t21
4395 ! Internal variables of convenience (
4396 REAL t221
4397 ! Internal variables for temperature
4398 REAL t3
4399 ! Internal variables for temperature
4400 REAL t4
4401 ! Internal variables for temperature
4402 REAL t6
4403 ! Total ammonia and ammonium in micro
4404 REAL tnh4
4405 ! Total nitrate in micromoles / meter
4406 REAL tno3
4407 ! Tolerances for convergence test
4408 REAL toler1
4409 ! Tolerances for convergence test
4410 REAL toler2
4411 ! Total sulfate in micromoles / meter
4412 REAL tso4
4413 ! 2.0 * TSO4 (high ammonia case) (mo
4414 REAL twoso4
4415 ! Water mass fraction
4416 REAL wfrac
4417 ! micrograms / meter **3 on output
4418 REAL wh2o
4419 ! internally it is 10 ** (-6) kg (wat
4420 ! the conversion factor (1000 g = 1 k
4421 ! for AH2O output
4422 ! Aerosol liquid water content (inter
4423 ! internal variables ( high ammonia c
4424 REAL wsqd
4425 ! Nitrate aerosol concentration in mi
4426 REAL xno3
4427 ! Variable used in quadratic solution
4428 REAL xxq
4429 ! Ammonium aerosol concentration in m
4430 REAL ynh4
4431 ! Water variable saved in case ionic
4432 REAL zh2o
4434 REAL zso4
4435 ! Total sulfate molality - mso4 + mhs
4436 REAL cat(2) ! Array for cations (1, H+); (2, NH4+
4437 REAL an(3) ! Array for anions (1, SO4--); (2, NO
4438 REAL crutes(3) ! Coefficients and roots of
4439 REAL gams(2,3) ! Array of activity coefficients
4440 ! Minimum value of sulfate laerosol c
4441 REAL minso4
4442 PARAMETER (minso4=1.0E-6/mwso4)
4443 REAL floor
4444 PARAMETER (floor=1.0E-30)
4445 !-----------------------------------------------------------------------
4446 ! begin body of subroutine RPMARES
4448 !...convert into micromoles/m**3
4449 !cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
4450 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
4451 ! minimum concentration
4452 tso4 = max(0.0,so4/mwso4)
4453 tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
4454 tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
4455 !cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
4457 !...now set humidity index IRH as a percent
4459 irh = nint(100.0*rh)
4461 !...Check for valid IRH
4463 irh = max(1,irh)
4464 irh = min(99,irh)
4465 !cc WRITE(10,*)'RH,IRH ',RH,IRH
4467 !...Specify the equilibrium constants at correct
4468 !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA
4469 !... KPH, and K3 )
4470 !... Values from Kim et al. (1993) except as noted.
4472 convt = 1.0/(0.082*temp)
4473 t6 = 0.082E-9*temp
4474 t1 = 298.0/temp
4475 t2 = alog(t1)
4476 t3 = t1 - 1.0
4477 t4 = 1.0 + t2 - t1
4478 kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
4479 k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
4480 k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
4481 kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
4482 kph = 57.639*exp(13.79*t3-5.39*t4)*t6
4483 !cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6
4484 khat = kph*k1a/kw
4485 kan = kna*khat
4487 !...Compute temperature dependent equilibrium constant for NH4NO3
4488 !... ( from Mozurkewich, 1993)
4489 k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
4491 !...Convert to (micromoles/m**3) **2
4492 k3 = k3*convt*convt
4493 wh2o = 0.0
4494 stion = 0.0
4495 ah2o = 0.0
4496 mas = 0.0
4497 man = 0.0
4498 hplus = 0.0
4499 toler1 = 0.00001
4500 toler2 = 0.001
4501 nitr = 0
4502 nr = 0
4503 ratio = 0.0
4504 gamaan = 1.0
4505 gamold = 1.0
4507 !...set the ratio according to the amount of sulfate and nitrate
4508 IF (tso4>minso4) THEN
4509 ratio = tnh4/tso4
4511 !...If there is no sulfate and no nitrate, there can be no ammonium
4512 !... under the current paradigm. Organics are ignored in this version.
4514 ELSE
4516 IF (tno3==0.0) THEN
4518 ! *** If there is very little sulfate and no nitrate set concentrations
4519 ! to a very small value and return.
4520 aso4 = max(floor,aso4)
4521 ano3 = max(floor,ano3)
4522 wh2o = 0.0
4523 ah2o = 0.0
4524 gnh3 = max(floor,gnh3)
4525 gno3 = max(floor,gno3)
4526 RETURN
4527 END IF
4529 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
4530 !... to send the code to the high ammonia case
4532 ratio = 5.0
4533 END IF
4535 !....................................
4536 !......... High Ammonia Case ........
4537 !....................................
4539 IF (ratio>2.0) THEN
4541 gamaan = 0.1
4543 !...Set up twice the sulfate for future use.
4545 twoso4 = 2.0*tso4
4546 xno3 = 0.0
4547 ynh4 = twoso4
4549 !...Treat different regimes of relative humidity
4551 !...ZSR relationship is used to set water levels. Units are
4552 !... 10**(-6) kg water/ (cubic meter of air)
4553 !... start with ammomium sulfate solution without nitrate
4555 CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
4556 wh2o = 1.0E-3*ah2o
4557 aso4 = tso4*mwso4
4558 ano3 = 0.0
4559 anh4 = ynh4*mwnh4
4560 wfrac = ah2o/(aso4+anh4+ah2o)
4561 !cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water
4562 IF (wfrac<0.2) THEN
4564 !... dry ammonium sulfate and ammonium nitrate
4565 !... compute free ammonia
4567 fnh3 = tnh4 - twoso4
4568 cc = tno3*fnh3 - k3
4570 !...check for not enough to support aerosol
4572 IF (cc<=0.0) THEN
4573 xno3 = 0.0
4574 ELSE
4575 aa = 1.0
4576 bb = -(tno3+fnh3)
4577 disc = bb*bb - 4.0*cc
4579 !...Check for complex roots of the quadratic
4580 !... set nitrate to zero and RETURN if complex roots are found
4582 IF (disc<0.0) THEN
4583 xno3 = 0.0
4584 ah2o = 1000.0*wh2o
4585 ynh4 = twoso4
4586 gno3 = tno3*mwhno3
4587 gnh3 = (tnh4-ynh4)*mwnh3
4588 aso4 = tso4*mwso4
4589 ano3 = 0.0
4590 anh4 = ynh4*mwnh4
4591 RETURN
4592 END IF
4594 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
4596 dd = sqrt(disc)
4597 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4599 !...Since both roots are positive, select smaller root.
4601 xno3 = min(xxq/aa,cc/xxq)
4603 END IF
4604 ah2o = 1000.0*wh2o
4605 ynh4 = 2.0*tso4 + xno3
4606 gno3 = (tno3-xno3)*mwhno3
4607 gnh3 = (tnh4-ynh4)*mwnh3
4608 aso4 = tso4*mwso4
4609 ano3 = xno3*mwno3
4610 anh4 = ynh4*mwnh4
4611 RETURN
4613 END IF
4615 !...liquid phase containing completely neutralized sulfate and
4616 !... some nitrate. Solve for composition and quantity.
4618 mas = tso4/wh2o
4619 man = 0.0
4620 xno3 = 0.0
4621 ynh4 = twoso4
4622 phiold = 1.0
4624 !...Start loop for iteration
4626 !...The assumption here is that all sulfate is ammonium sulfate,
4627 !... and is supersaturated at lower relative humidities.
4629 DO nnn = 1, 150
4630 nitr = nnn
4631 gasqd = gamaan*gamaan
4632 wsqd = wh2o*wh2o
4633 kw2 = kan*wsqd/gasqd
4634 aa = 1.0 - kw2
4635 bb = twoso4 + kw2*(tno3+tnh4-twoso4)
4636 cc = -kw2*tno3*(tnh4-twoso4)
4638 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
4640 disc = bb*bb - 4.0*aa*cc
4642 !...Check for complex roots, if so set nitrate to zero and RETURN
4644 IF (disc<0.0) THEN
4645 xno3 = 0.0
4646 ah2o = 1000.0*wh2o
4647 ynh4 = twoso4
4648 gno3 = tno3*mwhno3
4649 gnh3 = (tnh4-ynh4)*mwnh3
4650 aso4 = tso4*mwso4
4651 ano3 = 0.0
4652 anh4 = ynh4*mwnh4
4653 !cc WRITE( 10, * ) ' COMPLEX ROOTS '
4654 RETURN
4655 END IF
4657 dd = sqrt(disc)
4658 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4660 !KW PMA
4661 aa=max(aa,1.e-20)
4662 xxq=max(xxq,1.e-20)
4664 rr1 = xxq/aa
4665 rr2 = cc/xxq
4667 !...choose minimum positve root
4669 IF ((rr1*rr2)<0.0) THEN
4670 xno3 = max(rr1,rr2)
4671 ELSE
4672 xno3 = min(rr1,rr2)
4673 END IF
4674 xno3 = min(xno3,tno3)
4676 !...This version assumes no solid sulfate forms (supersaturated )
4677 !... Now update water
4679 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4681 !...ZSR relationship is used to set water levels. Units are
4682 !... 10**(-6) kg water/ (cubic meter of air)
4683 !... The conversion from micromoles to moles is done by the units of WH
4685 wh2o = 1.0E-3*ah2o
4687 !...Ionic balance determines the ammonium in solution.
4689 man = xno3/wh2o
4690 mas = tso4/wh2o
4691 mnh4 = 2.0*mas + man
4692 ynh4 = mnh4*wh2o
4694 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
4695 !... and ammonium in molal units (moles/(kg water) ).
4696 !KW PMA adds avoid cat and an to be < 0
4697 stion = 3.0*mas + man
4698 cat(1) = 0.0
4699 ! cat(2) = mnh4
4700 ! an(1) = mas
4701 ! an(2) = man
4702 cat(2) = max(mnh4,0.0)
4703 an(1) = max(mas,0.0)
4704 an(2) = max(man,0.0)
4705 an(3) = 0.0
4706 CALL actcof(cat,an,gams,molnu,phibar)
4707 gamaan = gams(2,2)
4709 !...Use GAMAAN for convergence control
4711 eror = abs(gamold-gamaan)/gamold
4712 gamold = gamaan
4714 !...Check to see if we have a solution
4716 IF (eror<=toler1) THEN
4717 !cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
4718 !cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
4720 aso4 = tso4*mwso4
4721 ano3 = xno3*mwno3
4722 anh4 = ynh4*mwnh4
4723 gno3 = (tno3-xno3)*mwhno3
4724 gnh3 = (tnh4-ynh4)*mwnh3
4725 ah2o = 1000.0*wh2o
4726 RETURN
4727 END IF
4729 END DO
4731 !...If after NITR iterations no solution is found, then:
4733 aso4 = tso4*mwso4
4734 ano3 = 0.0
4735 ynh4 = twoso4
4736 anh4 = ynh4*mwnh4
4737 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4738 gno3 = tno3*mwhno3
4739 gnh3 = (tnh4-ynh4)*mwnh3
4740 RETURN
4742 ELSE
4743 !......................................
4744 !......... Low Ammonia Case ...........
4745 !......................................
4747 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
4749 !...All cases covered by this logic
4750 wh2o = 0.0
4751 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4752 wh2o = 1.0E-3*ah2o
4753 zh2o = ah2o
4754 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4755 !... per cubic meter of air (1000 g = 1 kg)
4757 aso4 = tso4*mwso4
4758 anh4 = tnh4*mwnh4
4759 ano3 = 0.0
4760 gno3 = tno3*mwhno3
4761 gnh3 = 0.0
4763 !...Check for zero water.
4764 IF (wh2o==0.0) RETURN
4765 zso4 = tso4/wh2o
4767 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
4769 !cc IF ( ZSO4 .GT. 11.0 ) THEN
4771 !...do not solve for aerosol nitrate for total sulfate molality
4772 !... greater than 11.0 because the model parameters break down
4773 !... greater than 9.0 because the model parameters break down
4775 IF (zso4>9.0) & ! 18 June 97
4776 THEN
4777 RETURN
4778 END IF
4780 !...First solve with activity coeffs of 1.0, then iterate.
4781 phiold = 1.0
4782 gamana = 1.0
4783 gamas1 = 1.0
4784 gamas2 = 1.0
4785 gamaab = 1.0
4786 gamold = 1.0
4788 !...All ammonia is considered to be aerosol ammonium.
4789 mnh4 = tnh4/wh2o
4791 !...MNH4 is the molality of ammonium ion.
4792 ynh4 = tnh4
4794 !...loop for iteration
4795 DO nnn = 1, 150
4796 nitr = nnn
4798 !...set up equilibrium constants including activities
4799 !... solve the system for hplus first then sulfate & nitrate
4800 ! print*,'gamas,gamana',gamas1,gamas2,gamana
4801 rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
4802 rkna = kna/(gamana*gamana)
4803 rknwet = rkna*wh2o
4804 t21 = zso4 - mnh4
4805 t221 = zso4 + t21
4807 !...set up coefficients for cubic
4809 a2 = rk2sa + rknwet - t21
4810 a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
4811 a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
4813 CALL cubic(a2,a1,a0,nr,crutes)
4815 !...Code assumes the smallest positive root is in CRUTES(1)
4817 hplus = crutes(1)
4818 bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
4819 mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
4820 mhso4 = zso4 - & ! molality of bisulf
4821 mso4
4822 mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
4823 mna = max(0.0,mna)
4824 mna = min(mna,tno3/wh2o)
4825 xno3 = mna*wh2o
4826 ano3 = mna*wh2o*mwno3
4827 gno3 = (tno3-xno3)*mwhno3
4829 !...Calculate ionic strength
4830 stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
4832 !...Update water
4833 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4835 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4836 !... per cubic meter of air (1000 g = 1 kg)
4837 !KW PMA adds checker to avoid cat and an < 0.0
4839 wh2o = 1.0E-3*ah2o
4840 cat(1) = max(hplus,0.0)
4841 cat(2) = max(mnh4,0.0)
4842 an(1) = max(mso4,0.0)
4843 an(2) = max(mna,0.0)
4844 an(3) = max(mhso4,0.0)
4845 ! cat(1) = hplus
4846 ! cat(2) = mnh4
4847 ! an(1) = mso4
4848 ! an(2) = mna
4849 ! an(3) = mhso4
4850 ! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
4851 CALL actcof(cat,an,gams,molnu,phibar)
4853 gamana = gams(1,2)
4854 gamas1 = gams(1,1)
4855 gamas2 = gams(1,3)
4856 gamaan = gams(2,2)
4858 gamahat = (gamas2*gamas2/(gamaab*gamaab))
4859 bhat = khat*gamahat
4860 !cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
4861 !cc PHIOLD = PHIBAR
4862 eror = abs(gamold-gamahat)/gamold
4863 gamold = gamahat
4865 !...write out molalities and activity coefficient
4866 !... and return with good solution
4868 IF (eror<=toler2) THEN
4869 !cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
4870 !cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
4871 !cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
4872 RETURN
4873 END IF
4875 END DO
4877 !...after NITR iterations, failure to solve the system, no ANO3
4879 gno3 = tno3*mwhno3
4880 ano3 = 0.0
4881 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4882 RETURN
4884 END IF
4885 ! ratio .gt. 2.0
4886 END SUBROUTINE rpmares_old
4888 !ia*********************************************************
4889 !ia *
4890 !ia BEGIN OF AEROSOL ROUTINE *
4891 !ia *
4892 !ia*********************************************************
4894 !***********************************************************************
4895 ! BEGIN OF AEROSOL CALCULATIONS
4896 !***********************************************************************
4897 !ia *
4898 !ia MAIN AEROSOL DYNAMICS ROUTINE *
4899 !ia based on MODELS3 formulation by FZB *
4900 !ia Modified by IA in May 97 *
4901 !ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
4902 !ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
4903 !ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
4904 !ia CALCULATIONS.
4905 !ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
4906 !ia ONE GRID CELL!!!!
4907 !ia and passed to dynamics calcs. subroutines.
4908 !ia *
4909 !ia Revision history *
4910 !ia When WHO WHAT *
4911 !ia ---- ---- ---- *
4912 !ia ???? FZB BEGIN *
4913 !ia 05/97 IA Adapted for use in CTM2-S *
4914 !ia Modified renaming/bug fixing *
4915 !ia 11/97 IA Modified for new model version
4916 !ia see comments under iarev02
4917 !ia 03/98 IA corrected error on pressure units
4918 !ia *
4919 !ia Called BY: CHEM *
4920 !ia *
4921 !ia Calls to: OUTPUT1,AEROPRC *
4922 !ia *
4923 !ia*********************************************************************
4925 ! end RPMares
4926 ! convapr_in is removed, it wasn't used indeed
4927 SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
4928 nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv, &
4929 nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, &
4930 soilrat_in,cblk,igrid,jgrid,kgrid,brrto)
4932 !USE module_configure, only: grid_config_rec_type
4933 !TYPE (grid_config_rec_type), INTENT (in) :: config_flags
4935 ! IMPLICIT NONE
4937 ! Includes:
4938 !iarev02 INCLUDE AEROINCL.EXT
4939 ! block size, set to 1 in column model ciarev0
4940 INTEGER blksize
4941 !ia kept to 1 in current version of column model
4942 ! actual number of cells in arrays ( default is
4943 INTEGER, PARAMETER :: numcells=1
4945 INTEGER layer
4946 ! number of layer (default is 1 in
4948 ! index for cell in blocked array (default is 1 in
4949 INTEGER, PARAMETER :: ncell=1
4950 ! *** inputs
4951 ! Input temperature [ K ]
4952 REAL temp
4953 ! Input relative humidity [ fraction ]
4954 REAL relhum
4955 ! Input pressure [ hPa ]
4956 REAL pres
4957 ! Input number for Aitken mode [ m**-3 ]
4958 REAL numnuc_in
4959 ! Input number for accumulation mode [ m**-3 ]
4960 REAL numacc_in
4961 ! Input number for coarse mode [ m**-3 ]
4962 REAL numcor_in
4963 ! sulfuric acid [ ug m**-3 ]
4964 REAL vsulf_in
4965 ! total sulfate vapor as sulfuric acid as
4966 ! sulfuric acid [ ug m**-3 ]
4967 REAL asulf_in
4968 ! total sulfate aerosol as sulfuric acid as
4969 ! i-mode sulfate input as sulfuric acid [ ug m*
4970 REAL asulfi_in
4971 ! ammonia gas [ ug m**-3 ]
4972 REAL nh3_in
4973 ! input value of nitric acid vapor [ ug m**-3 ]
4974 REAL nitrate_in
4975 ! Production rate of sulfuric acid [ ug m**-3
4976 REAL so4rat_in
4977 ! aerosol [ ug m**-3 s**-1 ]
4978 REAL soilrat_in
4979 ! Production rate of soil derived coarse
4980 ! Emission rate of i-mode EC [ug m**-3 s**-1]
4981 REAL eeci_in
4982 ! Emission rate of j-mode EC [ug m**-3 s**-1]
4983 REAL eecj_in
4984 ! Emission rate of j-mode org. aerosol [ug m**-
4985 REAL eorgi_in
4986 REAL eorgj_in
4987 ! Emission rate of j-mode org. aerosol [ug m**-
4988 ! total # of cond. vapors & SOA species
4989 INTEGER ncv
4990 ! # of anthrop. cond. vapors & SOA speci
4991 INTEGER nacv
4992 ! # of organic aerosol precursor
4993 INTEGER ldrog_vbs
4994 REAL drog_in(ldrog_vbs) ! organic aerosol precursor [ppm]
4995 ! Input delta ROG concentration of
4996 REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
4997 REAL drog(blksize,ldrog_vbs) ! organic aerosol precursor [ppm]
4999 REAL brrto
5000 !bs
5001 ! *** Primary emissions rates: [ ug / m**3 s ]
5003 ! *** emissions rates for unidentified PM2.5 mass
5004 ! Delta ROG concentration of
5005 REAL epm25i(blksize) ! Aitken mode
5006 REAL epm25j(blksize)
5007 ! *** emissions rates for primary organic aerosol
5008 ! Accumululaton mode
5009 REAL eorgi(blksize) ! Aitken mode
5010 REAL eorgj(blksize)
5011 ! *** emissions rates for elemental carbon
5012 ! Accumululaton mode
5013 REAL eeci(blksize) ! Aitken mode
5014 REAL eecj(blksize)
5015 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
5017 ! Accumululaton mode
5018 REAL epm25(blksize) ! emissions rate for PM2.5 mass
5019 REAL esoil(blksize) ! emissions rate for soil derived coarse a
5020 REAL eseas(blksize) ! emissions rate for marine coarse aerosol
5021 REAL epmcoarse(blksize)
5022 ! emissions rate for anthropogenic coarse
5024 REAL dtsec
5025 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
5027 REAL newm3
5028 REAL totaersulf
5029 ! total aerosol sulfate
5030 ! loop index for time steps
5031 INTEGER numsteps
5032 REAL step
5034 ! *** arrays for aerosol model codes:
5036 ! synchronization time [s]
5038 INTEGER nspcsda
5040 ! number of species in CBLK ciarev02
5041 REAL cblk(blksize,nspcsda)
5043 ! *** Meteorological information in blocked arays:
5045 ! *** Thermodynamic variables:
5047 ! main array of variables
5048 REAL blkta(blksize) ! Air temperature [ K ]
5049 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5050 REAL blkdens(blksize) ! Air density [ kg m^-3 ]
5051 REAL blkrh(blksize)
5053 ! *** Chemical production rates [ ug m**-3 s -1 ] :
5055 ! Fractional relative humidity
5056 REAL so4rat(blksize) ! rate [ug/m^3/s]
5057 ! sulfuric acid vapor-phase production
5058 REAL organt1rat(blksize) ! production rate from aromatics [ ug /
5059 ! anthropogenic organic aerosol mass
5060 REAL organt2rat(blksize) ! production rate from aromatics [ ug /
5061 ! anthropogenic organic aerosol mass
5062 REAL organt3rat(blksize) ! rate from alkanes & others [ ug / m^3
5063 ! anthropogenic organic aerosol mass pro
5064 REAL organt4rat(blksize) ! rate from alkanes & others [ ug / m^3
5065 ! anthropogenic organic aerosol mass pro
5066 REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ]
5067 ! biogenic organic aerosol production
5068 REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ]
5069 ! biogenic organic aerosol production
5070 REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ]
5071 ! biogenic organic aerosol production
5072 REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ]
5073 !bs
5074 ! *** atmospheric properties
5076 ! biogenic organic aerosol production
5077 REAL xlm(blksize) ! atmospheric mean free path [ m ]
5078 REAL amu(blksize)
5079 ! *** aerosol properties:
5081 ! *** modal diameters:
5083 ! atmospheric dynamic viscosity [ kg
5084 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
5085 REAL dgacc(blksize) ! accumulation geometric mean diamet
5086 REAL dgcor(blksize)
5088 ! *** Modal mass concentrations [ ug m**3 ]
5090 ! coarse mode geometric mean diamete
5091 REAL pmassn(blksize) ! mass concentration in Aitken mode
5092 REAL pmassa(blksize) ! mass concentration in accumulation
5093 REAL pmassc(blksize)
5094 ! *** average modal particle densities [ kg/m**3 ]
5096 ! mass concentration in coarse mode
5097 REAL pdensn(blksize) ! average particle density in nuclei
5098 REAL pdensa(blksize) ! average particle density in accumu
5099 REAL pdensc(blksize)
5100 ! *** average modal Knudsen numbers
5102 ! average particle density in coarse
5103 REAL knnuc(blksize) ! nuclei mode Knudsen number
5104 REAL knacc(blksize) ! accumulation Knudsen number
5105 REAL kncor(blksize)
5106 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
5108 ! coarse mode Knudsen number
5109 REAL fconcn(blksize)
5110 ! reciprocal condensation rate Aitke
5111 REAL fconca(blksize) !bs
5112 ! reciprocal condensation rate acclu
5113 REAL fconcn_org(blksize)
5114 REAL fconca_org(blksize)
5116 ! *** Rates for secondary particle formation:
5118 ! *** production of new mass concentration [ ug/m**3 s ]
5119 REAL dmdt(blksize) ! by particle formation
5121 ! *** production of new number concentration [ number/m**3 s ]
5123 ! rate of production of new mass concen
5124 REAL dndt(blksize) ! by particle formation
5125 ! *** growth rate for third moment by condensation of precursor
5126 ! vapor on existing particles [ 3rd mom/m**3 s ]
5128 ! rate of producton of new particle num
5129 REAL cgrn3(blksize) ! Aitken mode
5130 REAL cgra3(blksize)
5131 ! *** Rates for coaglulation: [ m**3/s ]
5133 ! *** Unimodal Rates:
5135 ! Accumulation mode
5136 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
5137 REAL ura00(blksize)
5139 ! *** Bimodal Rates: Aitken mode with accumulation mode ( Aitken mode)
5140 ! accumulation mode 0th moment self-coagulat
5141 REAL brna01(blksize) ! rate for 0th moment
5142 REAL brna31(blksize)
5143 ! *** other processes
5145 ! rate for 3rd moment
5146 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
5148 ! *** housekeeping variables:
5149 ! increment of concentration added to
5150 INTEGER unit
5151 PARAMETER (unit=30)
5152 CHARACTER*16 pname
5153 PARAMETER (pname=' BOX ')
5154 INTEGER isp,igrid,jgrid,kgrid
5156 ! loop index for species.
5157 INTEGER ii, iimap(8)
5158 DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
5160 ! begin body of program box
5162 ! *** Set up files and other info
5163 ! *** set up experimental conditions
5164 ! *** initialize model variables
5165 !ia *** not required any more
5167 !ia DO ISP = 1, NSPCSDA
5168 !ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
5169 !ia END DO
5171 step = dtsec ! set time step
5173 blkta(blksize) = temp ! T in Kelvin
5175 blkprs(blksize)= pres*100. ! P in Pa (pres is given in
5177 blkrh(blksize) = relhum ! fractional RH
5179 blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in
5181 !rs CBLK(BLKSIZE,VHNO3) = nitrate_in
5182 !rs CBLK(BLKSIZE,VNH3) = nh3_in
5183 !bs
5184 !rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
5185 !rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
5186 !rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
5187 !rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
5188 !rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
5189 !rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
5190 !rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
5191 !rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
5193 DO isp = 1, ldrog_vbs
5194 drog(blksize,isp) = drog_in(isp)
5195 END DO
5197 ! print*,'drog in rpm',drog
5198 !bs
5199 !ia *** 27/05/97 the following variables are transported quantities
5200 !ia *** of the column-model now and thuse do not need this init.
5201 !ia *** step.
5203 ! CBLK(BLKSIZE,VNU0) = numnuc_in
5204 ! CBLK(BLKSIZE,VAC0) = numacc_in
5205 ! CBLK(BLKSIZE,VSO4A) = asulf_in
5206 ! CBLK(BLKSIZE,VSO4AI) = asulfi_in
5207 ! CBLK(BLKSIZE, VCORN) = numcor_in
5209 so4rat(blksize) = so4rat_in
5211 !...INITIALISE EMISSION RATES
5213 ! epm25i(blksize) = & ! unidentified PM2.5 mass
5214 ! 0.0
5215 ! epm25j(blksize) = &
5216 ! 0.0
5217 ! unidentified PM2.5 m
5218 eorgi(blksize) = & ! primary organic
5219 eorgi_in
5220 eorgj(blksize) = &
5221 eorgj_in
5222 ! primary organic
5223 eeci(blksize) = & ! elemental carbon
5224 eeci_in
5225 eecj(blksize) = &
5226 eecj_in
5227 ! elemental carbon
5228 epm25(blksize) = & !currently from input file ACTIONIA
5229 0.0
5230 esoil(blksize) = & ! ACTIONIA
5231 soilrat_in
5232 eseas(blksize) = & !currently from input file ACTIONIA
5233 0.0
5234 ! epmcoarse(blksize) = & !currently from input file ACTIONIA
5235 ! 0.0
5236 dgnuc(blksize) = dginin
5237 dgacc(blksize) = dginia
5238 dgcor(blksize) = dginic
5239 newm3 = 0.0
5241 ! *** Set up initial total 3rd moment factors
5243 totaersulf = 0.0
5244 newm3 = 0.0
5245 ! *** time loop
5246 ! write(50,*) ' numsteps dgnuc dgacc ', ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5248 ! *** Call aerosol routines
5249 CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5250 blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat, &
5251 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5252 nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5253 amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5254 knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5255 urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid,brrto)
5257 ! *** write output
5258 ! WRITE(UNIT,*) ' AFTER AEROPROC '
5259 ! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5261 ! *** Write out file for graphing.
5263 ! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5266 ! *** update sulfuric acid vapor
5267 !ia 21.04.98 this update is not required here
5268 !ia artefact from box model
5269 ! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5270 ! & SO4RAT(BLKSIZE) * STEP
5272 RETURN
5273 END SUBROUTINE rpmmod3
5274 !---------------------------------------------------------------------------
5275 SUBROUTINE sorgam_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, &
5276 organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, &
5277 nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto)
5279 !***** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM *!
5280 !bs Description: !
5281 !bs !
5282 !bs SOA_VBS calculates the formation and partitioning of secondary !
5283 !bs organic aerosol based on (pseudo-)ideal solution thermodynamics. !
5284 !bs !
5285 !sam The original Schell model (JGR, vol. 106, D22, 28275-28293, 2001) !
5286 !sam is modified drastically to incorporate the SOA vapor-pressure !
5287 !sam basis set approach developed by Carnegie Mellon folks. !
5288 !sam Recommended changes according to Allen Robinson, 9/15/09 !
5289 !sam The treatment is done very similar to Lane et al., Atmos. Envrn., !
5290 !sam vol 42, 7439-7451, 2008. !
5291 !sam Four basis vapor-pressures for anthropogenic and 4 basis vp's !
5292 !sam for biogenic SOA are used. The SAPRC-99 yield information for !
5293 !sam low and high NOx conditions (Lane, Donahue and Pandis, ES&T, !
5294 !sam vol. 42, 6022-6027, 2008) are mapped to RADM2/RACM species. !
5295 !sam !
5296 !sam Basis vapor pressures (@ 300K) !
5297 !sam Anthro (1 ug/m3) - asoa1 Biogenic (1 ug/m3) - bsoa1 !
5298 !sam Anthro (10 ug/m3) - asoa2 Biogenic (10 ug/m3) - bsoa2 !
5299 !sam Anthro (100 ug/m3) - asoa3 Biogenic (100 ug/m3) - bsoa3 !
5300 !sam Anthro (1000 ug/m3)- asoa4 Biogenic (1000 ug/m3)- bsoa4 !
5301 !bs !
5302 !bs This code considers two cases: !
5303 !bs i) initil absorbing mass is existend in the aerosol phase !
5304 !bs ii) a threshold has to be exeeded before partitioning (even below !
5305 !bs saturation) will take place. !
5306 !bs !
5307 !bs The temperature dependence of the saturation concentrations are !
5308 !bs calculated using the Clausius-Clapeyron equation. !
5309 !bs !
5310 !bs If there is no absorbing mass at all the Pandis method is applied !
5311 !bs for the first steps. !
5312 !bs !
5313 !bs References: !
5314 !bs Pankow (1994): !
5315 !bs An absorption model of the gas/aerosol !
5316 !bs partitioning involved in the formation of !
5317 !bs secondary organic aerosol, Atmos. Environ. 28(2), !
5318 !bs 189-193. !
5319 !bs Odum et al. (1996): !
5320 !bs Gas/particle partitioning and secondary organic !
5321 !bs aerosol yields, Environ. Sci. Technol. 30, !
5322 !bs 2580-2585. !
5323 !bs see also !
5324 !bs Bowman et al. (1997): !
5325 !bs Mathematical model for gas-particle partitioning !
5326 !bs of secondary organic aerosols, Atmos. Environ. !
5327 !bs 31(23), 3921-3931. !
5328 !bs Seinfeld and Pandis (1998): !
5329 !bs Atmospheric Chemistry and Physics (0-471-17816-0) !
5330 !bs chapter 13.5.2 Formation of binary ideal solution !
5331 !bs with -- preexisting aerosol !
5332 !bs -- other organic vapor !
5333 !bs !
5334 !bs Called by: SOA_VBS !
5335 !bs !
5336 !bs Calls: None !
5337 !bs !
5338 !bs Arguments: LAYER, !
5339 !bs BLKTA, BLKPRS, !
5340 !bs ORGARO1RAT, ORGARO2RAT, !
5341 !bs ORGALK1RAT, ORGOLE1RAT, !
5342 !bs ORGBIO1RAT, ORGBIO2RAT, !
5343 !bs ORGBIO3RAT, ORGBIO4RAT, !
5344 !bs DROG, LDROG, NCV, NACV, !
5345 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
5346 !bs DT !
5347 !bs !
5348 !bs Include files: AEROSTUFF.EXT !
5349 !bs AERO_internal.EXT !
5350 !bs !
5351 !bs Data: None !
5352 !bs !
5353 !bs Input files: None !
5354 !bs !
5355 !bs Output files: None !
5356 !bs !
5357 !bs--------------------------------------------------------------------!
5358 !bs !
5359 !bs History: !
5360 !bs No Date Author Change !
5361 !bs ____ ______ ________________ _________________________________ !
5362 ! 01 052011 McKeen/Ahmadov Subroutine development !
5364 USE module_configure, only: grid_config_rec_type
5366 ! model layer
5367 INTEGER layer
5368 ! dimension of arrays
5369 INTEGER blksize
5370 ! number of species in CBLK
5371 INTEGER nspcsda ! actual number of cells in arrays
5372 INTEGER numcells ! # of organic aerosol precursor
5373 INTEGER ldrog_vbs ! total # of cond. vapors & SOA sp
5374 INTEGER ncv ! # of anthrop. cond. vapors & SOA
5375 INTEGER nacv
5376 INTEGER igrid,jgrid,kgrid
5378 REAL cblk(blksize,nspcsda) ! main array of variables
5379 REAL dt ! model time step in SECONDS
5380 REAL blkta(blksize) ! Air temperature [ K ]
5381 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5383 REAL, INTENT(OUT) :: brrto ! branching ratio for NOx conditions
5385 ! anthropogenic organic vapor production rates
5387 REAL organt1rat(blksize) ! rates from
5388 REAL organt2rat(blksize) ! rates from
5389 REAL organt3rat(blksize) ! rates from
5390 REAL organt4rat(blksize) ! rates from
5392 ! biogenic organic vapor production rates
5393 REAL orgbio1rat(blksize)
5394 REAL orgbio2rat(blksize)
5395 REAL orgbio3rat(blksize)
5396 REAL orgbio4rat(blksize)
5397 REAL drog(blksize,ldrog_vbs) !blksize=1, ldrog_vbs=9+1, the last ldrog_vbs is actually is the branching ratio
5399 !bs * local variable declaration
5400 ! Delta ROG conc. [ppm]
5401 !bs numerical value for a minimum thresh
5402 REAL,PARAMETER :: thrsmin=1.E-19
5403 !bs numerical value for a minimum thresh
5404 !bs
5405 !bs universal gas constant [J/mol-K]
5406 REAL, PARAMETER :: rgas=8.314510
5408 !sam reference temperature T0 = 300 K, a change from original 298K
5409 REAL, PARAMETER :: tnull=300.
5411 !bs molecular weight for C
5412 REAL, PARAMETER :: mwc=12.0
5413 !bs molecular weight for organic species
5414 REAL, PARAMETER :: mworg=175.0
5415 !bs molecular weight for SO4
5416 REAL, PARAMETER :: mwso4=96.0576
5417 !bs molecular weight for NH4
5418 REAL, PARAMETER :: mwnh4=18.03858
5419 !bs molecular weight for NO3
5420 REAL, PARAMETER :: mwno3=62.01287
5421 ! molecular weight for AIR
5423 ! REAL mwair
5424 ! PARAMETER (mwair=28.964)
5425 !bs relative tolerance for mass check
5426 REAL, PARAMETER :: CABSMIN=.00001 ! Minimum amount of absorbing material - needed in iteration method
5427 !sm number of basis set variables in CMU partitioning scheme
5428 INTEGER, PARAMETER :: nbin=4 ! we use 4 bin volatility according to Robinson A. et al.
5430 ! we have 2 type of SOA - anthropogenic and biogenic
5431 !sm number of SAPRC species variables in CMU lumped partitioning table
5432 !sm 1=ALK4(hc5),2=ALK5(hc8),3=OLE1(ol2),4=OLE2(oli),5=ARO1(tol)
5433 !sm 6=AOR2(xyl),7=ISOP(iso),8=SESQ(?),9=TERP(alp)
5434 INTEGER, PARAMETER :: nsaprc=9 ! number of precursor classes
5436 !bs loop indices
5437 INTEGER lcell, n, l, ll, bn, cls
5438 !bs conversion factor ppm --> ug/m^3
5439 REAL convfac
5440 !bs difference of inverse temperatures
5441 REAL ttinv
5442 !bs initial organic absorbing mass [ug/m^3]
5443 REAL minit
5444 !bs inorganic mass [ug/m^3]
5445 REAL mnono
5446 !bs total organic mass [ug/m^3]
5447 REAL mtot
5449 ! REAL msum(ncv) !bs input total mass [ug/m^3]
5450 REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
5451 REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
5452 REAL dhvap(ncv) !bs heat of vaporisation of compound i [
5453 REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]
5454 REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
5455 REAL cgas(ncv) !bs gasphase concentration of cond. vapors
5456 REAL caer(ncv) !bs aerosolphase concentration of cond.
5457 REAL asav(ncv) !bs saved CAER for iteration
5458 REAL aold(ncv) !bs saved CAER for rate determination
5459 REAL csat(ncv) !bs saturation conc. of cond. vapor ug/,
5461 ! in basis set approach we need only 4 csat
5462 REAL ccsat(nbin)
5463 REAL ccaer(nbin)
5464 REAL cctot(nbin)
5465 REAL w1(nbin), w2(nbin)
5467 REAL prod(ncv) !bs production of condensable vapor ug/
5468 REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]
5469 REAL f(ldrog_vbs) !bs scaling factor for ind. oxidant
5471 REAL alphlowN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors low NOx condition
5472 REAL alphhiN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors high NOx condition
5473 REAL alphai(nbin,nsaprc) ! mass-based stoichometric yield for product i and csti is the effective saturation
5474 ! concentration in ug m^-3
5475 REAL mwvoc(nsaprc) ! molecular weight of the SOA precusors
5477 REAL PnGtotal,DUM,FMTOT,FMTOT2,DUM2 ! Real constants used in Newton iteration
5478 integer, save :: icall
5480 ! this is a correction factor to take into account the density of aerosols, from Murphy et al. (2009)
5481 ! Now it's determined by namelist
5483 ! in the preliminary version we use alphlowN only to check what would be the maximum yeild
5484 ! SAM: from Murphy et al. 2009
5485 DATA alphlowN / &
5486 0.0000, 0.0750, 0.0000, 0.0000, & ! ALK4
5487 0.0000, 0.3000, 0.0000, 0.0000, & ! ALK5
5488 0.0045, 0.0090, 0.0600, 0.2250, & ! OLE1
5489 0.0225, 0.0435, 0.1290, 0.3750, & ! OLE2
5490 0.0750, 0.2250, 0.3750, 0.5250, & ! ARO1
5491 0.0750, 0.3000, 0.3750, 0.5250, & ! ARO2
5492 0.0090, 0.0300, 0.0150, 0.0000, & ! ISOP
5493 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5494 0.1073, 0.0918, 0.3587, 0.6075/ ! TERP
5496 DATA alphhiN / &
5497 0.0000, 0.0375, 0.0000, 0.0000, & ! ALK4
5498 0.0000, 0.1500, 0.0000, 0.0000, & ! ALK5
5499 0.0008, 0.0045, 0.0375, 0.1500, & ! OLE1
5500 0.0030, 0.0255, 0.0825, 0.2700, & ! OLE2
5501 0.0030, 0.1650, 0.3000, 0.4350, & ! ARO1
5502 0.0015, 0.1950, 0.3000, 0.4350, & ! ARO2
5503 0.0003, 0.0225, 0.0150, 0.0000, & ! ISOP
5504 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ
5505 0.0120, 0.1215, 0.2010, 0.5070/ ! TERP
5507 DATA mwvoc / &
5508 73.23, & ! ALK4
5509 106.97, & ! ALK5
5510 61.68, & ! OLE1
5511 79.05, & ! OLE2
5512 100.47, & ! ARO1
5513 113.93, & ! ARO2
5514 68.12, & ! ISOP
5515 204.0, & ! SESQ
5516 136.24 / ! TERP
5518 !bs * initialisation
5519 !bs
5520 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
5521 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5522 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5523 !bs * average value is 156 kJ/mol
5524 !
5525 !sam changed 156kJ/mol to 30.kJ/mol as in Lane et al., AE, 2008
5526 dhvap(pasoa1) = 30.0E03
5527 dhvap(pasoa2) = 30.0E03
5528 dhvap(pasoa3) = 30.0E03
5529 dhvap(pasoa4) = 30.0E03
5531 dhvap(pbsoa1) = 30.0E03
5532 dhvap(pbsoa2) = 30.0E03
5533 dhvap(pbsoa3) = 30.0E03
5534 dhvap(pbsoa4) = 30.0E03
5535 !----------------------------------------------------------------
5536 !bs
5537 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
5538 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5539 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5540 !bs * average value is 222.5 g/mol
5541 !bs *
5542 !bs * molecular weights used are estimates taking the origin (reactants)
5543 !bs * into account. This should be updated if more information about
5544 !bs * the products is available.
5545 !bs * First hints are taken from Forstner et al. (1997), Environ. S
5546 !bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmos.
5547 !bs * Environ. 31(13), 1953-1964.
5548 !bs *
5549 ! Molecular weights of OCVs as in Murphy and Pandis, 2009
5550 mwcv(pasoa1) = 150.
5551 mwcv(pasoa2) = 150.
5552 mwcv(pasoa3) = 150.
5553 mwcv(pasoa4) = 150.
5555 mwcv(pbsoa1) = 180.
5556 mwcv(pbsoa2) = 180.
5557 mwcv(pbsoa3) = 180.
5558 mwcv(pbsoa4) = 180.
5560 ! In Shell partitioned aerosols according to their precursors, but we do as Allen due to the saturation concentrations
5561 ! We have 2 sets for anthropogenic and biogenic and therefore we use the same denotation
5562 pnull(pasoa1) = 1.
5563 pnull(pasoa2) = 10.
5564 pnull(pasoa3) = 100.
5565 pnull(pasoa4) = 1000.
5567 pnull(pbsoa1) = 1.
5568 pnull(pbsoa2) = 10.
5569 pnull(pbsoa3) = 100.
5570 pnull(pbsoa4) = 1000.
5572 ! scaling factors, for testing purposes, check TOL and ISO only
5573 ! 05/23/2011: for testing all are zero!
5574 f(palk4) = 1.
5575 f(palk5) = 1.
5576 f(pole1) = 1.
5577 f(pole2) = 1.
5578 f(paro1) = 1.
5579 f(paro2) = 1.
5580 f(pisop) = 1.
5581 f(pterp) = 1.
5582 f(psesq) = 1.
5584 loop_cells: DO lcell = 1, numcells ! numcells=1
5585 DO l= 1, ldrog_vbs-1
5586 drog(lcell,l) = f(l)*drog(lcell,l)
5587 END DO
5589 ! calculation of the yields using the branching ratio
5590 brrto= drog(lcell,pbrch) ! temporary variable for the branching ratio
5591 DO bn=1,nbin ! bins
5592 DO cls=1,nsaprc ! classes
5593 alphai(bn,cls)= mwvoc(cls)*( alphhiN(bn,cls)*brrto + alphlowN(bn,cls)*(1.-brrto) )
5594 ENDDO
5595 ENDDO
5597 ttinv = 1./tnull - 1./blkta(lcell)
5598 convfac = blkprs(lcell)/(rgas*blkta(lcell))
5600 ! cblk for gases comes in ppmv, we get the density in ug/m3 (microgram/m3)
5601 ! by multiplying it by (convfac=rho_air/mu_air)x mwcv
5602 cgas(pasoa1) = cblk(lcell,vcvasoa1)*convfac*mwcv(pasoa1)
5603 cgas(pasoa2) = cblk(lcell,vcvasoa2)*convfac*mwcv(pasoa2)
5604 cgas(pasoa3) = cblk(lcell,vcvasoa3)*convfac*mwcv(pasoa3)
5605 cgas(pasoa4) = cblk(lcell,vcvasoa4)*convfac*mwcv(pasoa4)
5607 cgas(pbsoa1) = cblk(lcell,vcvbsoa1)*convfac*mwcv(pbsoa1)
5608 cgas(pbsoa2) = cblk(lcell,vcvbsoa2)*convfac*mwcv(pbsoa2)
5609 cgas(pbsoa3) = cblk(lcell,vcvbsoa3)*convfac*mwcv(pbsoa3)
5610 cgas(pbsoa4) = cblk(lcell,vcvbsoa4)*convfac*mwcv(pbsoa4)
5612 ! cblk for aerosols come in density (ug/m3), converted already in soa_vbs_driver
5613 caer(pasoa1) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)
5614 caer(pasoa2) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)
5615 caer(pasoa3) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)
5616 caer(pasoa4) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)
5618 caer(pbsoa1) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)
5619 caer(pbsoa2) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)
5620 caer(pbsoa3) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)
5621 caer(pbsoa4) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)
5623 ! #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
5624 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5625 !SAM diagnostics
5626 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5627 ! if (igrid .eq. 1 .AND. jgrid .eq. 18) then
5628 ! if (kgrid .eq. 1 )then
5629 ! write(6,*)'drog', drog
5630 ! write(6,*)'caer(pasoa1)',caer(pasoa1)
5631 ! write(6,*)'caer(pasoa4)',caer(pasoa4)
5632 ! write(6,*)'caer(pbsoa1)',caer(pbsoa1)
5633 ! endif
5634 ! endif
5635 !SAM end print of aerosol physical parameter diagnostics
5636 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5637 ! #endif
5638 ! Production of SOA by oxidation of VOCs
5639 ! There are 6 classes of the precursors for ansthropogenic SOA
5640 prod(pasoa1) = alphai(1,1)*drog(lcell,palk4) + alphai(1,2)*drog(lcell,palk5) + &
5641 alphai(1,3)*drog(lcell,pole1) + alphai(1,4)*drog(lcell,pole2) + &
5642 alphai(1,5)*drog(lcell,paro1) + alphai(1,6)*drog(lcell,paro2)
5644 prod(pasoa2) = alphai(2,1)*drog(lcell,palk4) + alphai(2,2)*drog(lcell,palk5) + &
5645 alphai(2,3)*drog(lcell,pole1) + alphai(2,4)*drog(lcell,pole2) + &
5646 alphai(2,5)*drog(lcell,paro1) + alphai(2,6)*drog(lcell,paro2)
5648 prod(pasoa3) = alphai(3,1)*drog(lcell,palk4) + alphai(3,2)*drog(lcell,palk5) + &
5649 alphai(3,3)*drog(lcell,pole1) + alphai(3,4)*drog(lcell,pole2) + &
5650 alphai(3,5)*drog(lcell,paro1) + alphai(3,6)*drog(lcell,paro2)
5652 prod(pasoa4) = alphai(4,1)*drog(lcell,palk4) + alphai(4,2)*drog(lcell,palk5) + &
5653 alphai(4,3)*drog(lcell,pole1) + alphai(4,4)*drog(lcell,pole2) + &
5654 alphai(4,5)*drog(lcell,paro1) + alphai(4,6)*drog(lcell,paro2)
5656 ! There are 3 classes of the precursors for biogenic SOA
5657 prod(pbsoa1) = alphai(1,7)*drog(lcell,pisop) + alphai(1,8)*drog(lcell,psesq) + &
5658 alphai(1,9)*drog(lcell,pterp)
5660 prod(pbsoa2) = alphai(2,7)*drog(lcell,pisop) + alphai(2,8)*drog(lcell,psesq) + &
5661 alphai(2,9)*drog(lcell,pterp)
5663 prod(pbsoa3) = alphai(3,7)*drog(lcell,pisop) + alphai(3,8)*drog(lcell,psesq) + &
5664 alphai(3,9)*drog(lcell,pterp)
5666 prod(pbsoa4) = alphai(4,7)*drog(lcell,pisop) + alphai(4,8)*drog(lcell,psesq) + &
5667 alphai(4,9)*drog(lcell,pterp)
5669 !bs * calculate actual production from gasphase reactions [ug/m^3]
5670 !bs * calculate vapor pressure of pure compound as a liquid using the Clausius-Clapeyron equation and the actual saturation concentration.
5671 !bs * calculate the threshold for partitioning if no initial mass is present to partition into.
5673 loop_cc: DO l = 1,ncv ! we've total ncv=4*2 bins, no alpha is needed here
5674 prod(l) = convfac*prod(l) ! get in density units (ug/m3) from ppmv, (convfac=rho_air/mu_air)
5675 ctot(l) = prod(l) + cgas(l) + caer(l)
5676 aold(l) = caer(l)
5678 ! csat should be calculated 4 times, since pnull is the same for biogenic!
5679 csat(l) = pnull(l)*tnull/blkta(lcell)*exp(dhvap(l)/rgas*ttinv)
5680 END DO loop_cc
5682 ! when we solve the nonlinear equation to determine "caer" we need to combine
5683 ! asoa(n) and bsoa(n), since they have the same saturation concentrations, hence the equilibrium should cover the same bins
5685 PnGtotal=0. ! track total Condensed Vapors&SOA over bins for limits on Newton Iteration of total SOA mass
5686 do ll=1,nbin
5687 ccsat(ll)= csat(ll)
5688 ccaer(ll)= caer(ll) + caer(ll+4)
5689 cctot(ll)= ctot(ll) + ctot(ll+4)
5690 PnGtotal=PnGtotal+cctot(ll)
5691 w1(ll)= ctot(ll)/cctot(ll) ! Anthropogenic fraction to total
5692 w2(ll)= 1. - w1(ll) ! Biogenic fraction of total
5693 end do
5695 !bs
5696 !bs * small amount of non-volatile absorbing mass is assumed to be
5697 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
5698 !bs * mass in each size section, here mode)
5699 !bs
5700 ! inorganic mass isn't needed here
5701 !mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+ cblk(lcell,vno3aj))
5702 !mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+ cblk(lcell,vno3ai))
5704 ! they're assigned to zero at the next step
5705 ! test with minit=0
5706 ! minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) !+ mnono
5707 minit= cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) ! exclude EC from absorbing mass
5709 ! minit is taken into account
5711 !bs * If MINIT is set to zero partitioning will occur if the pure
5712 !bs * saturation concentation is exceeded (Pandis et al. 1992).
5713 !bs * If some amount of absorbing organic mass is formed gas/particle
5714 !bs * partitioning will follow the ideal solution approach.
5715 !bs
5716 !SAM 9/8/09 - Include absorbing SOA material within aerosols in calculation !
5718 minit = AMAX1(minit,CABSMIN)
5720 ! mtot is initial guess to SOA mass (aerosol plus extra absorbing mass (minit))
5721 mtot = 0.
5722 DO L=1,NBIN
5723 mtot = mtot + AMIN1(1.,CCTOT(L)/CCSAT(L))*CCTOT(L)
5724 ENDDO
5725 mtot = mtot + minit
5726 !
5727 ! debugging
5728 !if (igrid .eq. 8 .AND. jgrid .eq. 18) then
5729 ! if (kgrid .eq. 1 )then
5730 ! write(6,*)'before Newton iteration'
5731 ! write(6,*)'MTOT=',MTOT
5732 ! write(6,*)'minit=',minit
5733 ! write(6,*)'w1=',w1,'w2=',w2
5734 ! write(6,*)'cctot=',cctot
5735 ! write(6,*)'ccaer=',ccaer
5736 ! write(6,*)'ccsat=',ccsat
5737 ! write(6,*)'nbin=',nbin
5738 ! endif
5739 !endif
5741 !SAM: Find total SOA mass from newton iteration, needs only 5 iterations for exact solution
5742 loop_newt: DO LL=1,5 ! Fixed Newton iteration number
5743 FMTOT=0.
5744 FMTOT2=0.
5745 DO L=1,NBIN
5746 DUM=CCTOT(L)/(1.+CCSAT(L)/MTOT)
5747 FMTOT=FMTOT+DUM
5748 FMTOT2=FMTOT2+DUM**2
5749 ENDDO
5750 FMTOT=FMTOT+MINIT ! Forecast total SOA mass
5751 DUM=MTOT-FMTOT
5752 DUM2=((FMTOT-MINIT)/MTOT)-MTOT*FMTOT2
5753 MTOT=MTOT-DUM/(1.-DUM2)
5754 MTOT=AMAX1(MTOT,MINIT) ! Limit MTOT to min possible in case of instability
5755 MTOT=AMIN1(MTOT,PnGtotal+minit) ! Limit MTOT to max possible in case of instability
5756 END DO loop_newt ! LL iteration number loop
5758 ! Have total mass MTOT, get aerosol mass from semi-ideal partitioning equation
5759 DO L=1,NBIN
5760 CCAER(L)=CCTOT(L)*MTOT/(MTOT+CCSAT(L))
5761 ENDDO
5762 !
5764 do ll=1,nbin
5765 caer(ll)= AMAX1(w1(ll)*ccaer(ll),CONMIN)
5766 caer(ll+4)= AMAX1(w2(ll)*ccaer(ll),CONMIN)
5767 cgas(ll)= w1(ll)*(cctot(ll) - ccaer(ll))
5768 cgas(ll+4)= w2(ll)*(cctot(ll) - ccaer(ll))
5769 end do
5771 ! assigning values to CBLK array (gases), convert to ppm since it goes to chem
5772 cblk(lcell,vcvasoa1) = max(cgas(pasoa1),conmin)/convfac/mwcv(pasoa1)
5773 cblk(lcell,vcvasoa2) = max(cgas(pasoa2),conmin)/convfac/mwcv(pasoa2)
5774 cblk(lcell,vcvasoa3) = max(cgas(pasoa3),conmin)/convfac/mwcv(pasoa3)
5775 cblk(lcell,vcvasoa4) = max(cgas(pasoa4),conmin)/convfac/mwcv(pasoa4)
5777 cblk(lcell,vcvbsoa1) = max(cgas(pbsoa1),conmin)/convfac/mwcv(pbsoa1)
5778 cblk(lcell,vcvbsoa2) = max(cgas(pbsoa2),conmin)/convfac/mwcv(pbsoa2)
5779 cblk(lcell,vcvbsoa3) = max(cgas(pbsoa3),conmin)/convfac/mwcv(pbsoa3)
5780 cblk(lcell,vcvbsoa4) = max(cgas(pbsoa4),conmin)/convfac/mwcv(pbsoa4)
5782 organt1rat(lcell) = (caer(pasoa1)-aold(pasoa1))/dt
5783 organt2rat(lcell) = (caer(pasoa2)-aold(pasoa2))/dt
5784 organt3rat(lcell) = (caer(pasoa3)-aold(pasoa3))/dt
5785 organt4rat(lcell) = (caer(pasoa4)-aold(pasoa4))/dt
5787 orgbio1rat(lcell) = (caer(pbsoa1)-aold(pbsoa1))/dt
5788 orgbio2rat(lcell) = (caer(pbsoa2)-aold(pbsoa2))/dt
5789 orgbio3rat(lcell) = (caer(pbsoa3)-aold(pbsoa3))/dt
5790 orgbio4rat(lcell) = (caer(pbsoa4)-aold(pbsoa4))/dt
5791 END DO loop_cells
5792 RETURN
5793 END SUBROUTINE sorgam_vbs
5794 !
5795 ! *** this routine calculates the dry deposition and sedimentation
5796 ! velocities for the three modes.
5797 ! coded 1/23/97 by Dr. Francis S. Binkowski. Follows
5798 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
5799 ! velocity but includes Marv Wesely's wstar contribution.
5800 !ia eliminated Stokes term for coarse mode deposition calcs.,
5801 !ia see comments below
5803 SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, &
5804 LAYER, &
5805 CBLK, &
5806 BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, &
5807 DGNUC, DGACC, DGCOR, &
5808 KNNUC, KNACC,KNCOR, &
5809 PDENSN, PDENSA, PDENSC, &
5810 VSED, VDEP )
5812 ! *** calculate size-averaged particle dry deposition and
5813 ! size-averaged sedimentation velocities.
5816 ! IMPLICIT NONE
5818 INTEGER BLKSIZE ! dimension of arrays
5819 INTEGER NSPCSDA ! number of species in CBLK
5820 INTEGER NUMCELLS ! actual number of cells in arrays
5821 INTEGER LAYER ! number of layer
5823 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
5824 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
5825 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
5826 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
5827 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
5828 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
5829 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
5830 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
5831 REAL DGACC( BLKSIZE ) ! accumulation
5832 REAL DGCOR( BLKSIZE ) ! coarse mode
5833 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
5834 REAL KNACC( BLKSIZE ) ! accumulation
5835 REAL KNCOR( BLKSIZE ) ! coarse mode
5836 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
5837 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
5838 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
5841 ! *** modal particle diffusivities for number and 3rd moment, or mass:
5843 REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
5844 REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
5846 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
5848 REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
5849 REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
5851 ! *** deposition and sedimentation velocities
5853 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
5854 REAL VSED( BLKSIZE, NASPCSSED) ! sedimantation velocity [ m s**-1 ]
5857 INTEGER LCELL
5858 REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
5859 REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
5860 REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
5861 REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
5862 REAL ST0N, ST0A, ST0C ! Stokes numbers for number
5863 REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
5864 REAL RD0N, RD0A, RD0C ! canopy resistance for number
5865 REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment
5866 REAL UTSCALE ! scratch function of USTAR and WSTAR.
5867 REAL NU !kinematic viscosity [ m**2 s**-1 ]
5868 REAL USTFAC ! scratch function of USTAR, NU, and GRAV
5869 REAL BHAT
5870 PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction.
5873 ! *** check layer value.
5875 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
5876 ! sedimentation velocities
5878 DO LCELL = 1, NUMCELLS
5880 DCONST1 = BOLTZ * BLKTA(LCELL) / &
5881 ( THREEPI * AMU(LCELL) )
5882 DCONST1N = DCONST1 / DGNUC( LCELL )
5883 DCONST1A = DCONST1 / DGACC( LCELL )
5884 DCONST1C = DCONST1 / DGCOR( LCELL )
5885 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
5886 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
5887 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
5888 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
5890 ! *** i-mode
5892 DCHAT0N(LCELL) = DCONST1N &
5893 * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
5895 DCHAT3N(LCELL) = DCONST1N &
5896 * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
5898 VGHAT0N(LCELL) = DCONST3N &
5899 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
5901 VGHAT3N(LCELL) = DCONST3N &
5902 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
5904 ! *** j-mode
5906 DCHAT0A(LCELL) = DCONST1A &
5907 * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
5909 DCHAT3A(LCELL) = DCONST1A &
5910 * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
5912 VGHAT0A(LCELL) = DCONST3A &
5913 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
5915 VGHAT3A(LCELL) = DCONST3A &
5916 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
5919 ! *** coarse mode
5921 DCHAT0C(LCELL)= DCONST1C &
5922 * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
5924 DCHAT3C(LCELL) = DCONST1C &
5925 * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
5927 VGHAT0C(LCELL) = DCONST3C &
5928 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
5930 VGHAT3C(LCELL) = DCONST3C &
5931 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
5933 END DO
5935 ! *** now calculate the deposition and sedmentation velocities
5937 !ia 07.05.98
5938 ! *** NOTE In the deposition velocity for coarse mode,
5939 ! the impaction term 10.0 ** (-3.0 / st) is eliminated because
5940 ! coarse particles are likely to bounce on impact and the current
5941 ! formulation does not account for this.
5944 DO LCELL = 1, NUMCELLS
5946 NU = AMU(LCELL) / BLKDENS(LCELL)
5947 USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
5948 UTSCALE = USTAR(LCELL) + &
5949 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
5951 ! *** first do number
5953 ! *** nuclei or Aitken mode ( no sedimentation velocity )
5955 SC0N = NU / DCHAT0N(LCELL)
5956 ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
5957 RD0N = 1.0 / ( UTSCALE * &
5958 ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
5960 VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + &
5961 1.0 / ( &
5962 RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
5964 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
5966 ! *** accumulation mode
5968 SC0A = NU / DCHAT0A(LCELL)
5969 ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
5970 RD0A = 1.0 / ( UTSCALE * &
5971 ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
5973 VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + &
5974 1.0 / ( &
5975 RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
5977 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
5979 ! *** coarse mode
5981 SC0C = NU / DCHAT0C(LCELL)
5982 !ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
5983 !ia RD0C = 1.0 / ( UTSCALE *
5984 !ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
5986 RD0C = 1.0 / ( UTSCALE * &
5987 ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term
5989 VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + &
5990 1.0 / ( &
5991 RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
5993 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
5995 ! *** now do m3 for the deposition of mass
5997 ! *** nuclei or Aitken mode
5999 SC3N = NU / DCHAT3N(LCELL)
6000 ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
6001 RD3N = 1.0 / ( UTSCALE * &
6002 ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
6004 VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + &
6005 1.0 / ( &
6006 RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
6008 VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
6010 ! *** accumulation mode
6012 SC3A = NU / DCHAT3A(LCELL)
6013 ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
6014 RD3A = 1.0 / ( UTSCALE * &
6015 ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
6017 VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + &
6018 1.0 / ( &
6019 RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
6022 ! *** fine mass deposition velocity: combine Aitken and accumulation
6023 ! mode deposition velocities. Assume density is the same
6024 ! for both modes.
6027 ! VDEP(LCELL,VDMFINE) = (
6028 ! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
6029 ! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
6030 ! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
6033 ! *** fine mass sedimentation velocity
6035 ! VSED( LCELL, VSMFINE) = (
6036 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6037 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6038 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6040 VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
6042 ! *** coarse mode
6044 SC3C = NU / DCHAT3C(LCELL)
6045 !ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
6046 !ia RD3C = 1.0 / ( UTSCALE *
6047 !ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
6049 RD3C = 1.0 / ( UTSCALE * &
6050 ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
6051 VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + &
6052 1.0 / ( &
6053 RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
6055 ! *** coarse mode sedmentation velocity
6057 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6061 END DO
6063 ELSE ! LAYER greater than 1
6065 ! *** for layer greater than 1 calculate sedimentation velocities only
6067 DO LCELL = 1, NUMCELLS
6069 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6071 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6072 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6073 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6075 VGHAT0N(LCELL) = DCONST3N &
6076 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6078 ! *** nucleation mode number sedimentation velocity
6080 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6082 VGHAT3N(LCELL) = DCONST3N &
6083 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6085 ! *** nucleation mode volume sedimentation velocity
6087 VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
6089 VGHAT0A(LCELL) = DCONST3A &
6090 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6092 ! *** accumulation mode number sedimentation velocity
6094 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6096 VGHAT3A(LCELL) = DCONST3A &
6097 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6099 ! *** fine mass sedimentation velocity
6101 ! VSED( LCELL, VSMFINE) = (
6102 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6103 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6104 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6106 VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
6108 VGHAT0C(LCELL) = DCONST3C &
6109 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6111 ! *** coarse mode sedimentation velocity
6113 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6116 VGHAT3C(LCELL) = DCONST3C &
6117 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6119 ! *** coarse mode mass sedimentation velocity
6121 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6123 END DO
6125 END IF ! check on layer
6127 END SUBROUTINE VDVG
6128 !
6129 !---------------------------------------------------------------------------
6130 !
6131 ! *** this routine calculates the dry deposition and sedimentation
6132 ! velocities for the three modes.
6133 ! Stu McKeen 10/13/08
6134 ! Gaussian Quadrature numerical integration over diameter range for each mode.
6135 ! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10
6136 ! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv
6137 ! Numerical Integration allows more complete discription of the
6138 ! Cunningham Slip correction factor, Interception Term (not included previously),
6139 ! and the correction due to rebound for higher diameter particles.
6140 ! Sedimentation velocities the same as original Binkowski code, also the
6141 ! Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the
6142 ! same as Binkowski.
6143 ! Stokes number, and efficiency dependence on Stokes number now according to
6144 ! Peters and Eiden (1992). Interception term taken from Slinn (1982) with
6145 ! efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy
6146 ! for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction
6147 ! term is that of Slinn (1982)
6148 !
6149 ! Original code 1/23/97 by Dr. Francis S. Binkowski. Follows
6150 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
6151 ! velocity but includes Marv Wesely's wstar contribution.
6152 !ia eliminated Stokes term for coarse mode deposition calcs.,
6153 !ia see comments below
6155 ! CBLK is eliminated since the subroutine doesn't use it!
6156 SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, &
6157 LAYER, &
6158 BLKTA, BLKDENS, &
6159 RA, USTAR, PBLH, ZNTT, RMOLM, AMU, &
6160 DGNUC, DGACC, DGCOR, XLM, &
6161 KNNUC, KNACC,KNCOR, &
6162 PDENSN, PDENSA, PDENSC, &
6163 VSED, VDEP)
6165 ! *** calculate size-averaged particle dry deposition and
6166 ! size-averaged sedimentation velocities.
6167 ! IMPLICIT NONE
6169 INTEGER BLKSIZE ! dimension of arrays
6170 INTEGER NSPCSDA ! number of species in CBLK
6171 INTEGER NUMCELLS ! actual number of cells in arrays
6172 INTEGER LAYER ! number of layer
6173 INTEGER, PARAMETER :: iprnt = 0
6175 ! REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6176 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
6177 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
6178 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
6179 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
6180 REAL PBLH( BLKSIZE ) ! PBL height (m)
6181 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
6182 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
6183 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6184 REAL XLM( BLKSIZE ) ! mean free path of dry air [ m ]
6185 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
6186 REAL DGACC( BLKSIZE ) ! accumulation
6187 REAL DGCOR( BLKSIZE ) ! coarse mode
6188 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
6189 REAL KNACC( BLKSIZE ) ! accumulation
6190 REAL KNCOR( BLKSIZE ) ! coarse mode
6191 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode [ kg / m**3 ]
6192 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode [ kg / m**3 ]
6193 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode [ kg / m**3 ]
6195 ! *** deposition and sedimentation velocities
6197 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
6198 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
6200 INTEGER LCELL,N
6201 REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C
6202 REAL UTSCALE,CZH ! scratch functions of USTAR and WSTAR.
6203 REAL NU !kinematic viscosity [ m**2 s**-1 ]
6204 REAL BHAT
6205 PARAMETER( BHAT = 1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction.
6206 REAL COLCTR_BIGD,COLCTR_SMALD
6207 PARAMETER ( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6 ) ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest)
6208 REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim
6209 REAL Eff_dif, Eff_imp, Eff_int, RBcor
6210 INTEGER ISTOPvd0,IdoWesCor
6211 PARAMETER (ISTOPvd0 = 0) ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs.
6213 ! no Wesley deposition, otherwise EC is too low
6214 PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means don't do correction
6215 IF (ISTOPvd0.EQ.1)THEN
6216 RETURN
6217 ENDIF
6218 ! *** check layer value.
6220 IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER
6221 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and sedimentation velocities
6223 DO LCELL = 1, NUMCELLS
6224 DCONST1 = BOLTZ * BLKTA(LCELL) / &
6225 ( THREEPI * AMU(LCELL) )
6226 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6227 DCONST3 = USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD)
6229 ! *** now calculate the deposition velocities at layer 1
6231 NU = AMU(LCELL) / BLKDENS(LCELL)
6233 UTSCALE = 1.
6234 IF (IdoWesCor.EQ.1)THEN
6235 ! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08)
6236 IF(RMOLM(LCELL).LT.0.)THEN
6237 CZH = -1.*PBLH(LCELL)*RMOLM(LCELL)
6238 IF(CZH.GT.30.0)THEN
6239 UTSCALE=0.45*CZH**0.6667
6240 ELSE
6241 UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667
6242 ENDIF
6243 ENDIF
6244 ENDIF ! end of (IdoWesCor.EQ.1) test
6246 UTSCALE = USTAR(LCELL)*UTSCALE
6247 IF(iprnt.eq.1)THEN
6248 print *,'NGAUSdv,xxlsga,USTAR,UTSCALE'
6249 print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE
6250 print *,'DCONST2,PDENSA,DGACC,GRAV,AMU'
6251 print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL)
6252 endif
6254 ! *** nuclei mode
6256 SUM0=0.
6257 SUM3=0.
6258 DO N=1,NGAUSdv
6259 DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn) ! Diameter (m) at quadrature point
6260 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6261 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6262 VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6263 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6264 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6265 STQ=DCONST3*PDENSN(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6266 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6267 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6268 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
6269 RBcor=1. ! Rebound correction factor
6270 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6271 ! vdplim=.002*UTSCALE
6272 vdplim=min(vdplim,.02)
6273 RSURFQ=RA(LCELL)+1./vdplim
6274 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6275 !
6276 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6277 !
6278 ! RSURFQ=max(RSURFQ,50.)
6279 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6280 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6281 ENDDO
6282 VDEP(LCELL, VDNNUC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6283 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
6285 ! *** accumulation mode
6287 SUM0=0.
6288 SUM3=0.
6289 DO N=1,NGAUSdv
6290 DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga) ! Diameter (m) at quadrature point
6291 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6292 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6293 VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6294 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6295 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6296 STQ=DCONST3*PDENSA(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6297 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6298 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6299 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
6300 RBcor=1. ! Rebound correction factor
6301 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6302 vdplim=min(vdplim,.02)
6303 RSURFQ=RA(LCELL)+1./vdplim
6304 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6305 !
6306 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6307 !
6308 ! RSURFQ=max(RSURFQ,50.)
6309 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6310 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6311 IF(iprnt.eq.1)THEN
6312 print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ'
6313 print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ
6314 print *,'N,Eff_dif,imp,int,SUM0,SUM3'
6315 print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3
6316 endif
6317 ENDDO
6318 VDEP(LCELL, VDNACC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6319 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
6321 ! *** coarse mode
6323 SUM0=0.
6324 SUM3=0.
6325 DO N=1,NGAUSdv
6326 DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc) ! Diameter (m) at quadrature point
6327 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
6328 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
6329 VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
6330 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
6331 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
6332 STQ=DCONST3*PDENSC(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
6333 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
6334 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
6335 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
6336 EFF_int=min(1.,EFF_int)
6337 RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982)
6338 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
6339 vdplim=min(vdplim,.02)
6340 vdplim=max(vdplim,1e-35) !KW wig: add check since occasionally a lg particle causes overflow of rsurfq
6341 RSURFQ=RA(LCELL)+1./vdplim
6342 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
6343 !
6344 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
6345 !
6346 ! RSURFQ=max(RSURFQ,50.)
6347 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
6348 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
6349 ENDDO
6350 VDEP(LCELL, VDNCOR) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
6351 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
6352 END DO
6354 ENDIF ! ENDOF LAYER = 1 test
6356 ! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995)
6358 DO LCELL = 1, NUMCELLS
6360 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6361 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6362 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6363 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6365 ! *** nucleation mode number and mass sedimentation velociticies
6366 VSED( LCELL, VSNNUC) = DCONST3N &
6367 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6368 VSED( LCELL, VSMNUC) = DCONST3N &
6369 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6371 ! *** accumulation mode number and mass sedimentation velociticies
6372 VSED( LCELL, VSNACC) = DCONST3A &
6373 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6374 VSED( LCELL, VSMACC) = DCONST3A &
6375 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6377 ! *** coarse mode number and mass sedimentation velociticies
6378 VSED( LCELL, VSNCOR) = DCONST3C &
6379 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6380 VSED( LCELL, VSMCOR) = DCONST3C &
6381 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6382 END DO
6383 END SUBROUTINE VDVG_2
6384 !------------------------------------------------------------------------------
6386 SUBROUTINE aerosols_sorgam_vbs_init(chem,convfac,z_at_w, &
6387 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
6388 !KW
6389 tsoa,asoa,bsoa, &
6390 !KW
6391 chem_in_opt,aer_ic_opt, is_aerosol, &
6392 ids,ide, jds,jde, kds,kde, &
6393 ims,ime, jms,jme, kms,kme, &
6394 its,ite, jts,jte, kts,kte, config_flags )
6396 USE module_configure, only: grid_config_rec_type
6398 implicit none
6399 INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt
6400 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
6401 ims,ime, jms,jme, kms,kme, &
6402 its,ite, jts,jte, kts,kte
6403 LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
6404 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , &
6405 INTENT(INOUT ) :: &
6406 chem
6407 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6408 INTENT(INOUT ) :: &
6409 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
6410 !KW
6411 tsoa,asoa,bsoa
6412 !KW
6414 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6415 INTENT(IN ) :: &
6416 convfac
6417 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6418 INTENT(IN ) :: &
6419 z_at_w
6420 TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
6423 integer i,j,k,l,ii,jj,kk
6424 real tempfac,mwso4,zz
6425 ! real,dimension(its:ite,kts:kte,jts:jte) :: convfac
6426 REAL splitfac
6427 !between gas and aerosol phase
6428 REAL so4vaptoaer
6429 !factor for splitting initial conc. of SO4
6430 !3rd moment i-mode [3rd moment/m^3]
6431 REAL m3nuc
6432 !3rd MOMENT j-mode [3rd moment/m^3]
6433 REAL m3acc
6434 ! REAL ESN36
6435 REAL m3cor
6436 DATA splitfac/.98/
6437 DATA so4vaptoaer/.999/
6439 ! *** Compute these once and they will all be saved in COMMON
6440 xxlsgn = log(sginin)
6441 xxlsga = log(sginia)
6442 xxlsgc = log(sginic)
6444 l2sginin = xxlsgn**2
6445 l2sginia = xxlsga**2
6446 l2sginic = xxlsgc**2
6448 en1 = exp(0.125*l2sginin)
6449 ea1 = exp(0.125*l2sginia)
6450 ec1 = exp(0.125*l2sginic)
6452 esn04 = en1**4
6453 esa04 = ea1**4
6454 esc04 = ec1**4
6456 esn05 = esn04*en1
6457 esa05 = esa04*ea1
6459 esn08 = esn04*esn04
6460 esa08 = esa04*esa04
6461 esc08 = esc04*esc04
6463 esn09 = esn04*esn05
6464 esa09 = esa04*esa05
6466 esn12 = esn04*esn04*esn04
6467 esa12 = esa04*esa04*esa04
6468 esc12 = esc04*esc04*esc04
6470 esn16 = esn08*esn08
6471 esa16 = esa08*esa08
6472 esc16 = esc08*esc08
6474 esn20 = esn16*esn04
6475 esa20 = esa16*esa04
6476 esc20 = esc16*esc04
6478 esn24 = esn12*esn12
6479 esa24 = esa12*esa12
6480 esc24 = esc12*esc12
6482 esn25 = esn16*esn09
6483 esa25 = esa16*esa09
6485 esn28 = esn20*esn08
6486 esa28 = esa20*esa08
6487 esc28 = esc20*esc08
6490 esn32 = esn16*esn16
6491 esa32 = esa16*esa16
6492 esc32 = esc16*esc16
6494 esn36 = esn16*esn20
6495 esa36 = esa16*esa20
6496 esc36 = esc16*esc20
6498 esn49 = esn25*esn20*esn04
6499 esa49 = esa25*esa20*esa04
6501 esn52 = esn16*esn36
6502 esa52 = esa16*esa36
6504 esn64 = esn32*esn32
6505 esa64 = esa32*esa32
6506 esc64 = esc32*esc32
6508 esn100 = esn36*esn64
6510 esnm20 = 1.0/esn20
6511 esam20 = 1.0/esa20
6512 escm20 = 1.0/esc20
6514 esnm32 = 1.0/esn32
6515 esam32 = 1.0/esa32
6516 escm32 = 1.0/esc32
6518 xxm3 = 3.0*xxlsgn/ sqrt2
6519 ! factor used in error function cal
6520 nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
6522 nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
6524 nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
6526 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
6527 ! size distribution , then
6529 ! vol = (p/6) * density * num * (dgemv_xx**3) *
6530 ! exp(- 4.5 * log( sgem_xx)**2 ) )
6531 ! note minus sign!!
6533 factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
6534 factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
6535 factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
6536 ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
6537 ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
6538 mwso4=96.03
6540 ! initialize pointers used by aerosol-cloud-interaction routines
6541 call aerosols_sorgam_vbs_init_aercld_ptrs( &
6542 num_chem, is_aerosol, config_flags )
6544 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
6545 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
6546 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
6547 tsoa(its:ite, kts:kte-1, jts:jte) = 0.
6548 asoa(its:ite, kts:kte-1, jts:jte) = 0.
6549 bsoa(its:ite, kts:kte-1, jts:jte) = 0.
6551 !SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv
6553 Y_GQ(1)=-2.651961356835233
6554 WGAUS(1)=0.0009717812450995
6555 Y_GQ(2)=-1.673551628767471
6556 WGAUS(2)=0.05451558281913
6557 Y_GQ(3)=-0.816287882858965
6558 WGAUS(3)=0.4256072526101
6559 Y_GQ(4)=-0.0
6560 WGAUS(4)=0.8102646175568
6561 Y_GQ(5)=0.816287882858965
6562 WGAUS(5)=WGAUS(3)
6563 Y_GQ(6)=1.673551628767471
6564 WGAUS(6)=WGAUS(2)
6565 Y_GQ(7)=2.651961356835233
6566 WGAUS(7)=WGAUS(1)
6567 !
6568 ! IF USING OLD SIMULATION, DO NOT REINITIALIZE!
6569 !
6570 if(chem_in_opt == 1 ) return
6571 do l=p_so4aj,num_chem
6572 chem(ims:ime,kms:kme,jms:jme,l)=epsilc
6573 enddo
6574 chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
6575 chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
6576 do j=jts,jte
6577 jj=min(jde-1,j)
6578 do k=kts,kte-1
6579 kk=min(kde-1,k)
6580 do i=its,ite
6581 ii=min(ide-1,i)
6583 !Option for alternate ic's
6584 if( aer_ic_opt == AER_IC_DEFAULT ) then
6585 chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer
6586 chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*(1.-splitfac)*so4vaptoaer
6587 chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
6588 chem(i,k,j,p_nh4aj) = 10.E-05
6589 chem(i,k,j,p_nh4ai) = 10.E-05
6590 chem(i,k,j,p_no3aj) = 10.E-05
6591 chem(i,k,j,p_no3ai) = 10.E-05
6592 chem(i,k,j,p_naaj) = 10.E-05
6593 chem(i,k,j,p_naai) = 10.E-05
6594 chem(i,k,j,p_claj) = 10.E-05
6595 chem(i,k,j,p_clai) = 10.E-05
6597 elseif( aer_ic_opt == AER_IC_PNNL ) then
6598 zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5
6599 call sorgam_vbs_init_aer_ic_pnnl( &
6600 chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
6601 else
6602 call wrf_error_fatal( &
6603 "aerosols_sorgam_vbs_init: unable to parse aer_ic_opt" )
6604 end if
6606 !... i-mode
6607 m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
6608 no3fac*chem(i,k,j,p_no3ai) + &
6609 nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) + &
6610 orgfac*chem(i,k,j,p_asoa1i) + &
6611 orgfac*chem(i,k,j,p_asoa2i) + orgfac*chem(i,k,j,p_asoa3i) + &
6612 orgfac*chem(i,k,j,p_asoa4i) + orgfac*chem(i,k,j,p_bsoa1i) + &
6613 orgfac*chem(i,k,j,p_bsoa2i) + orgfac*chem(i,k,j,p_bsoa3i) + &
6614 orgfac*chem(i,k,j,p_bsoa4i) + orgfac*chem(i,k,j,p_orgpai) + &
6615 anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)
6617 !... j-mode
6618 m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + &
6619 no3fac*chem(i,k,j,p_no3aj) + &
6620 nafac*chem(i,k,j,p_naaj) + clfac*chem(i,k,j,p_claj) + &
6621 orgfac*chem(i,k,j,p_asoa1j) + &
6622 orgfac*chem(i,k,j,p_asoa2j) + orgfac*chem(i,k,j,p_asoa3j) + &
6623 orgfac*chem(i,k,j,p_asoa4j) + orgfac*chem(i,k,j,p_bsoa1j) + &
6624 orgfac*chem(i,k,j,p_bsoa2j) + orgfac*chem(i,k,j,p_bsoa3j) + &
6625 orgfac*chem(i,k,j,p_bsoa4j) + orgfac*chem(i,k,j,p_orgpaj) + &
6626 anthfac*chem(i,k,j,p_p25j) + anthfac*chem(i,k,j,p_ecj)
6628 !...c-mode
6629 m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
6630 anthfac*chem(i,k,j,p_antha)
6632 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
6633 chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
6635 chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
6637 chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
6639 enddo
6640 enddo
6641 enddo
6643 return
6644 END SUBROUTINE aerosols_sorgam_vbs_init
6646 SUBROUTINE aerosols_sorgam_vbs_init_aercld_ptrs( &
6647 num_chem, is_aerosol, config_flags )
6648 !
6649 ! initialize pointers used by aerosol-cloud-interaction routines
6650 !
6651 USE module_configure,only: grid_config_rec_type
6652 USE module_mosaic_wetscav,only: initwet
6654 implicit none
6655 INTEGER, INTENT(IN) :: num_chem
6656 LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
6657 TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
6660 integer iphase, isize, itype, l, ll, n, p1st
6661 REAL dp_meanvol_tmp
6664 nphase_aer = 1
6665 if(p_so4cwj.ge. param_first_scalar) then
6666 nphase_aer = 2
6667 endif
6668 ai_phase=-999888777
6669 cw_phase=-999888777
6670 ci_phase=-999888777
6671 cr_phase=-999888777
6672 cs_phase=-999888777
6673 cg_phase=-999888777
6674 if(nphase_aer>=1)ai_phase=1
6675 if(nphase_aer>=2)cw_phase=2
6676 if(nphase_aer>=3)cr_phase=3
6677 if(nphase_aer>=4)ci_phase=4
6678 if(nphase_aer>=5)cw_phase=5
6679 if(nphase_aer>=6)cg_phase=6
6681 ! aitken and accum mode have same set of species
6682 ! so are treated as isize=1,2 of itype=1
6683 ! coarse mode has different set of species
6684 ! so is treated as isize=1 of itype=2
6685 ntype_aer = 2
6686 nsize_aer(1)=2
6687 nsize_aer(2)=1
6689 msectional = 0
6690 maerosolincw = 0
6691 #if defined ( cw_species_are_in_registry )
6692 maerosolincw = 1
6693 #endif
6694 name_mastercomp_aer( 1) = 'sulfate'
6695 dens_mastercomp_aer( 1) = dens_so4_aer
6696 mw_mastercomp_aer( 1) = mw_so4_aer
6697 hygro_mastercomp_aer(1) = hygro_so4_aer
6699 name_mastercomp_aer( 2) = 'nitrate'
6700 dens_mastercomp_aer( 2) = dens_no3_aer
6701 mw_mastercomp_aer( 2) = mw_no3_aer
6702 hygro_mastercomp_aer(2) = hygro_no3_aer
6704 name_mastercomp_aer( 3) = 'ammonium'
6705 dens_mastercomp_aer( 3) = dens_nh4_aer
6706 mw_mastercomp_aer( 3) = mw_nh4_aer
6707 hygro_mastercomp_aer(3) = hygro_nh4_aer
6709 name_mastercomp_aer( 4) = 'asoa1'
6710 dens_mastercomp_aer( 4) = dens_oc_aer
6711 mw_mastercomp_aer( 4) = mw_oc_aer
6712 hygro_mastercomp_aer(4) = hygro_oc_aer
6714 name_mastercomp_aer( 5) = 'asoa2'
6715 dens_mastercomp_aer( 5) = dens_oc_aer
6716 mw_mastercomp_aer( 5) = mw_oc_aer
6717 hygro_mastercomp_aer(5) = hygro_oc_aer
6719 name_mastercomp_aer( 6) = 'asoa3'
6720 dens_mastercomp_aer( 6) = dens_oc_aer
6721 mw_mastercomp_aer( 6) = mw_oc_aer
6722 hygro_mastercomp_aer(6) = hygro_oc_aer
6724 name_mastercomp_aer( 7) = 'asoa4'
6725 dens_mastercomp_aer( 7) = dens_oc_aer
6726 mw_mastercomp_aer( 7) = mw_oc_aer
6727 hygro_mastercomp_aer(7) = hygro_oc_aer
6729 name_mastercomp_aer( 8) = 'bsoa1'
6730 dens_mastercomp_aer( 8) = dens_oc_aer
6731 mw_mastercomp_aer( 8) = mw_oc_aer
6732 hygro_mastercomp_aer(8) = hygro_oc_aer
6734 name_mastercomp_aer( 9) = 'bsoa2'
6735 dens_mastercomp_aer( 9) = dens_oc_aer
6736 mw_mastercomp_aer( 9) = mw_oc_aer
6737 hygro_mastercomp_aer(9) = hygro_oc_aer
6739 name_mastercomp_aer( 10) = 'bsoa3'
6740 dens_mastercomp_aer( 10) = dens_oc_aer
6741 mw_mastercomp_aer( 10) = mw_oc_aer
6742 hygro_mastercomp_aer(10) = hygro_oc_aer
6744 name_mastercomp_aer( 11) = 'bsoa4'
6745 dens_mastercomp_aer( 11) = dens_oc_aer
6746 mw_mastercomp_aer( 11) = mw_oc_aer
6747 hygro_mastercomp_aer(11) = hygro_oc_aer
6749 name_mastercomp_aer( 12) = 'orgpa'
6750 dens_mastercomp_aer( 12) = dens_oc_aer
6751 mw_mastercomp_aer( 12) = mw_oc_aer
6752 hygro_mastercomp_aer(12) = hygro_oc_aer
6754 name_mastercomp_aer( 13) = 'ec'
6755 dens_mastercomp_aer( 13) = dens_ec_aer
6756 mw_mastercomp_aer( 13) = mw_ec_aer
6757 hygro_mastercomp_aer(13) = hygro_ec_aer
6759 name_mastercomp_aer( 14) = 'p25'
6760 dens_mastercomp_aer( 14) = dens_oin_aer
6761 mw_mastercomp_aer( 14) = mw_oin_aer
6762 hygro_mastercomp_aer(14) = hygro_oin_aer
6764 name_mastercomp_aer( 15) = 'anth'
6765 dens_mastercomp_aer( 15) = dens_oin_aer
6766 mw_mastercomp_aer( 15) = mw_oin_aer
6767 hygro_mastercomp_aer(15) = hygro_oin_aer
6769 name_mastercomp_aer( 16) = 'seas'
6770 dens_mastercomp_aer( 16) = dens_seas_aer
6771 mw_mastercomp_aer( 16) = mw_seas_aer
6772 hygro_mastercomp_aer(16) = hygro_seas_aer
6774 name_mastercomp_aer( 17) = 'soil'
6775 dens_mastercomp_aer( 17) = dens_dust_aer
6776 mw_mastercomp_aer( 17) = mw_dust_aer
6777 hygro_mastercomp_aer(17) = hygro_dust_aer
6779 name_mastercomp_aer(18) = 'sodium'
6780 dens_mastercomp_aer(18) = dens_na_aer
6781 mw_mastercomp_aer( 18) = mw_na_aer
6782 hygro_mastercomp_aer(18) = hygro_na_aer
6784 name_mastercomp_aer(19) = 'chloride'
6785 dens_mastercomp_aer(19) = dens_cl_aer
6786 mw_mastercomp_aer( 19) = mw_cl_aer
6787 hygro_mastercomp_aer(19) = hygro_cl_aer
6789 lptr_so4_aer( :,:,:) = 1
6790 lptr_nh4_aer( :,:,:) = 1
6791 lptr_no3_aer( :,:,:) = 1
6792 lptr_na_aer( :,:,:) = 1
6793 lptr_cl_aer( :,:,:) = 1
6794 lptr_asoa1_aer(:,:,:) = 1
6795 lptr_asoa2_aer(:,:,:) = 1
6796 lptr_asoa3_aer( :,:,:) = 1
6797 lptr_asoa4_aer( :,:,:) = 1
6798 lptr_bsoa1_aer( :,:,:) = 1
6799 lptr_bsoa2_aer( :,:,:) = 1
6800 lptr_bsoa3_aer( :,:,:) = 1
6801 lptr_bsoa4_aer( :,:,:) = 1
6802 lptr_orgpa_aer( :,:,:) = 1
6803 lptr_ec_aer( :,:,:) = 1
6804 lptr_p25_aer( :,:,:) = 1
6805 lptr_anth_aer( :,:,:) = 1
6806 lptr_seas_aer( :,:,:) = 1
6807 lptr_soil_aer( :,:,:) = 1
6808 numptr_aer( :,:,:) = 1
6810 do_cloudchem_aer(:,:) = .false.
6813 ! Aitken mode
6814 itype = 1
6815 isize = 1
6816 ncomp_aer(itype) = 16
6817 numptr_aer( isize,itype,ai_phase) = p_nu0
6818 lptr_so4_aer( isize,itype,ai_phase) = p_so4ai
6819 lptr_nh4_aer( isize,itype,ai_phase) = p_nh4ai
6820 lptr_no3_aer( isize,itype,ai_phase) = p_no3ai
6821 lptr_na_aer( isize,itype,ai_phase) = p_naai
6822 lptr_cl_aer( isize,itype,ai_phase) = p_clai
6823 lptr_asoa1_aer(isize,itype,ai_phase) = p_asoa1i
6824 lptr_asoa2_aer(isize,itype,ai_phase) = p_asoa2i
6825 lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3i
6826 lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4i
6827 lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1i
6828 lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2i
6829 lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3i
6830 lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4i
6831 lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpai
6832 lptr_ec_aer( isize,itype,ai_phase) = p_eci
6833 lptr_p25_aer( isize,itype,ai_phase) = p_p25i
6834 ! aerosol in cloud water
6835 if(cw_phase.gt.0)then
6836 numptr_aer( isize,itype,cw_phase) = p_nu0cw
6837 lptr_so4_aer( isize,itype,cw_phase) = p_so4cwi
6838 lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwi
6839 lptr_no3_aer( isize,itype,cw_phase) = p_no3cwi
6840 lptr_na_aer( isize,itype,ai_phase) = p_nacwi
6841 lptr_cl_aer( isize,itype,ai_phase) = p_clcwi
6842 lptr_asoa1_aer(isize,itype,cw_phase) = p_asoa1cwi
6843 lptr_asoa2_aer(isize,itype,cw_phase) = p_asoa2cwi
6844 lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwi
6845 lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwi
6846 lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwi
6847 lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwi
6848 lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwi
6849 lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwi
6850 lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwi
6851 lptr_ec_aer( isize,itype,cw_phase) = p_eccwi
6852 lptr_p25_aer( isize,itype,cw_phase) = p_p25cwi
6853 do_cloudchem_aer(isize,itype) = .true.
6854 endif
6856 ! Accumulation mode
6857 itype = 1
6858 isize = 2
6859 ncomp_aer(itype) = 16
6860 numptr_aer( isize,itype,ai_phase) = p_ac0
6861 lptr_so4_aer( isize,itype,ai_phase) = p_so4aj
6862 lptr_nh4_aer( isize,itype,ai_phase) = p_nh4aj
6863 lptr_no3_aer( isize,itype,ai_phase) = p_no3aj
6864 lptr_na_aer( isize,itype,ai_phase) = p_naaj
6865 lptr_cl_aer( isize,itype,ai_phase) = p_claj
6866 lptr_asoa1_aer(isize,itype,ai_phase) = p_asoa1j
6867 lptr_asoa2_aer(isize,itype,ai_phase) = p_asoa2j
6868 lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3j
6869 lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4j
6870 lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1j
6871 lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2j
6872 lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3j
6873 lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4j
6874 lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpaj
6875 lptr_ec_aer( isize,itype,ai_phase) = p_ecj
6876 lptr_p25_aer( isize,itype,ai_phase) = p_p25j
6877 ! aerosol in cloud water
6878 if(cw_phase.gt.0)then
6879 numptr_aer( isize,itype,cw_phase) = p_ac0cw
6880 lptr_so4_aer( isize,itype,cw_phase) = p_so4cwj
6881 lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwj
6882 lptr_no3_aer( isize,itype,cw_phase) = p_no3cwj
6883 lptr_na_aer( isize,itype,ai_phase) = p_nacwj
6884 lptr_cl_aer( isize,itype,ai_phase) = p_clcwj
6885 lptr_asoa1_aer(isize,itype,cw_phase) = p_asoa1cwj
6886 lptr_asoa2_aer(isize,itype,cw_phase) = p_asoa2cwj
6887 lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwj
6888 lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwj
6889 lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwj
6890 lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwj
6891 lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwj
6892 lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwj
6893 lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwj
6894 lptr_ec_aer( isize,itype,cw_phase) = p_eccwj
6895 lptr_p25_aer( isize,itype,cw_phase) = p_p25cwj
6896 do_cloudchem_aer(isize,itype) = .true.
6897 endif
6899 ! coarse mode
6900 itype = 2
6901 isize = 1
6902 ncomp_aer(itype) = 3
6903 numptr_aer( isize,itype,ai_phase) = p_corn
6904 lptr_anth_aer( isize,itype,ai_phase) = p_antha
6905 lptr_seas_aer( isize,itype,ai_phase) = p_seas
6906 lptr_soil_aer( isize,itype,ai_phase) = p_soila
6907 ! aerosol in cloud water
6908 if(cw_phase.gt.0)then
6909 numptr_aer( isize,itype,cw_phase) = p_corncw
6910 lptr_anth_aer( isize,itype,cw_phase) = p_anthcw
6911 lptr_seas_aer( isize,itype,cw_phase) = p_seascw
6912 lptr_soil_aer( isize,itype,cw_phase) = p_soilcw
6913 ! no cloudchem for coarse mode because it has no so4/nh4/no3 species
6914 do_cloudchem_aer(isize,itype) = .false.
6915 endif
6917 massptr_aer(:,:,:,:) = -999888777
6918 mastercompptr_aer(:,:) = -999888777
6920 p1st = param_first_scalar
6922 do iphase=1,nphase_aer
6923 do itype=1,ntype_aer
6924 do n = 1, nsize_aer(itype)
6925 ll = 0
6926 if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then
6927 ll = ll + 1
6928 massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase)
6929 mastercompptr_aer(ll,itype) = 1
6930 end if
6931 if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then
6932 ll = ll + 1
6933 massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase)
6934 mastercompptr_aer(ll,itype) = 2
6935 end if
6936 if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then
6937 ll = ll + 1
6938 massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase)
6939 mastercompptr_aer(ll,itype) = 3
6940 end if
6941 if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) then
6942 ll = ll + 1
6943 massptr_aer(ll,n,itype,iphase) = lptr_asoa1_aer(n,itype,iphase)
6944 mastercompptr_aer(ll,itype) = 4
6945 end if
6946 if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) then
6947 ll = ll + 1
6948 massptr_aer(ll,n,itype,iphase) = lptr_asoa2_aer(n,itype,iphase)
6949 mastercompptr_aer(ll,itype) = 5
6950 end if
6951 if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) then
6952 ll = ll + 1
6953 massptr_aer(ll,n,itype,iphase) = lptr_asoa3_aer(n,itype,iphase)
6954 mastercompptr_aer(ll,itype) = 6
6955 end if
6956 if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) then
6957 ll = ll + 1
6958 massptr_aer(ll,n,itype,iphase) = lptr_asoa4_aer(n,itype,iphase)
6959 mastercompptr_aer(ll,itype) = 7
6960 end if
6961 if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) then
6962 ll = ll + 1
6963 massptr_aer(ll,n,itype,iphase) = lptr_bsoa1_aer(n,itype,iphase)
6964 mastercompptr_aer(ll,itype) = 8
6965 end if
6966 if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) then
6967 ll = ll + 1
6968 massptr_aer(ll,n,itype,iphase) = lptr_bsoa2_aer(n,itype,iphase)
6969 mastercompptr_aer(ll,itype) = 9
6970 end if
6971 if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) then
6972 ll = ll + 1
6973 massptr_aer(ll,n,itype,iphase) = lptr_bsoa3_aer(n,itype,iphase)
6974 mastercompptr_aer(ll,itype) = 10
6975 end if
6976 if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) then
6977 ll = ll + 1
6978 massptr_aer(ll,n,itype,iphase) = lptr_bsoa4_aer(n,itype,iphase)
6979 mastercompptr_aer(ll,itype) = 11
6980 end if
6981 if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then
6982 ll = ll + 1
6983 massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase)
6984 mastercompptr_aer(ll,itype) = 12
6985 end if
6986 if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then
6987 ll = ll + 1
6988 massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase)
6989 mastercompptr_aer(ll,itype) = 13
6990 end if
6991 if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then
6992 ll = ll + 1
6993 massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase)
6994 mastercompptr_aer(ll,itype) = 14
6995 end if
6996 if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then
6997 ll = ll + 1
6998 massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase)
6999 mastercompptr_aer(ll,itype) = 15
7000 end if
7001 if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then
7002 ll = ll + 1
7003 massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase)
7004 mastercompptr_aer(ll,itype) = 16
7005 end if
7006 if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then
7007 ll = ll + 1
7008 massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase)
7009 mastercompptr_aer(ll,itype) = 17
7010 end if
7011 if (lptr_na_aer(n,itype,iphase) .ge. p1st) then
7012 ll = ll + 1
7013 massptr_aer(ll,n,itype,iphase) = lptr_na_aer(n,itype,iphase)
7014 mastercompptr_aer(ll,itype) = 18
7015 end if
7016 if (lptr_cl_aer(n,itype,iphase) .ge. p1st) then
7017 ll = ll + 1
7018 massptr_aer(ll,n,itype,iphase) = lptr_cl_aer(n,itype,iphase)
7019 mastercompptr_aer(ll,itype) = 19
7020 endif
7021 ncomp_aer_nontracer(itype) = ll
7023 ncomp_aer(itype) = ll
7025 mprognum_aer(n,itype,iphase) = 0
7026 if (numptr_aer(n,itype,iphase) .ge. p1st) then
7027 mprognum_aer(n,itype,iphase) = 1
7028 end if
7030 end do ! size
7031 end do ! type
7032 end do ! phase
7034 waterptr_aer(:,:) = 0
7036 do itype=1,ntype_aer
7037 do ll=1,ncomp_aer(itype)
7038 dens_aer(ll,itype) = dens_mastercomp_aer(mastercompptr_aer(ll,itype))
7039 mw_aer(ll,itype) = mw_mastercomp_aer(mastercompptr_aer(ll,itype))
7040 hygro_aer(ll,itype) = hygro_mastercomp_aer(mastercompptr_aer(ll,itype))
7041 name_aer(ll,itype) = name_mastercomp_aer(mastercompptr_aer(ll,itype))
7042 end do
7043 end do
7045 is_aerosol(:) = .false.
7046 do iphase=1,nphase_aer
7047 do itype=1,ntype_aer
7048 do n = 1, nsize_aer(itype)
7049 do ll = 1, ncomp_aer(itype)
7050 is_aerosol(massptr_aer(ll,n,itype,iphase))=.true.
7051 end do
7052 is_aerosol(numptr_aer(n,itype,iphase))=.true.
7053 end do ! size
7054 end do ! type
7055 end do ! phase
7057 ! for sectional
7058 ! the dhi/dlo_sect are the upper/lower bounds for
7059 ! mean-volume diameter for a section/bin
7060 ! for modal
7061 ! they should be set to reasonable upper/lower
7062 ! bounds for mean-volume diameters of each modes
7063 ! they are primarily used to put reasonable bounds
7064 ! on number (in relation to mass/volume)
7065 ! the dcen_sect are used by initwet for the impaction scavenging
7066 ! lookup tables, and should represent a "base" mean-volume diameter
7067 ! dp_meanvol_tmp (below) is the made-sorgam default initial value
7068 ! for mean-volume diameter (in cm)
7069 ! terminology: (pi/6) * (mean-volume diameter)**3 ==
7070 ! (volume mixing ratio of section/mode)/(number mixing ratio)
7071 !
7072 dhi_sect(:,:) = 0.0
7073 dlo_sect(:,:) = 0.0
7075 itype = 1
7076 isize = 1
7077 sigmag_aer(isize,itype) = sginin ! aitken
7078 dp_meanvol_tmp = 1.0e2*dginin*exp(1.5*l2sginin) ! aitken
7079 dcen_sect(isize,itype) = dp_meanvol_tmp
7080 dhi_sect(isize,itype) = dp_meanvol_tmp*4.0
7081 dlo_sect(isize,itype) = dp_meanvol_tmp/4.0
7083 itype = 1
7084 isize = 2
7085 sigmag_aer(isize,itype) = sginia ! accum
7086 dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
7087 dcen_sect(isize,itype) = dp_meanvol_tmp
7088 dhi_sect(isize,itype) = dp_meanvol_tmp*4.0
7089 dlo_sect(isize,itype) = dp_meanvol_tmp/4.0
7091 itype = 2
7092 isize = 1
7093 sigmag_aer(isize,itype) = sginic ! coarse
7094 dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
7095 dcen_sect(isize,itype) = dp_meanvol_tmp
7096 dhi_sect(isize,itype) = dp_meanvol_tmp*4.0
7097 dlo_sect(isize,itype) = dp_meanvol_tmp/4.0
7099 do itype = 1, ntype_aer
7100 do isize = 1, nsize_aer(itype)
7101 volumcen_sect(isize,itype) = (pirs/6.0)*(dcen_sect(isize,itype)**3)
7102 volumlo_sect(isize,itype) = (pirs/6.0)*(dlo_sect(isize,itype)**3)
7103 volumhi_sect(isize,itype) = (pirs/6.0)*(dhi_sect(isize,itype)**3)
7104 end do
7105 end do
7108 ! do initialization of the impaction/interception scavenging
7109 ! lookup tables
7110 call initwet( &
7111 ntype_aer, nsize_aer, ncomp_aer, &
7112 massptr_aer, dens_aer, numptr_aer, &
7113 maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, &
7114 dcen_sect, sigmag_aer, &
7115 waterptr_aer, dens_water_aer, &
7116 scavimptblvol, scavimptblnum, nimptblgrow_mind, &
7117 nimptblgrow_maxd, dlndg_nimptblgrow )
7119 END SUBROUTINE aerosols_sorgam_vbs_init_aercld_ptrs
7121 !****************************************************************
7122 ! *
7123 ! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE *
7124 ! aer_ic_opt == aer_ic_pnnl OPTION. *
7125 ! *
7126 ! wig, 21-Apr-2004, original version *
7127 ! rce, 25-apr-2004 - name changes for consistency with *
7128 ! new aer_ic constants in Registry *
7129 ! wig, 7-May-2004, added height dependance *
7130 ! *
7131 ! CALLS THE FOLLOWING SUBROUTINES: NONE *
7132 ! *
7133 ! CALLED BY : aerosols_sorgam_init *
7134 ! *
7135 !****************************************************************
7136 SUBROUTINE sorgam_vbs_init_aer_ic_pnnl( &
7137 chem, z, i,k,j, ims,ime, jms,jme, kms,kme )
7139 USE module_configure,only: num_chem, grid_config_rec_type
7140 implicit none
7142 INTEGER,INTENT(IN ) :: i,k,j, &
7143 ims,ime, jms,jme, kms,kme
7144 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),&
7145 INTENT(INOUT ) :: chem
7147 real, intent(in ) :: z
7148 real :: mult
7150 !
7151 ! Determine height multiplier...
7152 ! This should mimic the calculation in sorgam_set_aer_bc_pnnl,
7153 ! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic
7154 !!$! Height(m) Multiplier
7155 !!$! --------- ----------
7156 !!$! <=2000 1.0
7157 !!$! 2000<z<3000 linear transition zone to 0.5
7158 !!$! 3000<z<5000 linear transision zone to 0.25
7159 !!$! >=3000 0.25
7160 !!$!
7161 !!$! which translates to:
7162 !!$! 2000<z<3000 mult = 1.0 + (z-2000.)*(0.5-1.0)/(3000.-2000.)
7163 !!$! 3000<z<5000 mult = 0.5 + (z-3000.)*(0.25-0.5)/(5000.-3000.)
7164 !!$! or in reduced form:
7165 !!$ if( z <= 2000. ) then
7166 !!$ mult = 1.0
7167 !!$ elseif( z > 2000. &
7168 !!$ .and. z <= 3000. ) then
7169 !!$ mult = 1.0 - 0.0005*(z-2000.)
7170 !!$ elseif( z > 3000. &
7171 !!$ .and. z <= 5000. ) then
7172 !!$ mult = 0.5 - 1.25e-4*(z-3000.)
7173 !!$ else
7174 !!$ mult = 0.25
7175 !!$ end if
7176 ! Updated aerosol profile multiplier 1-Apr-2005:
7177 ! Height(m) Multiplier
7178 ! --------- ----------
7179 ! <=2000 1.0
7180 ! 2000<z<3000 linear transition zone to 0.25
7181 ! 3000<z<5000 linear transision zone to 0.125
7182 ! >=5000 0.125
7183 !
7184 ! which translates to:
7185 ! 2000<z<3000 mult = 1.00 + (z-2000.)*(0.25-1.0)/(3000.-2000.)
7186 ! 3000<z<5000 mult = 0.25 + (z-3000.)*(0.125-0.25)/(5000.-3000.)
7187 ! or in reduced form:
7188 !jdf comment these values and have another profile consistent with mosaic
7189 ! if( z <= 2000. ) then
7190 ! mult = 1.0
7191 ! elseif( z > 2000. &
7192 ! .and. z <= 3000. ) then
7193 ! mult = 1.0 - 0.00075*(z-2000.)
7194 ! elseif( z > 3000. &
7195 ! .and. z <= 5000. ) then
7196 ! mult = 0.25 - 4.166666667e-5*(z-3000.)
7197 ! else
7198 ! mult = 0.125
7199 ! end if
7200 if( z <= 500. ) then
7201 mult = 1.0
7202 elseif( z > 500. &
7203 .and. z <= 1000. ) then
7204 mult = 1.0 - 0.001074*(z-500.)
7205 elseif( z > 1000. &
7206 .and. z <= 5000. ) then
7207 mult = 0.463 - 0.000111*(z-1000.)
7208 else
7209 mult = 0.019
7210 end if
7212 ! These should match what is in sorgam_set_aer_bc_pnnl.
7213 ! Values as of 2-Dec-2004:
7214 !jdf comment these values and have another profile consistent with mosaic
7215 ! chem(i,k,j,p_sulf) = mult*conmin
7216 ! chem(i,k,j,p_so4aj) = mult*2.375
7217 ! chem(i,k,j,p_so4ai) = mult*0.179
7218 ! chem(i,k,j,p_nh4aj) = mult*0.9604
7219 ! chem(i,k,j,p_nh4ai) = mult*0.0196
7220 ! chem(i,k,j,p_no3aj) = mult*0.0650
7221 ! chem(i,k,j,p_no3ai) = mult*0.0050
7222 ! chem(i,k,j,p_ecj) = mult*0.1630
7223 ! chem(i,k,j,p_eci) = mult*0.0120
7224 ! chem(i,k,j,p_p25j) = mult*0.6350
7225 ! chem(i,k,j,p_p25i) = mult*0.0490
7226 ! chem(i,k,j,p_antha) = mult*2.2970
7227 ! chem(i,k,j,p_orgpaj) = mult*0.9300
7228 ! chem(i,k,j,p_orgpai) = mult*0.0700
7229 ! chem(i,k,j,p_orgaro1j) = conmin
7230 ! chem(i,k,j,p_orgaro1i) = conmin
7231 ! chem(i,k,j,p_orgaro2j) = conmin
7232 ! chem(i,k,j,p_orgaro2i) = conmin
7233 ! chem(i,k,j,p_orgalk1j) = conmin
7234 ! chem(i,k,j,p_orgalk1i) = conmin
7235 ! chem(i,k,j,p_orgole1j) = conmin
7236 ! chem(i,k,j,p_orgole1i) = conmin
7237 ! chem(i,k,j,p_orgba1j) = conmin
7238 ! chem(i,k,j,p_orgba1i) = conmin
7239 ! chem(i,k,j,p_orgba2j) = conmin
7240 ! chem(i,k,j,p_orgba2i) = conmin
7241 ! chem(i,k,j,p_orgba3j) = conmin
7242 ! chem(i,k,j,p_orgba3i) = conmin
7243 ! chem(i,k,j,p_orgba4j) = conmin
7244 ! chem(i,k,j,p_orgba4i) = conmin
7245 ! chem(i,k,j,p_seas) = mult*0.229
7246 chem(i,k,j,p_sulf) = mult*conmin
7247 chem(i,k,j,p_so4aj) = mult*0.300*0.97
7248 chem(i,k,j,p_so4ai) = mult*0.300*0.03
7249 chem(i,k,j,p_nh4aj) = mult*0.094*0.97
7250 chem(i,k,j,p_nh4ai) = mult*0.094*0.03
7251 chem(i,k,j,p_no3aj) = mult*0.001*0.97
7252 chem(i,k,j,p_no3ai) = mult*0.001*0.03
7253 chem(i,k,j,p_naaj) = 10.E-05
7254 chem(i,k,j,p_naai) = 10.E-05
7255 chem(i,k,j,p_claj) = 10.E-05
7256 chem(i,k,j,p_clai) = 10.E-05
7257 chem(i,k,j,p_ecj) = mult*0.013*0.97
7258 chem(i,k,j,p_eci) = mult*0.013*0.03
7259 chem(i,k,j,p_p25j) = mult*4.500*0.97
7260 chem(i,k,j,p_p25i) = mult*4.500*0.03
7261 chem(i,k,j,p_antha) = mult*4.500/2.0
7262 chem(i,k,j,p_orgpaj) = mult*0.088*0.97
7263 chem(i,k,j,p_orgpai) = mult*0.088*0.03
7264 chem(i,k,j,p_asoa1j) = conmin
7265 chem(i,k,j,p_asoa1i) = conmin
7266 chem(i,k,j,p_asoa2j) = conmin
7267 chem(i,k,j,p_asoa2i) = conmin
7268 chem(i,k,j,p_asoa3j) = conmin
7269 chem(i,k,j,p_asoa3i) = conmin
7270 chem(i,k,j,p_asoa4j) = conmin
7271 chem(i,k,j,p_asoa4i) = conmin
7272 chem(i,k,j,p_bsoa1j) = conmin
7273 chem(i,k,j,p_bsoa1i) = conmin
7274 chem(i,k,j,p_bsoa2j) = conmin
7275 chem(i,k,j,p_bsoa2i) = conmin
7276 chem(i,k,j,p_bsoa3j) = conmin
7277 chem(i,k,j,p_bsoa3i) = conmin
7278 chem(i,k,j,p_bsoa4j) = conmin
7279 chem(i,k,j,p_bsoa4i) = conmin
7280 chem(i,k,j,p_seas) = mult*1.75
7283 END SUBROUTINE sorgam_vbs_init_aer_ic_pnnl
7284 !
7285 SUBROUTINE sorgam_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, &
7286 ebu, &
7287 slai,ust,smois,ivgtyp,isltyp, &
7288 emis_ant,dust_emiss_active, &
7289 seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, &
7290 dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, &
7291 !KW
7292 emis_seas2, &
7293 !KW
7294 ids,ide, jds,jde, kds,kde, &
7295 ims,ime, jms,jme, kms,kme, &
7296 its,ite, jts,jte, kts,kte )
7297 !
7298 ! Routine to apply aerosol emissions for MADE/SOA_VBS...
7299 ! William.Gustafson@pnl.gov; 3-May-2007
7300 ! Modified by
7301 ! steven.peckham@noaa.gov; 8-Jan-2008
7302 !------------------------------------------------------------------------
7304 USE module_state_description, only: num_chem,num_emis_seas2
7306 INTEGER, INTENT(IN ) :: seasalt_emiss_active,kemit,emissopt, &
7307 dust_emiss_active,num_soil_layers,id, &
7308 ktau,dust_opt,biom, &
7309 ids,ide, jds,jde, kds,kde, &
7310 ims,ime, jms,jme, kms,kme, &
7311 its,ite, jts,jte, kts,kte
7313 REAL, INTENT(IN ) :: dtstep
7315 ! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air)
7316 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7317 INTENT(INOUT ) :: chem
7319 !KW
7320 REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas2),OPTIONAL, &
7321 INTENT(INOUT ) :: &
7322 emis_seas2
7323 !KW
7325 !
7326 ! aerosol emissions arrays ((ug/m3)*m/s)
7327 !
7328 REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), &
7329 INTENT(IN ) :: emis_ant
7331 ! biomass burning aerosol emissions arrays ((ug/m3)*m/s)
7332 REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), &
7333 INTENT(IN ) :: ebu
7335 ! 1/(dry air density) and layer thickness (m)
7336 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7337 INTENT(IN ) :: &
7338 alt, dz8w
7340 ! add for gocart dust
7341 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
7342 INTENT(IN ) :: p8w,u_phy,v_phy,rho_phy
7343 REAL, INTENT(IN ) :: dx, g
7344 REAL, DIMENSION( ims:ime, jms:jme, 3 ), &
7345 INTENT(IN ) :: erod
7347 REAL, DIMENSION( ims:ime , jms:jme ), &
7348 INTENT(IN ) :: &
7349 u10, v10, xland, slai, ust
7350 INTEGER, DIMENSION( ims:ime , jms:jme ), &
7351 INTENT(IN ) :: ivgtyp, isltyp
7352 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ), &
7353 INTENT(INOUT) :: smois
7355 ! Local variables...
7356 real, dimension(its:ite,kts:kte,jts:jte) :: factor
7357 !
7358 ! Get the emissions unit conversion factor including the time step.
7359 ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep]
7360 !
7361 factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ &
7362 dz8w(its:ite,kts:kte,jts:jte)
7363 !
7364 ! Increment the aerosol numbers...
7365 !
7366 ! Increment the aerosol numbers...
7367 !KW Changed 'if' statement
7368 !KW if(emissopt .lt. 5 )then
7369 if(emissopt .ne. 5 )then
7370 !
7371 ! Aitken mode first...
7373 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7374 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7375 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7376 anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + &
7377 anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + &
7378 nafac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) + &
7379 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) + &
7380 so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i) + &
7381 no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i) )
7383 !KW chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7384 !KW chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7385 !KW factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7386 !KW anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + &
7387 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + &
7388 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + &
7389 !KW orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) )
7391 ! Accumulation mode next...
7393 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7394 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7395 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7396 anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + &
7397 anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + &
7398 nafac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) + &
7399 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) + &
7400 so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j) + &
7401 no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j) )
7403 !KW chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7404 !KW chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7405 !KW factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7406 !KW anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + &
7407 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + &
7408 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + &
7409 !KW orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) )
7411 ! And now the coarse mode...
7413 chem(its:ite,kts:kemit,jts:jte,p_corn) = &
7414 chem(its:ite,kts:kemit,jts:jte,p_corn) + &
7415 factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac* &
7416 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm10) !KW
7417 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)
7418 !
7419 ! Increment the aerosol masses...
7420 !
7421 chem(its:ite,kts:kemit,jts:jte,p_antha) = &
7422 chem(its:ite,kts:kemit,jts:jte,p_antha) + &
7423 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm10)*factor(its:ite,kts:kemit,jts:jte) !KW
7424 !KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte)
7426 chem(its:ite,kts:kemit,jts:jte,p_p25j) = &
7427 chem(its:ite,kts:kemit,jts:jte,p_p25j) + &
7428 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte)
7430 chem(its:ite,kts:kemit,jts:jte,p_p25i) = &
7431 chem(its:ite,kts:kemit,jts:jte,p_p25i) + &
7432 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte)
7434 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
7435 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
7436 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte)
7438 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
7439 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
7440 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte)
7441 chem(its:ite,kts:kemit,jts:jte,p_naaj) = &
7442 chem(its:ite,kts:kemit,jts:jte,p_naaj) + &
7443 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte)
7444 chem(its:ite,kts:kemit,jts:jte,p_naai) = &
7445 chem(its:ite,kts:kemit,jts:jte,p_naai) + &
7446 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte)
7448 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
7449 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
7450 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte)
7452 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7453 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7454 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte)
7456 chem(its:ite,kts:kemit,jts:jte,p_so4aj) = &
7457 chem(its:ite,kts:kemit,jts:jte,p_so4aj) + &
7458 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte)
7460 chem(its:ite,kts:kemit,jts:jte,p_so4ai) = &
7461 chem(its:ite,kts:kemit,jts:jte,p_so4ai) + &
7462 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte)
7464 chem(its:ite,kts:kemit,jts:jte,p_no3aj) = &
7465 chem(its:ite,kts:kemit,jts:jte,p_no3aj) + &
7466 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte)
7468 chem(its:ite,kts:kemit,jts:jte,p_no3ai) = &
7469 chem(its:ite,kts:kemit,jts:jte,p_no3ai) + &
7470 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte)
7472 elseif(emissopt == 5)then
7473 !
7474 ! Aitken mode first...
7476 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7477 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7478 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7479 anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7480 orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7482 ! Accumulation mode next...
7484 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7485 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7486 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7487 anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7488 orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7490 !
7491 ! Increment the aerosol masses...
7492 !
7494 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
7495 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
7496 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7498 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
7499 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
7500 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7502 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
7503 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
7504 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7506 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7507 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7508 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7510 endif
7511 ! add biomass burning emissions if present
7512 !
7513 if(biom == 1 )then
7514 !
7515 ! Aitken mode first...
7517 chem(its:ite,kts:kte,jts:jte,p_nu0) = &
7518 chem(its:ite,kts:kte,jts:jte,p_nu0) + &
7519 factor(its:ite,kts:kte,jts:jte)*factnumn*( &
7520 anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7521 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7522 orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7524 ! Accumulation mode next...
7526 chem(its:ite,kts:kte,jts:jte,p_ac0) = &
7527 chem(its:ite,kts:kte,jts:jte,p_ac0) + &
7528 factor(its:ite,kts:kte,jts:jte)*factnuma*( &
7529 anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7530 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7531 orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7532 ! coarse
7533 chem(its:ite,kts:kte,jts:jte,p_corn) = &
7534 chem(its:ite,kts:kte,jts:jte,p_corn) + &
7535 factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* &
7536 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)
7538 !
7539 ! Increment the aerosol masses...
7540 !
7542 chem(its:ite,kts:kte,jts:jte,p_ecj) = &
7543 chem(its:ite,kts:kte,jts:jte,p_ecj) + &
7544 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7546 chem(its:ite,kts:kte,jts:jte,p_eci) = &
7547 chem(its:ite,kts:kte,jts:jte,p_eci) + &
7548 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
7550 chem(its:ite,kts:kte,jts:jte,p_orgpaj) = &
7551 chem(its:ite,kts:kte,jts:jte,p_orgpaj) + &
7552 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7554 chem(its:ite,kts:kte,jts:jte,p_orgpai) = &
7555 chem(its:ite,kts:kte,jts:jte,p_orgpai) + &
7556 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
7558 chem(its:ite,kts:kte,jts:jte,p_antha) = &
7559 chem(its:ite,kts:kte,jts:jte,p_antha) + &
7560 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte)
7562 chem(its:ite,kts:kte,jts:jte,p_p25j) = &
7563 chem(its:ite,kts:kte,jts:jte,p_p25j) + &
7564 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7566 chem(its:ite,kts:kte,jts:jte,p_p25i) = &
7567 chem(its:ite,kts:kte,jts:jte,p_p25i) + &
7568 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
7570 endif !end biomass burning
7571 !
7572 ! Get the sea salt emissions...
7573 !
7574 if( seasalt_emiss_active == 1 ) then
7575 call sorgam_vbs_seasalt_emiss( &
7576 dtstep, u10, v10, alt, dz8w, xland, chem, &
7577 !KW
7578 emis_seas2, &
7579 !KW
7580 ids,ide, jds,jde, kds,kde, &
7581 ims,ime, jms,jme, kms,kme, &
7582 its,ite, jts,jte, kts,kte )
7583 end if
7584 if( seasalt_emiss_active == 2 ) then
7585 ! call Monahan_seasalt_emiss( &
7586 ! dtstep, u10, v10, alt, dz8w, xland, chem, &
7587 ! ids,ide, jds,jde, kds,kde, &
7588 ! ims,ime, jms,jme, kms,kme, &
7589 ! its,ite, jts,jte, kts,kte )
7590 end if
7591 if( dust_opt == 2 ) then
7592 call sorgam_vbs_dust_emiss( &
7593 slai, ust, smois, ivgtyp, isltyp, &
7594 id, dtstep, u10, v10, alt, dz8w, &
7595 xland, num_soil_layers, chem, &
7596 ids,ide, jds,jde, kds,kde, &
7597 ims,ime, jms,jme, kms,kme, &
7598 its,ite, jts,jte, kts,kte )
7599 end if
7600 if( dust_opt == 5 ) then
7601 call sorgam_vbs_dust_gocartemis( &
7602 ktau,dtstep,num_soil_layers,alt,u_phy, &
7603 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
7604 ivgtyp,isltyp,xland,dx,g, &
7605 ids,ide, jds,jde, kds,kde, &
7606 ims,ime, jms,jme, kms,kme, &
7607 its,ite, jts,jte, kts,kte )
7608 end if
7610 END SUBROUTINE sorgam_vbs_addemiss
7612 !------------------------------------------------------------------------
7613 SUBROUTINE sorgam_vbs_seasalt_emiss( &
7614 dtstep, u10, v10, alt, dz8w, xland, chem, &
7615 !KW
7616 emis_seas2, &
7617 !KW
7618 ids,ide, jds,jde, kds,kde, &
7619 ims,ime, jms,jme, kms,kme, &
7620 its,ite, jts,jte, kts,kte )
7621 !
7622 ! Routine to calculate seasalt emissions for SOA_VBS over the time
7623 ! dtstep...
7624 ! William.Gustafson@pnl.gov; 10-May-2007
7625 !------------------------------------------------------------------------
7627 USE module_mosaic_addemiss, only: seasalt_emitfactors_1bin
7629 IMPLICIT NONE
7631 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
7632 ims,ime, jms,jme, kms,kme, &
7633 its,ite, jts,jte, kts,kte
7635 REAL, INTENT(IN ) :: dtstep
7637 ! 10-m wind speed components (m/s)
7638 REAL, DIMENSION( ims:ime , jms:jme ), &
7639 INTENT(IN ) :: u10, v10, xland
7641 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7642 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7643 INTENT(INOUT ) :: chem
7645 !KW
7646 REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas2),OPTIONAL, &
7647 INTENT(INOUT ) :: &
7648 emis_seas2
7649 !KW
7651 ! alt = 1.0/(dry air density) in (m3/kg)
7652 ! dz8w = layer thickness in (m)
7653 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7654 INTENT(IN ) :: alt, dz8w
7656 ! local variables
7657 integer :: i, j, k, l, l_na, l_cl, n
7658 integer :: p1st
7660 real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
7661 real :: factaa, factbb, fraccl, fracna
7663 real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c
7664 real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c
7667 ! Compute emissions factors for the Aitken mode...
7668 ! Nope, we won't because the parameterization is only valid down to
7669 ! 0.1 microns.
7670 ! Setup in units of cm.
7671 ! dumdlo = 0.039e-4
7672 ! dumdhi = 0.078e-4
7673 ssemfact_numb_i = 0.
7674 ssemfact_mass_i = 0.
7676 ! Compute emissions factors for the accumulation mode...
7677 ! Potentially, we could go down to 0.078 microns to match the bin
7678 ! boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end
7679 ! has been chosen to match the MOSAIC bin boundary closest to two
7680 ! standard deviations from the default bin mean diameter for the coarse
7681 ! mode.
7682 dumdlo = 0.1e-4
7683 dumdhi = 1.250e-4
7684 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
7685 ssemfact_numb_j, dum, ssemfact_mass_j )
7687 ! Compute emissions factors for the coarse mode...
7688 dumdlo = 1.25e-4
7689 dumdhi = 10.0e-4
7690 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
7691 ssemfact_numb_c, dum, ssemfact_mass_c )
7693 ! Convert mass emissions factor from (g/m2/s) to (ug/m2/s)
7694 ssemfact_mass_i = ssemfact_mass_i*1.0e6
7695 ssemfact_mass_j = ssemfact_mass_j*1.0e6
7696 ssemfact_mass_c = ssemfact_mass_c*1.0e6
7698 ! Loop over i,j and apply seasalt emissions
7699 k = kts
7700 do j = jts, jte
7701 do i = its, ite
7703 !Skip this point if over land. xland=1 for land and 2 for water.
7704 !Also, there is no way to differentiate fresh from salt water.
7705 !Currently, this assumes all water is salty.
7706 if( xland(i,j) < 1.5 ) cycle
7708 !wig: As far as I can tell, only real.exe knows the fractional breakdown
7709 ! of land use. So, in wrf.exe, dumoceanfrac will always be 1.
7710 dumoceanfrac = 1. !fraction of grid i,j that is salt water
7711 dumspd10 = dumoceanfrac* &
7712 ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
7714 ! factaa is (s*m2/kg-air)
7715 ! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air
7716 ! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air
7717 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
7718 factbb = factaa * dumspd10
7720 ! Apportion seasalt mass emissions assumming that seasalt is pure NaCl
7721 fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
7722 fraccl = 1.0 - fracna
7724 ! Add the emissions into the chem array...
7725 chem(i,k,j,p_naai) = chem(i,k,j,p_naai) + &
7726 factbb * ssemfact_mass_i * fracna
7727 chem(i,k,j,p_clai) = chem(i,k,j,p_clai) + &
7728 factbb * ssemfact_mass_i * fraccl
7729 chem(i,k,j,p_nu0) = chem(i,k,j,p_nu0) + &
7730 factbb * ssemfact_numb_i
7732 chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) + &
7733 factbb * ssemfact_mass_j * fracna
7734 chem(i,k,j,p_claj) = chem(i,k,j,p_claj) + &
7735 factbb * ssemfact_mass_j * fraccl
7736 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + &
7737 factbb * ssemfact_numb_j
7739 chem(i,k,j,p_seas) = chem(i,k,j,p_seas) + &
7740 factbb * ssemfact_mass_c
7741 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + &
7742 factbb * ssemfact_numb_c
7744 !KW sea emis g/m2/s
7745 emis_seas2(i,1,j,p_eseasj)=ssemfact_mass_j*dumspd10/1.0e6
7746 emis_seas2(i,1,j,p_eseasc)=ssemfact_mass_c*dumspd10/1.0e6
7747 !KW
7749 end do !i
7750 end do !j
7751 END SUBROUTINE sorgam_vbs_seasalt_emiss
7752 !----------------------------------------------------------------------
7754 subroutine sorgam_vbs_dust_emiss( slai,ust, smois, ivgtyp, isltyp, &
7755 id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers, &
7756 chem, &
7757 ids,ide, jds,jde, kds,kde, &
7758 ims,ime, jms,jme, kms,kme, &
7759 its,ite, jts,jte, kts,kte )
7760 !
7761 ! adds dust emissions for mosaic aerosol species (i.e. emission tendencies
7762 ! over time dtstep are applied to the aerosol mixing ratios)
7763 !
7764 ! This is a simple dust scheme based on Shaw et al. (2008) to appear in
7765 ! Atmospheric Environment, recoded by Jerome Fast
7766 !
7767 ! NOTE:
7768 ! 1) This version only works with the 8-bin version of MOSAIC.
7769 ! 2) Dust added to MOSAIC's other inorganic specie, OIN. If Ca and CO3 are
7770 ! activated in the Registry, a small fraction also added to Ca and CO3.
7771 ! 3) The main departure from Shaw et al., is now alphamask is computed since
7772 ! the land-use categories in that paper and in WRF differ. WRF currently
7773 ! does not have that many land-use categories and adhoc assumptions had to
7774 ! be made. This version was tested for Mexico in the dry season. The main
7775 ! land-use categories in WRF that are likely dust sources are grass, shrub,
7776 ! and savannna (that WRF has in the desert regions of NW Mexico). Having
7777 ! dust emitted from these types for other locations and other times of the
7778 ! year is not likely to be valid.
7779 ! 4) An upper bound on ustar was placed because the surface parameterizations
7780 ! in WRF can produce unrealistically high values that lead to very high
7781 ! dust emission rates.
7782 ! 5) Other departures' from Shaw et al. noted below, but are probably not as
7783 ! important as 2) and 3).
7784 !
7785 USE module_configure, only: grid_config_rec_type
7786 USE module_state_description, only: num_chem, param_first_scalar
7787 USE module_data_mosaic_asect
7789 IMPLICIT NONE
7791 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
7793 INTEGER, INTENT(IN ) :: id,num_soil_layers, &
7794 ids,ide, jds,jde, kds,kde, &
7795 ims,ime, jms,jme, kms,kme, &
7796 its,ite, jts,jte, kts,kte
7798 REAL, INTENT(IN ) :: dtstep
7800 ! 10-m wind speed components (m/s)
7801 REAL, DIMENSION( ims:ime , jms:jme ), &
7802 INTENT(IN ) :: u10, v10, xland, slai, ust
7803 INTEGER, DIMENSION( ims:ime , jms:jme ), &
7804 INTENT(IN ) :: ivgtyp, isltyp
7806 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
7807 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7808 INTENT(INOUT ) :: chem
7810 ! alt = 1.0/(dry air density) in (m3/kg)
7811 ! dz8w = layer thickness in (m)
7812 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7813 INTENT(IN ) :: alt, dz8w
7815 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
7816 INTENT(INOUT) :: smois
7818 ! local variables
7819 integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
7820 integer iphase, itype, izob
7821 integer p1st
7823 real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
7824 real factaa, factbb, fracoin, fracca, fracco3, fractot
7825 real ustart, ustar1, ustart0
7826 real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
7827 real smois_grav, wp, pclay
7828 real :: beta(4,7)
7829 real :: gamma(4), delta(4)
7830 real :: sz(8)
7831 real :: dustflux, densdust, mass1part
7832 real :: dp_meanvol_tmp
7833 !
7834 ! from Nickovic et al., JGR, 2001 and Shaw et al. 2007
7835 ! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7)
7836 ! beta (1,*) for 0.5-1 um
7837 ! beta (2,*) for 1-10 um
7838 ! beta (3,*) for 10-25 um
7839 ! beta (4,*) for 25-50 um
7840 !
7841 beta(1,1)=0.12
7842 beta(2,1)=0.04
7843 beta(3,1)=0.04
7844 beta(4,1)=0.80
7845 beta(1,2)=0.34
7846 beta(2,2)=0.28
7847 beta(3,2)=0.28
7848 beta(4,2)=0.10
7849 beta(1,3)=0.45
7850 beta(2,3)=0.15
7851 beta(3,3)=0.15
7852 beta(4,3)=0.25
7853 beta(1,4)=0.12
7854 beta(2,4)=0.09
7855 beta(3,4)=0.09
7856 beta(4,4)=0.70
7857 beta(1,5)=0.40
7858 beta(2,5)=0.05
7859 beta(3,5)=0.05
7860 beta(4,5)=0.50
7861 beta(1,6)=0.34
7862 beta(2,6)=0.18
7863 beta(3,6)=0.18
7864 beta(4,6)=0.30
7865 beta(1,7)=0.22
7866 beta(2,7)=0.09
7867 beta(3,7)=0.09
7868 beta(4,7)=0.60
7869 gamma(1)=0.08
7870 gamma(2)=1.00
7871 gamma(3)=1.00
7872 gamma(4)=0.12
7873 !
7874 ! * Mass fractions for each size bin. These values were recommended by
7875 ! Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM.
7876 ! * Changed slightly since Natelie's estimates do not add up to 1.0
7877 ! * This would need to be made more generic for other bin sizes.
7878 ! sz(1)=0
7879 ! sz(2)=1.78751e-06
7880 ! sz(3)=0.000273786
7881 ! sz(4)=0.00847978
7882 ! sz(5)=0.056055
7883 ! sz(6)=0.0951896
7884 ! sz(7)=0.17
7885 ! sz(8)=0.67
7886 sz(1)=0.0
7887 sz(2)=0.0
7888 sz(3)=0.0005
7889 sz(4)=0.0095
7890 sz(5)=0.03
7891 sz(6)=0.10
7892 sz(7)=0.18
7893 sz(8)=0.68
7895 ! for now just do itype=1
7896 itype = 1
7897 iphase = ai_phase
7899 ! loop over i,j and apply dust emissions
7900 k = kts
7901 do 1830 j = jts, jte
7902 do 1820 i = its, ite
7904 if( xland(i,j) > 1.5 ) cycle
7906 ! compute wind speed anyway, even though ustar is used below
7908 dumlandfrac = 1.
7909 dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
7910 if(dumspd10 >= 5.0) then
7911 dumspd10 = dumlandfrac* &
7912 ( dumspd10*dumspd10*(dumspd10-5.0))
7913 else
7914 dumspd10=0.
7915 endif
7917 ! part1 - compute vegetation mask
7918 !
7919 ! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories
7920 ! for desert, sand desert, grass aemi-desert, and shrub semi-desert
7921 ! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna
7922 ! that are dominate types in Mexico and probably have some erodable surface
7923 ! during the dry season
7924 ! * currently modified these values so that only a small fraction of cell
7925 ! area is erodable
7926 ! * these values are highly tuneable!
7928 alphamask=0.001
7929 if (ivgtyp(i,j) .eq. 7) then
7930 f8=0.005
7931 f50=0.00
7932 f51=0.10
7933 f52=0.00
7934 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7935 endif
7936 if (ivgtyp(i,j) .eq. 8) then
7937 f8=0.010
7938 f50=0.00
7939 f51=0.00
7940 f52=0.15
7941 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7942 endif
7943 if (ivgtyp(i,j) .eq. 10) then
7944 f8=0.00
7945 f50=0.00
7946 f51=0.01
7947 f52=0.00
7948 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
7949 endif
7951 ! part2 - zobler
7952 !
7953 ! * in Shaw's paper, dust is computed for 4 size ranges:
7954 ! 0.5-1 um
7955 ! 1-10 um
7956 ! 10-25 um
7957 ! 25-50 um
7958 ! * Shaw's paper also accounts for sub-grid variability in soil
7959 ! texture, but here we just assume the same soil texture for each
7960 ! grid cell
7961 ! * since MOSAIC is currently has a maximum size range up to 10 um,
7962 ! neglect upper 2 size ranges and lowest size range (assume small)
7963 ! * map WRF soil classes arbitrarily to Zolber soil textural classes
7964 ! * skip dust computations for WRF soil classes greater than 13, i.e.
7965 ! do not compute dust over water, bedrock, and other surfaces
7966 ! * should be skipping for water surface at this point anyway
7967 !
7968 izob=0
7969 if(isltyp(i,j).eq.1) izob=1
7970 if(isltyp(i,j).eq.2) izob=1
7971 if(isltyp(i,j).eq.3) izob=4
7972 if(isltyp(i,j).eq.4) izob=2
7973 if(isltyp(i,j).eq.5) izob=2
7974 if(isltyp(i,j).eq.6) izob=2
7975 if(isltyp(i,j).eq.7) izob=7
7976 if(isltyp(i,j).eq.8) izob=2
7977 if(isltyp(i,j).eq.9) izob=6
7978 if(isltyp(i,j).eq.10) izob=5
7979 if(isltyp(i,j).eq.11) izob=2
7980 if(isltyp(i,j).eq.12) izob=3
7981 if(isltyp(i,j).ge.13) izob=0
7982 if(izob.eq.0) goto 1840
7983 !
7984 ! part3 - dustprod
7985 !
7986 do ii=1,4
7987 delta(ii)=0.0
7988 enddo
7989 sumdelta=0.0
7990 do ii=1,4
7991 delta(ii)=beta(ii,izob)*gamma(ii)
7992 if(ii.lt.4) then
7993 sumdelta=sumdelta+delta(ii)
7994 endif
7995 enddo
7996 do ii=1,4
7997 delta(ii)=delta(ii)/sumdelta
7998 enddo
8000 ! part4 - wetness
8001 !
8002 ! * assume dry for now, have passed in soil moisture to this routine
8003 ! but needs to be included here
8004 ! * wetfactor less than 1 would reduce dustflux
8005 ! * convert model soil moisture (m3/m3) to gravimetric soil moisture
8006 ! (mass of water / mass of soil in %) assuming a constant density
8007 ! for soil
8008 pclay=beta(1,izob)*100.
8009 wp=0.0014*pclay*pclay+0.17*pclay
8010 smois_grav=(smois(i,1,j)/2.6)*100.
8011 if(smois_grav.gt.wp) then
8012 wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
8013 else
8014 wetfactor=1.0
8015 endif
8016 ! wetfactor=1.0
8018 ! part5 - dustflux
8019 ! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper
8020 ! bound to 100 cm/s
8022 ustar1=ust(i,j)*100.0
8023 if(ustar1.gt.100.0) ustar1=100.0
8024 ustart0=20.0
8025 ustart=ustart0*wetfactor
8026 if(ustar1.le.ustart) then
8027 dustflux=0.0
8028 else
8029 dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1))
8030 endif
8031 dustflux=dustflux*10.0
8032 ! units kg m-2 s-1
8033 ftot=0.0
8034 do ii=1,2
8035 ftot=ftot+dustflux*alphamask*delta(ii)
8036 enddo
8037 ! convert to ug m-2 s-1
8038 ftot=ftot*1.0e+09
8040 ! apportion other inorganics only
8041 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
8042 factbb = factaa * ftot
8043 fracoin = 1.00
8044 ! fracca = 0.03*0.4
8045 ! fracco3 = 0.03*0.6
8046 fracca = 0.0
8047 fracco3 = 0.0
8048 fractot = fracoin + fracca + fracco3
8049 ! if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot
8050 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + &
8051 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot
8053 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot
8054 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + &
8055 factbb * (sz(7)+sz(8)) * fractot
8056 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot
8057 ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3
8058 densdust=2.5
8059 dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
8060 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
8061 chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) + &
8062 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part
8063 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part
8064 dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
8065 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
8066 chem(i,k,j,p_corn)=chem(i,k,j,p_corn) + &
8067 factbb * (sz(7)+sz(8)) * fractot / mass1part
8068 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part
8070 1840 continue
8072 1820 continue
8073 1830 continue
8075 return
8077 END subroutine sorgam_vbs_dust_emiss
8079 !====================================================================================
8080 !add another dust emission scheme following GOCART mechanism --czhao 09/17/2009
8081 !====================================================================================
8082 subroutine sorgam_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, &
8083 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
8084 ivgtyp,isltyp,xland,dx,g, &
8085 ids,ide, jds,jde, kds,kde, &
8086 ims,ime, jms,jme, kms,kme, &
8087 its,ite, jts,jte, kts,kte )
8088 USE module_data_gocart_dust
8089 USE module_configure
8090 USE module_state_description
8091 USE module_model_constants, ONLY: mwdry
8092 USE module_data_mosaic_asect
8093 IMPLICIT NONE
8095 INTEGER, INTENT(IN ) :: ktau, num_soil_layers, &
8096 ids,ide, jds,jde, kds,kde, &
8097 ims,ime, jms,jme, kms,kme, &
8098 its,ite, jts,jte, kts,kte
8099 INTEGER,DIMENSION( ims:ime , jms:jme ) , &
8100 INTENT(IN ) :: &
8101 ivgtyp, &
8102 isltyp
8103 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8104 INTENT(INOUT ) :: chem
8105 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
8106 INTENT(INOUT) :: smois
8107 REAL, DIMENSION( ims:ime , jms:jme, 3 ) , &
8108 INTENT(IN ) :: erod
8109 REAL, DIMENSION( ims:ime , jms:jme ) , &
8110 INTENT(IN ) :: &
8111 u10, &
8112 v10, &
8113 xland
8114 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
8115 INTENT(IN ) :: &
8116 alt, &
8117 dz8w,p8w, &
8118 u_phy,v_phy,rho_phy
8120 REAL, INTENT(IN ) :: dt,dx,g
8121 !
8122 ! local variables
8123 !
8124 integer :: nmx,i,j,k,ndt,imx,jmx,lmx
8125 integer ilwi, start_month
8126 real*8, DIMENSION (3) :: erodin
8127 real*8, DIMENSION (5) :: bems
8128 real*8 w10m,gwet,airden,airmas
8129 real*8 cdustemis,jdustemis,cdustcon,jdustcon
8130 real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
8131 real*8 dxy
8132 real*8 conver,converi
8133 real dttt
8134 real soilfacj,rhosoilj,rhosoilc
8135 real totalemis,accfrac,corfrac,rscale1,rscale2
8137 accfrac=0.07 ! assign 7% to accumulation mode
8138 corfrac=0.93 ! assign 93% to coarse mode
8139 rscale1=1.00 ! to account for the dust larger than 10um in radius
8140 rscale2=1.02 ! to account for the dust larger than 10um in radius
8141 accfrac=accfrac*rscale1
8142 corfrac=corfrac*rscale2
8144 rhosoilj=2.5e3
8145 rhosoilc=2.6e3
8146 soilfacj=soilfac*rhosoilj/rhosoilc
8148 conver=1.e-9
8149 converi=1.e9
8150 !
8151 ! number of dust bins
8152 nmx=5
8153 k=kts
8154 do j=jts,jte
8155 do i=its,ite
8156 !
8157 ! don't do dust over water!!!
8158 if(xland(i,j).lt.1.5)then
8160 ilwi=1
8161 start_month = 3 ! it doesn't matter, ch_dust is not a month dependent now, a constant
8162 w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
8163 airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! kg
8165 ! we don't trust the u10,v10 values, if model layers are very thin near surface
8166 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))
8167 !erodin(1)=erod(i,j,1)/dx/dx ! czhao erod shouldn't be scaled to the area, because it's a fraction
8168 !erodin(2)=erod(i,j,2)/dx/dx
8169 !erodin(3)=erod(i,j,3)/dx/dx
8170 erodin(1)=erod(i,j,1)
8171 erodin(2)=erod(i,j,2)
8172 erodin(3)=erod(i,j,3)
8173 !
8174 ! volumetric soil moisture over porosity
8175 gwet=smois(i,1,j)/porosity(isltyp(i,j))
8176 ndt=ifix(dt)
8177 airden=rho_phy(i,kts,j)
8178 dxy=dx*dx
8180 call sorgam_vbs_source_du( nmx, dt,i,j, &
8181 erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
8182 bems,start_month,g)
8184 !bems: kg/timestep/cell
8185 !sum up the dust emission from 0.1-10 um in radius
8186 ! unit change from kg/timestep/cell to ug/m2/s
8187 totalemis=(sum(bems(1:5))/dt)*converi/dxy
8188 ! to account for the particles larger than 10 um radius
8189 ! based on assumed size distribution
8190 jdustemis = totalemis*accfrac ! accumulation mode
8191 cdustemis = totalemis*corfrac ! coarse mode
8193 cdustcon = sum(bems(1:5))*corfrac/airmas ! kg/kg-dryair
8194 cdustcon = cdustcon * converi ! ug/kg-dryair
8195 jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair
8196 jdustcon = jdustcon * converi ! ug/kg-dryair
8198 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon
8199 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon
8201 ! czhao doing dust number emission following pm10
8202 ! use soilfacj for accumulation mode because GOCART assign a less dense dust in
8203 ! accumulation mode
8204 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj
8205 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac
8207 endif
8208 enddo
8209 enddo
8211 end subroutine sorgam_vbs_dust_gocartemis
8213 SUBROUTINE sorgam_vbs_source_du( nmx, dt1,i,j, &
8214 erod, ilwi, dxy, w10m, gwet, airden, airmas, &
8215 bems,month,g0)
8217 ! ****************************************************************************
8218 ! * Evaluate the source of each dust particles size classes (kg/m3)
8219 ! * by soil emission.
8220 ! * Input:
8221 ! * EROD Fraction of erodible grid cell (-)
8222 ! * for 1: Sand, 2: Silt, 3: Clay
8223 ! * DUSTDEN Dust density (kg/m3)
8224 ! * DXY Surface of each grid cell (m2)
8225 ! * AIRVOL Volume occupy by each grid boxes (m3)
8226 ! * NDT1 Time step (s)
8227 ! * W10m Velocity at the anemometer level (10meters) (m/s)
8228 ! * u_tresh Threshold velocity for particule uplifting (m/s)
8229 ! * CH_dust Constant to fudge the total emission of dust (s2/m2)
8230 ! *
8231 ! * Output:
8232 ! * DSRC Source of each dust type (kg/timestep/cell)
8233 ! *
8234 ! * Working:
8235 ! * SRC Potential source (kg/m/timestep/cell)
8236 ! *
8237 ! ****************************************************************************
8239 USE module_data_gocart_dust
8241 INTEGER, INTENT(IN) :: nmx
8242 REAL*8, INTENT(IN) :: erod(ndcls)
8243 INTEGER, INTENT(IN) :: ilwi,month
8245 REAL*8, INTENT(IN) :: w10m, gwet
8246 REAL*8, INTENT(IN) :: dxy
8247 REAL*8, INTENT(IN) :: airden, airmas
8248 REAL*8, INTENT(OUT) :: bems(nmx)
8250 REAL*8 :: den(nmx), diam(nmx)
8251 REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce
8252 REAL, intent(in) :: g0
8253 REAL :: rhoa, g,dt1
8254 INTEGER :: i, j, n, m, k
8256 ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5
8257 !ch_dust(:,:)=0.8D-9 ! ch_dust is defined here instead of in the chemics_ini.F if with SOA_VBS -czhao
8258 ch_dust(:,:)=1.0D-9 ! default
8259 !ch_dust(:,:)=0.65D-9 ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara
8260 !ch_dust(:,:)=1.0D-9*0.36 ! ch_dust is scaled to soa_vbs total dust emission
8262 ! executable statemenst
8263 DO n = 1, nmx
8264 ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941)
8265 den(n) = den_dust(n)*1.0D-3
8266 diam(n) = 2.0*reff_dust(n)*1.0D2
8267 g = g0*1.0E2
8268 ! Pointer to the 3 classes considered in the source data files
8269 m = ipoint(n)
8270 tsrc = 0.0
8271 rhoa = airden*1.0D-3
8272 u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
8273 SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
8274 SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
8276 ! Case of surface dry enough to erode
8277 IF (gwet < 0.5) THEN ! Pete's modified value
8278 ! IF (gwet < 0.2) THEN
8279 u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
8280 ELSE
8281 ! Case of wet surface, no erosion
8282 u_ts = 100.0
8283 END IF
8284 srce = frac_s(n)*erod(m)*dxy ! (m2)
8285 IF (ilwi == 1 ) THEN
8286 dsrc = ch_dust(n,month)*srce*w10m**2 &
8287 * (w10m - u_ts)*dt1 ! (kg)
8288 ELSE
8289 dsrc = 0.0
8290 END IF
8291 IF (dsrc < 0.0) dsrc = 0.0
8293 ! Update dust mixing ratio at first model level.
8294 !tc(n) = tc(n) + dsrc / airmas !kg/kg-dryair -czhao
8295 bems(n) = dsrc ! kg/timestep/cell
8297 ENDDO
8299 END SUBROUTINE sorgam_vbs_source_du
8301 !===========================================================================
8302 !===========================================================================
8303 subroutine wetscav_sorgam_vbs_driver (id,ktau,dtstep,ktauc,config_flags, &
8304 dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
8305 qlsink,precr,preci,precs,precg,qsrflx, &
8306 gas_aqfrac, numgas_aqfrac, &
8307 ids,ide, jds,jde, kds,kde, &
8308 ims,ime, jms,jme, kms,kme, &
8309 its,ite, jts,jte, kts,kte )
8311 ! wet removal by grid-resolved precipitation
8312 ! scavenging of cloud-phase aerosols and gases by collection, freezing, ...
8313 ! scavenging of interstitial-phase aerosols by impaction
8314 ! scavenging of gas-phase gases by mass transfer and reaction
8316 !----------------------------------------------------------------------
8317 USE module_configure
8318 USE module_state_description
8319 USE module_data_sorgam_vbs
8320 USE module_mosaic_wetscav,only: wetscav
8322 !----------------------------------------------------------------------
8323 IMPLICIT NONE
8325 TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
8327 INTEGER, INTENT(IN ) :: &
8328 ids,ide, jds,jde, kds,kde, &
8329 ims,ime, jms,jme, kms,kme, &
8330 its,ite, jts,jte, kts,kte, &
8331 id, ktau, ktauc, numgas_aqfrac
8332 REAL, INTENT(IN ) :: dtstep,dtstepc
8333 !
8334 ! all advected chemical species
8335 !
8336 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8337 INTENT(INOUT ) :: chem
8339 ! fraction of gas species in cloud water
8340 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), &
8341 INTENT(IN ) :: gas_aqfrac
8343 !
8344 !
8345 ! input from meteorology
8346 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
8347 INTENT(IN ) :: &
8348 alt, &
8349 t_phy, &
8350 p_phy, &
8351 t8w,p8w, &
8352 qlsink,precr,preci,precs,precg, &
8353 rho_phy,cldfra
8354 REAL, DIMENSION( ims:ime, jms:jme, num_chem ), &
8355 INTENT(OUT ) :: qsrflx ! column change due to scavening
8357 call wetscav (id,ktau,dtstep,ktauc,config_flags, &
8358 dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
8359 qlsink,precr,preci,precs,precg,qsrflx, &
8360 gas_aqfrac, numgas_aqfrac, &
8361 ntype_aer, nsize_aer, ncomp_aer, &
8362 massptr_aer, dens_aer, numptr_aer, &
8363 maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, &
8364 volumcen_sect, volumlo_sect, volumhi_sect, &
8365 waterptr_aer, dens_water_aer, &
8366 scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, &
8367 ids,ide, jds,jde, kds,kde, &
8368 ims,ime, jms,jme, kms,kme, &
8369 its,ite, jts,jte, kts,kte )
8371 end subroutine wetscav_sorgam_vbs_driver
8373 !===========================================================================
8376 END Module module_aerosols_sorgam_vbs