| blob | 5260f4b680c5c72100a354c12abc0cba0f4a2b22 |
1 MODULE module_aerosols_sorgam
2 !
3 USE module_state_description
4 USE module_data_radm2
5 USE module_data_sorgam
6 USE module_radm
7 ! USE module_isrpia, only: isoropia
8 !
9 IMPLICIT NONE
10 #define cw_species_are_in_registry
12 CONTAINS
13 SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, &
14 t8w,alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, &
15 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
16 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old, &
17 vdrog3, &
18 kemit, &
19 ids,ide, jds,jde, kds,kde, &
20 ims,ime, jms,jme, kms,kme, &
21 its,ite, jts,jte, kts,kte )
23 INTEGER, INTENT(IN ) :: &
24 ids,ide, jds,jde, kds,kde, &
25 ims,ime, jms,jme, kms,kme, &
26 its,ite, jts,jte, kts,kte, &
27 kemit, &
28 id,ktau
30 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
31 INTENT(IN ) :: moist
33 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
34 INTENT(INOUT ) :: chem
35 !
36 ! following are aerosol arrays that are not advected
37 !
38 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
39 INTENT(INOUT ) :: &
40 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
41 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
44 REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog), &
45 INTENT(IN ) :: &
46 VDROG3
47 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
48 INTENT(IN ) :: &
49 t_phy, &
50 alt, &
51 p_phy, &
52 dz8w, &
53 z , &
54 t8w,p8w,z_at_w , &
55 aerwrf , &
56 rho_phy
57 REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , &
58 INTENT(IN ) :: &
59 vcsulf_old
60 REAL, INTENT(IN ) :: &
61 dtstep
63 REAL drog_in(ldrog) ! anthropogenic AND
64 ! biogenic organic
65 ! aerosol precursor [ug m**-3 s**-1]
67 REAL condvap_in(lspcv) !bs
68 !rs
69 ! condensable vapors [ug m**-3]
70 REAL rgas
71 DATA rgas/8.314510/
72 REAL convfac,convfac2
73 !...BLKSIZE set to one in column model ciarev02
75 INTEGER blksize
76 PARAMETER (blksize=1)
78 !...number of aerosol species
79 ! number of species (gas + aerosol)
80 INTEGER nspcsda
81 PARAMETER (nspcsda=l1ae) !bs
82 ! (internal aerosol dynamics)
83 !bs # of anth. cond. vapors in SORGAM
84 INTEGER nacv
85 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
86 !bs total # of cond. vapors in SORGAM
87 INTEGER ncv
88 PARAMETER (ncv=lspcv) !bs
89 !bs total # of cond. vapors in CTM
90 REAL cblk(blksize,nspcsda) ! main array of variables
91 ! particles [ug/m^3/s]
92 REAL soilrat_in
93 ! emission rate of soil derived coars
94 ! input HNO3 to CBLK [ug/m^3]
95 REAL nitrate_in
96 ! input NH3 to CBLK [ug/m^3]
97 REAL nh3_in
98 ! input SO4 vapor [ug/m^3]
99 REAL hcl_in
101 REAL vsulf_in
103 REAL so4rat_in
104 ! input SO4 formation[ug/m^3/sec]
105 REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
106 ! Emission rate of i-mode EC [ug m**-3 s**-1]
107 REAL eeci_in
108 ! Emission rate of j-mode EC [ug m**-3 s**-1]
109 REAL eecj_in
110 ! Emission rate of j-mode org. aerosol [ug m**-
111 REAL eorgi_in
113 REAL eorgj_in
114 ! Emission rate of j-mode org. aerosol [ug m**-
115 ! pressure in cb
116 REAL pres
117 ! temperature in K
118 REAL temp
119 !bs
120 REAL relhum
121 ! rel. humidity (0,1)
122 REAL ::p(kts:kte),t(kts:kte),rh(kts:kte)
124 !...molecular weights ciarev02
126 ! molecular weight for SO4
127 REAL mwso4
128 PARAMETER (mwso4=96.0576)
130 ! molecular weight for HNO3
131 REAL mwhno3
132 PARAMETER (mwhno3=63.01287)
134 ! molecular weight for NH3
135 REAL mwnh3
136 PARAMETER (mwnh3=17.03061)
138 ! molecular weight for HCL
139 REAL mwhcl
140 PARAMETER (mwhcl=36.46100)
142 !bs molecular weight for Organic Spec
143 ! REAL mworg
144 ! PARAMETER (mworg=175.0)
146 !bs molecular weight for Elemental Ca
147 REAL mwec
148 PARAMETER (mwec=12.0)
150 !rs molecular weight
151 REAL mwaro1
152 PARAMETER (mwaro1=150.0)
154 !rs molecular weight
155 REAL mwaro2
156 PARAMETER (mwaro2=150.0)
158 !rs molecular weight
159 REAL mwalk1
160 PARAMETER (mwalk1=140.0)
162 !rs molecular weight
163 REAL mwalk2
164 PARAMETER (mwalk2=140.0)
166 !rs molecular weight
167 !rs molecular weight
168 REAL mwole1
169 PARAMETER (mwole1=140.0)
171 !rs molecular weight
172 REAL mwapi1
173 PARAMETER (mwapi1=200.0)
175 !rs molecular weight
176 REAL mwapi2
177 PARAMETER (mwapi2=200.0)
179 !rs molecular weight
180 REAL mwlim1
181 PARAMETER (mwlim1=200.0)
183 !rs molecular weight
184 REAL mwlim2
185 PARAMETER (mwlim2=200.0)
188 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
190 INTEGER :: i,j,k,l,debug_level
191 !
192 ! convert advected aerosol variables to ug/m3 from mixing ratio
193 ! they will be converted back at the end of this driver
194 !
195 do l=p_so4aj,num_chem
196 do j=jts,jte
197 do k=kts,kte
198 do i=its,ite
199 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j))
200 enddo
201 enddo
202 enddo
203 enddo
204 do 100 j=jts,jte
205 do 100 i=its,ite
206 debug_level=0
207 do k=kts,kte
208 t(k) = t_phy(i,k,j)
209 p(k) = .001*p_phy(i,k,j)
210 rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / &
211 (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
212 (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) )
213 rh(k)=max(.1,0.01*rh(k))
214 enddo
215 do k=kts,kte
216 ! if(timer.gt.2.)then
217 ! if((i.eq.12.and.j.eq.17.and.k.eq.1).or. &
218 ! (i.eq.12.and.j.eq.7.and.k.eq.2).or. &
219 ! (i.eq.1.and.j.eq.17.and.k.eq.2))iprt=1
220 ! if(debug_level.ge.1)print *,ktau,timer,i,j,k,p(k),t(k),dtstep,rgas,vcsulf_old(i,k,j),MWSO4,chem(i,k,j,p_sulf)
221 ! endif
222 cblk=0.
223 do l=1,ldrog
224 drog_in(l)=0.
225 enddo
226 do l=1,lspcv
227 condvap_in(l)=0.
228 enddo
229 convfac = p(k)/rgas/t(k)*1000.
230 so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
231 soilrat_in = 0.
232 nitrate_in =max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
233 nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
234 hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl)
235 ! hcl_in = 0.
236 vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
237 ! if(i.eq.28.and.j.eq.25.and.k.eq.1)then
238 ! print *,'vsulfin = ',vsulf_in,chem(i,k,j,p_sulf),convfac,mwso4
239 ! print *,'nitratein = ',nitrate_in,chem(i,k,j,p_hno3)
240 ! print *,'nh3in = ',nh3_in,chem(i,k,j,p_nh3)
241 ! print *,'hclin = ',hcl_in,chem(i,k,j,p_hcl)
242 ! print *,'pso4ai = ',chem(i,k,j,p_so4aj),chem(i,k,j,p_no3aj),chem(i,k,j,p_nh4aj),chem(i,k,j,p_naaj)
243 ! endif
245 !rs
246 !rs * organic aerosol precursors
247 !rs * anthropogenic organics DeltaROG
248 drog_in(PXYL ) = VDROG3(i,k,j,PXYL )
249 drog_in(PTOL ) = VDROG3(i,k,j,PTOL )
250 drog_in(PCSL1) = VDROG3(i,k,j,PCSL1)
251 drog_in(PCSL2) = VDROG3(i,k,j,PCSL2)
252 drog_in(PHC8 ) = VDROG3(i,k,j,PHC8 )
253 drog_in(POLI1) = VDROG3(i,k,j,POLI1)
254 drog_in(POLI2) = VDROG3(i,k,j,POLI2)
255 drog_in(POLI3) = VDROG3(i,k,j,POLI3)
256 drog_in(POLT1) = VDROG3(i,k,j,POLT1)
257 drog_in(POLT2) = VDROG3(i,k,j,POLT2)
258 drog_in(POLT3) = VDROG3(i,k,j,POLT3)
259 !rs * biogenic organics DeltaROG
260 if(p_lim.eq.1)then
261 ! if(p_ete.eq.1)then
262 drog_in(PAPI1) = 0.
263 drog_in(PAPI2) = 0.
264 drog_in(PAPI3) = 0.
265 drog_in(PLIM1) = 0.
266 drog_in(PLIM2) = 0.
267 drog_in(PLIM3) = 0.
268 condvap_in(PSOAAPI1) = 0.
269 condvap_in(PSOAAPI2) = 0.
270 condvap_in(PSOALIM1) = 0.
271 condvap_in(PSOALIM2) = 0.
272 elseif(p_lim.gt.1)then
273 ! elseif(p_ete.gt.1)then
274 drog_in(PAPI1) = VDROG3(i,k,j,PAPI1)
275 drog_in(PAPI2) = VDROG3(i,k,j,PAPI2)
276 drog_in(PAPI3) = VDROG3(i,k,j,PAPI3)
277 drog_in(PLIM1) = VDROG3(i,k,j,PLIM1)
278 drog_in(PLIM2) = VDROG3(i,k,j,PLIM2)
279 drog_in(PLIM3) = VDROG3(i,k,j,PLIM3)
280 condvap_in(PSOAAPI1) = max(epsilc,cvapi1(i,k,j))
281 condvap_in(PSOAAPI2) = max(epsilc,cvapi2(i,k,j))
282 condvap_in(PSOALIM1) = max(epsilc,cvlim1(i,k,j))
283 condvap_in(PSOALIM2) = max(epsilc,cvlim2(i,k,j))
284 endif
285 condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
286 condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
287 condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
288 condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
289 cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j)
290 cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i)
291 cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j)
292 cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i)
293 cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j)
294 cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i)
295 cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j)
296 cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i)
297 cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j)
298 cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i)
299 cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j)
300 cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i)
301 cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j)
302 cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i)
303 cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j)
304 cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i)
305 cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj)
306 cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai)
307 cblk(1,VECJ ) = chem(i,k,j,p_ecj)
308 cblk(1,VECI ) = chem(i,k,j,p_eci)
309 cblk(1,VP25AJ ) = chem(i,k,j,p_p25j)
310 cblk(1,VP25AI ) = chem(i,k,j,p_p25i)
311 cblk(1,VANTHA ) = chem(i,k,j,p_antha)
312 cblk(1,VSEAS ) = chem(i,k,j,p_seas)
313 cblk(1,VSOILA ) = chem(i,k,j,p_soila)
314 cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j))
315 cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j))
316 cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j))
317 cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j))
318 cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j))
319 cblk(1,VCVARO1 ) = max(epsilc,cvaro1(i,k,j))
320 cblk(1,VCVARO2 ) = max(epsilc,cvaro2(i,k,j))
321 cblk(1,VCVALK1 ) = max(epsilc,cvalk1(i,k,j))
322 cblk(1,VCVOLE1 ) = max(epsilc,cvole1(i,k,j))
323 ! cblk(1,VCVAPI1 ) = 0.
324 ! cblk(1,VCVAPI2 ) = 0.
325 ! cblk(1,VCVLIM1 ) = 0.
326 ! cblk(1,VCVLIM2 ) = 0.
327 cblk(1,VCVAPI1 ) = max(epsilc,cvapi1(i,k,j))
328 cblk(1,VCVAPI2 ) = max(epsilc,cvapi2(i,k,j))
329 cblk(1,VCVLIM1 ) = max(epsilc,cvlim1(i,k,j))
330 cblk(1,VCVLIM2 ) = max(epsilc,cvlim2(i,k,j))
332 !
333 ! Set emissions to zero
334 !
335 epmcoarse(1) = 0.
336 epm25i(1) = 0.
337 epm25j (1) = 0.
338 eeci_in = 0.
339 eecj_in = 0.
340 eorgi_in = 0.
341 eorgj_in = 0.
342 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
343 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
344 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
345 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
346 cblk(1,VNAAJ ) = chem(i,k,j,p_naaj)
347 cblk(1,VNAAI ) = chem(i,k,j,p_naai)
348 cblk(1,VCLAJ ) = chem(i,k,j,p_claj)
349 cblk(1,VCLAI ) = chem(i,k,j,p_clai)
350 ! cblk(1,VCLAJ ) = 0.
351 ! cblk(1,VCLAI ) = 0.
352 !
353 ! Set emissions to zero when above level kemit.
354 !
355 ! if( k > kemit ) then
356 ! epmcoarse(1) = 0.
357 ! epm25i(1) = 0.
358 ! epm25j (1) = 0.
359 ! eeci_in = 0.
360 ! eecj_in = 0.
361 ! eorgi_in = 0.
362 ! eorgj_in = 0.
363 ! cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
364 ! cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
365 ! cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
366 ! cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
367 ! else
368 ! epmcoarse(1) = emis_ant(i,k,j,p_e_pm_10)/dz8w(i,k,j)
369 ! epm25i(1) = emis_ant(i,k,j,p_e_pm25i)/dz8w(i,k,j)
370 ! epm25j(1) = emis_ant(i,k,j,p_e_pm25j)/dz8w(i,k,j)
371 ! eeci_in = emis_ant(i,k,j,p_e_eci)/dz8w(i,k,j)
372 ! eecj_in = emis_ant(i,k,j,p_e_ecj)/dz8w(i,k,j)
373 ! eorgi_in = emis_ant(i,k,j,p_e_orgi)/dz8w(i,k,j)
374 ! eorgj_in = emis_ant(i,k,j,p_e_orgj)/dz8w(i,k,j)
375 ! cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)+emis_ant(i,k,j,p_e_so4j)/dz8w(i,k,j)*dtstep
376 ! cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)+emis_ant(i,k,j,p_e_so4i)/dz8w(i,k,j)*dtstep
377 ! cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)+emis_ant(i,k,j,p_e_no3j)/dz8w(i,k,j)*dtstep
378 ! cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)+emis_ant(i,k,j,p_e_no3i)/dz8w(i,k,j)*dtstep
379 ! end if
380 !rs. nitrate, nh3, sulf
381 cblk(1,vsulf) = vsulf_in
382 cblk(1,vhno3) = nitrate_in
383 cblk(1,vnh3) = nh3_in
384 cblk(1,vhcl) = hcl_in
385 cblk(1,VNH4AJ ) = chem(i,k,j,p_nh4aj)
386 cblk(1,VNH4AI ) = chem(i,k,j,p_nh4ai)
387 cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0))
388 cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0))
389 cblk(1,VCORN ) = chem(i,k,j,p_corn)
392 if(debug_level.ge.1)then
393 if(i.eq.its.and.j.eq.jts.and.k.eq.kts)then
394 print*,'in a_mechanisms',i,j,k
395 print*,'NSPCSDA, BLKSIZE',NSPCSDA, BLKSIZE
396 print*,'k,DTA,PRES,TEMP,RELHUM',k,DTstep,10.*P(k),T(k),RH(k)
397 print*,'nitrate_in, nh3_in, vsulf_in, so4rat_in', &
398 nitrate_in, nh3_in, vsulf_in, so4rat_in
399 print*,'drog_in,ldrog',drog_in,ldrog
400 print*,'condvap_in,NCV,NACV',condvap_in,NCV,NACV
401 print*,'eeci_in, eecj_in, eorgi_in, eorgj_in,convfac' &
402 ,eeci_in, eecj_in, eorgi_in, eorgj_in,convfac
403 print*,'CBLK',CBLK
404 endif
405 end if
406 CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh(k),nitrate_in,nh3_in, &
407 vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv,nacv,eeci_in,eecj_in, &
408 eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k)
409 chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
410 chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
411 chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
412 chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
413 chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
414 chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
415 chem(i,k,j,p_naaj) = cblk(1,VNAAJ )
416 chem(i,k,j,p_naai) = cblk(1,VNAAI )
418 chem(i,k,j,p_claj) = cblk(1,VCLAJ )
419 chem(i,k,j,p_clai) = cblk(1,VCLAI )
421 chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
422 chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
423 chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
424 chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
425 chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
426 chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
427 chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
428 chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
429 chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
430 chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
431 chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
432 chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
433 chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
434 chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
435 chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
436 chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
437 chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ )
438 chem(i,k,j,p_orgpai) = cblk(1,VORGPAI )
439 chem(i,k,j,p_ecj) = cblk(1,VECJ )
440 chem(i,k,j,p_eci) = cblk(1,VECI )
441 chem(i,k,j,p_p25j) = cblk(1,VP25AJ )
442 chem(i,k,j,p_p25i) = cblk(1,VP25AI )
443 chem(i,k,j,p_antha) =cblk(1,VANTHA )
444 chem(i,k,j,p_seas) = cblk(1,VSEAS )
445 chem(i,k,j,p_soila) = cblk(1,VSOILA )
446 chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 ))
447 chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 ))
448 ! chem(i,k,j,p_ac0) = cblk(1,VAC0 )
449 chem(i,k,j,p_corn) = cblk(1,VCORN )
450 h2oaj(i,k,j) = cblk(1,VH2OAJ )
451 h2oai(i,k,j) = cblk(1,VH2OAI )
452 nu3(i,k,j) = cblk(1,VNU3 )
453 ac3(i,k,j) = cblk(1,VAC3 )
454 cor3(i,k,j) = cblk(1,VCOR3 )
455 cvaro1(i,k,j) = cblk(1,VCVARO1 )
456 cvaro2(i,k,j) = cblk(1,VCVARO2 )
457 cvalk1(i,k,j) = cblk(1,VCVALK1 )
458 cvole1(i,k,j) = cblk(1,VCVOLE1 )
459 ! cvapi1(i,k,j) = 0.
460 ! cvapi2(i,k,j) = 0.
461 ! cvlim1(i,k,j) = 0.
462 ! cvlim2(i,k,j) = 0.
463 cvapi1(i,k,j) = cblk(1,VCVAPI1 )
464 cvapi2(i,k,j) = cblk(1,VCVAPI2 )
465 cvlim1(i,k,j) = cblk(1,VCVLIM1 )
466 cvlim2(i,k,j) = cblk(1,VCVLIM2 )
468 chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
469 chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
470 chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
471 chem(i,k,j,p_hcl)=max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL)
472 ! if(i.eq.28.and.j.eq.25.and.k.eq.1)then
473 ! print *,vhcl
474 ! print *,'vsulfout = ',chem(i,k,j,p_sulf)
475 ! print *,'nitrateout = ',chem(i,k,j,p_hno3)
476 ! print *,'nh3out = ',chem(i,k,j,p_nh3)
477 ! print *,'hclout = ',cblk(1,vhcl)/CONVFAC/MWHCL
478 ! print *,'pso4ai = ',chem(i,k,j,p_so4aj),chem(i,k,j,p_no3aj),chem(i,k,j,p_nh4aj),chem(i,k,j,p_naaj)
479 ! endif
480 enddo ! k-loop
481 100 continue ! i,j-loop
483 !
484 ! convert aerosol variables back to mixing ratio from ug/m3
485 !
486 do l=p_so4aj,num_chem
487 do j=jts,jte
488 do k=kts,kte
489 do i=its,ite
490 chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j))
491 enddo
492 enddo
493 enddo
494 enddo
496 END SUBROUTINE sorgam_driver
497 ! ///////////////////////////////////////////////////
498 SUBROUTINE sum_pm_sorgam ( &
499 alt, chem, h2oaj, h2oai, &
500 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, &
501 dust_opt,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
519 INTEGER :: i,ii,j,jj,k,n
520 !
521 ! sum up pm2_5 and pm10 output
522 !
523 pm2_5_dry(its:ite, kts:kte, jts:jte) = 0.
524 pm2_5_water(its:ite, kts:kte, jts:jte) = 0.
525 pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0.
526 do j=jts,jte
527 jj=min(jde-1,j)
528 do k=kts,kte
529 do i=its,ite
530 ii=min(ide-1,i)
531 ! if(dust_opt == 1 ) then
532 ! first add gocart dust and seasalt (aqmeii)
533 ! pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,p_dust_1)+ &
534 ! .286*chem(ii,k,jj,p_dust_2) + &
535 ! chem(ii,k,jj,p_seas_1) + &
536 ! .942*chem(ii,k,jj,p_seas_2)
537 ! endif
538 !
539 do n=p_so4aj,p_p25i
540 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
541 enddo
542 if( p_p25cwi .gt. p_p25i) then
543 do n=p_so4cwj,p_p25cwi
544 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n)
545 enddo
546 endif
547 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) &
548 + chem(ii,k,jj,p_eci)
549 pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) &
550 + h2oai(i,k,j)
552 !Convert the units from mixing ratio to concentration (ug m^-3)
553 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,k,jj)
554 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj)
555 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,k,jj)
556 enddo
557 enddo
558 enddo
559 do j=jts,jte
560 jj=min(jde-1,j)
561 do k=kts,kte
562 do i=its,ite
563 ii=min(ide-1,i)
564 ! if(dust_opt == 1 ) then
565 ! pm10(i,k,j) = pm2_5_dry(i,k,j) &
566 ! + ( chem(ii,k,jj,p_antha) &
567 ! + .714*chem(ii,k,jj,p_dust_2) &
568 ! + chem(ii,k,jj,p_dust_3) &
569 ! + .058*chem(ii,k,jj,p_seas_2) &
570 ! + chem(ii,k,jj,p_seas_3) ) / alt(ii,k,jj)
571 ! else
572 pm10(i,k,j) = pm2_5_dry(i,k,j) &
573 + ( chem(ii,k,jj,p_antha) &
574 + chem(ii,k,jj,p_soila) &
575 + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj)
576 if( p_p25cwi .gt. p_p25i) then
577 pm10(i,k,j) = pm10(i,k,j) &
578 + ( chem(ii,k,jj,p_anthcw) &
579 + chem(ii,k,jj,p_soilcw) &
580 + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj)
581 endif
582 ! endif
583 enddo
584 enddo
585 enddo
586 END SUBROUTINE sum_pm_sorgam
587 ! ///////////////////////////////////////////////////
588 SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, &
589 ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, &
590 alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, &
591 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
592 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, &
593 aer_res,vgsa, &
594 numgas,ddflx, &
595 numaer, &
596 ids,ide, jds,jde, kds,kde, &
597 ims,ime, jms,jme, kms,kme, &
598 its,ite, jts,jte, kts,kte )
600 USE module_configure,only: grid_config_rec_type
601 TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags
602 INTEGER, INTENT(IN ) :: &
603 numgas, &
604 numaer, &
605 ids,ide, jds,jde, kds,kde, &
606 ims,ime, jms,jme, kms,kme, &
607 its,ite, jts,jte, kts,kte, &
608 id,ktau
610 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
611 INTENT(IN ) :: moist
612 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
613 INTENT(INOUT ) :: chem
614 !
615 ! following are aerosol arrays that are not advected
616 !
617 REAL, DIMENSION( its:ite, jts:jte, numaer ), &
618 INTENT(INOUT ) :: &
619 vgsa
620 real, intent(inout), &
621 dimension( ims:ime, jms:jme, numgas+1:num_chem ) :: &
622 ddflx
624 REAL, DIMENSION( its:ite, jts:jte ), &
625 INTENT(INOUT ) :: &
626 aer_res
628 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
629 INTENT(INOUT ) :: &
630 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
631 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
632 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
633 INTENT(IN ) :: &
634 t_phy, &
635 alt, &
636 p_phy, &
637 dz8w, &
638 z , &
639 t8w,p8w,z_at_w , &
640 rho_phy
641 REAL, DIMENSION( ims:ime , jms:jme ) , &
642 INTENT(IN ) :: &
643 ust,rmol, pbl, znt
644 REAL, INTENT(IN ) :: &
645 dtstep
647 REAL rgas
648 DATA rgas/8.314510/
649 REAL convfac,convfac2
650 !...BLKSIZE set to one in column model ciarev02
652 INTEGER blksize
653 PARAMETER (blksize=1)
655 !...number of aerosol species
656 ! number of species (gas + aerosol)
657 INTEGER nspcsda
658 PARAMETER (nspcsda=l1ae) !bs
659 ! (internal aerosol dynamics)
660 !bs # of anth. cond. vapors in SORGAM
661 INTEGER nacv
662 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
663 !bs total # of cond. vapors in SORGAM
664 INTEGER ncv
665 PARAMETER (ncv=lspcv) !bs
666 !bs total # of cond. vapors in CTM
667 REAL cblk(blksize,nspcsda) ! main array of variables
668 ! particles [ug/m^3/s]
669 REAL soilrat_in
670 ! emission rate of soil derived coars
671 ! input HNO3 to CBLK [ug/m^3]
672 REAL nitrate_in
673 ! input NH3 to CBLK [ug/m^3]
674 REAL nh3_in
675 ! ! input hcl vapor
676 REAL hcl_in
677 ! input SO4 vapor [ug/m^3]
678 REAL vsulf_in
680 REAL so4rat_in
681 ! input SO4 formation[ug/m^3/sec]
682 ! pressure in cb
683 REAL pres
684 ! temperature in K
685 REAL temp
686 !bs
687 REAL relhum
688 ! rel. humidity (0,1)
689 REAL ::p(kts:kte),t(kts:kte),rh(kts:kte)
691 !...molecular weights ciarev02
693 ! molecular weight for SO4
694 REAL mwso4
695 PARAMETER (mwso4=96.0576)
697 ! molecular weight for HNO3
698 REAL mwhno3
699 PARAMETER (mwhno3=63.01287)
701 ! molecular weight for NH3
702 REAL mwnh3
703 PARAMETER (mwnh3=17.03061)
705 !molecular weight for HCL
706 REAL mwhcl
707 PARAMETER (mwhcl=36.46100)
709 !bs molecular weight for Organic Spec
710 ! REAL mworg
711 ! PARAMETER (mworg=175.0)
713 !bs molecular weight for Elemental Ca
714 REAL mwec
715 PARAMETER (mwec=12.0)
717 !rs molecular weight
718 REAL mwaro1
719 PARAMETER (mwaro1=150.0)
721 !rs molecular weight
722 REAL mwaro2
723 PARAMETER (mwaro2=150.0)
725 !rs molecular weight
726 REAL mwalk1
727 PARAMETER (mwalk1=140.0)
729 !rs molecular weight
730 REAL mwalk2
731 PARAMETER (mwalk2=140.0)
733 !rs molecular weight
734 !rs molecular weight
735 REAL mwole1
736 PARAMETER (mwole1=140.0)
738 !rs molecular weight
739 REAL mwapi1
740 PARAMETER (mwapi1=200.0)
742 !rs molecular weight
743 REAL mwapi2
744 PARAMETER (mwapi2=200.0)
746 !rs molecular weight
747 REAL mwlim1
748 PARAMETER (mwlim1=200.0)
750 !rs molecular weight
751 REAL mwlim2
752 PARAMETER (mwlim2=200.0)
753 INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model)
754 !ia kept to 1 in current version of column model
756 PARAMETER( NUMCELLS = 1)
759 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
760 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
761 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
762 REAL PBLH( BLKSIZE ) ! PBL height (m)
763 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
764 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
766 REAL BLKPRS(BLKSIZE) ! pressure in cb
767 REAL BLKTA(BLKSIZE) ! temperature in K
768 REAL BLKDENS(BLKSIZE) ! Air density in kg/m3
770 !
771 ! *** OUTPUT:
772 !
773 ! *** atmospheric properties
775 REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ]
776 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ]
778 ! *** followng is for future version
779 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
780 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
782 ! *** modal diameters: [ m ]
784 REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ]
785 REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ]
786 REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ]
789 ! *** aerosol properties:
791 ! *** Modal mass concentrations [ ug m**3 ]
793 REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode
794 REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode
795 REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode
797 ! *** average modal particle densities [ kg/m**3 ]
799 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode
800 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode
801 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode
803 ! *** average modal Knudsen numbers
805 REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number
806 REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number
807 REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number
810 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
812 INTEGER :: i,j,k,l
813 !
814 ! print *,'in sorgdepdriver ',its,ite,jts,jte
815 do l=1,numaer
816 do i=its,ite
817 do j=jts,jte
818 vgsa(i,j,l)=0.
819 enddo
820 enddo
821 enddo
822 vdep=0.
823 do 100 j=jts,jte
824 do 100 i=its,ite
825 cblk=epsilc
826 do k=kts,kte
827 t(k) = t_phy(i,k,j)
828 p(k) = .001*p_phy(i,k,j)
829 rh(k) = MIN( 100.,100. * moist(i,k,j,p_qv) / &
830 (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
831 (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))))
832 rh(k)=max(.05,0.01*rh(k))
833 enddo
834 ! do k=kts,kte
835 k=kts
836 convfac = p(k)/rgas/t(k)*1000.
837 nitrate_in =chem(i,k,j,p_hno3)*convfac*mwhno3
838 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
839 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4
840 hcl_in = chem(i,k,j,p_hcl)*convfac*mwhcl
842 !rs. nitrate, nh3, sulf
843 BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa
844 BLKTA(BLKSIZE) = T(K) ! temperature in K
845 USTAR(BLKSIZE) = max(1.e-1,UST(i,j))
846 WSTAR(BLKSIZE) = 0.
847 pblh(blksize) = pbl(i,j)
848 zntt(blksize) = znt(i,j)
849 rmolm(blksize)= rmol(i,j)
850 convfac2=1./alt(i,k,j)
851 BLKDENS(BLKSIZE)=convfac2
852 cblk(1,vsulf) = max(epsilc,vsulf_in)
853 cblk(1,vhno3) = max(epsilc,nitrate_in)
854 cblk(1,vnh3) = max(epsilc,nh3_in)
855 cblk(1,vhcl) = max(epsilc,hcl_in)
856 cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
857 cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
858 cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
859 cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
860 cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
861 cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
862 if (p_naai >= param_first_scalar) &
863 cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2)
864 if (p_naaj >= param_first_scalar) &
865 cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2)
866 if (p_clai >= param_first_scalar) &
867 cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2)
868 if (p_claj >= param_first_scalar) &
869 cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2)
870 cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
871 cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
872 cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
873 cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
874 cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
875 cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
876 cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
877 cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
878 cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
879 cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
880 cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
881 cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
882 cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
883 cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
884 cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
885 cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
886 cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
887 cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
888 cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2)
889 cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2)
890 cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2)
891 cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2)
892 cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2)
893 cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2)
894 cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2)
895 cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2)
896 cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2)
897 cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2)
898 cblk(1,VH2OAJ ) = h2oaj(i,k,j)
899 cblk(1,VH2OAI ) = h2oai(i,k,j)
900 cblk(1,VNU3 ) = nu3(i,k,j)
901 cblk(1,VAC3 ) = ac3(i,k,j)
902 cblk(1,VCOR3 ) = cor3(i,k,j)
903 cblk(1,VCVARO1 ) = cvaro1(i,k,j)
904 cblk(1,VCVARO2 ) = cvaro2(i,k,j)
905 cblk(1,VCVALK1 ) = cvalk1(i,k,j)
906 cblk(1,VCVOLE1 ) = cvole1(i,k,j)
907 ! cblk(1,VCVAPI1 ) = 0.
908 ! cblk(1,VCVAPI2 ) = 0.
909 ! cblk(1,VCVLIM1 ) = 0.
910 ! cblk(1,VCVLIM2 ) = 0.
911 cblk(1,VCVAPI1 ) = cvapi1(i,k,j)
912 cblk(1,VCVAPI2 ) = cvapi2(i,k,j)
913 cblk(1,VCVLIM1 ) = cvlim1(i,k,j)
914 cblk(1,VCVLIM2 ) = cvlim2(i,k,j)
915 !
916 !rs. get size distribution information
917 !
918 ! if(i.eq.126.and.j.eq.99)then
919 ! print *,'in modpar ',i,j
920 ! print *,cblk,BLKTA,BLKPRS,USTAR
921 ! print *,'BLKSIZE, NSPCSDA, NUMCELLS'
922 ! print *,BLKSIZE, NSPCSDA, NUMCELLS
923 ! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
924 ! print *,XLM, AMU,PDENSN, PDENSA, PDENSC
925 ! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
926 ! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
927 ! endif
929 CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, &
930 CBLK, &
931 BLKTA, BLKPRS, &
932 PMASSN, PMASSA, PMASSC, &
933 PDENSN, PDENSA, PDENSC, &
934 XLM, AMU, &
935 DGNUC, DGACC, DGCOR, &
936 KNNUC, KNACC,KNCOR )
937 ! print *,'out modpar ',i,j
938 if (config_flags%aer_drydep_opt == 11) then
939 CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
940 BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, &
941 DGNUC, DGACC, DGCOR, &
942 KNNUC, KNACC,KNCOR, &
943 PDENSN, PDENSA, PDENSC, &
944 VSED, VDEP )
945 else
946 CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
947 BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,&
948 ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,&
949 KNNUC, KNACC,KNCOR, &
950 PDENSN, PDENSA, PDENSC, &
951 VSED, VDEP )
952 endif
954 VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC )
955 VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC )
956 VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ )
957 VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI )
958 VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ )
959 VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI )
960 if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI )
961 if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ )
962 if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI )
963 if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ )
964 VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ )
965 VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI )
966 VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ )
967 VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI )
968 VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ )
969 VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI )
970 VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ )
971 VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI )
972 VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ )
973 VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI )
974 VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ )
975 VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI )
976 VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ )
977 VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI )
978 VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ )
979 VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI )
980 VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ )
981 VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI )
982 VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ )
983 VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI )
984 VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ )
985 VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI )
986 VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR )
987 VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA )
988 VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA )
989 VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC )
990 VGSA(i, j, VAC0 ) = VDEP(1, VDNACC )
991 VGSA(i, j, VCORN ) = VDEP(1, VDNCOR )
992 if( config_flags%diagnostic_dep == 1) then
993 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
994 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
995 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
996 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
997 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
998 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
999 ddflx(i,j,p_orgaro1j)=ddflx(i,j,p_orgaro1j)+chem(i,k,j,p_orgaro1j)/alt(i,k,j)*VGSA(i,j,VORGARO1J)*dtstep
1000 ddflx(i,j,p_orgaro1i)=ddflx(i,j,p_orgaro1i)+chem(i,k,j,p_orgaro1i)/alt(i,k,j)*VGSA(i,j,VORGARO1I)*dtstep
1001 ddflx(i,j,p_orgaro2j)=ddflx(i,j,p_orgaro2j)+chem(i,k,j,p_orgaro2j)/alt(i,k,j)*VGSA(i,j,VORGARO2J)*dtstep
1002 ddflx(i,j,p_orgaro2i)=ddflx(i,j,p_orgaro2i)+chem(i,k,j,p_orgaro2i)/alt(i,k,j)*VGSA(i,j,VORGARO2I)*dtstep
1003 ddflx(i,j,p_orgalk1j)=ddflx(i,j,p_orgalk1j)+chem(i,k,j,p_orgalk1j)/alt(i,k,j)*VGSA(i,j,VORGALK1J)*dtstep
1004 ddflx(i,j,p_orgalk1i)=ddflx(i,j,p_orgalk1i)+chem(i,k,j,p_orgalk1i)/alt(i,k,j)*VGSA(i,j,VORGALK1I)*dtstep
1005 ddflx(i,j,p_orgole1j)=ddflx(i,j,p_orgole1j)+chem(i,k,j,p_orgole1j)/alt(i,k,j)*VGSA(i,j,VORGOLE1J)*dtstep
1006 ddflx(i,j,p_orgole1i)=ddflx(i,j,p_orgole1i)+chem(i,k,j,p_orgole1i)/alt(i,k,j)*VGSA(i,j,VORGOLE1I)*dtstep
1007 ddflx(i,j,p_orgba1j)=ddflx(i,j,p_orgba1j)+chem(i,k,j,p_orgba1j)/alt(i,k,j)*VGSA(i,j,VORGBA1J)*dtstep
1008 ddflx(i,j,p_orgba1i)=ddflx(i,j,p_orgba1i)+chem(i,k,j,p_orgba1i)/alt(i,k,j)*VGSA(i,j,VORGBA1I)*dtstep
1009 ddflx(i,j,p_orgba2j)=ddflx(i,j,p_orgba2j)+chem(i,k,j,p_orgba2j)/alt(i,k,j)*VGSA(i,j,VORGBA2J)*dtstep
1010 ddflx(i,j,p_orgba2i)=ddflx(i,j,p_orgba2i)+chem(i,k,j,p_orgba2i)/alt(i,k,j)*VGSA(i,j,VORGBA2I)*dtstep
1011 ddflx(i,j,p_orgba3j)=ddflx(i,j,p_orgba3j)+chem(i,k,j,p_orgba3j)/alt(i,k,j)*VGSA(i,j,VORGBA3J)*dtstep
1012 ddflx(i,j,p_orgba3i)=ddflx(i,j,p_orgba3i)+chem(i,k,j,p_orgba3i)/alt(i,k,j)*VGSA(i,j,VORGBA3I)*dtstep
1013 ddflx(i,j,p_orgba4j)=ddflx(i,j,p_orgba4j)+chem(i,k,j,p_orgba4j)/alt(i,k,j)*VGSA(i,j,VORGBA4J)*dtstep
1014 ddflx(i,j,p_orgba4i)=ddflx(i,j,p_orgba4i)+chem(i,k,j,p_orgba4i)/alt(i,k,j)*VGSA(i,j,VORGBA4I)*dtstep
1015 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
1016 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
1017 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
1018 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
1019 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
1020 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
1021 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
1022 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
1023 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
1024 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
1025 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
1026 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
1027 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
1028 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
1029 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
1030 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
1031 end if
1033 ! enddo ! k-loop
1034 100 continue ! i,j-loop
1036 END SUBROUTINE sorgam_depdriver
1037 ! ///////////////////////////////////////////////////
1038 SUBROUTINE actcof(cat,an,gama,molnu,phimult)
1040 !-----------------------------------------------------------------------
1042 ! DESCRIPTION:
1044 ! This subroutine computes the activity coefficients of (2NH4+,SO4--),
1045 ! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
1046 ! multicomponent solution, using Bromley's model and Pitzer's method.
1048 ! REFERENCES:
1050 ! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
1051 ! in aqueous solutions. AIChE J. 19, 313-320.
1053 ! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of
1054 ! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
1056 ! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
1057 ! of strong acids over saline solutions - I HNO3,
1058 ! Atmos. Environ. (22): 91-100
1060 ! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
1061 ! and mean activity and osmotic coefficients of 0-100% nitric acid
1062 ! as a function of temperature, J. Phys. Chem (94): 5369 - 5380
1064 ! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
1065 ! general equilibrium model for inorganic multicomponent atmospheric
1066 ! aerosols. Atmos. Environ. 21(11), 2453-2466.
1071 ! ARGUMENT DESCRIPTION:
1073 ! CAT(1) : conc. of H+ (moles/kg)
1074 ! CAT(2) : conc. of NH4+ (moles/kg)
1075 ! AN(1) : conc. of SO4-- (moles/kg)
1076 ! AN(2) : conc. of NO3- (moles/kg)
1077 ! AN(3) : conc. of HSO4- (moles/kg)
1078 ! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--)
1079 ! GAMA(2,2) : (NH4+,NO3-)
1080 ! GAMA(2,3) : (NH4+. HSO4-)
1081 ! GAMA(1,1) : (2H+,SO4--)
1082 ! GAMA(1,2) : (H+,NO3-)
1083 ! GAMA(1,3) : (H+,HSO4-)
1084 ! MOLNU : the total number of moles of all ions.
1085 ! PHIMULT : the multicomponent paractical osmotic coefficient.
1087 ! REVISION HISTORY:
1088 ! Who When Detailed description of changes
1089 ! --------- -------- -------------------------------------------
1090 ! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this
1091 ! new routine using a method described by Pilini
1092 ! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
1093 ! S.Roselle 7/30/97 Modified for use in Models-3
1094 ! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA
1096 !-----------------------------------------------------------------------
1098 ! IMPLICIT NONE
1100 !...........INCLUDES and their descriptions
1102 ! INCLUDE SUBST_XSTAT ! M3EXIT status codes
1103 !....................................................................
1105 ! Normal, successful completion
1106 INTEGER xstat0
1107 PARAMETER (xstat0=0)
1108 ! File I/O error
1109 INTEGER xstat1
1110 PARAMETER (xstat1=1)
1111 ! Execution error
1112 INTEGER xstat2
1113 PARAMETER (xstat2=2)
1114 ! Special error
1115 INTEGER xstat3
1116 PARAMETER (xstat3=3)
1118 CHARACTER*120 xmsg
1120 !...........PARAMETERS and their descriptions:
1122 ! number of cations
1123 INTEGER ncat
1124 PARAMETER (ncat=2)
1126 ! number of anions
1127 INTEGER nan
1128 PARAMETER (nan=3)
1130 !...........ARGUMENTS and their descriptions
1132 ! tot # moles of all ions
1133 REAL molnu
1134 ! multicomponent paractical osmo
1135 REAL phimult
1136 REAL cat(ncat) ! cation conc in moles/kg (input
1137 REAL an(nan) ! anion conc in moles/kg (input)
1138 REAL gama(ncat,nan)
1139 !...........SCRATCH LOCAL VARIABLES and their descriptions:
1141 ! mean molal ionic activity coef
1142 CHARACTER*16 & ! driver program name
1143 pname
1144 SAVE pname
1146 ! anion indX
1147 INTEGER ian
1149 INTEGER icat
1150 ! cation indX
1152 REAL fgama
1153 ! ionic strength
1154 REAL i
1156 REAL r
1158 REAL s
1160 REAL ta
1162 REAL tb
1164 REAL tc
1166 REAL texpv
1168 REAL trm
1169 ! 2*ionic strength
1170 REAL twoi
1171 ! 2*sqrt of ionic strength
1172 REAL twosri
1174 REAL zbar
1176 REAL zbar2
1178 REAL zot1
1179 ! square root of ionic strength
1180 REAL sri
1181 REAL f2(ncat)
1182 REAL f1(nan)
1183 REAL zp(ncat) ! absolute value of charges of c
1184 REAL zm(nan) ! absolute value of charges of a
1185 REAL bgama(ncat,nan)
1186 REAL x(ncat,nan)
1187 REAL m(ncat,nan) ! molality of each electrolyte
1188 REAL lgama0(ncat,nan) ! binary activity coefficients
1189 REAL y(nan,ncat)
1190 REAL beta0(ncat,nan) ! binary activity coefficient pa
1191 REAL beta1(ncat,nan) ! binary activity coefficient pa
1192 REAL cgama(ncat,nan) ! binary activity coefficient pa
1193 REAL v1(ncat,nan) ! number of cations in electroly
1194 REAL v2(ncat,nan)
1195 ! number of anions in electrolyt
1196 DATA zp/1.0, 1.0/
1197 DATA zm/2.0, 1.0, 1.0/
1198 DATA xmsg/' '/
1199 DATA pname/'ACTCOF'/
1201 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1203 ! *** (1,1);(1,3) - Clegg & Brimblecombe (1988)
1204 ! *** (2,3) - Pilinis & Seinfeld (1987), cgama different
1205 ! *** (1,2) - Clegg & Brimblecombe (1990)
1206 ! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992)
1208 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1210 DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 &
1211 /
1212 ! 2H+SO4
1213 DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 &
1214 /
1215 ! HNO3
1216 DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 &
1217 /
1218 ! H+HSO4
1219 DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/, &
1220 cgama(2,1)/ -1.2683E-3 &
1221 /
1222 ! (NH4)2
1223 DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/, &
1224 cgama(2,2)/3.51217E-5 &
1225 /
1226 ! NH4NO3
1227 DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 &
1228 /
1229 ! NH4HSO
1230 DATA v1(1,1), v2(1,1)/2.0, 1.0 & ! 2H+SO4-
1231 /
1232 DATA v1(2,1), v2(2,1)/2.0, 1.0 & ! (NH4)2SO4
1233 /
1234 DATA v1(1,2), v2(1,2)/1.0, 1.0 & ! HNO3
1235 /
1236 DATA v1(2,2), v2(2,2)/1.0, 1.0 & ! NH4NO3
1237 /
1238 DATA v1(1,3), v2(1,3)/1.0, 1.0 & ! H+HSO4-
1239 /
1240 DATA v1(2,3), v2(2,3)/1.0, 1.0 &
1241 /
1242 !-----------------------------------------------------------------------
1243 ! begin body of subroutine ACTCOF
1245 !...compute ionic strength
1247 ! NH4HSO4
1248 i = 0.0
1250 DO icat = 1, ncat
1251 i = i + cat(icat)*zp(icat)*zp(icat)
1252 END DO
1254 DO ian = 1, nan
1255 i = i + an(ian)*zm(ian)*zm(ian)
1256 END DO
1258 i = 0.5*i
1260 !...check for problems in the ionic strength
1262 IF (i==0.0) THEN
1264 DO ian = 1, nan
1265 DO icat = 1, ncat
1266 gama(icat,ian) = 0.0
1267 END DO
1268 END DO
1270 ! xmsg = 'Ionic strength is zero...returning zero activities'
1271 ! WRITE (6,*) xmsg
1272 RETURN
1274 ELSE IF (i<0.0) THEN
1275 xmsg = 'WARNING: Ionic strength below zero (= negative ion concentrations) - setting ion concentrations to zero.'
1276 call wrf_message(xmsg)
1277 DO ian = 1, nan
1278 DO icat = 1, ncat
1279 gama(icat,ian) = 0.0
1280 END DO
1281 END DO
1282 RETURN
1284 END IF
1286 !...compute some essential expressions
1288 sri = sqrt(i)
1289 twosri = 2.0*sri
1290 twoi = 2.0*i
1291 texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1292 r = 1.0 + 0.75*i
1293 s = 1.0 + 1.5*i
1294 zot1 = 0.511*sri/(1.0+sri)
1296 !...Compute binary activity coeffs
1298 fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1300 DO icat = 1, ncat
1301 DO ian = 1, nan
1303 bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1304 )*texpv
1306 !...compute the molality of each electrolyte for given ionic strength
1308 m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1309 (1.0/(v1(icat,ian)+v2(icat,ian)))
1311 !...calculate the binary activity coefficients
1313 lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1314 ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1315 ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1316 v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1317 ian)))/2.302585093
1319 END DO
1320 END DO
1322 !...prepare variables for computing the multicomponent activity coeffs
1324 DO ian = 1, nan
1325 DO icat = 1, ncat
1326 zbar = (zp(icat)+zm(ian))*0.5
1327 zbar2 = zbar*zbar
1328 y(ian,icat) = zbar2*an(ian)/i
1329 x(icat,ian) = zbar2*cat(icat)/i
1330 END DO
1331 END DO
1333 DO ian = 1, nan
1334 f1(ian) = 0.0
1335 DO icat = 1, ncat
1336 f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1337 zot1*zp(icat)*zm(ian)*x(icat,ian)
1338 END DO
1339 END DO
1341 DO icat = 1, ncat
1342 f2(icat) = 0.0
1343 DO ian = 1, nan
1344 f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1345 zot1*zp(icat)*zm(ian)*y(ian,icat)
1346 END DO
1347 END DO
1349 !...now calculate the multicomponent activity coefficients
1351 DO ian = 1, nan
1352 DO icat = 1, ncat
1354 ta = -zot1*zp(icat)*zm(ian)
1355 tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1356 tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1357 trm = ta + tb*tc
1359 IF (trm>30.0) THEN
1360 gama(icat,ian) = 1.0E+30
1361 ! xmsg = 'Multicomponent activity coefficient is extremely large'
1362 ! WRITE (6,*) xmsg
1363 ELSE
1364 gama(icat,ian) = 10.0**trm
1365 END IF
1367 END DO
1368 END DO
1370 RETURN
1371 !ia*********************************************************************
1372 END SUBROUTINE actcof
1373 !ia
1374 !ia AEROSOL DYNAMICS DRIVER ROUTINE *
1375 !ia based on MODELS3 formulation by FZB
1376 !ia Modified by IA in November 97
1377 !ia
1378 !ia Revision history
1379 !ia When WHO WHAT
1380 !ia ---- ---- ----
1381 !ia ???? FZB BEGIN
1382 !ia 05/97 IA Adapted for use in CTM2-S
1383 !ia 11/97 IA Modified for new model version
1384 !ia see comments under iarev02
1385 !ia
1386 !ia Called BY: RPMMOD3
1387 !ia
1388 !ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1389 !ia GETVSED
1390 !ia
1391 !ia*********************************************************************
1392 ! actcof
1393 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1394 blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat, &
1395 orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,epm25i, &
1396 epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1397 dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1398 kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1399 ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid)
1404 ! IMPLICIT NONE
1405 ! dimension of arrays
1406 INTEGER blksize
1407 ! number of species in CBLK
1408 INTEGER nspcsda
1409 ! actual number of cells in arrays
1410 INTEGER numcells
1411 ! number of k-level
1412 INTEGER layer
1413 ! of organic aerosol precursor
1414 INTEGER ldrog
1415 REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1417 REAL dt
1418 ! *** Meteorological information:
1420 ! synchronization time [s]
1421 REAL blkta(blksize) ! Air temperature [ K ]
1422 REAL blkprs(blksize) ! Air pressure in [ Pa ]
1423 REAL blkdens(blksize) ! Air density [ kg/ m**3 ]
1424 REAL blkrh(blksize)
1425 ! *** Chemical production rates: [ ug / m**3 s ]
1427 ! Fractional relative humidity
1428 REAL so4rat(blksize)
1429 !bs
1430 ! sulfate gas-phase production rate
1431 ! total # of cond. vapors & SOA species
1432 INTEGER ncv
1433 !bs
1434 INTEGER nacv
1435 !bs * organic condensable vapor production rate
1436 ! # of anthrop. cond. vapors & SOA speci
1437 REAL drog(blksize,ldrog) !bs
1438 ! *** anthropogenic organic aerosol mass production rates from aromatics
1439 ! Delta ROG conc. [ppm]
1440 REAL orgaro1rat(blksize)
1442 ! *** anthropogenic organic aerosol mass production rates from aromatics
1443 REAL orgaro2rat(blksize)
1445 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1446 REAL orgalk1rat(blksize)
1448 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1449 REAL orgole1rat(blksize)
1451 ! *** biogenic organic aerosol production rates
1452 REAL orgbio1rat(blksize)
1454 ! *** biogenic organic aerosol production rates
1455 REAL orgbio2rat(blksize)
1457 ! *** biogenic organic aerosol production rates
1458 REAL orgbio3rat(blksize)
1460 ! *** biogenic organic aerosol production rates
1461 REAL orgbio4rat(blksize)
1463 ! *** Primary emissions rates: [ ug / m**3 s ]
1465 ! *** emissions rates for unidentified PM2.5 mass
1466 REAL epm25i(blksize) ! Aitken mode
1467 REAL epm25j(blksize)
1468 ! *** emissions rates for primary organic aerosol
1469 ! Accumululaton mode
1470 REAL eorgi(blksize) ! Aitken mode
1471 REAL eorgj(blksize)
1472 ! *** emissions rates for elemental carbon
1473 ! Accumululaton mode
1474 REAL eeci(blksize) ! Aitken mode
1475 REAL eecj(blksize)
1476 ! *** emissions rates for coarse mode particles
1477 ! Accumululaton mode
1478 REAL esoil(blksize) ! soil derived coarse aerosols
1479 REAL eseas(blksize) ! marine coarse aerosols
1480 REAL epmcoarse(blksize)
1482 ! *** OUTPUT:
1484 ! *** atmospheric properties
1486 ! anthropogenic coarse aerosols
1487 REAL xlm(blksize) ! atmospheric mean free path [ m ]
1488 REAL amu(blksize)
1489 ! *** modal diameters: [ m ]
1491 ! atmospheric dynamic viscosity [ kg
1492 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1493 REAL dgacc(blksize) ! accumulation geometric mean diamet
1494 REAL dgcor(blksize)
1496 ! *** aerosol properties:
1498 ! *** Modal mass concentrations [ ug m**3 ]
1500 ! coarse mode geometric mean diamete
1501 REAL pmassn(blksize) ! mass concentration in Aitken mode
1502 REAL pmassa(blksize) ! mass concentration in accumulation
1503 REAL pmassc(blksize)
1504 ! *** average modal particle densities [ kg/m**3 ]
1506 ! mass concentration in coarse mode
1507 REAL pdensn(blksize) ! average particle density in nuclei
1508 REAL pdensa(blksize) ! average particle density in accumu
1509 REAL pdensc(blksize)
1510 ! *** average modal Knudsen numbers
1512 ! average particle density in coarse
1513 REAL knnuc(blksize) ! nuclei mode Knudsen number
1514 REAL knacc(blksize) ! accumulation Knudsen number
1515 REAL kncor(blksize)
1516 ! *** modal condensation factors ( see comments in NUCLCOND )
1518 ! coarse mode Knudsen number
1519 REAL fconcn(blksize)
1520 REAL fconca(blksize)
1521 !bs
1522 REAL fconcn_org(blksize)
1523 REAL fconca_org(blksize)
1524 !bs
1526 ! *** Rates for secondary particle formation:
1528 ! *** production of new mass concentration [ ug/m**3 s ]
1529 REAL dmdt(blksize) ! by particle formation
1531 ! *** production of new number concentration [ number/m**3 s ]
1533 ! rate of production of new mass concen
1534 REAL dndt(blksize) ! by particle formation
1536 ! *** growth rate for third moment by condensation of precursor
1537 ! vapor on existing particles [ 3rd mom/m**3 s ]
1539 ! rate of producton of new particle num
1540 REAL cgrn3(blksize) ! Aitken mode
1541 REAL cgra3(blksize)
1542 ! *** Rates for coaglulation: [ m**3/s ]
1544 ! *** Unimodal Rates:
1546 ! Accumulation mode
1547 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1548 REAL ura00(blksize)
1550 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
1552 ! accumulation mode 0th moment self-coagulat
1553 REAL brna01(blksize)
1554 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1555 ! rate for 0th moment
1556 REAL c30(blksize) ! by intermodal c
1558 ! *** other processes
1560 ! intermodal 3rd moment transfer r
1561 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
1564 ! INTEGER NN, VV ! loop indICES
1566 ! increment of concentration added to
1567 ! ////////////////////// Begin code ///////////////////////////////////
1572 ! concentration lower limit
1573 CHARACTER*16 pname
1574 PARAMETER (pname=' AEROPROC ')
1576 INTEGER unit
1577 PARAMETER (unit=20)
1578 integer igrid,jgrid,kgrid,isorop
1579 ! isorop=0
1580 isorop=1
1584 ! *** get water, ammonium and nitrate content:
1585 ! for now, don't call if temp is below -40C (humidity
1586 ! for this wrf version is already limited to 10 percent)
1588 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then
1589 CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
1590 else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then
1591 CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1592 endif
1594 ! *** get size distribution information:
1596 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1597 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1598 kncor)
1600 ! *** Calculate coagulation rates for fine particles:
1602 CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1603 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1606 ! *** get condensation and particle formation (nucleation) rates:
1608 CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1609 so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
1610 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
1611 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)
1613 ! if(dndt(1).lt.-10.)print*,'dndt in aeroproc',dndt
1615 ! *** advance forward in time DT seconds:
1616 CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,orgaro1rat, &
1617 orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1618 orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1619 dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1620 dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1623 ! *** get new distribution information:
1625 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1626 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1627 kncor)
1629 RETURN
1630 END SUBROUTINE aeroproc
1631 !//////////////////////////////////////////////////////////////////
1632 ! *** Time stepping code advances the aerosol moments one timestep;
1635 SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat &
1636 ,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat &
1637 ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1638 ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn &
1639 ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1640 igrid,jgrid,kgrid &
1641 )
1643 !***********************************************************************
1645 ! NOTE:
1647 ! *** DESCRIPTION: Integrate the Number and Mass equations
1648 ! for each mode over the time interval DT.
1650 ! PRECONDITIONS:
1651 ! AEROSTEP() must follow calls to all other dynamics routines.
1653 ! *** Revision history:
1654 ! Adapted 3/95 by UAS and CJC from EAM2's code.
1655 ! Revised 7/29/96 by FSB to use block structure
1656 ! Revised 11/15/96 by FSB dropped flow-through and cast
1657 ! number solver into Riccati equation form.
1658 ! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mo
1659 ! each predicted rather than total mass and
1660 ! Aitken mode mass. Also used a local approximati
1661 ! the error function. Also added coarse mode.
1662 ! Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1663 ! accumulation mode by coagulation
1664 ! Revised 10/27/97 by FSB to modify code to use primay emissions
1665 ! and to correct 3rd moment updates.
1666 ! Also added coarse mode.
1667 ! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1668 ! Revised 11/5/97 by FSB to fix error in MSTRNSFR
1669 ! Revised 11/6/97 FSB to correct the expression for FACTRANS to
1670 ! remove the 6/pi coefficient. UAS found this.
1671 ! Revised 12/15/97 by FSB to change equations for mass concentrati
1672 ! to a chemical production form with analytic
1673 ! solutions for the Aitken mode and to remove
1674 ! time stepping of the 3rd moments. The mass conc
1675 ! in the accumulation mode is updated with a forw
1676 ! Euler step.
1677 ! Revised 1/6/98 by FSB Lowered minimum concentration for
1678 ! sulfate aerosol to 0.1 [ ng / m**3 ].
1679 ! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represen
1680 ! intermodal transfer rate of 3rd moment in place
1681 ! of 3rd moment coagulation rate.
1682 ! Revised 5/5/98 added new renaming criterion based on diameters
1683 ! Added 3/23/98 by BS condensational groth factors for organics
1685 !**********************************************************************
1687 ! IMPLICIT NONE
1689 ! Includes:
1693 ! *** ARGUMENTS:
1695 ! dimension of arrays
1696 INTEGER blksize
1697 ! actual number of cells in arrays
1698 INTEGER numcells
1699 ! nmber of species in CBLK
1700 INTEGER nspcsda
1701 ! model layer
1702 INTEGER layer
1703 REAL cblk(blksize,nspcsda) ! main array of variables
1704 INTEGER igrid,jgrid,kgrid
1705 REAL dt
1706 ! *** Chemical production rates: [ ug / m**3 s ]
1708 ! time step [sec]
1709 REAL so4rat(blksize)
1710 ! *** anthropogenic organic aerosol mass production rates from aromatics
1711 ! sulfate gas-phase production rate
1712 REAL orgaro1rat(blksize)
1713 REAL orgaro2rat(blksize)
1715 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1716 REAL orgalk1rat(blksize)
1717 REAL orgole1rat(blksize)
1719 ! *** biogenic organic aerosol production rates
1720 REAL orgbio1rat(blksize)
1721 REAL orgbio2rat(blksize)
1722 REAL orgbio3rat(blksize)
1723 REAL orgbio4rat(blksize)
1725 ! *** Primary emissions rates: [ ug / m**3 s ]
1727 ! *** emissions rates for unidentified PM2.5 mass
1728 REAL epm25i(blksize) ! Aitken mode
1729 REAL epm25j(blksize)
1730 ! *** emissions rates for primary organic aerosol
1731 ! Accumululaton mode
1732 REAL eorgi(blksize) ! Aitken mode
1733 REAL eorgj(blksize)
1734 ! *** emissions rates for elemental carbon
1735 ! Accumululaton mode
1736 REAL eeci(blksize) ! Aitken mode
1737 REAL eecj(blksize)
1738 ! *** emissions rates for coarse mode particles
1739 ! Accumululaton mode
1740 REAL esoil(blksize) ! soil derived coarse aerosols
1741 REAL eseas(blksize) ! marine coarse aerosols
1742 REAL epmcoarse(blksize)
1743 ! anthropogenic coarse aerosols
1744 REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1745 REAL dgacc(blksize)
1746 ! accumulation
1747 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
1748 ! reciprocal condensation rate
1749 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
1750 ! reciprocal condensation rate
1751 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
1752 ! reciprocal condensation rate for organ
1753 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
1754 ! reciprocal condensation rate for organ
1755 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
1756 ! rate of production of new mass concent
1757 REAL dndt(blksize) ! by particle formation [ number/m**3 /s
1758 ! rate of producton of new particle numb
1759 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
1760 ! increment of concentration added to
1761 REAL urn00(blksize) ! Aitken intramodal coagulation rate
1762 REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1763 REAL brna01(blksize) ! bimodal coagulation rate for number
1764 REAL c30(blksize) ! by intermodal coagulation
1765 ! intermodal 3rd moment transfer rate by
1766 REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1767 REAL cgra3(blksize)
1768 ! *** Modal mass concentrations [ ug m**3 ]
1770 ! growth rate for 3rd moment for Accumul
1771 REAL pmassn(blksize) ! mass concentration in Aitken mode
1772 REAL pmassa(blksize) ! mass concentration in accumulation
1773 REAL pmassc(blksize)
1775 ! *** Local Variables
1777 ! mass concentration in coarse mode
1778 INTEGER l, lcell, &
1779 spc
1780 ! ** following scratch variables are used for solvers
1784 ! *** variables needed for modal dynamics solvers:
1786 ! Loop indices
1787 REAL*8 a, b, c
1788 REAL*8 m1, m2, y0, y
1789 REAL*8 dhat, p, pexpdt, expdt
1790 REAL*8 loss, prod, pol, lossinv
1791 ! mass intermodal transfer by coagulation
1792 REAL mstrnsfr
1794 REAL factrans
1796 ! *** CODE additions for renaming
1797 REAL getaf2
1798 REAL aaa, xnum, xm3, fnum, fm3, phnum, & ! Defined below
1799 phm3
1800 REAL erf, & ! Error and complementary error function
1801 erfc
1803 REAL xx
1804 ! dummy argument for ERF and ERFC
1805 ! a numerical value for a minimum concentration
1807 ! *** This value is smaller than any reported tropospheric concentration
1810 ! :::::::::::::::::::::::::::::::::::::
1811 ! *** Statement function given for error function. Source is
1812 ! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1813 ! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1814 ! 20:253-265. They cite Reasearch & Education Asociation (REA), (19
1815 ! Handbook of Mathematical, Scientific, and Engineering Formulas,
1816 ! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1818 erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1819 erfc(xx) = 1.0 - erf(xx)
1820 ! ::::::::::::::::::::::::::::::::::::::::
1823 ! ///// begin code
1828 ! *** set up time-step integration
1830 DO l = 1, numcells
1832 ! *** code to move number forward by one time step.
1833 ! *** solves the Ricatti equation:
1835 ! dY/dt = C - A * Y ** 2 - B * Y
1837 ! Coded 11/21/96 by Dr. Francis S. Binkowski
1839 ! *** Aitken mode:
1841 ! *** coefficients
1843 a = urn00(l)
1844 b = brna01(l)*cblk(l,vac0)
1845 c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1847 ! includes primary emissions
1848 y0 = cblk(l,vnu0)
1849 ! *** trap on C = 0
1851 ! initial condition
1852 IF (c>0.0D0) THEN
1854 dhat = sqrt(b*b+4.0D0*a*c)
1856 m1 = 2.0D0*a*c/(b+dhat)
1858 m2 = -0.5D0*(b+dhat)
1860 p = -(m1-a*y0)/(m2-a*y0)
1862 pexpdt = p*exp(-dhat*dt)
1864 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1865 ! solution
1866 ELSE
1868 ! *** rearrange solution for NUMERICAL stability
1869 ! note If B << A * Y0, the following form, although
1870 ! seemingly awkward gives the correct answer.
1872 expdt = exp(-b*dt)
1873 IF (expdt<1.0D0) THEN
1874 y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1875 ELSE
1876 y = y0
1877 END IF
1879 END IF
1880 ! if(y.lt.nummin_i)then
1881 ! print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
1882 ! print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
1883 ! print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
1884 ! endif
1886 cblk(l,vnu0) = max(nummin_i,y)
1888 ! *** now do accumulation mode number
1890 ! *** coefficients
1892 ! update
1893 a = ura00(l)
1894 b = & ! NOTE B = 0.0
1895 0.0D0
1896 c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
1897 ! includes primary emissi
1898 y0 = cblk(l,vac0)
1899 ! *** this equation requires special handling, because C can be zero.
1900 ! if this happens, the form of the equation is different:
1902 ! initial condition
1903 ! print *,vac0,y0,c,nummin_j,a
1904 IF (c>0.0D0) THEN
1906 dhat = sqrt(4.0D0*a*c)
1908 m1 = 2.0D0*a*c/dhat
1910 m2 = -0.5D0*dhat
1912 p = -(m1-a*y0)/(m2-a*y0)
1914 ! print *,p,-dhat,dt,-dhat*dt
1915 ! print *,exp(-dhat*dt)
1916 pexpdt = p*exp(-dhat*dt)
1918 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1919 ! solution
1920 ELSE
1922 y = y0/(1.0D0+dt*a*y0)
1923 ! print *,dhat,y0,dt,a
1924 y = y0/(1.+dt*a*y0)
1925 ! print *,y
1926 ! correct solution to equatio
1927 END IF
1929 cblk(l,vac0) = max(nummin_j,y)
1930 ! *** now do coarse mode number neglecting coagulation
1931 ! update
1932 ! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
1933 prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
1935 ! print *,cblk(l,vcorn),factnumc,prod
1936 cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
1939 ! *** Prepare to advance modal mass concentration one time step.
1941 ! *** Set up production and and intermodal transfer terms terms:
1942 ! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
1943 cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
1945 ! includes growth from pri
1946 cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
1947 orgfac*eorgj(l) ! and transfer of 3rd momen
1948 ! intermodal coagulation
1950 ! *** set up transfer coefficients for coagulation between Aitken and ac
1953 ! *** set up special factors for mass transfer from the Aitken to accumu
1954 ! intermodal coagulation. The mass transfer rate is proportional to
1955 ! transfer rate, C30. The proportionality factor is p/6 times the th
1956 ! density. The average particle density for a species is the species
1957 ! divided by the particle volume concentration, pi/6 times the 3rd m
1958 ! The p/6 coefficients cancel.
1960 ! includes growth from prim
1961 ! print *,'loss',vnu3,c30(l),cblk(l,vnu3)
1962 loss = c30(l)/cblk(l,vnu3)
1964 ! Normalized coagulation transfer r
1965 factrans = loss* & ! yields an estimate of the amount of mass t
1966 dt
1967 ! the Aitken to the accumulation mode in the
1969 ! Multiplying this factor by the species con
1970 ! print *,'factrans = ',factrans,loss
1971 expdt = exp(-factrans) ! decay term is common to all Aitken mode
1972 ! print *,'factrans = ',factrans,loss,expdt
1973 ! variable name is re-used here. This expo
1974 lossinv = 1.0/ &
1975 loss
1976 ! *** now advance mass concentrations one time step.
1979 ! *** update sulfuric acid vapor concentration by removing mass concent
1980 ! condensed sulfate and newly produced particles.
1981 ! *** The method follows Youngblood and Kreidenweis, Further Development
1982 ! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
1983 ! Atmospheric Science Paper Number 550, April,1994, pp 85-89.
1984 ! set up for multiplication rather than divi
1985 cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
1988 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
1989 ! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
1991 ! *** sulfate:
1993 mstrnsfr = cblk(l,vso4ai)*factrans
1994 prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
1995 pol = prod*lossinv
1996 ! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
1998 cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
2000 cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
2002 cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
2004 ! *** anthropogenic secondary organic:
2005 !bs * anthropogenic secondary organics from aromatic precursors
2007 mstrnsfr = cblk(l,vorgaro1i)*factrans
2008 prod = orgaro1rat(l)*fconcn_org(l)
2009 pol = prod*lossinv
2011 cblk(l,vorgaro1i) = pol + (cblk(l,vorgaro1i)-pol)*expdt
2013 cblk(l,vorgaro1i) = max(conmin,cblk(l,vorgaro1i))
2015 cblk(l,vorgaro1j) = cblk(l,vorgaro1j) + orgaro1rat(l)*fconca_org(l)*dt &
2016 + mstrnsfr
2017 !bs * second species from aromatics
2018 mstrnsfr = cblk(l,vorgaro2i)*factrans
2019 prod = orgaro2rat(l)*fconcn_org(l)
2020 pol = prod*lossinv
2022 cblk(l,vorgaro2i) = pol + (cblk(l,vorgaro2i)-pol)*expdt
2024 cblk(l,vorgaro2i) = max(conmin,cblk(l,vorgaro2i))
2026 cblk(l,vorgaro2j) = cblk(l,vorgaro2j) + orgaro2rat(l)*fconca_org(l)*dt &
2027 + mstrnsfr
2029 !bs * anthropogenic secondary organics from alkanes & other precursors
2030 !bs * higher alkanes
2031 mstrnsfr = cblk(l,vorgalk1i)*factrans
2032 prod = orgalk1rat(l)*fconcn_org(l)
2033 pol = prod*lossinv
2035 cblk(l,vorgalk1i) = pol + (cblk(l,vorgalk1i)-pol)*expdt
2037 cblk(l,vorgalk1i) = max(conmin,cblk(l,vorgalk1i))
2039 cblk(l,vorgalk1j) = cblk(l,vorgalk1j) + orgalk1rat(l)*fconca_org(l)*dt &
2040 + mstrnsfr
2041 !bs * higher olefines
2042 mstrnsfr = cblk(l,vorgole1i)*factrans
2043 prod = orgole1rat(l)*fconcn_org(l)
2044 pol = prod*lossinv
2046 cblk(l,vorgole1i) = pol + (cblk(l,vorgole1i)-pol)*expdt
2048 cblk(l,vorgole1i) = max(conmin,cblk(l,vorgole1i))
2050 cblk(l,vorgole1j) = cblk(l,vorgole1j) + orgole1rat(l)*fconca_org(l)*dt &
2051 + mstrnsfr
2053 ! *** biogenic secondary organic
2055 mstrnsfr = cblk(l,vorgba1i)*factrans
2056 prod = orgbio1rat(l)*fconcn_org(l)
2057 pol = prod*lossinv
2059 cblk(l,vorgba1i) = pol + (cblk(l,vorgba1i)-pol)*expdt
2061 cblk(l,vorgba1i) = max(conmin,cblk(l,vorgba1i))
2063 cblk(l,vorgba1j) = cblk(l,vorgba1j) + orgbio1rat(l)*fconca_org(l)*dt + &
2064 mstrnsfr
2065 !bs * second biogenic species
2066 mstrnsfr = cblk(l,vorgba2i)*factrans
2067 prod = orgbio2rat(l)*fconcn_org(l)
2068 pol = prod*lossinv
2070 cblk(l,vorgba2i) = pol + (cblk(l,vorgba2i)-pol)*expdt
2072 cblk(l,vorgba2i) = max(conmin,cblk(l,vorgba2i))
2074 cblk(l,vorgba2j) = cblk(l,vorgba2j) + orgbio2rat(l)*fconca_org(l)*dt + &
2075 mstrnsfr
2077 !bs * third biogenic species
2078 mstrnsfr = cblk(l,vorgba3i)*factrans
2079 prod = orgbio3rat(l)*fconcn_org(l)
2080 pol = prod*lossinv
2082 cblk(l,vorgba3i) = pol + (cblk(l,vorgba3i)-pol)*expdt
2084 cblk(l,vorgba3i) = max(conmin,cblk(l,vorgba3i))
2086 cblk(l,vorgba3j) = cblk(l,vorgba3j) + orgbio3rat(l)*fconca_org(l)*dt + &
2087 mstrnsfr
2089 !bs * fourth biogenic species
2090 mstrnsfr = cblk(l,vorgba4i)*factrans
2091 prod = orgbio4rat(l)*fconcn_org(l)
2092 pol = prod*lossinv
2094 cblk(l,vorgba4i) = pol + (cblk(l,vorgba4i)-pol)*expdt
2096 cblk(l,vorgba4i) = max(conmin,cblk(l,vorgba4i))
2098 cblk(l,vorgba4j) = cblk(l,vorgba4j) + orgbio4rat(l)*fconca_org(l)*dt + &
2099 mstrnsfr
2101 ! *** primary anthropogenic organic
2103 mstrnsfr = cblk(l,vorgpai)*factrans
2104 prod = eorgi(l)
2105 pol = prod*lossinv
2107 cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
2109 cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
2111 cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
2113 ! *** other anthropogenic PM2.5
2115 mstrnsfr = cblk(l,vp25ai)*factrans
2116 prod = epm25i(l)
2117 pol = prod*lossinv
2119 cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
2121 cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
2123 cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
2125 ! *** elemental carbon
2127 mstrnsfr = cblk(l,veci)*factrans
2128 prod = eeci(l)
2129 pol = prod*lossinv
2131 cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
2133 cblk(l,veci) = max(conmin,cblk(l,veci))
2135 cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
2138 ! *** coarse mode
2140 ! *** soil dust
2142 cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
2143 cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
2145 ! *** sea salt
2147 cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
2148 cblk(l,vseas) = max(conmin,cblk(l,vseas))
2150 ! *** anthropogenic PM10 coarse fraction
2152 cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
2153 cblk(l,vantha) = max(conmin,cblk(l,vantha))
2157 END DO
2160 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
2161 ! then merge modes by renaming.
2163 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
2166 ! end of time-step loop for total mass
2167 DO lcell = 1, numcells
2169 ! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
2170 ! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
2171 IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
2172 lcell,vnu0)>cblk(lcell,vac0)) &
2173 THEN
2175 ! check if mer
2176 aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
2177 dgacc(lcell),xxlsgn,xxlsga,sqrt2)
2179 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2180 ! dd is the diameter at which the Aitken-mode and accumulation-mo
2181 ! distributions intersect (overap).
2184 xnum = max(aaa,xxm3) ! this means that no more than one ha
2185 ! total Aitken mode number may be tra
2186 ! per call.
2188 ! do not let XNUM become negative bec
2189 xm3 = xnum - &
2190 xxm3
2191 ! set up for 3rd moment and mass tran
2192 IF (xm3>0.0) &
2193 THEN
2194 ! do mode merging if overlap is corr
2195 phnum = 0.5*(1.0+erf(xnum))
2196 phm3 = 0.5*(1.0+erf(xm3))
2197 fnum = 0.5*erfc(xnum)
2198 fm3 = 0.5*erfc(xm3)
2201 ! In the Aitken mode:
2203 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2204 ! distributions with diameters greater than dd respectively.
2207 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2208 ! distributions with diameters less than dd.
2211 ! *** rename the Aitken mode particle number as accumulation mode
2212 ! particle number
2214 cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2217 ! *** adjust the Aitken mode number
2219 cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2221 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2222 ! to the accumulation mode is proportional to the amount of 3rd mome
2223 ! transferred, therefore FM3 is used for mass transfer.
2225 cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2227 cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2229 cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2231 cblk(lcell,vorgaro1j) = cblk(lcell,vorgaro1j) + &
2232 cblk(lcell,vorgaro1i)*fm3
2234 cblk(lcell,vorgaro2j) = cblk(lcell,vorgaro2j) + &
2235 cblk(lcell,vorgaro2i)*fm3
2237 cblk(lcell,vorgalk1j) = cblk(lcell,vorgalk1j) + &
2238 cblk(lcell,vorgalk1i)*fm3
2240 cblk(lcell,vorgole1j) = cblk(lcell,vorgole1j) + &
2241 cblk(lcell,vorgole1i)*fm3
2243 cblk(lcell,vorgba1j) = cblk(lcell,vorgba1j) + &
2244 cblk(lcell,vorgba1i)*fm3
2246 cblk(lcell,vorgba2j) = cblk(lcell,vorgba2j) + &
2247 cblk(lcell,vorgba2i)*fm3
2249 cblk(lcell,vorgba3j) = cblk(lcell,vorgba3j) + &
2250 cblk(lcell,vorgba3i)*fm3
2252 cblk(lcell,vorgba4j) = cblk(lcell,vorgba4j) + &
2253 cblk(lcell,vorgba4i)*fm3
2255 cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + &
2256 cblk(lcell,vorgpai)*fm3
2258 cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2260 cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2262 ! *** update Aitken mode for mass loss to accumulation mode
2264 cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2267 cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2269 cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2271 cblk(lcell,vorgaro1i) = cblk(lcell,vorgaro1i)*phm3
2273 cblk(lcell,vorgaro2i) = cblk(lcell,vorgaro2i)*phm3
2275 cblk(lcell,vorgalk1i) = cblk(lcell,vorgalk1i)*phm3
2277 cblk(lcell,vorgole1i) = cblk(lcell,vorgole1i)*phm3
2279 cblk(lcell,vorgba1i) = cblk(lcell,vorgba1i)*phm3
2281 cblk(lcell,vorgba2i) = cblk(lcell,vorgba2i)*phm3
2283 cblk(lcell,vorgba3i) = cblk(lcell,vorgba3i)*phm3
2285 cblk(lcell,vorgba4i) = cblk(lcell,vorgba4i)*phm3
2287 cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2289 cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2291 cblk(lcell,veci) = cblk(lcell,veci)*phm3
2294 END IF
2295 ! end check on whether modal overlap is OK
2297 END IF
2298 ! end check on necessity for merging
2300 END DO
2301 ! set min value for all concentrations
2303 ! loop for merging
2304 DO spc = 1, nspcsda
2305 DO lcell = 1, numcells
2306 cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2307 END DO
2308 END DO
2311 RETURN
2313 !#######################################################################
2314 END SUBROUTINE aerostep
2315 ! aerostep
2316 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2317 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2318 ! mso4,mnh4,mno3 are in microMOLES / cubic meter
2320 ! This version uses polynomials rather than tables, and uses empirical
2321 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2322 ! where:
2324 ! mfs = ms / ( ms + mw)
2325 ! ms is the mass of solute
2326 ! mw is the mass of water.
2328 ! Define y = mw/ ms
2330 ! then mfs = 1 / (1 + y)
2332 ! y can then be obtained from the values of mfs as
2334 ! y = (1 - mfs) / mfs
2337 ! the aerosol is assumed to be in a metastable state if the rh is
2338 ! is below the rh of deliquescence, but above the rh of crystallizat
2340 ! ZSR interpolation is used for sulfates with x ( the molar ratio of
2341 ! ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2342 ! section 1: 0 <= x < 1
2343 ! section 2: 1 <= x < 1.5
2344 ! section 3: 1.5 <= x < 2.0
2345 ! section 4: 2 <= x
2346 ! In sections 1 through 3, only the sulfates can affect the amount o
2347 ! on the particles.
2348 ! In section 4, we have fully neutralized sulfate, and extra ammoniu
2349 ! allows more nitrate to be present. Thus, the ammount of water is c
2350 ! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2351 ! assumed to occur in sections 2,3,and 4. See detailed discussion be
2355 ! definitions:
2356 ! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2357 ! for sulfate, ammonium, and nitrate respectively
2358 ! irhx is the relative humidity (%)
2359 ! wh2o is the returned water amount in micrograms / cubic meter of a
2360 ! x is the molar ratio of ammonium to sulfate
2361 ! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2362 ! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2363 ! y3 is the value of the mass ratio of water to solute for
2364 ! a pure ammonium nitrate solution.
2367 !oded by Dr. Francis S. Binkowski, 4/8/96.
2369 ! IMPLICIT NONE
2370 INTEGER irhx, irh
2371 REAL mso4, mnh4, mno3
2372 REAL tso4, tnh4, tno3, wh2o, x
2373 REAL aw, awc
2374 ! REAL poly4, poly6
2375 REAL mfs0, mfs1, mfs15, mfs2
2376 REAL c0(4), c1(4), c15(4), c2(4)
2377 REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2378 REAL kso4(6), kno3(6), mfsso4, mfsno3
2382 REAL mwso4, mwnh4, mwno3, mw2, mwano3
2384 ! *** molecular weights:
2385 PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2386 mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2388 ! The polynomials use data for aw as a function of mfs from Tang and
2389 ! Munkelwitz, JGR 99: 18801-18808, 1994.
2390 ! The polynomials were fit to Tang's values of water activity as a
2391 ! function of mfs.
2393 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2394 ! now give mfs as a function of water activity.
2396 DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2397 DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2398 DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2400 ! *** the following coefficients are a fit to the data in Table 1 of
2401 ! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2402 ! data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2403 ! *** New data fit to data from
2404 ! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2405 ! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2406 ! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2407 DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2410 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2411 ! Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2413 DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2414 DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2417 ! *** check range of per cent relative humidity
2418 irh = irhx
2419 irh = max(1,irh)
2420 irh = min(irh,100)
2421 aw = float(irh)/ & ! water activity = fractional relative h
2422 100.0
2423 tso4 = max(mso4,0.0)
2424 tnh4 = max(mnh4,0.0)
2425 tno3 = max(mno3,0.0)
2426 x = 0.0
2427 ! *** if there is non-zero sulfate calculate the molar ratio
2428 IF (tso4>0.0) THEN
2429 x = tnh4/tso4
2430 ELSE
2431 ! *** otherwise check for non-zero nitrate and ammonium
2432 IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2433 END IF
2437 ! *** begin screen on x for calculating wh2o
2438 IF (x<1.0) THEN
2440 mfs0 = poly4(c0,aw)
2441 mfs1 = poly4(c1,aw)
2442 y0 = (1.0-mfs0)/mfs0
2443 y1 = (1.0-mfs1)/mfs1
2444 y = (1.0-x)*y0 + x*y1
2447 ELSE IF (x<1.5) THEN
2449 IF (irh>=40) THEN
2450 mfs1 = poly4(c1,aw)
2451 mfs15 = poly4(c15,aw)
2452 y1 = (1.0-mfs1)/mfs1
2453 y15 = (1.0-mfs15)/mfs15
2454 y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2455 ELSE
2456 ! *** set up for crystalization
2458 ! *** Crystallization is done as follows:
2459 ! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2460 ! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2461 ! and since the code does not allow ar rh < 0.01, crystallization
2462 ! is assumed not to occur in this range.
2463 ! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2464 ! from a value of y15 at rh = 0.4 to a value of zero at y1. From
2465 ! point B to point A in the diagram.
2466 ! The algorithm does a double interpolation to calculate the amount
2467 ! water.
2469 ! y1(0.40) y15(0.40)
2470 ! + + Point B
2475 ! +--------------------+
2476 ! x=1 x=1.5
2477 ! Point A
2481 awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2482 y = 0.0
2483 IF (aw>=awc) & ! interpolate using crystalization
2484 THEN
2485 mfs1 = poly4(c1,0.40)
2486 mfs15 = poly4(c15,0.40)
2487 y140 = (1.0-mfs1)/mfs1
2488 y1540 = (1.0-mfs15)/mfs15
2489 y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2490 yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2491 y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2492 ! end of checking for aw
2493 END IF
2495 END IF
2496 ! end of checking on irh
2497 ELSE IF (x<1.9999) THEN
2499 y = 0.0
2500 IF (irh>=40) THEN
2501 mfs15 = poly4(c15,aw)
2502 mfs2 = poly4(c2,aw)
2503 y15 = (1.0-mfs15)/mfs15
2504 y2 = (1.0-mfs2)/mfs2
2505 y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2507 END IF
2511 ! end of check for crystallization
2513 ELSE
2514 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2516 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2517 ! *** check for crystallization here. their data indicate a 40% value
2518 ! is appropriate.
2519 ! 1.9999 < x
2520 y2 = 0.0
2521 y3 = 0.0
2522 IF (irh>=40) THEN
2523 mfsso4 = poly6(kso4,aw)
2524 mfsno3 = poly6(kno3,aw)
2525 y2 = (1.0-mfsso4)/mfsso4
2526 y3 = (1.0-mfsno3)/mfsno3
2528 END IF
2531 END IF
2532 ! *** now set up output of wh2o
2534 ! wh2o units are micrograms (liquid water) / cubic meter of air
2536 ! end of checking on x
2537 IF (x<1.9999) THEN
2539 wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2541 ELSE
2543 ! *** this is the case that all the sulfate is ammonium sulfate
2544 ! and the excess ammonium forms ammonum nitrate
2546 wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2548 END IF
2550 RETURN
2551 END SUBROUTINE awater
2552 !//////////////////////////////////////////////////////////////////////
2554 SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2555 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2556 !***********************************************************************
2557 !** DESCRIPTION: calculates aerosol coagulation rates for unimodal
2558 ! and bimodal coagulation using E. Whitby 1990's prescription.
2560 !....... Rates for coaglulation:
2561 !....... Unimodal Rates:
2562 !....... URN00: nuclei mode 0th moment self-coagulation rate
2563 !....... URA00: accumulation mode 0th moment self-coagulation rate
2565 !....... Bimodal Rates: (only 1st order coeffs appear)
2566 !....... NA-- nuclei with accumulation coagulation rates,
2567 !....... AN-- accumulation with nuclei coagulation rates
2568 !....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term)
2569 !....... BRNA31: 3rd ( d(nuclei mode 3) / dt term)
2570 !**
2571 !**
2572 !** Revision history:
2573 ! prototype 1/95 by Uma and Carlie
2574 ! Revised 8/95 by US for calculation of density from stmt func
2575 ! and collect met variable stmt funcs in one include fil
2576 ! REVISED 7/25/96 by FSB to use block structure
2577 ! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2578 ! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2579 ! changed. All coagulation coefficients
2580 ! returned with positive signs. Their
2581 ! linearization is also abandoned.
2582 ! Fixed values are used for the corrections
2583 ! to the free-molecular coagulation integra
2584 ! The code forces the harmonic means to be
2585 ! evaluated in 64 bit arithmetic on 32 bit
2586 ! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit
2588 ! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa
2589 ! because BRNA31 can become zero on a works
2590 ! because of limited precision. With the ch
2591 ! aerostep to omit update of the 3rd moment
2592 ! C30 is the only variable now needed.
2593 ! the logic using ONE88 to force REAL*8 ari
2594 ! has been removed and all intermediates ar
2595 ! REAL*8.
2597 ! IMPLICIT NONE
2599 ! dimension of arrays
2600 INTEGER blksize
2601 ! actual number of cells in arrays
2602 INTEGER numcells
2604 INTEGER nspcsda
2606 ! nmber of species in CBLK
2607 REAL cblk(blksize,nspcsda) ! main array of variables
2608 REAL blkta(blksize) ! Air temperature [ K ]
2609 REAL pdensn(blksize) ! average particel density in Aitk
2610 REAL pdensa(blksize) ! average particel density in accu
2611 REAL amu(blksize) ! atmospheric dynamic viscosity [
2612 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2613 REAL dgacc(blksize) ! accumulation mode mean diameter
2614 REAL knnuc(blksize) ! Aitken mode Knudsen number
2615 REAL knacc(blksize)
2616 ! *** output:
2618 ! accumulation mode Knudsen number
2619 REAL urn00(blksize) ! intramodal coagulation rate (Ait
2620 REAL ura00(blksize)
2621 ! intramodal coagulation rate (acc
2622 REAL brna01(blksize) ! intermodal coagulaton rate (numb
2623 REAL c30(blksize) ! by inter
2625 ! *** Local variables:
2626 ! intermodal 3rd moment transfer r
2627 REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2628 kncacc
2629 REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2630 kfmacc
2631 REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2632 kfm
2633 REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2634 bencna
2635 REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2636 bencm3n
2637 REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2638 befmna
2639 REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2640 befm3n
2641 REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2642 betana
2643 REAL*8 & ! intermodal coagulation rate for 3rd mo
2644 brna31
2645 REAL*8 & ! scratch subexpression
2646 s1
2647 REAL*8 t1, & ! scratch subexpressions
2648 t2
2649 REAL*8 t16, & ! T1**6, T2**6
2650 t26
2651 REAL*8 rat, & ! ratio of acc to nuc size and its inver
2652 rin
2653 REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2654 rsq4
2655 REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2656 rsqi3
2657 REAL*8 & ! dgnuc**3
2658 dgn3
2659 REAL*8 & ! in 64 bit arithmetic
2660 dga3
2662 ! dgacc**3
2664 INTEGER lcell
2665 ! *** Fixed values for correctionss to coagulation
2666 ! integrals for free-molecular case.
2667 ! loop counter
2668 REAL*8 bm0
2669 PARAMETER (bm0=0.8D0)
2670 REAL*8 bm0i
2671 PARAMETER (bm0i=0.9D0)
2672 REAL*8 bm3i
2673 PARAMETER (bm3i=0.9D0)
2674 REAL*8 & ! approx Cunningham corr. factor
2675 a
2676 PARAMETER (a=1.246D0)
2678 !.......................................................................
2679 ! begin body of subroutine COAGRATE
2681 !........... Main computational grid-traversal loops
2682 !........... for computing coagulation rates.
2684 ! *** Both modes have fixed std devs.
2685 DO lcell = 1, &
2686 numcells
2687 ! *** moment independent factors
2689 ! loop on LCELL
2690 s1 = two3*boltz*blkta(lcell)/amu(lcell)
2692 ! For unimodal coagualtion:
2694 kncnuc = s1
2695 kncacc = s1
2697 kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2698 kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2700 ! For bimodal coagulation:
2702 knc = s1
2703 kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2707 !........... Begin unimodal coagulation rate calculations:
2709 !........... Near-continuum regime.
2711 dgn3 = dgnuc(lcell)**3
2712 dga3 = dgacc(lcell)**3
2714 t1 = sqrt(dgnuc(lcell))
2715 t2 = sqrt(dgacc(lcell))
2716 t16 = & ! = T1**6
2717 dgn3
2718 t26 = &
2719 dga3
2720 !....... Note rationalization of fractions and subsequent cancellation
2721 !....... from the formulation in Whitby et al. (1990)
2723 ! = T2**6
2724 bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2726 bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2729 !........... Free molecular regime. Uses fixed value for correction
2730 ! factor BM0
2733 befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2735 befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2738 !........... Calculate half the harmonic mean between unimodal rates
2739 !........... free molecular and near-continuum regimes
2741 ! FSB 64 bit evaluation
2743 betann = bencnn*befmnn/(bencnn+befmnn)
2744 betana = bencna*befmna/(bencna+befmna)
2748 urn00(lcell) = betann
2749 ura00(lcell) = betana
2752 ! *** End of unimodal coagulation calculations.
2754 !........... Begin bimodal coagulation rate calculations:
2756 rat = dgacc(lcell)/dgnuc(lcell)
2757 rin = 1.0D0/rat
2758 rsqt = sqrt(rat)
2759 rsq4 = rat**2
2761 rsqti = 1.0D0/rsqt
2762 rsqi3 = rin*rsqti
2764 !........... Near-continuum coeffs:
2765 !........... 0th moment nuc mode bimodal coag coefficient
2767 bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2768 )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2770 !........... 3rd moment nuc mode bimodal coag coefficient
2772 bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2773 *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2774 rin*esn64*esa04)
2778 !........... Free molecular regime coefficients:
2779 !........... Uses fixed value for correction
2780 ! factor BM0I, BM3I
2783 !........... 0th moment nuc mode coeff
2787 befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2788 rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2790 !........... 3rd moment nuc mode coeff
2792 befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2793 rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2796 !........... Calculate half the harmonic mean between bimodal rates
2797 !........... free molecular and near-continuum regimes
2799 ! FSB Force 64 bit evaluation
2802 brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2804 brna31 = bencm3n* & ! BRNA31 now is a scala
2805 befm3n/(bencm3n+befm3n)
2806 c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2807 ! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2808 ! 3d moment transfer by intermodal coagula
2810 ! End bimodal coagulation rate.
2814 END DO
2815 ! end of main lop over cells
2816 RETURN
2817 !------------------------------------------------------------------
2818 END SUBROUTINE coagrate
2819 ! subroutine to find the roots of a cubic equation / 3rd order polynomi
2820 ! formulae can be found in numer. recip. on page 145
2821 ! kiran developed this version on 25/4/1990
2822 ! dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2823 ! ***
2824 !234567
2825 ! coagrate
2826 SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2827 ! IMPLICIT NONE
2828 INTEGER nr
2829 REAL*8 a2, a1, a0
2830 REAL crutes(3)
2831 REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2832 REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2833 REAL*8 costh, sinth
2834 DATA sqrt3/1.732050808/, one3rd/0.333333333/
2835 !bs
2836 REAL*8 onebs
2837 PARAMETER (onebs=1.0)
2838 !bs
2839 a2sq = a2*a2
2840 qq = (a2sq-3.*a1)/9.
2841 rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2842 ! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT
2843 dum1 = qq*qq*qq
2844 rrsq = rr*rr
2845 dum2 = dum1 - rrsq
2846 IF (dum2>=0.) THEN
2847 ! NOW WE HAVE THREE REAL ROOTS
2848 phi = sqrt(dum1)
2849 IF (abs(phi)<1.E-20) THEN
2850 print *, ' cubic phi small, phi = ',phi
2851 crutes(1) = 0.0
2852 crutes(2) = 0.0
2853 crutes(3) = 0.0
2854 nr = 0
2855 CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2856 END IF
2857 theta = acos(rr/phi)/3.0
2858 costh = cos(theta)
2859 sinth = sin(theta)
2860 ! *** use trig identities to simplify the expressions
2861 ! *** binkowski's modification
2862 part1 = sqrt(qq)
2863 yy1 = part1*costh
2864 yy2 = yy1 - a2/3.0
2865 yy3 = sqrt3*part1*sinth
2866 crutes(3) = -2.0*yy1 - a2/3.0
2867 crutes(2) = yy2 + yy3
2868 crutes(1) = yy2 - yy3
2869 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2870 IF (crutes(1)<0.0) crutes(1) = 1.0E9
2871 IF (crutes(2)<0.0) crutes(2) = 1.0E9
2872 IF (crutes(3)<0.0) crutes(3) = 1.0E9
2873 ! *** put smallest positive root in crutes(1)
2874 crutes(1) = min(crutes(1),crutes(2),crutes(3))
2875 nr = 3
2876 ! NOW HERE WE HAVE ONLY ONE REAL ROOT
2877 ELSE
2878 ! dum IS NEGATIVE
2879 part1 = sqrt(rrsq-dum1)
2880 part2 = abs(rr)
2881 part3 = (part1+part2)**one3rd
2882 crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2883 !bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2884 crutes(2) = 0.
2885 crutes(3) = 0.
2886 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2887 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2888 ! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2889 nr = 1
2890 END IF
2891 RETURN
2892 !///////////////////////////////////////////////////////////////////////
2893 END SUBROUTINE cubic
2895 ! Calculate the aerosol chemical speciation and water content.
2897 ! cubic
2898 SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid)
2899 !***********************************************************************
2900 !** DESCRIPTION:
2901 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2902 ! and water between the gas and aerosol phases as the total sulfate,
2903 ! ammonia, and nitrate concentrations, relative humidity and
2904 ! temperature change. The evolution of the aerosol mass concentration
2905 ! due to the change in aerosol chemical composition is calculated.
2906 !** REVISION HISTORY:
2907 ! prototype 1/95 by Uma and Carlie
2908 ! Revised 8/95 by US to calculate air density in stmt func
2909 ! and collect met variable stmt funcs in one include fil
2910 ! Revised 7/26/96 by FSB to use block concept.
2911 ! Revise 12/1896 to do do i-mode calculation.
2912 !**********************************************************************
2914 ! IMPLICIT NONE
2917 ! dimension of arrays
2918 INTEGER blksize
2919 ! actual number of cells in arrays
2920 INTEGER numcells
2921 ! nmber of species in CBLK
2922 INTEGER nspcsda,igrid,jgrid,kgrid
2923 REAL cblk(blksize,nspcsda)
2924 ! *** Meteorological information in blocked arays:
2926 ! main array of variables
2927 REAL blkta(blksize) ! Air temperature [ K ]
2928 REAL blkrh(blksize)
2930 ! Fractional relative humidity
2932 INTEGER lcell
2933 ! loop counter
2934 ! air temperature
2935 REAL temp
2936 !iamodels3
2937 REAL rh
2938 ! relative humidity
2939 REAL so4, no3, nh3, nh4, hno3
2940 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2941 ! Fraction of dry sulfate mass in i-mode
2942 REAL fraci
2943 !.......................................................................
2944 REAL fracj
2945 !
2946 ! ISOROPIA variables double precision
2947 !
2948 real(kind=8) wi(5),wt(5),wt_save(5)
2949 real(kind=8) rhi,tempi,cntrl(2)
2950 real(kind=8) gas(3),aerliq(12),aersld(9),other(6)
2951 character*15 scasi
2953 ! WRITE(20,*) ' IN EQL 3 '
2957 ! Fraction of dry sulfate mass in j-mode
2958 DO lcell = 1, &
2959 numcells
2960 ! *** Fetch temperature, fractional relative humidity, and
2961 ! air density
2963 ! loop on cells
2964 temp = blkta(lcell)
2965 rh = blkrh(lcell)
2967 rhi = amin1( rh,0.995 )
2968 tempi = temp
2969 cntrl(1) = 0.d0 ! 0 = forward problem
2970 cntrl(2) = 0.d0 ! 0 = solids and liquid allowed
2972 wi(1) = (cblk(lcell,vnaaj) + cblk(lcell,vnaai))/mw_na_aer*1.e-6 ! sodium
2974 wi(2) = (cblk(lcell,vsulf)/(mw_so4_aer+2.) + &
2975 (cblk(lcell,vso4aj) + cblk(lcell,vso4ai))/mw_so4_aer)*1.e-6 ! sulfate
2977 wi(3) = (cblk(lcell,vnh3)/(mw_nh4_aer-1.) + &
2978 (cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai))/mw_nh4_aer)*1.e-6 ! ammoinum
2980 wi(4) = (cblk(lcell,vhno3)/(mw_no3_aer+1.) + &
2981 (cblk(lcell,vno3aj) + cblk(lcell,vno3ai))/mw_no3_aer)*1.e-6 ! nitrate
2984 ! wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer-1.) + &
2985 wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer+1.) + &
2986 (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6 ! chloride
2988 ! Following added: wi should be positive
2989 wi(1) = max(wi(1),0.)
2990 wi(2) = max(wi(2),0.)
2991 wi(3) = max(wi(3),0.)
2992 wi(4) = max(wi(4),0.)
2993 wi(5) = max(wi(5),0.)
2995 wt_save(1) = wi(1) ! sodium
2996 wt_save(2) = wi(2) ! sulfate
2997 wt_save(3) = wi(3) ! ammoinum
2998 wt_save(4) = wi(4) ! nitrate
2999 wt_save(5) = wi(5) ! chloride
3000 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
3001 print *,vhcl,vclai
3002 print *,wi(1),wi(2),wi(3),wi(4),wi(5)
3003 endif
3005 call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other)
3008 ! *** the following is an interim procedure. Assume the i-mode has the
3009 ! same relative mass concentrations as the total mass. Use SO4 as
3010 ! the surrogate.
3013 ! *** update gas / vapor phase
3014 gas(1) = min(gas(1),wt_save(3))
3015 gas(2) = min(gas(2),wt_save(4))
3016 gas(3) = min(gas(3),wt_save(5))
3018 gas(1) = max(gas(1),0.)
3019 gas(2) = max(gas(2),0.)
3020 gas(3) = max(gas(3),0.)
3022 ! cblk(lcell,vnh3) = gas(1)*1.e6*17.
3023 ! cblk(lcell,vhno3) = gas(2)*1.e6*63.
3024 ! cblk(lcell,vhcl) = gas(3)*1.e6*36.
3025 cblk(lcell,vnh3) = gas(1)*1.e6*(mw_nh4_aer-1.)
3026 cblk(lcell,vhno3) = gas(2)*1.e6*(mw_no3_aer+1.)
3027 cblk(lcell,vhcl) = gas(3)*1.e6*(mw_cl_aer+1.)
3028 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
3029 print *,vhcl,vnh3,vhno3
3030 print *,cblk(lcell,vnh3),cblk(lcell,vhno3),cblk(lcell,vhcl)
3031 endif
3033 ! *** get modal fraction
3034 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3036 fraci = min(fraci,1.0)
3037 fraci = max(fraci,0.0)
3039 fracj = 1.0 - fraci
3041 ! *** update do i-mode
3043 ! correct mapping from (mol m-3) to (ug m-3)
3044 aerliq(8) = max(aerliq(8),0.)
3046 cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6
3047 cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6
3048 cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))*mw_no3_aer*1.e6
3049 cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))*mw_cl_aer*1.e6
3050 cblk(lcell,vnaai) = fraci*wi(1)*mw_na_aer*1.e6
3052 ! cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6
3053 ! cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))
3054 ! cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))
3055 ! cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))
3056 ! cblk(lcell,vnaai) = fraci*wi(1)
3058 ! *** update accumulation mode:
3059 ! correct mapping from (mol m-3) to (ug m-3)
3060 cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6
3061 cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6
3062 cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))*mw_no3_aer*1.e6
3063 cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))*mw_cl_aer*1.e6
3064 cblk(lcell,vnaaj) = fracj*wi(1)*mw_na_aer*1.e6
3066 ! cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6
3067 ! cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))
3068 ! cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))
3069 ! cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))
3070 ! cblk(lcell,vnaaj) = fracj*wi(1)
3071 if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then
3072 print *,vh2oaj,vnh4aj,vno3aj,vclaj,vnaaj
3073 print *,cblk(lcell,vnh4aj),cblk(lcell,vno3aj),cblk(lcell,vclaj),aerliq(8)
3074 endif
3078 END DO
3079 ! end loop on cells
3081 RETURN
3083 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3084 END SUBROUTINE eql3
3085 ! eql3
3086 ! Calculate the aerosol chemical speciation and water content.
3088 ! cubic
3089 SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh)
3090 !***********************************************************************
3091 !** DESCRIPTION:
3092 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
3093 ! and water between the gas and aerosol phases as the total sulfate,
3094 ! ammonia, and nitrate concentrations, relative humidity and
3095 ! temperature change. The evolution of the aerosol mass concentration
3096 ! due to the change in aerosol chemical composition is calculated.
3097 !** REVISION HISTORY:
3098 ! prototype 1/95 by Uma and Carlie
3099 ! Revised 8/95 by US to calculate air density in stmt func
3100 ! and collect met variable stmt funcs in one include fil
3101 ! Revised 7/26/96 by FSB to use block concept.
3102 ! Revise 12/1896 to do do i-mode calculation.
3103 !**********************************************************************
3105 ! IMPLICIT NONE
3108 ! dimension of arrays
3109 INTEGER blksize
3110 ! actual number of cells in arrays
3111 INTEGER numcells
3112 ! nmber of species in CBLK
3113 INTEGER nspcsda
3114 REAL cblk(blksize,nspcsda)
3115 ! *** Meteorological information in blocked arays:
3117 ! main array of variables
3118 REAL blkta(blksize) ! Air temperature [ K ]
3119 REAL blkrh(blksize)
3121 ! Fractional relative humidity
3123 INTEGER lcell
3124 ! loop counter
3125 ! air temperature
3126 REAL temp
3127 !iamodels3
3128 REAL rh
3129 ! relative humidity
3130 REAL so4, no3, nh3, nh4, hno3
3131 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
3132 ! Fraction of dry sulfate mass in i-mode
3133 REAL fraci
3134 !.......................................................................
3135 REAL fracj
3136 ! Fraction of dry sulfate mass in j-mode
3137 DO lcell = 1, &
3138 numcells
3139 ! *** Fetch temperature, fractional relative humidity, and
3140 ! air density
3142 ! loop on cells
3143 temp = blkta(lcell)
3144 rh = blkrh(lcell)
3146 ! *** the following is an interim procedure. Assume the i-mode has the
3147 ! same relative mass concentrations as the total mass. Use SO4 as
3148 ! the surrogate. The results of this should be the same as those
3149 ! from the original RPM.
3151 ! *** do total aerosol
3152 so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
3154 !iamodels3
3155 no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
3156 ! & + CBLK(LCELL, VHNO3)
3158 hno3 = cblk(lcell,vhno3)
3160 !iamodels3
3162 nh3 = cblk(lcell,vnh3)
3164 nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
3165 ! & + CBLK(LCELL, VNH3)
3167 !bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
3168 !bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
3169 !bs
3170 !bs * call old version of rpmares
3171 !bs
3172 CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
3173 gnh3,gno3)
3174 !bs
3176 ! *** get modal fraction
3177 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
3178 fracj = 1.0 - fraci
3180 ! *** update do i-mode
3182 cblk(lcell,vh2oai) = fraci*ah2o
3183 cblk(lcell,vnh4ai) = fraci*anh4
3184 cblk(lcell,vno3ai) = fraci*ano3
3186 ! *** update accumulation mode:
3188 cblk(lcell,vh2oaj) = fracj*ah2o
3189 cblk(lcell,vnh4aj) = fracj*anh4
3190 cblk(lcell,vno3aj) = fracj*ano3
3193 ! *** update gas / vapor phase
3194 cblk(lcell,vnh3) = gnh3
3195 cblk(lcell,vhno3) = gno3
3197 END DO
3198 ! end loop on cells
3199 RETURN
3201 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3202 END SUBROUTINE eql4
3203 ! eql4
3205 SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
3206 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3207 !bs !
3208 !bs Description: !
3209 !bs !
3210 !bs Get the Jacobian of the function !
3211 !bs !
3212 !bs ( a1 * X1^2 + b1 * X1 + c1 ) !
3213 !bs ( a2 * X2^2 + b2 * X1 + c2 ) !
3214 !bs ( a3 * X3^2 + b3 * X1 + c3 ) !
3215 !bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. !
3216 !bs ( a5 * X5^2 + b5 * X1 + c5 ) !
3217 !bs ( a6 * X6^2 + b6 * X1 + c6 ) !
3218 !bs !
3219 !bs a_i = IMW_i !
3220 !bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i !
3221 !bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] !
3222 !bs !
3223 !bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j !
3224 !bs J_ij = ----------- = ( !
3225 !bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j !
3226 !bs !
3227 !bs !
3228 !bs Called by: NEWT !
3229 !bs !
3230 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3231 !bs
3232 ! IMPLICIT NONE
3233 !bs
3234 !bs
3235 !dimension of problem
3236 INTEGER n
3237 REAL x(n) !bs
3238 ! INTEGER NP !bs maximum expected value of N
3239 ! PARAMETER (NP = 6)
3240 !bs initial guess of CAER
3241 REAL ct(np)
3242 REAL cs(np)
3243 REAL imw(np)
3244 !bs
3245 REAL fjac(n,n)
3246 !bs
3247 INTEGER i, & !bs loop index
3248 j
3249 REAL a(np)
3250 REAL b(np)
3251 REAL b1(np)
3252 REAL b2(np)
3253 REAL sum_jnei
3254 !bs
3255 DO i = 1, n
3256 a(i) = imw(i)
3257 sum_jnei = 0.
3258 DO j = 1, n
3259 sum_jnei = sum_jnei + x(j)*imw(j)
3260 END DO
3261 b1(i) = sum_jnei - (x(i)*imw(i))
3262 b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
3263 b(i) = b1(i) + b2(i)
3264 END DO
3265 DO j = 1, n
3266 DO i = 1, n
3267 IF (i==j) THEN
3268 fjac(i,j) = 2.*a(i)*x(i) + b(i)
3269 ELSE
3270 fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
3271 END IF
3272 END DO
3273 END DO
3274 !bs
3275 RETURN
3276 END SUBROUTINE fdjac
3277 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3278 FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
3279 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3280 !bs !
3281 !bs Description: !
3282 !bs !
3283 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3284 !bs !
3285 !bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, !
3286 !bs user-supplied routine that returns the vector of functions at X. !
3287 !bs The common block NEWTV communicates the function values back to !
3288 !bs NEWT. !
3289 !bs !
3290 !bs Called by: NEWT !
3291 !bs !
3292 !bs Calls: FUNCV !
3293 !bs !
3294 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3296 ! IMPLICIT NONE
3298 !bs
3299 !bs
3300 INTEGER n
3301 ! INTEGER NP
3302 ! PARAMETER (NP = 6)
3303 REAL ct(np)
3304 REAL cs(np)
3305 REAL imw(np)
3306 REAL m,fmin
3307 REAL x(*), fvec(np)
3310 INTEGER i
3311 REAL sum
3313 CALL funcv(n,x,fvec,ct,cs,imw,m)
3314 sum = 0.
3315 DO i = 1, n
3316 sum = sum + fvec(i)**2
3317 END DO
3318 fmin = 0.5*sum
3319 RETURN
3320 END FUNCTION fmin
3321 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3322 SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
3323 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3324 !bs !
3325 !bs Description: !
3326 !bs !
3327 !bs Called by: FMIN !
3328 !bs !
3329 !bs Calls: None !
3330 !bs !
3331 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3332 !bs
3333 ! IMPLICIT NONE
3334 !bs
3335 !bs
3336 INTEGER n
3337 REAL x(*)
3338 REAL fvec(n)
3339 !bs
3340 ! INTEGER NP
3341 ! PARAMETER (NP = 6)
3342 REAL ct(np)
3343 REAL cs(np)
3344 REAL imw(np)
3345 REAL m
3346 !bs
3347 INTEGER i, j
3348 REAL sum_jnei
3349 REAL a(np)
3350 REAL b(np)
3351 REAL c(np)
3352 !bs
3353 DO i = 1, n
3354 a(i) = imw(i)
3355 sum_jnei = 0.
3356 DO j = 1, n
3357 sum_jnei = sum_jnei + x(j)*imw(j)
3358 END DO
3359 sum_jnei = sum_jnei - (x(i)*imw(i))
3360 b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
3361 c(i) = -ct(i)*(sum_jnei+m)
3362 fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
3363 END DO
3364 !bs
3365 RETURN
3366 END SUBROUTINE funcv
3367 REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
3368 ! *** set up new processor for renaming of particles from i to j modes
3369 ! IMPLICIT NONE
3370 REAL aa, bb, cc, disc, qq, alfa, l, yji
3371 REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
3373 alfa = xlsgi/xlsgj
3374 yji = log(dgnj/dgni)/(sqrt2*xlsgi)
3375 aa = 1.0 - alfa*alfa
3376 l = log(alfa*nj/ni)
3377 bb = 2.0*yji*alfa*alfa
3378 cc = l - yji*yji*alfa*alfa
3379 disc = bb*bb - 4.0*aa*cc
3380 IF (disc<0.0) THEN
3381 getaf = - & ! error in intersection
3382 5.0
3383 RETURN
3384 END IF
3385 qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3386 getaf = cc/qq
3387 RETURN
3388 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3389 END FUNCTION getaf
3390 ! Parameterization for sulfuric acid/water
3391 ! nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3392 ! April 20, 1998.
3394 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3395 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3398 !ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3399 ! getaf
3400 SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3401 ! IMPLICIT NONE
3404 ! *** Input:
3406 ! ambient temperature [ K ]
3407 REAL temp
3408 ! fractional relative humidity
3409 REAL rh
3410 ! sulfuric acid concentration [ ug / m**3 ]
3411 REAL h2so4
3413 REAL so4rat
3414 ! *** Output:
3416 !sulfuric acid production rate [ ug / ( m**3 s )]
3417 ! particle number production rate [ # / ( m**3 s )]
3418 REAL ndot1
3419 ! particle mass production rate [ ug / ( m**3 s )]
3420 REAL mdot1
3421 ! [ m**2 / ( m**3 s )]
3422 REAL m2dot
3424 ! *** Internal:
3426 ! *** NOTE, all units are cgs internally.
3427 ! particle second moment production rate
3429 REAL ra
3430 ! fractional relative acidity
3431 ! sulfuric acid vaper concentration [ cm ** -3 ]
3432 REAL nav
3433 ! water vapor concentration [ cm ** -3 ]
3434 REAL nwv
3435 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3436 REAL nav0
3437 ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1
3438 REAL nac
3439 ! critical sulfuric acid vapor concentration [ cm ** -3
3440 ! mole fractio of the critical nucleus
3441 REAL xal
3442 REAL nsulf, & ! see usage
3443 delta
3444 REAL*8 & ! factor to calculate Jnuc
3445 chi
3446 REAL*8 &
3447 jnuc
3448 ! nucleation rate [ cm ** -3 s ** -1 ]
3449 REAL tt, & ! dummy variables for statement functions
3450 rr
3451 REAL pi
3452 PARAMETER (pi=3.14159265)
3454 REAL pid6
3455 PARAMETER (pid6=pi/6.0)
3457 ! avogadro's constant [ 1/mol ]
3458 REAL avo
3459 PARAMETER (avo=6.0221367E23)
3461 ! universal gas constant [ j/mol-k ]
3462 REAL rgasuniv
3463 PARAMETER (rgasuniv=8.314510)
3465 ! 1 atmosphere in pascals
3466 REAL atm
3467 PARAMETER (atm=1013.25E+02)
3469 ! formula weight for h2so4 [ g mole **-1 ]
3470 REAL mwh2so4
3471 PARAMETER (mwh2so4=98.07948)
3473 ! diameter of a 3.5 nm particle in cm
3474 REAL d35
3475 PARAMETER (d35=3.5E-07)
3476 REAL d35sq
3477 PARAMETER (d35sq=d35*d35)
3478 ! volume of a 3.5 nm particle in cm**3
3479 REAL v35
3480 PARAMETER (v35=pid6*d35*d35sq)
3481 !ia rev01
3483 REAL mp
3484 ! *** conversion factors:
3485 ! mass of sulfate in a 3.5 nm particle
3486 ! number per cubic cm.
3487 REAL ugm3_ncm3
3488 ! micrograms per cubic meter to
3489 PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3490 !ia rev01
3491 ! molecules to micrograms
3492 REAL nc_ug
3493 PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3497 ! *** statement functions **************
3499 REAL pdens, &
3500 rho_p
3501 ! particle density [ g / cm**3]
3502 REAL ad0, ad1, ad2, &
3503 ad3
3504 ! coefficients for density expression
3505 PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3506 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3507 ! as a function of relative humidity,
3508 ! J. Aerosol Science, 6, pp 265-271, 1975.
3510 !ia rev01
3512 ! fit to Nair & Vohra data
3513 ! the mass of sulfate in a 3.5 nm particle
3514 REAL mp35
3515 ! arithmetic statement function to compute
3516 REAL a0, a1, a2, & ! coefficients for cubic in mp35
3517 a3
3518 PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3520 REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ]
3521 ph2o
3524 ! arithmetic statement functions
3525 pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3527 ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3529 ph2so4(tt) = exp(27.78492066-10156.0/tt)
3531 ! *** both ph2o and ph2so4 are as in Kulmala et al. paper
3533 !ia rev01
3535 ! *** function for the mass of sulfate in a 3.5 nm sphere
3536 ! *** obtained from a fit to the number of sulfate monomers in
3537 ! a 3.5 nm particle. Uses data from Nair & Vohra
3538 mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3542 ! *** begin code:
3544 ! The 1.0e-6 factor in the following converts from MKS to cgs units
3546 ! *** get water vapor concentration [ molecles / cm **3 ]
3548 nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3550 ! *** calculate the equilibrium h2so4 vapor concentration.
3552 ! *** use Kulmala corrections:
3555 ! ***
3557 nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3559 ! *** convert sulfuric acid vapor concentration from micrograms
3560 ! per cubic meter to molecules per cubic centimeter.
3562 nav = ugm3_ncm3*h2so4
3565 ! *** calculate critical concentration of sulfuric acid vapor
3567 nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3569 ! *** calculate relative acidity
3571 ra = nav/nav0
3573 ! *** calculate temperature correction
3575 delta = 1.0 + (temp-273.15)/273.14
3577 ! *** calculate molar fraction
3579 xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3580 0.0016*temp
3582 ! *** calculate Nsulf
3583 nsulf = log(nav/nac)
3585 ! *** calculate particle produtcion rate [ # / cm**3 ]
3587 chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3588 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3590 jnuc = exp(chi)
3591 ! [ # / cm**3 ]
3592 ndot1 = (1.0E06)*jnuc
3593 ! write(91,*) ' inside klpnuc '
3594 ! write(91,*) ' Jnuc = ', Jnuc
3595 ! write(91,*) ' NDOT = ', NDOT1
3597 ! *** calculate particle density
3600 rho_p = pdens(rh)
3602 ! write(91,*) ' rho_p =', rho_p
3604 ! *** get the mass of sulfate in a 3.5 nm particle
3606 mp = mp35(rh) ! in a 3.5 nm particle at ambient RH
3608 ! *** calculate mass production rate [ ug / m**3]
3609 ! assume that the particles are 3.5 nm in diameter.
3612 ! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc
3614 !ia rev01
3616 ! number of micrograms of sulfate
3617 mdot1 = mp*ndot1
3619 !ia rev02
3621 IF (mdot1>so4rat) THEN
3623 mdot1 = &
3624 so4rat
3625 ! limit nucleated mass by available ma
3626 ndot1 = mdot1/ &
3627 mp
3628 ! adjust DNDT to this
3629 END IF
3632 IF (mdot1==0.) ndot1 = 0.
3634 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3636 m2dot = 1.0E-04*d35sq*ndot1
3638 RETURN
3640 END SUBROUTINE klpnuc
3641 SUBROUTINE lnsrch(ctot,n,xold,fold,g,p,x,f,stpmax,check,func, &
3642 fvec,ct,cs,imw,m)
3643 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3644 !bs !
3645 !bs Description: !
3646 !bs !
3647 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3648 !bs !
3649 !bs Given an n-dimensional point XOLD(1:N), the value of the function !
3650 !bs and gradient there, FOLD and G(1:N), and a direction P(1:N), !
3651 !bs finds a new point X(1:N) along the direction P from XOLD where !
3652 !bs the function FUNC has decreased 'sufficiently'. The new function !
3653 !bs value is returned in F. STPMAX is an input quantity that limits !
3654 !bs the length of the steps so that you do not try to evaluate the !
3655 !bs function in regions where it is undefined or subject to overflow. !
3656 !bs P is usually the Newton direction. The output quantity CHECK is !
3657 !bs false on a normal; exit. It is true when X is too close to XOLD. !
3658 !bs In a minimization algorithm, this usually signals convergence and !
3659 !bs can be ignored. However, in a zero-finding algorithm the calling !
3660 !bs program should check whether the convergence is spurious. !
3661 !bs !
3662 !bs Called by: NEWT !
3663 !bs !
3664 !bs Calls: FUNC !
3665 !bs !
3666 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3668 ! IMPLICIT NONE
3669 !bs
3670 !bs
3671 INTEGER n
3672 LOGICAL check
3673 REAL f, fold, stpmax
3674 REAL g(n), p(n), x(n), xold(n)
3675 REAL func
3676 REAL ctot(n)
3677 REAL alf
3678 REAL ct(np)
3679 REAL cs(np)
3680 REAL imw(np)
3681 REAL fvec(n)
3682 REAL m
3684 PARAMETER (alf=1.E-04)
3686 EXTERNAL func
3688 INTEGER i
3689 REAL a, alam, alam2, alamin, b, disc
3690 REAL f2, fold2, rhs1, rhs2, slope
3691 REAL sum, temp, test, tmplam
3693 check = .FALSE.
3694 sum = 0.
3695 DO i = 1, n
3696 sum = sum + p(i)*p(i)
3697 END DO
3698 sum = sqrt(sum)
3699 IF (sum>stpmax) THEN
3700 DO i = 1, n
3701 p(i) = p(i)*stpmax/sum
3702 END DO
3703 END IF
3704 slope = 0.
3705 DO i = 1, n
3706 slope = slope + g(i)*p(i)
3707 END DO
3708 test = 0.
3709 DO i = 1, n
3710 temp = abs(p(i))/max(abs(xold(i)),1.)
3711 IF (temp>test) test = temp
3712 END DO
3713 alamin = tolx/test
3714 alam = 1.
3716 10 CONTINUE
3718 !bs
3719 !bs * avoid negative concentrations and set upper limit given by CTOT.
3720 !bs
3721 DO i = 1, n
3722 x(i) = xold(i) + alam*p(i)
3723 IF (x(i)<=0.) x(i) = conmin
3724 IF (x(i)>ctot(i)) x(i) = ctot(i)
3725 END DO
3726 f = func(x,fvec,n,ct,cs,imw,m)
3727 IF (alam<alamin) THEN
3728 DO i = 1, n
3729 x(i) = xold(i)
3730 END DO
3731 check = .TRUE.
3732 RETURN
3733 ELSE IF (f<=fold+alf*alam*slope) THEN
3734 RETURN
3735 ELSE
3736 IF (alam==1.) THEN
3737 tmplam = -slope/(2.*(f-fold-slope))
3738 ELSE
3739 rhs1 = f - fold - alam*slope
3740 rhs2 = f2 - fold2 - alam2*slope
3741 a = (rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
3742 b = (-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
3743 IF (a==0.) THEN
3744 tmplam = -slope/(2.*b)
3745 ELSE
3746 disc = b*b - 3.*a*slope
3747 tmplam = (-b+sqrt(disc))/(3.*a)
3748 END IF
3749 IF (tmplam>0.5*alam) tmplam = 0.5*alam
3750 END IF
3751 END IF
3752 alam2 = alam
3753 f2 = f
3754 fold2 = fold
3755 alam = max(tmplam,0.1*alam)
3756 GO TO 10
3758 END SUBROUTINE lnsrch
3759 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3760 SUBROUTINE lubksb(a,n,np,indx,b)
3761 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3762 !bs !
3763 !bs Description: !
3764 !bs !
3765 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. !
3766 !bs !
3767 !bs Solves the set of N linear equations A * X = B. Here A is input, !
3768 !bs not as the matrix A but rather as its LU decomposition, !
3769 !bs determined by the routine LUDCMP. B(1:N) is input as the right- !
3770 !bs hand side vector B, and returns with the solution vector X. A, N, !
3771 !bs NP, and INDX are not modified by this routine and can be left in !
3772 !bs place for successive calls with different right-hand sides B. !
3773 !bs This routine takes into account the possibilitythat B will begin !
3774 !bs with many zero elements, so it is efficient for use in matrix !
3775 !bs inversion. !
3776 !bs !
3777 !bs Called by: NEWT !
3778 !bs !
3779 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3780 !bs
3781 ! IMPLICIT NONE
3782 !bs
3783 INTEGER n, np, indx(n)
3784 REAL a(np,np), b(n)
3786 INTEGER i, ii, j, ll
3787 REAL sum
3789 ii = 0
3790 DO i = 1, n
3791 ll = indx(i)
3792 sum = b(ll)
3793 b(ll) = b(i)
3794 IF (ii/=0) THEN
3795 DO j = ii, i - 1
3796 sum = sum - a(i,j)*b(j)
3797 END DO
3798 ELSE IF (sum/=0) THEN
3799 ii = i
3800 END IF
3801 b(i) = sum
3802 END DO
3803 DO i = n, 1, -1
3804 sum = b(i)
3805 DO j = i + 1, n
3806 sum = sum - a(i,j)*b(j)
3807 END DO
3808 b(i) = sum/a(i,i)
3809 END DO
3811 RETURN
3812 END SUBROUTINE lubksb
3813 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3814 SUBROUTINE ludcmp(a,n,np,indx,d,klev)
3815 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3816 !bs !
3817 !bs Description: !
3818 !bs !
3819 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. !
3820 !bs !
3821 !bs Equation (2.3.14) Numerical Recipes, p 36: !
3822 !bs | b_11 b_12 b_13 b_14 | !
3823 !bs | a_21 b_22 b_23 b_24 | !
3824 !bs | a_31 a_32 b_33 b_34 | !
3825 !bs | a_41 a_42 a_43 b_44 | !
3826 !bs !
3827 !bs Given a matrix A(1:N,1:N), with physical dimension NP by NP, this !
3828 !bs routine replaces it by the LU decomposition of a rowwise !
3829 !bs permutation of itself. A and N are input. A is output arranged as !
3830 !bs in equation (2.3.14) above; INDX(1:N) is an output vector that !
3831 !bs records vector that records the row permutation effected by the !
3832 !bs partial pivoting; D is output as +-1 depending on whether the !
3833 !bs number of row interchanges was even or odd, respectively. This !
3834 !bs routine is used in combination with SR LUBKSB to solve linear !
3835 !bs equations or invert a matrix. !
3836 !bs !
3837 !bs Called by: NEWT !
3838 !bs !
3839 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3840 !bs
3841 ! IMPLICIT NONE
3842 !bs
3843 INTEGER n, np, indx(n)
3844 INTEGER nmax
3845 PARAMETER (nmax=10) !largest expected N
3846 REAL d, a(np,np)
3847 REAL tiny
3848 PARAMETER (tiny=1.0E-20)
3850 INTEGER i, imax, j, k
3851 REAL aamax, dum, sum, vv(nmax)
3852 integer klev
3854 d = 1
3855 DO i = 1, n
3856 aamax = 0.
3857 DO j = 1, n
3858 IF (abs(a(i,j))>aamax) aamax = abs(a(i,j))
3859 END DO
3860 IF (aamax==0) THEN
3861 print *, 'Singular matrix in ludcmp, klev = ',klev
3862 a(1,1)=epsilc
3863 ! STOP
3864 END IF
3865 vv(i) = 1./aamax
3866 END DO
3867 DO j = 1, n
3868 DO i = 1, j - 1
3869 sum = a(i,j)
3870 DO k = 1, i - 1
3871 sum = sum - a(i,k)*a(k,j)
3872 END DO
3873 a(i,j) = sum
3874 END DO
3875 aamax = 0.
3876 DO i = j, n
3877 sum = a(i,j)
3878 DO k = 1, j - 1
3879 sum = sum - a(i,k)*a(k,j)
3880 END DO
3881 a(i,j) = sum
3882 dum = vv(i)*abs(sum)
3883 IF (dum>=aamax) THEN
3884 imax = i
3885 aamax = dum
3886 END IF
3887 END DO
3888 IF (j/=imax) THEN
3889 DO k = 1, n
3890 dum = a(imax,k)
3891 a(imax,k) = a(j,k)
3892 a(j,k) = dum
3893 END DO
3894 d = -d
3895 vv(imax) = vv(j)
3896 END IF
3897 indx(j) = imax
3898 IF (a(j,j)==0.) a(j,j) = tiny
3899 IF (j/=n) THEN
3900 dum = 1./a(j,j)
3901 DO i = j + 1, n
3902 a(i,j) = a(i,j)*dum
3903 END DO
3904 END IF
3905 END DO
3907 RETURN
3908 END SUBROUTINE ludcmp
3910 ! //////////////////////////////////////////////////////////////////
3912 SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3913 pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3914 knacc,kncor)
3915 !***********************************************************************
3919 !** DESCRIPTION:
3920 ! Calculates modal parameters and derived variables,
3921 ! log-squared of std deviation, mode mean size, Knudsen number)
3922 ! based on current values of moments for the modes.
3923 ! FSB Now calculates the 3rd moment, mass, and density in all 3 modes.
3924 !**
3925 !** Revision history:
3926 ! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3927 ! Revised 7/23/96 by FSB to use COMMON blocks and small blocks
3928 ! instead of large 3-d arrays, and to assume a fixed std.
3929 ! Revised 12/06/96 by FSB to include coarse mode
3930 ! Revised 1/10/97 by FSB to have arrays passed in call vector
3931 !**********************************************************************
3933 ! IMPLICIT NONE
3935 ! Includes:
3938 ! *** input:
3940 ! dimension of arrays
3941 INTEGER blksize
3942 ! actual number of cells in arrays
3943 INTEGER numcells
3945 INTEGER nspcsda
3947 ! nmber of species in CBLK
3948 REAL cblk(blksize,nspcsda) ! main array of variables
3949 REAL blkta(blksize) ! Air temperature [ K ]
3950 REAL blkprs(blksize)
3951 ! *** output:
3953 ! Air pressure in [ Pa ]
3954 ! concentration lower limit [ ug/m*
3955 ! lowest particle diameter ( m )
3956 REAL dgmin
3957 PARAMETER (dgmin=1.0E-09)
3959 ! lowest particle density ( Kg/m**3
3960 REAL densmin
3961 PARAMETER (densmin=1.0E03)
3963 REAL pmassn(blksize) ! mass concentration in nuclei mode
3964 REAL pmassa(blksize) ! mass concentration in accumulation
3965 REAL pmassc(blksize) ! mass concentration in coarse mode
3966 REAL pdensn(blksize) ! average particel density in Aitken
3967 REAL pdensa(blksize) ! average particel density in accumu
3968 REAL pdensc(blksize) ! average particel density in coarse
3969 REAL xlm(blksize) ! atmospheric mean free path [ m]
3970 REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3971 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3972 REAL dgacc(blksize) ! accumulation
3973 REAL dgcor(blksize) ! coarse mode
3974 REAL knnuc(blksize) ! Aitken mode Knudsen number
3975 REAL knacc(blksize) ! accumulation
3976 REAL kncor(blksize)
3978 ! coarse mode
3980 INTEGER lcell
3981 ! WRITE(20,*) ' IN MODPAR '
3983 ! *** set up aerosol 3rd moment, mass, density
3985 ! loop counter
3986 DO lcell = 1, numcells
3988 ! *** Aitken-mode
3989 ! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
3990 cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3991 vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3992 vh2oai)+no3fac*cblk(lcell,vno3ai)+ &
3993 nafac*cblk(lcell,vnaai)+ clfac*cblk(lcell,vclai)+ &
3994 orgfac*cblk(lcell, &
3995 vorgaro1i)+orgfac*cblk(lcell,vorgaro2i)+orgfac*cblk(lcell, &
3996 vorgalk1i)+orgfac*cblk(lcell,vorgole1i)+orgfac*cblk(lcell, &
3997 vorgba1i)+orgfac*cblk(lcell,vorgba2i)+orgfac*cblk(lcell, &
3998 vorgba3i)+orgfac*cblk(lcell,vorgba4i)+orgfac*cblk(lcell, &
3999 vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
4000 ! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan
4004 ! *** Accumulation-mode
4006 ! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan
4007 cblk(lcell,vac3) = so4fac*cblk(lcell, &
4008 vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
4009 vh2oaj)+no3fac*cblk(lcell,vno3aj) + &
4010 nafac*cblk(lcell,vnaaj)+ clfac*cblk(lcell,vclaj)+ &
4011 orgfac*cblk(lcell, &
4012 vorgaro1j)+orgfac*cblk(lcell,vorgaro2j)+orgfac*cblk(lcell, &
4013 vorgalk1j)+orgfac*cblk(lcell,vorgole1j)+orgfac*cblk(lcell, &
4014 vorgba1j)+orgfac*cblk(lcell,vorgba2j)+orgfac*cblk(lcell, &
4015 vorgba3j)+orgfac*cblk(lcell,vorgba4j)+orgfac*cblk(lcell, &
4016 vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
4017 ! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan
4019 ! *** coarse mode
4021 ! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment
4022 ! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)))
4023 cblk(lcell,vcor3) = soilfac*cblk(lcell, &
4024 vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
4026 ! *** now get particle mass and density
4028 ! *** Aitken-mode:
4030 ! Na and Cl added to aitken mode mass conc
4032 pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
4033 vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+ &
4034 cblk(lcell,vnaai)+cblk(lcell,vclai)+cblk(lcell, &
4035 vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, &
4036 vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, &
4037 vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, &
4038 vp25ai)+cblk(lcell,veci)))
4040 ! pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
4041 ! vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
4042 ! vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, &
4043 ! vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, &
4044 ! vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, &
4045 ! vp25ai)+cblk(lcell,veci)))
4048 ! *** Accumulation-mode:
4050 ! ! Na and Cl added to accum mode mass conc
4052 pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
4053 vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+ &
4054 cblk(lcell,vnaaj)+cblk(lcell,vclaj)+cblk(lcell, &
4055 vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, &
4056 vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, &
4057 vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
4058 vp25aj)+cblk(lcell,vecj)))
4060 ! pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
4061 ! vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
4062 ! vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, &
4063 ! vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, &
4064 ! vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
4065 ! vp25aj)+cblk(lcell,vecj)))
4068 ! *** coarse mode:
4070 pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
4071 lcell,vantha))
4075 END DO
4076 ! *** now get particle density, mean free path, and dynamic viscosity
4078 ! aerosol 3rd moment and mass
4079 DO lcell = 1, &
4080 numcells
4081 ! *** density in [ kg m**-3 ]
4083 ! Density and mean free path
4084 pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
4085 pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
4086 pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
4088 ! *** Calculate mean free path [ m ]:
4090 xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
4092 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
4093 ! *** on page 10 of U.S. Standard Atmosphere 1962
4095 ! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
4097 ! *** U.S. Standard Atmosphere 1962 page 14 expression
4098 ! for dynamic viscosity is:
4099 ! dynamic viscosity = beta * T * sqrt(T) / ( T + S)
4100 ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
4102 amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
4103 (blkta(lcell)+110.4)
4106 END DO
4108 !............... Standard deviation fixed in both modes, so
4109 !............... diagnose diameter from 3rd moment and number concentr
4112 ! density and mean free path
4113 DO lcell = 1, &
4114 numcells
4116 ! calculate diameters
4117 dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
4118 one3)
4121 dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
4122 one3)
4125 dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
4126 **one3)
4128 ! when running with cloudborne aerosol, apply some very mild bounding
4129 ! to avoid unrealistic dg values
4130 if (cw_phase > 0) then
4131 dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2 ) ! > 0.002 um
4132 dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 ) ! < 0.10 um
4133 dgacc(lcell) = max( dgacc(lcell), dginia*0.2 ) ! > 0.014 um
4134 dgacc(lcell) = min( dgacc(lcell), dginia*10.0 ) ! < 0.7 um
4135 dgcor(lcell) = max( dgcor(lcell), dginic*0.2 ) ! > 0.2 um
4136 dgcor(lcell) = min( dgcor(lcell), dginic*10.0 ) ! < 10.0 um
4137 end if
4139 END DO
4140 ! end loop on diameters
4141 DO lcell = 1, &
4142 numcells
4143 ! Calculate Knudsen numbers
4144 knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
4146 knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
4148 kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
4151 END DO
4153 ! end loop for Knudsen numbers
4154 RETURN
4156 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
4157 END SUBROUTINE modpar
4158 ! modpar
4159 SUBROUTINE newt(layer,x,n,check,ctot,csat,imwcv,minitw,its)
4160 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
4161 !bs !
4162 !bs Description: !
4163 !bs !
4164 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
4165 !bs !
4166 !bs Given an initial guess X(1:N) for a root in N dimensions, find !
4167 !bs the root by globally convergent Newton's method. The vector of !
4168 !bs functions to be zeroed, called FVEC(1:N) in the routine below. is !
4169 !bs retuned by a user-supplied function that must be called FUNCV and !
4170 !bs have the declaration SUBROUTINE FUNCV(NX,FVEC). The output !
4171 !bs quantity CHECK is false on a normal return and true if the !
4172 !bs routine has converged to a local minimum of the function FMIN !
4173 !bs defined below. In this case try restarting from a different !
4174 !bs initial guess. !
4175 !bs !
4176 !bs PARAMETERS !
4177 !bs NP : maximum expected value of N !
4178 !bs MAXITS : maximum number of iterations !
4179 !bs TOLF : convergence criterion on function values !
4180 !bs TOLMIN : criterion for decidingwhether spurios convergence to a !
4181 !bs minimum of FMIN has ocurred !
4182 !bs TOLX : convergence criterion on delta_X !
4183 !bs STPMX : scaled maximum step length allowed in line searches !
4184 !bs !
4185 !bs Called by: SOA_PART !
4186 !bs !
4187 !bs Calls: FDJAC !
4188 !bs FMIN !
4189 !bs LNSRCH !
4190 !bs LUBKSB !
4191 !bs LUDCMP !
4192 !bs !
4193 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
4194 !bs
4195 ! IMPLICIT NONE
4196 !bs
4197 !bs * includes
4198 !bs
4199 !bs
4200 !bs * input variables
4201 !bs
4202 !bs model layer
4203 INTEGER layer
4204 !bs dimension of problem
4205 INTEGER n
4206 REAL x(n) !bs initial guess of CAER
4207 LOGICAL check
4208 REAL ctot(n) !bs total concentration GAS + AER + PROD
4209 REAL csat(n) !bs saturation conc. of cond. vapor [ug/m^
4210 REAL imwcv(n) !bs inverse molecular weights
4211 !bs
4212 REAL minitw
4213 !bs * following Numerical recipes
4214 !bs
4215 !bs weighted initial mass
4216 INTEGER nn
4217 ! INTEGER NP
4218 ! PARAMETER (NP = 6)
4219 REAL fvec(np) !bs
4220 !bs
4221 !bs vector of functions to be zeroed
4222 REAL ct(np)
4223 REAL cs(np)
4224 REAL imw(np)
4225 REAL m
4226 !bs
4227 INTEGER i, its, j, indx(np)
4228 REAL d, den, f, fold, stpmax, sum, temp, test
4229 REAL fjac(np,np)
4230 REAL g(np), p(np), xold(np)
4231 !bs
4232 ! EXTERNAL fmin
4233 !bs
4234 !bs * begin code
4235 !bs
4236 m = minitw
4237 DO i = 1, n
4238 ct(i) = ctot(i)
4239 cs(i) = csat(i)
4240 imw(i) = imwcv(i)
4241 END DO
4242 !bs
4243 nn = n
4244 f = fmin(x,fvec,nn,ct,cs,imw,m) !The vector FVEC is
4245 test = & !Test for initial guess being a root. Us
4246 0.
4247 DO i = 1, & !stringent test than simply TOLF.
4248 n
4249 IF (abs(fvec(i))>test) test = abs(fvec(i))
4250 END DO
4251 IF (test<0.01*tolf) RETURN
4252 sum = & !Calculate STPMAX for line searches
4253 0.
4254 DO i = 1, n
4255 sum = sum + x(i)**2
4256 END DO
4257 stpmax = stpmx*max(sqrt(sum),float(n))
4258 DO its = 1, & !start of iteration loop
4259 maxits
4260 CALL fdjac(n,x,fjac,ct,cs,imw) !get Jacobian
4261 DO i = 1, & !compute Delta f for line search
4262 n
4263 sum = 0.
4264 DO j = 1, n
4265 sum = sum + fjac(j,i)*fvec(j)
4266 END DO
4267 g(i) = sum
4268 END DO
4269 DO i = 1, & !store X
4270 n
4271 xold(i) = x(i)
4272 END DO
4273 fold = & !store F
4274 f
4275 DO i = 1, & !right-hand side for linear equations
4276 n
4277 p(i) = -fvec(i)
4278 END DO
4279 CALL ludcmp(fjac,n,np,indx,d,layer) !solve linear equations by LU dec
4280 CALL lubksb(fjac,n,np,indx,p)
4281 CALL lnsrch(ctot,n,xold,fold,g, & !LNSRCH returns new X and F. It a
4282 p,x,f,stpmax, & !calculates FVEC at the new X whe
4283 check,fmin,fvec,ct,cs,imw,m) !calls FMIN
4284 test = 0.
4285 DO i = 1, n
4286 IF (abs(fvec(i))>test) test = abs(fvec(i))
4287 END DO
4288 IF (test<tolf) THEN
4289 check = .FALSE.
4290 RETURN
4291 END IF
4292 IF (check) & !Check for gradient of F zero,
4293 THEN
4294 test = & !i.e., superious convergence.
4295 0.
4296 den = max(f,0.5*n)
4297 DO i = 1, n
4298 temp = abs(g(i))*max(abs(x(i)),1.)/den
4299 IF (temp>test) test = temp
4300 END DO
4301 IF (test<tolmin) THEN
4302 check = .TRUE.
4303 ELSE
4304 check = .FALSE.
4305 END IF
4306 RETURN
4307 END IF
4308 test = & !Test for convergence on delta_x
4309 0.
4310 DO i = 1, n
4311 temp = (abs(x(i)-xold(i)))/max(abs(x(i)),1.)
4312 IF (temp>test) test = temp
4313 END DO
4314 IF (test<tolx) RETURN
4315 END DO
4316 ! WRITE (6,'(a,i2)') 'MAXITS exceeded in newt.F ! Layer: ', layer
4317 !bs
4318 END SUBROUTINE newt
4319 ! //////////////////////////////////////////////////////////////////
4321 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
4322 blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
4323 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
4324 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)
4325 !***********************************************************************
4326 !** DESCRIPTION: calculates aerosol nucleation and condensational
4327 !** growth rates using Binkowski and Shankar (1995) method.
4329 ! *** In this version, the method od RPM is followed where
4330 ! the diffusivity, the average molecular ve3locity, and
4331 ! the accomodation coefficient for sulfuric acid are used for
4332 ! the organics. This is for consistency.
4333 ! Future versions will use the correct values. FSB 12/12/96
4336 !**
4337 !** Revision history:
4338 ! prototype 1/95 by Uma and Carlie
4339 ! Corrected 7/95 by Uma for condensation of mass not nucleated
4340 ! and mass conservation check
4341 ! Revised 8/95 by US to calculate air density in stmt function
4342 ! and collect met variable stmt funcs in one include fil
4343 ! Revised 7/25/96 by FSB to use block structure.
4344 ! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
4345 ! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units.
4346 ! Revised 1/13/97 by FSB to pass arrays and simplify code.
4347 ! Added 23/03/99 by BS growth factors for organics
4348 !**********************************************************************
4350 ! IMPLICIT NONE
4352 ! Includes:
4355 ! *** arguments
4357 ! *** input;
4359 ! dimension of arrays
4360 INTEGER blksize
4361 INTEGER layer
4362 ! number of species in CBLK
4363 INTEGER nspcsda
4364 ! actual number of cells in arrays
4365 INTEGER numcells
4367 INTEGER ldrog
4368 ! # of organic aerosol precursor
4369 REAL cblk(blksize,nspcsda) ! main array of variables
4370 ! model time step in SECONDS
4371 REAL dt
4372 REAL blkta(blksize) ! Air temperature [ K ]
4373 REAL blkprs(blksize) ! Air pressure in [ Pa ]
4374 REAL blkrh(blksize) ! Fractional relative humidity
4375 REAL so4rat(blksize) ! rate [ ug/m**3 /s ]
4376 !bs
4377 ! sulfate gas-phase production
4378 ! total # of cond. vapors & SOA spe
4379 INTEGER ncv
4380 !bs
4381 INTEGER nacv
4382 !bs * anthropogenic organic condensable vapor production rate
4383 ! # of anthrop. cond. vapors & SOA
4384 REAL drog(blksize,ldrog) !bs
4385 ! Delta ROG conc. [ppm]
4386 REAL orgaro1rat(blksize) ! production rate from aromatics [ug/m**
4387 ! anthropogenic organic aerosol mass
4388 REAL orgaro2rat(blksize) ! production rate from aromatics [ug/m**
4389 ! anthropogenic organic aerosol mass
4390 REAL orgalk1rat(blksize) ! production rate from alkanes & others
4391 ! anthropogenic organic aerosol mass
4392 REAL orgole1rat(blksize) ! production rate from alkenes & others
4393 !bs * biogenic organic condensable vapor production rate
4394 ! anthropogenic organic aerosol mass
4395 REAL orgbio1rat(blksize) ! rate [ ug/m**3 /s ]
4396 ! biogenic organic aerosol production
4397 REAL orgbio2rat(blksize) ! rate [ ug/m**3 /s ]
4398 ! biogenic organic aerosol production
4399 REAL orgbio3rat(blksize) ! rate [ ug/m**3 /s ]
4400 ! biogenic organic aerosol production
4401 REAL orgbio4rat(blksize) ! rate [ ug/m**3 /s ]
4402 !bs
4403 ! biogenic organic aerosol production
4404 REAL dgnuc(blksize) ! accumulation
4405 REAL dgacc(blksize)
4406 ! *** output:
4408 ! coarse mode
4409 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
4410 ! reciprocal condensation rate
4411 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
4412 ! reciprocal condensation rate
4413 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
4414 ! reciprocal condensation rate
4415 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
4416 ! reciprocal condensation rate
4417 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
4418 ! rate of production of new mass concent
4419 REAL dndt(blksize) ! concentration by particle formation [#
4420 ! rate of producton of new particle numb
4421 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
4422 ! increment of concentration added to
4423 REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ]
4424 ! growth rate for 3rd moment for
4425 REAL cgra3(blksize) ! Accumulation mode
4427 !........... SCRATCH local variables and their descriptions:
4429 ! growth rate for 3rd moment for
4431 INTEGER lcell
4433 ! LOOP INDEX
4434 ! conv rate so2 --> so4 [mom-3/g/s]
4435 REAL chemrat
4436 ! conv rate for organics [mom-3/g/s]
4437 REAL chemrat_org
4438 REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
4439 am1a
4440 REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
4441 am2a
4442 REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
4443 gnc3a
4444 REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den
4445 gfm3a
4446 ! total reciprocal condensation rate
4447 REAL fconc
4449 REAL td
4450 ! d * tinf (cgs)
4451 REAL*8 & ! Cnstant to force 64 bit evaluation of
4452 one88
4453 PARAMETER (one88=1.0D0)
4454 ! *** variables to set up sulfate and organic condensation rates
4456 ! sulfuric acid vapor at current time step
4457 REAL vapor1
4458 ! chemistry and emissions
4459 REAL vapor2
4460 ! Sulfuric acid vapor prior to addition from
4461 !bs
4462 REAL deltavap
4463 !bs * start update
4464 !bs
4465 ! change to vapor at previous time step
4466 REAL diffcorr
4468 !bs *
4469 REAL csqt_org
4470 !bs * end update
4471 !bs
4473 REAL csqt
4474 !.......................................................................
4475 ! begin body of subroutine NUCLCOND
4478 !........... Main computational grid-traversal loop nest
4479 !........... for computing condensation and nucleation:
4481 DO lcell = 1, &
4482 numcells
4483 ! *** First moment:
4485 ! 1st loop over NUMCELLS
4486 am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
4487 am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
4489 !.............. near-continuum factors [ 1 / sec ]
4490 !bs
4491 !bs * adopted from code of FSB
4492 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
4493 !bs
4494 diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
4495 !bs
4496 gnc3n = cconc*am1n*diffcorr
4497 gnc3a = cconc*am1a*diffcorr
4500 ! *** Second moment:
4502 am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
4503 am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
4505 csqt = ccofm*sqrt(blkta(lcell))
4506 !............... free molecular factors [ 1 / sec ]
4508 ! put in temperature fac
4509 gfm3n = csqt*am2n
4510 gfm3a = csqt*am2a
4512 ! *** Condensation factors in [ s**-1] for h2so4
4513 ! *** In the future, separate factors for condensing organics will
4514 ! be included. In this version, the h2so4 values are used.
4516 !............... Twice the harmonic mean of fm, nc functions:
4518 ! *** Force 64 bit evaluation:
4520 fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4521 fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4522 fconc = fconcn(lcell) + fconca(lcell)
4524 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
4525 !bs
4526 !bs * start modifications for organcis
4527 !bs
4528 gnc3n = cconc_org*am1n*diffcorr
4529 gnc3a = cconc_org*am1a*diffcorr
4530 !bs
4531 csqt_org = ccofm_org*sqrt(blkta(lcell))
4532 gfm3n = csqt_org*am2n
4533 gfm3a = csqt_org*am2a
4534 !bs
4535 fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4536 fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4537 !bs
4538 !bs * end modifications for organics
4539 !bs
4540 ! *** calculate the total change to sulfuric acid vapor from production
4541 ! and condensation
4543 vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
4544 vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
4545 dt
4546 ! vapor at prev
4547 vapor2 = max(0.0,vapor2)
4549 deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
4551 ! *** Calculate increment in total sufate aerosol mass concentration
4553 ! *** This follows the method of Youngblood & Kreidenweis.
4555 !bs
4556 !bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
4557 !bs
4558 !bs * allow DELTASO4A to be negative, but the change must not be larger
4559 !bs * than the amount of vapor available.
4560 !bs
4561 deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
4562 so4rat(lcell)*dt-deltavap)
4563 !bs
4565 ! *** zero out growth coefficients
4567 cgrn3(lcell) = 0.0
4568 cgra3(lcell) = 0.0
4571 END DO
4573 ! *** Select method of nucleation
4575 ! End 1st loop over NUMCELLS
4576 IF (inucl==1) THEN
4578 ! *** Do Youngblood & Kreidenweis Nucleation
4580 ! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4581 ! & DNDT,DMDT,NUMCELLS,BLKSIZE,
4582 ! & VAPOR1)
4583 ! IF (firstime) THEN
4584 ! WRITE (6,*)
4585 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4586 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4587 ! firstime = .FALSE.
4588 ! END IF
4590 ELSE IF (inucl==0) THEN
4592 ! *** Do Kerminen & Wexler Nucleation
4594 ! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4595 ! & DNDT,DMDT,NUMCELLS,BLKSIZE)
4596 ! IF (firstime) THEN
4597 ! WRITE (6,*)
4598 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4599 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4600 ! firstime = .FALSE.
4601 ! END IF
4604 ELSE IF (inucl==2) THEN
4606 !bs ** Do Kulmala et al. Nucleation
4607 ! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
4609 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
4610 CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4611 else
4612 dndt(1)=0.
4613 dmdt(1)=0.
4614 endif
4617 ! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4618 ! if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
4619 IF (dndt(1)==0.) dmdt(1) = 0.
4620 IF (dmdt(1)==0.) dndt(1) = 0.
4621 ! IF (firstime) THEN
4622 ! WRITE (6,*)
4623 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4624 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4625 ! firstime = .FALSE.
4626 ! END IF
4627 ! ELSE
4628 ! WRITE (6,'(a)') '*************************************'
4629 ! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!'
4630 ! WRITE (6,'(a)') ' PROGRAM TERMINATED !!'
4631 ! WRITE (6,'(a)') '*************************************'
4632 ! STOP
4634 END IF
4635 !bs
4636 !bs * Secondary organic aerosol module (SORGAM)
4637 !bs
4638 ! end of selection of nucleation method
4639 CALL sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
4640 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
4641 nacv,cblk,blksize,nspcsda,numcells,dt)
4642 !bs
4643 !bs * Secondary organic aerosol module (SORGAM)
4644 !bs
4646 DO lcell = 1, numcells
4648 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
4649 ! condensation factors
4651 td = 1.0/(fconcn(lcell)+fconca(lcell))
4652 fconcn(lcell) = td*fconcn(lcell)
4653 fconca(lcell) = td*fconca(lcell)
4654 !bs
4655 td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
4656 fconcn_org(lcell) = td*fconcn_org(lcell)
4657 fconca_org(lcell) = td*fconca_org(lcell)
4658 !bs
4659 END DO
4661 ! *** Begin second loop over cells
4663 DO lcell = 1, &
4664 numcells
4665 ! *** note CHEMRAT includes species other than sulfate.
4667 ! 3rd loop on NUMCELLS
4668 chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
4669 chemrat_org = orgfac*(orgaro1rat(lcell)+orgaro2rat(lcell)+orgalk1rat( &
4670 lcell)+orgole1rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
4671 orgbio3rat(lcell)+orgbio4rat(lcell))
4672 ! *** Calculate the production rates for new particle
4674 ! [mom3 m**-3 s-
4675 cgrn3(lcell) = so4fac*dmdt(lcell)
4676 ! Rate of increase of 3rd
4677 chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro
4679 !bs Remove the rate of new pa
4680 chemrat = max(chemrat,0.0)
4681 ! *** Now calculate the rate of condensation on existing particles.
4683 ! Prevent CHEMRAT from being negativ
4684 cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
4685 chemrat_org*fconcn_org(lcell)
4687 cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
4689 ! ***
4691 END DO
4692 ! end 2nd loop over NUMCELLS
4693 RETURN
4695 END SUBROUTINE nuclcond
4696 !23456789012345678901234567890123456789012345678901234567890123456789012
4698 ! nuclcond
4699 REAL FUNCTION poly4(a,x)
4700 REAL a(4), x
4702 poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
4703 RETURN
4704 END FUNCTION poly4
4705 REAL FUNCTION poly6(a,x)
4706 REAL a(6), x
4708 poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
4709 RETURN
4710 END FUNCTION poly6
4713 !-----------------------------------------------------------------------
4717 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
4718 gnh3,gno3)
4720 !-----------------------------------------------------------------------
4722 ! Description:
4724 ! ARES calculates the chemical composition of a sulfate/nitrate/
4725 ! ammonium/water aerosol based on equilibrium thermodynamics.
4727 ! This code considers two regimes depending upon the molar ratio
4728 ! of ammonium to sulfate.
4730 ! For values of this ratio less than 2,the code solves a cubic for
4731 ! hydrogen ion molality, HPLUS, and if enough ammonium and liquid
4732 ! water are present calculates the dissolved nitric acid. For molal
4733 ! ionic strengths greater than 50, nitrate is assumed not to be presen
4735 ! For values of the molar ratio of 2 or greater, all sulfate is assume
4736 ! to be ammonium sulfate and a calculation is made for the presence of
4737 ! ammonium nitrate.
4739 ! The Pitzer multicomponent approach is used in subroutine ACTCOF to
4740 ! obtain the activity coefficients. Abandoned -7/30/97 FSB
4742 ! The Bromley method of calculating the activity coefficients is s use
4743 ! in this version
4745 ! The calculation of liquid water
4746 ! is done in subroutine water. Details for both calculations are given
4747 ! in the respective subroutines.
4749 ! Based upon MARS due to
4750 ! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
4751 ! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
4753 ! and SCAPE due to
4754 ! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
4755 ! Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
4757 ! NOTE: All concentrations supplied to this subroutine are TOTAL
4758 ! over gas and aerosol phases
4760 ! Parameters:
4762 ! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
4763 ! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
4764 ! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
4765 ! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
4766 ! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
4767 ! RH : Fractional relative humidity (IN)
4768 ! TEMP : Temperature in Kelvin (IN)
4769 ! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
4770 ! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
4771 ! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
4772 ! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
4773 ! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
4774 ! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT)
4775 ! NITR : Number of iterations for obtaining activity coefficients (OU
4776 ! NR : Number of real roots to the cubic in the low ammonia case (OU
4778 ! Revision History:
4779 ! Who When Detailed description of changes
4780 ! --------- -------- -------------------------------------------
4781 ! S.Roselle 11/10/87 Received the first version of the MARS code
4782 ! S.Roselle 12/30/87 Restructured code
4783 ! S.Roselle 2/12/88 Made correction to compute liquid-phase
4784 ! concentration of H2O2.
4785 ! S.Roselle 5/26/88 Made correction as advised by SAI, for
4786 ! computing H+ concentration.
4787 ! S.Roselle 3/1/89 Modified to operate with EM2
4788 ! S.Roselle 5/19/89 Changed the maximum ionic strength from
4789 ! 100 to 20, for numerical stability.
4790 ! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case
4791 ! using equations for nitrate budget.
4792 ! F.Binkowski 6/18/91 New ammonia poor case which
4793 ! omits letovicite.
4794 ! F.Binkowski 7/25/91 Rearranged entire code, restructured
4795 ! ammonia poor case.
4796 ! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output
4797 ! as SO4--
4798 ! F.Binkowski 12/6/91 Changed the ammonia defficient case so that
4799 ! there is only neutralized sulfate (ammonium
4800 ! sulfate) and sulfuric acid.
4801 ! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen
4802 ! with the Cohen et al. (1987) maximum molalit
4803 ! of 36.2 in Table III.( J. Phys Chem (91) page
4804 ! 4569, and Table IV p 4587.)
4805 ! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem
4806 ! possibility for denomenator becoming zero;
4807 ! this involved solving for HPLUS first.
4808 ! Note that for a relative humidity
4809 ! less than 50%, the model assumes that there i
4810 ! aerosol nitrate.
4811 ! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System
4812 ! Redid logic as follows
4813 ! 1. Water algorithm now follows Spann & Richard
4814 ! 2. Pitzer Multicomponent method used
4815 ! 3. Multicomponent practical osmotic coefficien
4816 ! use to close iterations.
4817 ! 4. The model now assumes that for a water
4818 ! mass fraction WFRAC less than 50% there is
4819 ! no aerosol nitrate.
4820 ! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p
4821 ! case, and changed the WFRAC criterion to 40%.
4822 ! For ammonium to sulfate ratio less than 1.0
4823 ! all ammonium is aerosol and no nitrate aerosol
4824 ! exists.
4825 ! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case
4826 ! allow gas-phase ammonia to exist.
4827 ! F.Binkowski 7/26/95 Changed equilibrium constants to values from
4828 ! Kim et al. (1993)
4829 ! F.Binkowski 6/27/96 Changed to new water format
4830 ! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent
4831 ! activity coefficients. The binary activity coe
4832 ! are the same as the previous version
4833 ! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
4834 ! 1 picogram per cubic meter
4836 !-----------------------------------------------------------------------
4838 ! IMPLICIT NONE
4840 !...........INCLUDES and their descriptions
4842 !cc INCLUDE SUBST_CONST ! constants
4844 !...........PARAMETERS and their descriptions:
4846 ! molecular weight for NaCl
4847 REAL mwnacl
4848 PARAMETER (mwnacl=58.44277)
4850 ! molecular weight for NO3
4851 REAL mwno3
4852 PARAMETER (mwno3=62.0049)
4854 ! molecular weight for HNO3
4855 REAL mwhno3
4856 PARAMETER (mwhno3=63.01287)
4858 ! molecular weight for SO4
4859 REAL mwso4
4860 PARAMETER (mwso4=96.0576)
4862 ! molecular weight for HSO4
4863 REAL mwhso4
4864 PARAMETER (mwhso4=mwso4+1.0080)
4866 ! molecular weight for H2SO4
4867 REAL mh2so4
4868 PARAMETER (mh2so4=98.07354)
4870 ! molecular weight for NH3
4871 REAL mwnh3
4872 PARAMETER (mwnh3=17.03061)
4874 ! molecular weight for NH4
4875 REAL mwnh4
4876 PARAMETER (mwnh4=18.03858)
4878 ! molecular weight for Organic Specie
4879 REAL mworg
4880 !
4881 PARAMETER (mworg=175.0)
4882 ! PARAMETER (mworg=16.0)
4884 ! molecular weight for Chloride
4885 REAL mwcl
4886 PARAMETER (mwcl=35.453)
4888 ! molecular weight for AIR
4889 REAL mwair
4890 PARAMETER (mwair=28.964)
4892 ! molecular weight for Letovicite
4893 REAL mwlct
4894 PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4896 ! molecular weight for Ammonium Sulfa
4897 REAL mwas
4898 PARAMETER (mwas=2.0*mwnh4+mwso4)
4900 ! molecular weight for Ammonium Bisul
4901 REAL mwabs
4902 PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4904 !...........ARGUMENTS and their descriptions
4906 !iamodels3
4907 REAL so4
4908 ! Total sulfate in micrograms / m**3
4909 ! Total nitric acid in micrograms / m
4910 REAL hno3
4911 ! Total nitrate in micrograms / m**3
4912 REAL no3
4913 ! Total ammonia in micrograms / m**3
4914 REAL nh3
4915 ! Total ammonium in micrograms / m**3
4916 REAL nh4
4917 ! Fractional relative humidity
4918 REAL rh
4919 ! Temperature in Kelvin
4920 REAL temp
4921 ! Aerosol sulfate in micrograms / m**
4922 REAL aso4
4923 ! Aerosol nitrate in micrograms / m**
4924 REAL ano3
4925 ! Aerosol liquid water content water
4926 REAL ah2o
4927 ! Aerosol ammonium in micrograms / m*
4928 REAL anh4
4929 ! Gas-phase nitric acid in micrograms
4930 REAL gno3
4932 REAL gnh3
4933 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4935 ! Gas-phase ammonia in micrograms / m
4936 ! Index set to percent relative humid
4937 INTEGER irh
4938 ! Number of iterations for activity c
4939 INTEGER nitr
4940 ! Loop index for iterations
4941 INTEGER nnn
4943 INTEGER nr
4944 ! Number of roots to cubic equation f
4945 REAL*8 & ! Coefficients and roots of
4946 a0
4947 REAL*8 & ! Coefficients and roots of
4948 a1
4949 REAL*8 & ! Coefficients and roots of
4950 a2
4951 ! Coefficients and discriminant for q
4952 REAL aa
4953 ! internal variables ( high ammonia c
4954 REAL bal
4955 ! Coefficients and discriminant for q
4956 REAL bb
4957 ! Variables used for ammonia solubili
4958 REAL bhat
4959 ! Coefficients and discriminant for q
4960 REAL cc
4961 ! Factor for conversion of units
4962 REAL convt
4963 ! Coefficients and discriminant for q
4964 REAL dd
4965 ! Coefficients and discriminant for q
4966 REAL disc
4967 ! Relative error used for convergence
4968 REAL eror
4969 ! Free ammonia concentration , that
4970 REAL fnh3
4971 ! Activity Coefficient for (NH4+, HSO
4972 REAL gamaab
4973 ! Activity coefficient for (NH4+, NO3
4974 REAL gamaan
4975 ! Variables used for ammonia solubili
4976 REAL gamahat
4977 ! Activity coefficient for (H+ ,NO3-)
4978 REAL gamana
4979 ! Activity coefficient for (2H+, SO4-
4980 REAL gamas1
4981 ! Activity coefficient for (H+, HSO4-
4982 REAL gamas2
4983 ! used for convergence of iteration
4984 REAL gamold
4985 ! internal variables ( high ammonia c
4986 REAL gasqd
4987 ! Hydrogen ion (low ammonia case) (mo
4988 REAL hplus
4989 ! Equilibrium constant for ammoniua t
4990 REAL k1a
4991 ! Equilibrium constant for sulfate-bi
4992 REAL k2sa
4993 ! Dissociation constant for ammonium
4994 REAL k3
4995 ! Equilibrium constant for ammonium n
4996 REAL kan
4997 ! Variables used for ammonia solubili
4998 REAL khat
4999 ! Equilibrium constant for nitric aci
5000 REAL kna
5001 ! Henry's Law Constant for ammonia
5002 REAL kph
5003 ! Equilibrium constant for water diss
5004 REAL kw
5005 ! Internal variable using KAN
5006 REAL kw2
5007 ! Nitrate (high ammonia case) (moles
5008 REAL man
5009 ! Sulfate (high ammonia case) (moles
5010 REAL mas
5011 ! Bisulfate (low ammonia case) (moles
5012 REAL mhso4
5013 ! Nitrate (low ammonia case) (moles /
5014 REAL mna
5015 ! Ammonium (moles / kg water)
5016 REAL mnh4
5017 ! Total number of moles of all ions
5018 REAL molnu
5019 ! Sulfate (low ammonia case) (moles /
5020 REAL mso4
5021 ! Practical osmotic coefficient
5022 REAL phibar
5023 ! Previous value of practical osmotic
5024 REAL phiold
5025 ! Molar ratio of ammonium to sulfate
5026 REAL ratio
5027 ! Internal variable using K2SA
5028 REAL rk2sa
5029 ! Internal variables using KNA
5030 REAL rkna
5031 ! Internal variables using KNA
5032 REAL rknwet
5033 REAL rr1
5034 REAL rr2
5035 ! Ionic strength
5036 REAL stion
5037 ! Internal variables for temperature
5038 REAL t1
5039 ! Internal variables for temperature
5040 REAL t2
5041 ! Internal variables of convenience (
5042 REAL t21
5043 ! Internal variables of convenience (
5044 REAL t221
5045 ! Internal variables for temperature
5046 REAL t3
5047 ! Internal variables for temperature
5048 REAL t4
5049 ! Internal variables for temperature
5050 REAL t6
5051 ! Total ammonia and ammonium in micro
5052 REAL tnh4
5053 ! Total nitrate in micromoles / meter
5054 REAL tno3
5055 ! Tolerances for convergence test
5056 REAL toler1
5057 ! Tolerances for convergence test
5058 REAL toler2
5059 ! Total sulfate in micromoles / meter
5060 REAL tso4
5061 ! 2.0 * TSO4 (high ammonia case) (mo
5062 REAL twoso4
5063 ! Water mass fraction
5064 REAL wfrac
5065 ! micrograms / meter **3 on output
5066 REAL wh2o
5067 ! internally it is 10 ** (-6) kg (wat
5068 ! the conversion factor (1000 g = 1 k
5069 ! for AH2O output
5070 ! Aerosol liquid water content (inter
5071 ! internal variables ( high ammonia c
5072 REAL wsqd
5073 ! Nitrate aerosol concentration in mi
5074 REAL xno3
5075 ! Variable used in quadratic solution
5076 REAL xxq
5077 ! Ammonium aerosol concentration in m
5078 REAL ynh4
5079 ! Water variable saved in case ionic
5080 REAL zh2o
5082 REAL zso4
5083 ! Total sulfate molality - mso4 + mhs
5084 REAL cat(2) ! Array for cations (1, H+); (2, NH4+
5085 REAL an(3) ! Array for anions (1, SO4--); (2, NO
5086 REAL crutes(3) ! Coefficients and roots of
5087 REAL gams(2,3) ! Array of activity coefficients
5088 ! Minimum value of sulfate laerosol c
5089 REAL minso4
5090 PARAMETER (minso4=1.0E-6/mwso4)
5091 REAL floor
5092 PARAMETER (floor=1.0E-30)
5093 !-----------------------------------------------------------------------
5094 ! begin body of subroutine RPMARES
5096 !...convert into micromoles/m**3
5097 !cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
5098 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
5099 ! minimum concentration
5100 tso4 = max(0.0,so4/mwso4)
5101 tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
5102 tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
5103 !cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
5105 !...now set humidity index IRH as a percent
5107 irh = nint(100.0*rh)
5109 !...Check for valid IRH
5111 irh = max(1,irh)
5112 irh = min(99,irh)
5113 !cc WRITE(10,*)'RH,IRH ',RH,IRH
5115 !...Specify the equilibrium constants at correct
5116 !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA
5117 !... KPH, and K3 )
5118 !... Values from Kim et al. (1993) except as noted.
5120 convt = 1.0/(0.082*temp)
5121 t6 = 0.082E-9*temp
5122 t1 = 298.0/temp
5123 t2 = alog(t1)
5124 t3 = t1 - 1.0
5125 t4 = 1.0 + t2 - t1
5126 kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
5127 k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
5128 k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
5129 kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
5130 kph = 57.639*exp(13.79*t3-5.39*t4)*t6
5131 !cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6
5132 khat = kph*k1a/kw
5133 kan = kna*khat
5135 !...Compute temperature dependent equilibrium constant for NH4NO3
5136 !... ( from Mozurkewich, 1993)
5138 k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
5140 !...Convert to (micromoles/m**3) **2
5142 k3 = k3*convt*convt
5144 wh2o = 0.0
5145 stion = 0.0
5146 ah2o = 0.0
5147 mas = 0.0
5148 man = 0.0
5149 hplus = 0.0
5150 toler1 = 0.00001
5151 toler2 = 0.001
5152 nitr = 0
5153 nr = 0
5154 ratio = 0.0
5155 gamaan = 1.0
5156 gamold = 1.0
5158 !...set the ratio according to the amount of sulfate and nitrate
5159 IF (tso4>minso4) THEN
5160 ratio = tnh4/tso4
5162 !...If there is no sulfate and no nitrate, there can be no ammonium
5163 !... under the current paradigm. Organics are ignored in this version.
5165 ELSE
5167 IF (tno3==0.0) THEN
5169 ! *** If there is very little sulfate and no nitrate set concentrations
5170 ! to a very small value and return.
5171 aso4 = max(floor,aso4)
5172 ano3 = max(floor,ano3)
5173 wh2o = 0.0
5174 ah2o = 0.0
5175 gnh3 = max(floor,gnh3)
5176 gno3 = max(floor,gno3)
5177 RETURN
5178 END IF
5180 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
5181 !... to send the code to the high ammonia case
5183 ratio = 5.0
5184 END IF
5186 !....................................
5187 !......... High Ammonia Case ........
5188 !....................................
5190 IF (ratio>2.0) THEN
5192 gamaan = 0.1
5194 !...Set up twice the sulfate for future use.
5196 twoso4 = 2.0*tso4
5197 xno3 = 0.0
5198 ynh4 = twoso4
5200 !...Treat different regimes of relative humidity
5202 !...ZSR relationship is used to set water levels. Units are
5203 !... 10**(-6) kg water/ (cubic meter of air)
5204 !... start with ammomium sulfate solution without nitrate
5206 CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
5207 wh2o = 1.0E-3*ah2o
5208 aso4 = tso4*mwso4
5209 ano3 = 0.0
5210 anh4 = ynh4*mwnh4
5211 wfrac = ah2o/(aso4+anh4+ah2o)
5212 !cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water
5213 IF (wfrac<0.2) THEN
5215 !... dry ammonium sulfate and ammonium nitrate
5216 !... compute free ammonia
5218 fnh3 = tnh4 - twoso4
5219 cc = tno3*fnh3 - k3
5221 !...check for not enough to support aerosol
5223 IF (cc<=0.0) THEN
5224 xno3 = 0.0
5225 ELSE
5226 aa = 1.0
5227 bb = -(tno3+fnh3)
5228 disc = bb*bb - 4.0*cc
5230 !...Check for no real positive roots of the quadratic
5231 !... set nitrate to zero and RETURN if no real positive roots are found
5233 IF (disc<0.0) THEN
5234 xno3 = 0.0
5235 ah2o = 1000.0*wh2o
5236 ynh4 = twoso4
5237 gno3 = tno3*mwhno3
5238 gnh3 = (tnh4-ynh4)*mwnh3
5239 aso4 = tso4*mwso4
5240 ano3 = 0.0
5241 anh4 = ynh4*mwnh4
5242 RETURN
5243 END IF
5245 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
5247 dd = sqrt(disc)
5248 xxq = -0.5*(bb+sign(1.0,bb)*dd)
5250 !...Since both roots are positive, select smaller root.
5252 xno3 = min(xxq/aa,cc/xxq)
5254 END IF
5255 ah2o = 1000.0*wh2o
5256 ynh4 = 2.0*tso4 + xno3
5257 gno3 = (tno3-xno3)*mwhno3
5258 gnh3 = (tnh4-ynh4)*mwnh3
5259 aso4 = tso4*mwso4
5260 ano3 = xno3*mwno3
5261 anh4 = ynh4*mwnh4
5262 RETURN
5264 END IF
5266 !...liquid phase containing completely neutralized sulfate and
5267 !... some nitrate. Solve for composition and quantity.
5269 mas = tso4/wh2o
5270 man = 0.0
5271 xno3 = 0.0
5272 ynh4 = twoso4
5273 phiold = 1.0
5275 !...Start loop for iteration
5277 !...The assumption here is that all sulfate is ammonium sulfate,
5278 !... and is supersaturated at lower relative humidities.
5280 DO nnn = 1, 150
5281 nitr = nnn
5282 gasqd = gamaan*gamaan
5283 wsqd = wh2o*wh2o
5284 kw2 = kan*wsqd/gasqd
5285 aa = 1.0 - kw2
5286 bb = twoso4 + kw2*(tno3+tnh4-twoso4)
5287 cc = -kw2*tno3*(tnh4-twoso4)
5289 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
5291 disc = bb*bb - 4.0*aa*cc
5293 !...Check for complex roots, if so set nitrate to zero and RETURN
5295 IF((disc<0.0) .OR. &
5296 (bb>0.0 .AND. aa>0.0 .AND.cc >0.0) .OR. &
5297 (bb<0.0 .AND. aa<0.0 .AND.cc <0.0)) THEN
5298 xno3 = 0.0
5299 ah2o = 1000.0*wh2o
5300 ynh4 = twoso4
5301 gno3 = tno3*mwhno3
5302 gnh3 = (tnh4-ynh4)*mwnh3
5303 aso4 = tso4*mwso4
5304 ano3 = 0.0
5305 anh4 = ynh4*mwnh4
5306 !cc WRITE( 10, * ) ' COMPLEX ROOTS '
5307 RETURN
5308 END IF
5310 dd = sqrt(disc)
5311 xxq = -0.5*(bb+sign(1.0,bb)*dd)
5312 !PMA
5313 aa=max(aa,1.e-20)
5314 xxq=max(xxq,1.e-20)
5316 rr1 = xxq/aa
5317 rr2 = cc/xxq
5319 IF (rr1 <= 0.0 .AND. rr2 <= 0.0) THEN
5320 xno3 = 0.0
5321 ah2o = 1000.0*wh2o
5322 ynh4 = twoso4
5323 gno3 = tno3*mwhno3
5324 gnh3 = (tnh4-ynh4)*mwnh3
5325 aso4 = tso4*mwso4
5326 ano3 = 0.0
5327 anh4 = ynh4*mwnh4
5328 ! WRITE(*,*) 'TWO NON-POSITIVE ROOTS!!! '
5329 RETURN
5330 END IF
5332 !...choose minimum positve root
5334 IF ((rr1*rr2)<0.0) THEN
5335 xno3 = max(rr1,rr2)
5336 ELSE
5337 xno3 = min(rr1,rr2)
5338 END IF
5340 xno3 = min(xno3,tno3)
5342 !...This version assumes no solid sulfate forms (supersaturated )
5343 !... Now update water
5345 CALL awater(irh,tso4,ynh4,xno3,ah2o)
5347 !...ZSR relationship is used to set water levels. Units are
5348 !... 10**(-6) kg water/ (cubic meter of air)
5349 !... The conversion from micromoles to moles is done by the units of WH
5351 wh2o = 1.0E-3*ah2o
5353 !...Ionic balance determines the ammonium in solution.
5355 man = xno3/wh2o
5356 mas = tso4/wh2o
5357 mnh4 = 2.0*mas + man
5358 ynh4 = mnh4*wh2o
5360 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
5361 !... and ammonium in molal units (moles/(kg water) ).
5362 !PMA adds avoid cat and an to be < 0
5363 stion = 3.0*mas + man
5364 cat(1) = 0.0
5365 cat(2) = max(mnh4,0.0)
5366 an(1) = max(mas,0.0)
5367 an(2) = max(man,0.0)
5368 an(3) = 0.0
5369 CALL actcof(cat,an,gams,molnu,phibar)
5370 gamaan = gams(2,2)
5372 !...Use GAMAAN for convergence control
5374 eror = abs(gamold-gamaan)/gamold
5375 gamold = gamaan
5377 !...Check to see if we have a solution
5379 IF (eror<=toler1) THEN
5380 !cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
5381 !cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
5383 aso4 = tso4*mwso4
5384 ano3 = xno3*mwno3
5385 anh4 = ynh4*mwnh4
5386 gno3 = (tno3-xno3)*mwhno3
5387 gnh3 = (tnh4-ynh4)*mwnh3
5388 ah2o = 1000.0*wh2o
5389 RETURN
5390 END IF
5392 END DO
5394 !...If after NITR iterations no solution is found, then:
5396 aso4 = tso4*mwso4
5397 ano3 = 0.0
5398 ynh4 = twoso4
5399 anh4 = ynh4*mwnh4
5400 CALL awater(irh,tso4,ynh4,xno3,ah2o)
5401 gno3 = tno3*mwhno3
5402 gnh3 = (tnh4-ynh4)*mwnh3
5403 RETURN
5405 ELSE
5407 !......................................
5408 !......... Low Ammonia Case ...........
5409 !......................................
5411 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
5413 !...All cases covered by this logic
5414 wh2o = 0.0
5415 CALL awater(irh,tso4,tnh4,tno3,ah2o)
5416 wh2o = 1.0E-3*ah2o
5417 zh2o = ah2o
5418 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
5419 !... per cubic meter of air (1000 g = 1 kg)
5421 aso4 = tso4*mwso4
5422 anh4 = tnh4*mwnh4
5423 ano3 = 0.0
5424 gno3 = tno3*mwhno3
5425 gnh3 = 0.0
5427 !...Check for zero water.
5429 IF (wh2o==0.0) RETURN
5430 zso4 = tso4/wh2o
5432 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
5434 !cc IF ( ZSO4 .GT. 11.0 ) THEN
5436 !...do not solve for aerosol nitrate for total sulfate molality
5437 !... greater than 11.0 because the model parameters break down
5438 !... greater than 9.0 because the model parameters break down
5440 IF (zso4>9.0) & ! 18 June 97
5441 THEN
5442 RETURN
5443 END IF
5445 !...First solve with activity coeffs of 1.0, then iterate.
5447 phiold = 1.0
5448 gamana = 1.0
5449 gamas1 = 1.0
5450 gamas2 = 1.0
5451 gamaab = 1.0
5452 gamold = 1.0
5454 !...All ammonia is considered to be aerosol ammonium.
5456 mnh4 = tnh4/wh2o
5458 !...MNH4 is the molality of ammonium ion.
5460 ynh4 = tnh4
5461 !...loop for iteration
5463 DO nnn = 1, 150
5464 nitr = nnn
5466 !...set up equilibrium constants including activities
5467 !... solve the system for hplus first then sulfate & nitrate
5468 ! print*,'gamas,gamana',gamas1,gamas2,gamana
5469 rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
5470 rkna = kna/(gamana*gamana)
5471 rknwet = rkna*wh2o
5472 t21 = zso4 - mnh4
5473 t221 = zso4 + t21
5475 !...set up coefficients for cubic
5477 a2 = rk2sa + rknwet - t21
5478 a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
5479 a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
5482 CALL cubic(a2,a1,a0,nr,crutes)
5484 !...Code assumes the smallest positive root is in CRUTES(1)
5486 hplus = crutes(1)
5487 bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
5488 mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
5489 mhso4 = zso4 - & ! molality of bisulf
5490 mso4
5491 mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
5492 mna = max(0.0,mna)
5493 mna = min(mna,tno3/wh2o)
5494 xno3 = mna*wh2o
5495 ano3 = mna*wh2o*mwno3
5496 gno3 = (tno3-xno3)*mwhno3
5497 !...Calculate ionic strength
5499 stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
5501 !...Update water
5503 CALL awater(irh,tso4,ynh4,xno3,ah2o)
5505 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
5506 !... per cubic meter of air (1000 g = 1 kg)
5507 !PMA adds checker to avoid cat and an < 0.0
5508 wh2o = 1.0E-3*ah2o
5509 cat(1) = max(hplus,0.0)
5510 cat(2) = max(mnh4,0.0)
5511 an(1) = max(mso4,0.0)
5512 an(2) = max(mna,0.0)
5513 an(3) = max(mhso4,0.0)
5514 ! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
5515 CALL actcof(cat,an,gams,molnu,phibar)
5517 gamana = gams(1,2)
5518 gamas1 = gams(1,1)
5519 gamas2 = gams(1,3)
5520 gamaan = gams(2,2)
5522 gamahat = (gamas2*gamas2/(gamaab*gamaab))
5523 bhat = khat*gamahat
5524 !cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
5525 !cc PHIOLD = PHIBAR
5526 eror = abs(gamold-gamahat)/gamold
5527 gamold = gamahat
5529 !...write out molalities and activity coefficient
5530 !... and return with good solution
5532 IF (eror<=toler2) THEN
5533 !cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
5534 !cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
5535 !cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
5536 RETURN
5537 END IF
5539 END DO
5541 !...after NITR iterations, failure to solve the system, no ANO3
5543 gno3 = tno3*mwhno3
5544 ano3 = 0.0
5545 CALL awater(irh,tso4,tnh4,tno3,ah2o)
5546 RETURN
5549 END IF
5550 ! ratio .gt. 2.0
5551 ! ///////////////////////////////////////////////////
5552 END SUBROUTINE rpmares_old
5553 !ia*********************************************************
5554 !ia *
5555 !ia BEGIN OF AEROSOL ROUTINE *
5556 !ia *
5557 !ia*********************************************************
5559 !***********************************************************************
5561 ! BEGIN OF AEROSOL CALCULATIONS
5563 !***********************************************************************
5566 !ia*********************************************************************
5567 !ia *
5568 !ia MAIN AEROSOL DYNAMICS ROUTINE *
5569 !ia based on MODELS3 formulation by FZB *
5570 !ia Modified by IA in May 97 *
5571 !ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
5572 !ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
5573 !ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
5574 !ia CALCULATIONS.
5575 !ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
5576 !ia ONE GRID CELL!!!!
5577 !ia and passed to dynamics calcs. subroutines.
5578 !ia *
5579 !ia Revision history *
5580 !ia When WHO WHAT *
5581 !ia ---- ---- ---- *
5582 !ia ???? FZB BEGIN *
5583 !ia 05/97 IA Adapted for use in CTM2-S *
5584 !ia Modified renaming/bug fixing *
5585 !ia 11/97 IA Modified for new model version
5586 !ia see comments under iarev02
5587 !ia 03/98 IA corrected error on pressure units
5588 !ia *
5589 !ia Called BY: CHEM *
5590 !ia *
5591 !ia Calls to: OUTPUT1,AEROPRC *
5592 !ia *
5593 !ia*********************************************************************
5595 ! end RPMares
5596 SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
5597 nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv, &
5598 nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, &
5599 soilrat_in,cblk,igrid,jgrid,kgrid)
5603 ! IMPLICIT NONE
5605 ! Includes:
5607 !iarev02 INCLUDE AEROINCL.EXT
5608 ! block size, set to 1 in column model ciarev0
5609 INTEGER blksize
5610 !ia kept to 1 in current version of column model
5611 INTEGER numcells
5613 ! actual number of cells in arrays ( default is
5614 PARAMETER (numcells=1)
5617 INTEGER layer
5618 ! number of layer (default is 1 in
5620 INTEGER ncell
5621 ! index for cell in blocked array (default is 1 in
5622 PARAMETER (ncell=1)
5623 ! *** inputs
5624 ! Input temperature [ K ]
5625 REAL temp
5626 ! Input relative humidity [ fraction ]
5627 REAL relhum
5628 ! Input pressure [ hPa ]
5629 REAL pres
5630 ! Input number for Aitken mode [ m**-3 ]
5631 REAL numnuc_in
5632 ! Input number for accumulation mode [ m**-3 ]
5633 REAL numacc_in
5634 ! Input number for coarse mode [ m**-3 ]
5635 REAL numcor_in
5636 ! sulfuric acid [ ug m**-3 ]
5637 REAL vsulf_in
5638 ! total sulfate vapor as sulfuric acid as
5639 ! sulfuric acid [ ug m**-3 ]
5640 REAL asulf_in
5641 ! total sulfate aerosol as sulfuric acid as
5642 ! i-mode sulfate input as sulfuric acid [ ug m*
5643 REAL asulfi_in
5644 ! ammonia gas [ ug m**-3 ]
5645 REAL nh3_in
5646 ! input value of nitric acid vapor [ ug m**-3 ]
5647 REAL nitrate_in
5648 ! Production rate of sulfuric acid [ ug m**-3
5649 REAL so4rat_in
5650 ! aerosol [ ug m**-3 s**-1 ]
5651 REAL soilrat_in
5652 ! Production rate of soil derived coarse
5653 ! Emission rate of i-mode EC [ug m**-3 s**-1]
5654 REAL eeci_in
5655 ! Emission rate of j-mode EC [ug m**-3 s**-1]
5656 REAL eecj_in
5657 ! Emission rate of j-mode org. aerosol [ug m**-
5658 REAL eorgi_in
5660 REAL eorgj_in
5661 !bs
5662 ! Emission rate of j-mode org. aerosol [ug m**-
5663 ! total # of cond. vapors & SOA species
5664 INTEGER ncv
5665 ! # of anthrop. cond. vapors & SOA speci
5666 INTEGER nacv
5667 ! # of organic aerosol precursor
5668 INTEGER ldrog
5669 REAL drog_in(ldrog) ! organic aerosol precursor [ppm]
5670 ! Input delta ROG concentration of
5671 REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
5672 REAL drog(blksize,ldrog) ! organic aerosol precursor [ppm]
5673 !bs
5674 ! *** Primary emissions rates: [ ug / m**3 s ]
5676 ! *** emissions rates for unidentified PM2.5 mass
5677 ! Delta ROG concentration of
5678 REAL epm25i(blksize) ! Aitken mode
5679 REAL epm25j(blksize)
5680 ! *** emissions rates for primary organic aerosol
5681 ! Accumululaton mode
5682 REAL eorgi(blksize) ! Aitken mode
5683 REAL eorgj(blksize)
5684 ! *** emissions rates for elemental carbon
5685 ! Accumululaton mode
5686 REAL eeci(blksize) ! Aitken mode
5687 REAL eecj(blksize)
5688 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
5690 ! Accumululaton mode
5691 REAL epm25(blksize) ! emissions rate for PM2.5 mass
5692 REAL esoil(blksize) ! emissions rate for soil derived coarse a
5693 REAL eseas(blksize) ! emissions rate for marine coarse aerosol
5694 REAL epmcoarse(blksize)
5695 ! emissions rate for anthropogenic coarse
5697 REAL dtsec
5699 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
5701 REAL newm3
5703 REAL totaersulf
5704 ! total aerosol sulfate
5705 ! loop index for time steps
5706 INTEGER numsteps
5708 REAL step
5710 ! *** arrays for aerosol model codes:
5712 ! synchronization time [s]
5714 INTEGER nspcsda
5716 ! number of species in CBLK ciarev02
5717 REAL cblk(blksize,nspcsda)
5719 ! *** Meteorological information in blocked arays:
5721 ! *** Thermodynamic variables:
5723 ! main array of variables
5724 REAL blkta(blksize) ! Air temperature [ K ]
5725 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5726 REAL blkdens(blksize) ! Air density [ kg m^-3 ]
5727 REAL blkrh(blksize)
5730 ! *** Chemical production rates [ ug m**-3 s -1 ] :
5732 ! Fractional relative humidity
5733 REAL so4rat(blksize) ! rate [ug/m^3/s]
5734 ! sulfuric acid vapor-phase production
5735 REAL orgaro1rat(blksize) ! production rate from aromatics [ ug /
5736 ! anthropogenic organic aerosol mass
5737 REAL orgaro2rat(blksize) ! production rate from aromatics [ ug /
5738 ! anthropogenic organic aerosol mass
5739 REAL orgalk1rat(blksize) ! rate from alkanes & others [ ug / m^3
5740 ! anthropogenic organic aerosol mass pro
5741 REAL orgole1rat(blksize) ! rate from alkanes & others [ ug / m^3
5742 ! anthropogenic organic aerosol mass pro
5743 REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ]
5744 ! biogenic organic aerosol production
5745 REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ]
5746 ! biogenic organic aerosol production
5747 REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ]
5748 ! biogenic organic aerosol production
5749 REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ]
5750 !bs
5751 ! *** atmospheric properties
5753 ! biogenic organic aerosol production
5754 REAL xlm(blksize) ! atmospheric mean free path [ m ]
5755 REAL amu(blksize)
5756 ! *** aerosol properties:
5759 ! *** modal diameters:
5761 ! atmospheric dynamic viscosity [ kg
5762 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
5763 REAL dgacc(blksize) ! accumulation geometric mean diamet
5764 REAL dgcor(blksize)
5766 ! *** Modal mass concentrations [ ug m**3 ]
5768 ! coarse mode geometric mean diamete
5769 REAL pmassn(blksize) ! mass concentration in Aitken mode
5770 REAL pmassa(blksize) ! mass concentration in accumulation
5771 REAL pmassc(blksize)
5772 ! *** average modal particle densities [ kg/m**3 ]
5774 ! mass concentration in coarse mode
5775 REAL pdensn(blksize) ! average particle density in nuclei
5776 REAL pdensa(blksize) ! average particle density in accumu
5777 REAL pdensc(blksize)
5778 ! *** average modal Knudsen numbers
5780 ! average particle density in coarse
5781 REAL knnuc(blksize) ! nuclei mode Knudsen number
5782 REAL knacc(blksize) ! accumulation Knudsen number
5783 REAL kncor(blksize)
5784 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
5786 ! coarse mode Knudsen number
5787 REAL fconcn(blksize)
5788 ! reciprocal condensation rate Aitke
5789 REAL fconca(blksize) !bs
5790 ! reciprocal condensation rate acclu
5791 REAL fconcn_org(blksize)
5792 REAL fconca_org(blksize)
5793 !bs
5795 ! *** Rates for secondary particle formation:
5797 ! *** production of new mass concentration [ ug/m**3 s ]
5798 REAL dmdt(blksize) ! by particle formation
5800 ! *** production of new number concentration [ number/m**3 s ]
5802 ! rate of production of new mass concen
5803 REAL dndt(blksize) ! by particle formation
5804 ! *** growth rate for third moment by condensation of precursor
5805 ! vapor on existing particles [ 3rd mom/m**3 s ]
5807 ! rate of producton of new particle num
5808 REAL cgrn3(blksize) ! Aitken mode
5809 REAL cgra3(blksize)
5810 ! *** Rates for coaglulation: [ m**3/s ]
5812 ! *** Unimodal Rates:
5814 ! Accumulation mode
5815 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
5816 REAL ura00(blksize)
5818 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
5820 ! accumulation mode 0th moment self-coagulat
5821 REAL brna01(blksize) ! rate for 0th moment
5822 REAL brna31(blksize)
5823 ! *** other processes
5825 ! rate for 3rd moment
5826 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
5829 ! *** housekeeping variables:
5831 ! increment of concentration added to
5832 INTEGER unit
5833 PARAMETER (unit=30)
5835 CHARACTER*16 pname
5836 PARAMETER (pname=' BOX ')
5841 INTEGER isp,igrid,jgrid,kgrid
5843 ! loop index for species.
5844 INTEGER ii, iimap(8)
5845 DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
5848 ! begin body of program box
5850 ! *** Set up files and other info
5853 ! *** set up experimental conditions
5855 ! *** initialize model variables
5857 !ia *** not required any more
5859 !ia DO ISP = 1, NSPCSDA
5860 !ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
5861 !ia END DO
5863 step = & ! set time step
5864 dtsec
5865 blkta(blksize) = & ! T in Kelvin
5866 temp
5867 blkprs(blksize) = pres* & ! P in Pa (pres is given in
5868 100.
5869 blkrh(blksize) = & ! fractional RH
5870 relhum
5871 blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in
5872 !rs CBLK(BLKSIZE,VHNO3) = nitrate_in
5873 !rs CBLK(BLKSIZE,VNH3) = nh3_in
5874 !bs
5875 !rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
5876 !rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
5877 !rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
5878 !rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
5879 !rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
5880 !rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
5881 !rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
5882 !rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
5883 ! dr
5884 DO isp = 1, ldrog
5885 drog(blksize,isp) = drog_in(isp)
5886 END DO
5887 ! print*,'drog in rpm',drog
5888 !bs
5889 !ia *** 27/05/97 the following variables are transported quantities
5890 !ia *** of the column-model now and thuse do not need this init.
5891 !ia *** step.
5893 ! CBLK(BLKSIZE,VNU0) = numnuc_in
5894 ! CBLK(BLKSIZE,VAC0) = numacc_in
5895 ! CBLK(BLKSIZE,VSO4A) = asulf_in
5896 ! CBLK(BLKSIZE,VSO4AI) = asulfi_in
5897 ! CBLK(BLKSIZE, VCORN) = numcor_in
5900 so4rat(blksize) = so4rat_in
5902 !...INITIALISE EMISSION RATES
5904 ! epm25i(blksize) = & ! unidentified PM2.5 mass
5905 ! 0.0
5906 ! epm25j(blksize) = &
5907 ! 0.0
5908 ! unidentified PM2.5 m
5909 eorgi(blksize) = & ! primary organic
5910 eorgi_in
5911 eorgj(blksize) = &
5912 eorgj_in
5913 ! primary organic
5914 eeci(blksize) = & ! elemental carbon
5915 eeci_in
5916 eecj(blksize) = &
5917 eecj_in
5918 ! elemental carbon
5919 epm25(blksize) = & !currently from input file ACTIONIA
5920 0.0
5921 esoil(blksize) = & ! ACTIONIA
5922 soilrat_in
5923 eseas(blksize) = & !currently from input file ACTIONIA
5924 0.0
5925 ! epmcoarse(blksize) = & !currently from input file ACTIONIA
5926 ! 0.0
5927 dgnuc(blksize) = dginin
5928 dgacc(blksize) = dginia
5929 dgcor(blksize) = dginic
5930 newm3 = 0.0
5934 ! *** Set up initial total 3rd moment factors
5936 totaersulf = 0.0
5937 newm3 = 0.0
5938 ! *** time loop
5940 ! write(50,*) ' numsteps dgnuc dgacc ',
5941 ! & ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5944 ! *** Call aerosol routines
5946 CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5947 blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat, &
5948 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
5949 nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5950 amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5951 knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5952 urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid)
5954 ! *** write output
5956 ! WRITE(UNIT,*) ' AFTER AEROPROC '
5957 ! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5959 ! *** Write out file for graphing.
5961 ! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5964 ! *** update sulfuric acid vapor
5965 !ia 21.04.98 this update is not required here
5966 !ia artefact from box model
5967 ! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5968 ! & SO4RAT(BLKSIZE) * STEP
5970 RETURN
5972 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
5973 END SUBROUTINE rpmmod3
5974 ! main box model
5975 SUBROUTINE soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
5976 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
5977 nacv,cblk,blksize,nspcsda,numcells,dt)
5978 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
5979 !bs !
5980 !bs Description: !
5981 !bs !
5982 !bs SOA_PART calculates the formation and partitioning of secondary !
5983 !bs organic aerosol based on (pseudo-)ideal solution thermodynamics. !
5984 !bs !
5985 !bs This code considers two cases: !
5986 !bs i) initil absorbing mass is existend in the aerosol phase !
5987 !bs ii) a threshold has to be exeeded before partitioning (even below !
5988 !bs saturation) will take place. !
5989 !bs !
5990 !bs The temperature dependence of the saturation concentrations are !
5991 !bs calculated using the Clausius-Clapeyron equation. !
5992 !bs !
5993 !bs It is assumed that the condensable vapors also evaporate if the !
5994 !bs saturation concentraion lowers e.g. due to temperature effects. !
5995 !bs Therefor negative production rates (= evaporation rates) are !
5996 !bs possible. !
5997 !bs !
5998 !bs If there is no absorbing mass at all the Pandis method is applied !
5999 !bs for the first steps. !
6000 !bs !
6001 !bs References: !
6002 !bs Pankow (1994): !
6003 !bs An absorption model of the gas/aerosol !
6004 !bs partitioning involved in the formation of !
6005 !bs secondary organic aerosol, Atmos. Environ. 28(2), !
6006 !bs 189-193. !
6007 !bs Odum et al. (1996): !
6008 !bs Gas/particle partitioning and secondary organic !
6009 !bs aerosol yields, Environ. Sci. Technol. 30, !
6010 !bs 2580-2585. !
6011 !bs see also !
6012 !bs Bowman et al. (1997): !
6013 !bs Mathematical model for gas-particle partitioning !
6014 !bs of secondary organic aerosols, Atmos. Environ. !
6015 !bs 31(23), 3921-3931. !
6016 !bs Seinfeld and Pandis (1998): !
6017 !bs Atmospheric Chemistry and Physics (0-471-17816-0) !
6018 !bs chapter 13.5.2 Formation of binary ideal solution !
6019 !bs with -- preexisting aerosol !
6020 !bs -- other organic vapor !
6021 !bs !
6022 !bs Called by: SORGAM !
6023 !bs !
6024 !bs Calls: None !
6025 !bs !
6026 !bs Arguments: LAYER, !
6027 !bs BLKTA, BLKPRS, !
6028 !bs ORGARO1RAT, ORGARO2RAT, !
6029 !bs ORGALK1RAT, ORGOLE1RAT, !
6030 !bs ORGBIO1RAT, ORGBIO2RAT, !
6031 !bs ORGBIO3RAT, ORGBIO4RAT, !
6032 !bs DROG, LDROG, NCV, NACV, !
6033 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
6034 !bs DT !
6035 !bs !
6036 !bs Include files: AEROSTUFF.EXT !
6037 !bs AERO_internal.EXT !
6038 !bs !
6039 !bs Data: None !
6040 !bs !
6041 !bs Input files: None !
6042 !bs !
6043 !bs Output files: None !
6044 !bs !
6045 !bs--------------------------------------------------------------------!
6046 !bs !
6047 !bs History: !
6048 !bs No Date Author Change !
6049 !bs ____ ______ ________________ _________________________________ !
6050 !bs 01 170399 B.Schell Set up !
6051 !bs 02 050499 B.Schell introduced SR NEWT !
6052 !bs 03 040599 B.Schell include-file sorgam.inc !
6053 !bs !
6054 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
6055 !bs
6056 ! IMPLICIT NONE
6057 !bs
6058 !bs * includes
6059 !bs
6060 !bs
6061 !bs * input variables
6062 !bs
6063 ! model layer
6064 INTEGER layer
6065 ! dimension of arrays
6066 INTEGER blksize
6067 ! number of species in CBLK
6068 INTEGER nspcsda
6069 ! actual number of cells in arrays
6070 INTEGER numcells
6071 ! # of organic aerosol precursor
6072 INTEGER ldrog
6073 ! total # of cond. vapors & SOA sp
6074 INTEGER ncv
6075 ! # of anthrop. cond. vapors & SOA
6076 INTEGER nacv
6077 REAL cblk(blksize,nspcsda) ! main array of variables
6078 ! model time step in SECONDS
6079 REAL dt
6080 REAL blkta(blksize) ! Air temperature [ K ]
6081 REAL blkprs(blksize) ! Air pressure in [ Pa ]
6082 REAL orgaro1rat(blksize) ! rates from aromatics
6083 ! anth. organic vapor production
6084 REAL orgaro2rat(blksize) ! rates from aromatics
6085 ! anth. organic vapor production
6086 REAL orgalk1rat(blksize) ! rates from alkenes and others
6087 ! anth. organic vapor production
6088 REAL orgole1rat(blksize) ! rates from alkanes and others
6089 ! anth. organic vapor production
6090 REAL orgbio1rat(blksize) ! bio. organic vapor production ra
6091 REAL orgbio2rat(blksize) ! bio. organic vapor production ra
6092 REAL orgbio3rat(blksize) ! bio. organic vapor production ra
6093 REAL orgbio4rat(blksize) ! bio. organic vapor production ra
6094 REAL drog(blksize,ldrog) !bs
6095 !bs * local variable declaration
6096 !bs
6097 ! Delta ROG conc. [ppm]
6098 !bs numerical value for a minimum thresh
6099 REAL thrsmin
6100 PARAMETER (thrsmin=1.E-19)
6101 !bs numerical value for a minimum thresh
6102 !bs
6103 !bs universal gas constant [J/mol-K]
6104 REAL rgas
6105 PARAMETER (rgas=8.314510)
6106 !bs reference temperature T0 = 298 K
6107 REAL tnull
6108 PARAMETER (tnull=298.)
6109 !bs molecular weight for C
6110 REAL mwc
6111 PARAMETER (mwc=12.0)
6112 !bs molecular weight for organic species
6113 REAL mworg
6114 PARAMETER (mworg=175.0)
6115 !bs molecular weight for SO4
6116 REAL mwso4
6117 PARAMETER (mwso4=96.0576)
6118 !bs molecular weight for NH4
6119 REAL mwnh4
6120 PARAMETER (mwnh4=18.03858)
6121 !bs molecular weight for NO3
6122 REAL mwno3
6123 PARAMETER (mwno3=62.01287)
6124 !bs relative tolerance for mass check
6125 REAL rtol
6126 PARAMETER (rtol=1.E-04)
6127 !bs REAL DTMIN !bs minimum time step in seconds
6128 !bs PARAMETER (DTMIN = 0.1)
6129 !bs
6130 !bs loop index
6131 INTEGER lcell
6132 INTEGER l, & !bs loop index
6133 n
6134 !bs conversion factor ppm --> ug/m^3
6135 REAL convfac
6136 !bs difference of inverse temperatures
6137 REAL ttinv
6138 !bs weighted initial organic mass [10^-6
6139 REAL minitw
6140 !bs weighted total organic mass [10^-6 m
6141 REAL mtotw
6142 !bs weighted inorganic mass [10^-6 mol/m
6143 REAL mnonow
6144 !bs 1. / MTOTW
6145 REAL imtotw
6146 !bs initial organic mass [ug/m^3]
6147 REAL minit
6148 !bs inorganic mass [ug/m^3]
6149 REAL mnono
6150 !bs total organic mass [ug/m^3]
6151 REAL mtot
6152 !bs threshold for SOA formatio for low M
6153 REAL thres
6154 !bs mass check ratio of input/output mas
6155 REAL mcheck
6156 REAL msum(ncv) !bs input total mass [ug/m^3]
6157 REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
6158 REAL imwcv(ncv) !bs 1. / MWCV(NCV)
6159 REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
6160 REAL dhvap(ncv) !bs heat of vaporisation of compound i [
6161 REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]
6162 REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
6163 REAL cgas(ncv) !bs gasphase concentration of cond. vapo
6164 REAL caer(ncv) !bs aerosolphase concentration of cond.
6165 REAL asav(ncv) !bs saved CAER for iteration
6166 REAL aold(ncv) !bs saved CAER for rate determination
6167 REAL csat(ncv) !bs saturation conc. of cond. vapor [ug/
6168 REAL alpha(ncv) !bs molar yield for condensable vapors
6169 REAL prod(ncv) !bs production of condensable vapor [ug/
6170 REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]
6171 REAL f(ldrog) !bs scaling factor for ind. oxidant
6172 !bs check convergence of SR NEWT
6173 LOGICAL check
6174 !bs
6175 INTEGER its
6176 !bs * initialisation
6177 !bs
6178 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
6179 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
6180 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
6181 !bs * average value is 156 kJ/mol
6182 !bs
6183 !bs number of iterations in NEWT
6184 dhvap(psoaaro1) = 156.0E03
6185 dhvap(psoaaro2) = 156.0E03
6186 dhvap(psoaalk1) = 156.0E03
6187 dhvap(psoaole1) = 156.0E03
6188 dhvap(psoaapi1) = 156.0E03
6189 dhvap(psoaapi2) = 156.0E03
6190 dhvap(psoalim1) = 156.0E03
6191 dhvap(psoalim2) = 156.0E03
6192 !bs
6193 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
6194 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
6195 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
6196 !bs * average value is 222.5 g/mol
6197 !bs *
6198 !bs * molecular weights used are estimates taking the origin (reactants)
6199 !bs * into account. This should be updated if more information abou
6200 !bs * the products is available.
6201 !bs * First hints are taken from Forstner et al. (1997), Environ. S
6202 !bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmo
6203 !bs * Environ. 31(13), 1953-1964.
6204 !bs *
6205 !bs * !! these molecular weights should be identical with WTM in CTM !!
6206 !bs
6207 mwcv(psoaaro1) = 150.
6208 mwcv(psoaaro2) = 150.
6209 mwcv(psoaalk1) = 140.
6210 mwcv(psoaole1) = 140.
6211 mwcv(psoaapi1) = 184.
6212 mwcv(psoaapi2) = 184.
6213 mwcv(psoalim1) = 200.
6214 mwcv(psoalim2) = 200.
6215 !bs
6216 !bs * aromatic yields from:
6217 !bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, R.C. Flagan, and
6218 !bs * J.H. Seinfeld: The atmospheric aerosol-forming potential of whol
6219 !bs * gasoline vapor, Science 276, 96-99, 1997.
6220 !bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, H.J.L. Forstner, R.C. Fl
6221 !bs * and J.H. Seinfeld: Aromatics, reformulated gasoline, and atmosph
6222 !bs * organic aerosol formation, Environ. Sci. Technol. 31, 1890-1897,
6223 !bs *
6224 !bs * !! yields provided by Odum are mass-based stoichiometric coefficen
6225 !bs * average for high and low yield aromatics
6226 !bs * alpha1 = 0.0545 K1 = 0.0475 m^3/ug
6227 !bs * alpha2 = 0.1525 K2 = 0.00165 m^3/ug
6228 !bs * change to molar yields using the model MW
6229 !bs * alpha1 * MW(XYL) / MW(PSOAARO1) = alpha1 * 106 / 150 = 0.0385
6230 !bs * alpha2 * MW(XYL) / MW(PSOAARO2) = alpha2 * 106 / 150 = 0.1077
6231 !bs * ALPHA(PSOAARO1) = 0.0385; ALPHA(PSOAARO2) = 0.1077
6232 !bs *
6233 !bs
6234 !bs * alkane and alkene yields from:
6235 !bs * Moucheron M.C. and J. Milford: Development and testing of a proces
6236 !bs * model for secondary organic aerosols. Air & Waste Manag. Assoc.
6237 !bs * for presentation at the 89th Annual Meeting & Exhibition, Nashv
6238 !bs * Tennessee, June 23-28, 96-FA130B.03, 1996.
6239 !bs * molar yields used instead of [ ug m^-3 / ppm ], calculation
6240 !bs * at T=298K, P=1.0133*10^5 Pa
6241 !bs * ALPHA(PSOAALK1) = 0.048; ALPHA(PSOAOLE1) = 0.008
6242 !bs
6243 !bs * biogenic yields from:
6244 !bs * Griffin R.J., D.R. Cocker III, R.C. Flagan, and J.H. Seinfeld:
6245 !bs * Organic aerosol formation from the oxidation of biogenic hydro-
6246 !bs * carbons, JGR, 1999 in press.
6247 !bs * the yields given in Table 3 are mass yields [ ug m^-3 / ug m^-3
6248 !bs * change to molar yields via:
6249 !bs * molar yield = mass yield * ((R*T/M_soa*p) / (R*T/M_terp*p))
6250 !bs * = mass yield * (M_terp / M_soa)
6251 !bs * = mass yield * ( M(Terpenes) / M(pinonic acid) )
6252 !bs * = mass yield * 136 / 184
6253 !bs * average for a-Pinene and Limonene, maybe splitted in future versio
6254 !bs * 0.138 * 0.739 = 0.102; 0.345 * 0.739 = 0.254
6255 !bs * values for a-Pinene (molar yield) alpha1 = 0.028, alpha2 = 0.241
6256 !bs * values for limonene (molar yield) alpha1 = 0.163, alpha2 = 0.247
6257 !bs
6258 alpha(psoaaro1) = 0.039
6259 alpha(psoaaro2) = 0.108
6260 alpha(psoaalk1) = 0.048
6261 alpha(psoaole1) = 0.008
6262 !bs ALPHA(PSOAAPI1) = 0.028
6263 !bs ALPHA(PSOAAPI2) = 0.241
6264 alpha(psoaapi1) = & !bs API + O3 only Griffin '99
6265 0.092
6266 alpha(psoaapi2) = & !bs API + O3 only Griffin '99
6267 0.075
6268 alpha(psoalim1) = 0.163
6269 alpha(psoalim2) = 0.247
6270 !bs
6271 !bs * P0 data in Pa for T = 298K:
6272 !bs * aromatics: Odum et al. (1997) using R = 8.314 J/(mol*K),
6273 !bs * DHvap = 156 kJ/mol, T = 313K, MW = 150 g/mol and averaged
6274 !bs * Ki's of high and low aromatics.
6275 !bs * T = 313 => PNULL(ARO1) = 1.7E-05, PNULL(ARO2) = 5.1E-04
6276 !bs * T = 307.4 => PNULL(ARO1) = 5.7E-05, PNULL(ARO2) = 1.6E-03
6277 !bs * biogenics: Hoffmann et al. (1997); Griffin et al. (1999);
6278 !bs * using R = 8.314 J/(mol*K),
6279 !bs * DHvap = 156 kJ/mol, T = 313, MW = 184 g/mol, and
6280 !bs * averaged Ki's of a-pinene and limonene
6281 !bs * p1(298K) = 6.1E-06; p2(298K) = 1.5E-04
6282 !bs * Ki's for a-pinene p1(298K) = 4.0E-06; p2(298K) = 1.7E-04
6283 !bs * Ki's for limonene p1(298K) = 2.5E-05; p2(298K) = 1.2E-04
6284 !bs * alkanes and alkenes: no data available, use low value to get cl
6285 !bs * to the Pandis yields, 1 ppt = 1*10^-7 Pa.
6286 !bs
6287 pnull(psoaaro1) = 5.7E-05
6288 pnull(psoaaro2) = 1.6E-03
6289 pnull(psoaalk1) = 5.0E-06
6290 pnull(psoaole1) = 5.0E-06
6291 !bs PNULL(PSOAAPI1) = 4.0E-06
6292 !bs PNULL(PSOAAPI2) = 1.7E-04
6293 pnull(psoaapi1) = & !bs API + O3 only Griffin '99
6294 2.488E-05
6295 pnull(psoaapi2) = & !bs API + O3 only Griffin '99
6296 2.778E-05
6297 pnull(psoalim1) = 2.5E-05
6298 pnull(psoalim2) = 1.2E-04
6299 !bs
6300 !bs * scaling of contribution of individual oxidants to aerosol formatio
6301 !bs
6302 f(pxyl) = & !bs * XYL + OH
6303 1.
6304 f(ptol) = & !bs * TOL + OH
6305 1.
6306 f(pcsl1) = & !bs * CSL + OH
6307 1.
6308 f(pcsl2) = & !bs * CSL + NO
6309 1.
6310 f(phc8) = & !bs * HC + OH
6311 1.
6312 f(poli1) = & !bs * OLI + OH
6313 1.
6314 f(poli2) = & !bs * OLI + NO
6315 1.
6316 f(poli3) = & !bs * OLI + O3
6317 1.
6318 f(polt1) = & !bs * OLT + OH
6319 1.
6320 f(polt2) = & !bs * OLT + NO
6321 1.
6322 f(polt3) = & !bs F(PAPI1) = 0.228 !bs * API + OH
6323 1.
6324 !bs F(PAPI2) = 0. !bs * API + NO
6325 !bs F(PAPI3) = 0.771 !bs * API + O3
6326 !bs * OLT + O3
6327 f(papi1) = & !bs * API + OH
6328 0.
6329 f(papi2) = & !bs * API + NO
6330 0.
6331 f(papi3) = & !bs * API + O3
6332 1.
6333 f(plim1) = & !bs * LIM + OH
6334 0.228
6335 f(plim2) = & !bs * LIM + NO
6336 0.
6337 f(plim3) = & !bs
6338 0.771
6339 !bs * begin code -------------------------------------------------------
6340 !bs
6341 !bs * LIM + O3
6342 DO lcell = 1, numcells
6343 DO l = 1, ldrog
6344 drog(lcell,l) = f(l)*drog(lcell,l)
6345 END DO
6346 ttinv = 1./tnull - 1./blkta(lcell)
6347 convfac = blkprs(lcell)/(rgas*blkta(lcell))
6348 cgas(psoaaro1) = cblk(lcell,vcvaro1)
6349 cgas(psoaaro2) = cblk(lcell,vcvaro2)
6350 cgas(psoaalk1) = cblk(lcell,vcvalk1)
6351 cgas(psoaole1) = cblk(lcell,vcvole1)
6352 cgas(psoaapi1) = cblk(lcell,vcvapi1)
6353 cgas(psoaapi2) = cblk(lcell,vcvapi2)
6354 cgas(psoalim1) = cblk(lcell,vcvlim1)
6355 cgas(psoalim2) = cblk(lcell,vcvlim2)
6356 caer(psoaaro1) = cblk(lcell,vorgaro1j) + cblk(lcell,vorgaro1i)
6357 caer(psoaaro2) = cblk(lcell,vorgaro2j) + cblk(lcell,vorgaro2i)
6358 caer(psoaalk1) = cblk(lcell,vorgalk1j) + cblk(lcell,vorgalk1i)
6359 caer(psoaole1) = cblk(lcell,vorgole1j) + cblk(lcell,vorgole1i)
6360 caer(psoaapi1) = cblk(lcell,vorgba1j) + cblk(lcell,vorgba1i)
6361 caer(psoaapi2) = cblk(lcell,vorgba2j) + cblk(lcell,vorgba2i)
6362 caer(psoalim1) = cblk(lcell,vorgba3j) + cblk(lcell,vorgba3i)
6363 caer(psoalim2) = cblk(lcell,vorgba4j) + cblk(lcell,vorgba4i)
6364 !bs
6365 prod(psoaaro1) = drog(lcell,pxyl) + drog(lcell,ptol) + &
6366 drog(lcell,pcsl1) + drog(lcell,pcsl2)
6367 prod(psoaaro2) = drog(lcell,pxyl) + drog(lcell,ptol) + &
6368 drog(lcell,pcsl1) + drog(lcell,pcsl2)
6369 prod(psoaalk1) = drog(lcell,phc8)
6370 prod(psoaole1) = drog(lcell,poli1) + drog(lcell,poli2) + &
6371 !jdf bug drog(lcell,poli3) + drog(lcell,polt1) + drog(lcell,poli2) + &
6372 drog(lcell,poli3) + drog(lcell,polt1) + drog(lcell,polt2) + &
6373 drog(lcell,polt3)
6374 prod(psoaapi1) = drog(lcell,papi1) + drog(lcell,papi2) + &
6375 drog(lcell,papi3)
6376 prod(psoaapi2) = drog(lcell,papi1) + drog(lcell,papi2) + &
6377 drog(lcell,papi3)
6378 prod(psoalim1) = drog(lcell,plim1) + drog(lcell,plim2) + &
6379 drog(lcell,plim3)
6380 prod(psoalim2) = drog(lcell,plim1) + drog(lcell,plim2) + &
6381 drog(lcell,plim3)
6382 !bs
6383 !bs * calculate actual production from gasphase reactions [ug/m^3]
6384 !bs * calculate vapor pressure of pure compound as a liquid
6385 !bs * using the Clausius-Clapeyromn equation and the actual
6386 !bs * saturation concentration.
6387 !bs * calculate the threshold for partitioning if no initial mass
6388 !bs * is present to partition into.
6389 !bs
6390 thres = 0.
6391 mtot = 0.
6392 mtotw = 0.
6393 DO l = 1, ncv
6394 prod(l) = convfac*mwcv(l)*alpha(l)*prod(l)
6395 ctot(l) = prod(l) + cgas(l) + caer(l) !bs redefined below
6396 p(l) = prod(l)
6397 msum(l) = cgas(l) + caer(l) + prod(l)
6398 aold(l) = caer(l)
6399 imwcv(l) = 1./mwcv(l)
6400 pvap(l) = pnull(l)*exp(dhvap(l)/rgas*ttinv)
6401 csat(l) = pvap(l)*mwcv(l)*1.0E06/(rgas*blkta(lcell))
6402 thres = thres + ((cgas(l)+prod(l))/csat(l))
6403 mtot = mtot + caer(l)
6404 mtotw = mtotw + caer(l)*imwcv(l)
6405 END DO
6406 !bs
6407 !bs * small amount of non-volatile absorbing mass is assumed to be
6408 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
6409 !bs * mass in each size section, here mode)
6410 !bs
6411 mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+cblk(lcell, &
6412 vno3aj))
6413 mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+cblk( &
6414 lcell,vno3ai))
6415 mnonow = 0.0001*(cblk(lcell,vso4aj)/mwso4+cblk(lcell,vnh4aj)/mwnh4+ &
6416 cblk(lcell,vno3aj)/mwno3)
6417 mnonow = mnonow + 0.0001*(cblk(lcell,vso4ai)/mwso4+cblk(lcell,vnh4ai)/ &
6418 mwnh4+cblk(lcell,vno3ai)/mwno3)
6419 mnono = max(mnono,conmin)
6420 mnonow = max(mnonow,conmin)
6421 !bs
6422 !bs MNONOW = 0.
6423 !bs MNONO = 0.
6424 !bs
6425 minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + &
6426 cblk(lcell,vorgpai) + mnono
6427 minitw = (cblk(lcell,vecj)+cblk(lcell,veci))/mwc + &
6428 (cblk(lcell,vorgpaj)+cblk(lcell,vorgpai))/mworg + mnonow
6429 !bs
6430 !bs * If MINIT is set to zero partitioning will occur if the pure
6431 !bs * saturation concentation is exceeded (Pandis et al. 1992).
6432 !bs * If some amount of absorbing organic mass is formed gas/particle
6433 !bs * partitioning will follow the ideal solution approach.
6434 !bs
6435 minit = 0.
6436 minitw = 0.
6437 !bs
6438 mtot = mtot + minit
6439 mtotw = mtotw + minitw
6440 imtotw = 1./mtotw
6441 !bs
6442 !bs * do the gas/particle partitioning
6443 !bs
6444 IF ((thres>1 .AND. minitw<thrsmin) .OR. (minitw>thrsmin) .OR. &
6445 (mtot>thrsmin)) THEN
6446 !bs
6447 DO l = 1, ncv
6448 ctot(l) = p(l) + cgas(l) + caer(l)
6449 caer(l) = ctot(l) !bs 'initial' guess
6450 END DO
6451 !bs
6452 !bs * globally convergent method for nonlinear system of equations
6453 !bs * adopted from Numerical Recipes 2nd Edition
6454 !bs
6455 CALL newt(layer,caer,ncv,check,ctot,csat,imwcv,minitw,its)
6456 !bs
6457 IF (check) THEN
6458 ! WRITE (6,'(a,i2)') '!! Problems in SR NEWT !! K: ', layer
6459 END IF
6460 !bs
6461 !bs IF (layer==1) WRITE (76,'(i3)') its
6462 !bs
6463 DO l = 1, ncv
6464 IF (caer(l)<=tolmin) THEN
6465 ! IF (abs(caer(l))>tolmin) WRITE (6,90000) l, caer(l)
6466 caer(l) = conmin
6467 END IF
6468 IF (caer(l)>ctot(l)) THEN
6469 IF (caer(l)-ctot(l)>tolmin) THEN
6470 ! WRITE (6,90010)
6471 END IF
6472 caer(l) = ctot(l)
6473 END IF
6474 cgas(l) = ctot(l) - caer(l)
6475 END DO
6476 !bs
6477 !90000 FORMAT ('!! PROBLEMS WITH CAER, CAER < 0. !!',1X,I1,1PE14.6)
6478 !90010 FORMAT ('!! PROBLEMS WITH CAER, CAER > CTOT !!')
6479 !bs
6480 !bs * assign values to CBLK array
6481 !bs
6482 cblk(lcell,vcvaro1) = max(cgas(psoaaro1),conmin)
6483 cblk(lcell,vcvaro2) = max(cgas(psoaaro2),conmin)
6484 cblk(lcell,vcvalk1) = max(cgas(psoaalk1),conmin)
6485 cblk(lcell,vcvole1) = max(cgas(psoaole1),conmin)
6486 cblk(lcell,vcvapi1) = max(cgas(psoaapi1),conmin)
6487 cblk(lcell,vcvapi2) = max(cgas(psoaapi2),conmin)
6488 cblk(lcell,vcvlim1) = max(cgas(psoalim1),conmin)
6489 cblk(lcell,vcvlim2) = max(cgas(psoalim2),conmin)
6490 orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
6491 orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
6492 orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
6493 orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
6494 orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
6495 orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
6496 orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
6497 orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
6498 !bs
6499 !bs
6500 ELSE
6501 !bs WRITE(6,'(a)') 'Pandis method in SR SOA_PART.F used!'
6502 !bs WRITE(6,1010) THRES, MINITW
6503 !bs 1010 FORMAT('THRES =',1pe14.6,1X,'MINITW =',1pe14.6)
6504 !bs
6505 !bs do Pandis method
6506 DO l = 1, ncv
6507 caer(l) = ctot(l) - csat(l)
6508 caer(l) = max(caer(l),0.)
6509 cgas(l) = ctot(l) - caer(l)
6510 END DO
6511 !bs
6512 cblk(lcell,vcvaro1) = cgas(psoaaro1)
6513 cblk(lcell,vcvaro2) = cgas(psoaaro2)
6514 cblk(lcell,vcvalk1) = cgas(psoaalk1)
6515 cblk(lcell,vcvole1) = cgas(psoaole1)
6516 cblk(lcell,vcvapi1) = cgas(psoaapi1)
6517 cblk(lcell,vcvapi2) = cgas(psoaapi2)
6518 cblk(lcell,vcvlim1) = cgas(psoalim1)
6519 cblk(lcell,vcvlim2) = cgas(psoalim2)
6520 orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
6521 orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
6522 orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
6523 orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
6524 orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
6525 orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
6526 orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
6527 orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
6528 !bs
6529 END IF
6530 !bs
6531 !bs * check mass conservation
6532 !bs
6533 DO l = 1, ncv
6534 !rs check is component exits
6535 IF (cgas(l)==0. .AND. caer(l)==0. .AND. msum(l)==0) THEN
6536 mcheck = 1.
6537 ELSE
6538 mcheck = (cgas(l)+caer(l))/msum(l)
6539 END IF
6540 IF ((mcheck<1.-rtol) .OR. (mcheck>1.+rtol)) THEN
6541 ! WRITE (6,'(/,a)') 'Problems with mass conservation!'
6542 ! WRITE (6,90020) layer, l, mcheck, cgas(l) + caer(l)
6543 ! WRITE (6,'(a)') '!! CHECK RESULTS !!'
6544 90020 FORMAT ('LAYER = ',I2,', L = ',I2,', MCHECK = ',E12.6,', MASS = ', &
6545 E12.6)
6546 END IF
6547 END DO
6548 !bs
6549 !bs
6550 END DO
6551 !bs * end of SR SOA_PART
6552 !bs
6553 !bs loop over NUMCELLS
6554 RETURN
6555 END SUBROUTINE soa_part
6556 SUBROUTINE sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
6557 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
6558 nacv,cblk,blksize,nspcsda,numcells,dt)
6559 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
6560 !bs !
6561 !bs Description: Secondary organic aerosol module !
6562 !bs This module calculates the gas/particle parti- !
6563 !bs tioning of semi-volatile organic vapors !
6564 !bs !
6565 !bs Called by: RPMMOD3 !
6566 !bs !
6567 !bs Calls: SOA_PANDIS !
6568 !bs SOA_PART !
6569 !bs !
6570 !bs Arguments: LAYER, BLKTA, !
6571 !bs ORGARO1RAT, ORGARO2RAT, !
6572 !bs ORGALK1RAT, ORGOLE1RAT, !
6573 !bs ORGBIO1RAT, ORGBIO2RAT, !
6574 !bs DROG, LDROG, !
6575 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
6576 !bs DT !
6577 !bs !
6578 !bs Include files: AEROSTUFF.EXT !
6579 !bs AERO_internal.EXT !
6580 !bs !
6581 !bs Data: !
6582 !bs !
6583 !bs Input files: None !
6584 !bs !
6585 !bs Output files: UNIT 90: control output !
6586 !bs !
6587 !bs--------------------------------------------------------------------!
6588 !bs !
6589 !bs History: !
6590 !bs No Date Author Change !
6591 !bs ____ ______ ________________ _________________________________ !
6592 !bs 01 040299 B.Schell Set up !
6593 !bs !
6594 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
6595 !bs
6596 !bs * Literature:
6597 !bs * Pandis et al. (1992): Secondary organic aerosol formation and
6598 !bs * transport. Atmos Environ. 26A, 2453-2466.
6599 !bs * Seinfeld and Pandis (1998): Atmospheric Chemistry and Physics
6600 !bs * chapter 13.5.2 Noninteracting SOA compounds. (0-471-17816-0)
6601 !bs * STI Report (Sonoma Technology, Inc.) (1998):
6602 !bs * Development of gas-phase chemistry, secondary organic aerosol,
6603 !bs * and aqueous-phase chemistry modules for PM modeling.
6604 !bs * By: R. Strader, C. Gurciullo, S. Pandis, N. Kumar, F. Lurmann
6605 !bs * Prepared for: Coordinating Research Council, Atlanta, Aug 24 1
6606 !bs * Tao and McMurray (1989): Vapor pressures and surface free energies
6607 !bs * C14-C18 monocarboxylic acids and C5 and C6 dicarboxylic acids.
6608 !bs * Eniron. Sci. Technol. 23, 1519-1523.
6609 !bs * Pankow (1994): An absorption model of gas/particle partitioning of
6610 !bs * organic compounds in the atmosphere. Atmos. Environ. 28, 185-1
6611 !bs * Pankow (1994): An absorption model of gas/aerosol partitioning inv
6612 !bs * in the formation of secondary organic aerosol.
6613 !bs * Atmos. Environ. 28, 189-193.
6614 !bs * Odum et al. (1996): Gas/particle partitioning and secondary organi
6615 !bs * aerosol yields. Environ. Sci. Technol. 30(8), 2580-2585.
6616 !bs
6617 ! IMPLICIT NONE
6618 !bs
6619 !bs
6620 !bs * variable declaration
6621 !bs
6622 !bs
6623 !bs * inputs
6624 !bs
6625 ! dimension of arrays
6626 INTEGER blksize
6627 ! number of species in CBLK
6628 INTEGER nspcsda
6629 ! actual number of cells in arrays
6630 INTEGER numcells
6631 ! model layer
6632 INTEGER layer
6633 ! # of organic aerosol precursor
6634 INTEGER ldrog
6635 ! total # of cond. vapors & SOA sp
6636 INTEGER ncv
6637 ! # of anthrop. cond. vapors & SOA
6638 INTEGER nacv
6639 ! model time step in SECONDS
6640 REAL dt
6641 REAL cblk(blksize,nspcsda) ! main array of variables
6642 REAL blkta(blksize) ! Air temperature [ K ]
6643 REAL blkprs(blksize) ! Air pressure in [ Pa ]
6644 REAL orgaro1rat(blksize) ! rates from aromatics
6645 ! anth. organic vapor production
6646 REAL orgaro2rat(blksize) ! rates from aromatics
6647 ! anth. organic vapor production
6648 REAL orgalk1rat(blksize) ! rates from alkanes and others
6649 ! anth. organic vapor production
6650 REAL orgole1rat(blksize) ! rates from alkenes and others
6651 ! anth. organic vapor production
6652 REAL orgbio1rat(blksize) ! bio. organic vapor production ra
6653 REAL orgbio2rat(blksize) ! bio. organic vapor production ra
6654 REAL orgbio3rat(blksize) ! bio. organic vapor production ra
6655 REAL orgbio4rat(blksize) ! bio. organic vapor production ra
6656 REAL drog(blksize,ldrog) !bs
6657 !bs * get some infos
6658 !bs
6659 !bs INTEGER LL
6660 !bs IF (LAYER .EQ. 1) THEN
6661 !bs WRITE(75,4711) (CBLK(1,LL), LL = VORGARO1J, VORGOLE1I)
6662 !bs WRITE(75,4711) (CBLK(1,LL), LL = VORGBA1J , VORGBA4I )
6663 !bs WRITE(75,4712) (CBLK(1,LL), LL = VCVARO1, VCVLIM2)
6664 !bs WRITE(75,4712) (DROG(1,LL), LL = 1, 8)
6665 !bs WRITE(75,4712) (DROG(1,LL), LL = 9, 16)
6666 !bs WRITE(75,4714) (DROG(1,LL), LL = 17,LDROG)
6667 !bs ENDIF
6668 !bs 4711 FORMAT(8(e12.6,1X))
6669 !bs 4712 FORMAT(8(e12.6,1X))
6670 !bs 4713 FORMAT(17(e12.6,1X))
6671 !bs 4714 FORMAT(e12.6,/)
6672 !bs
6673 !bs * begin code
6674 !bs
6675 ! ROG production rate [ug m^-3 s^-
6676 IF (orgaer==1) THEN
6677 ! IF (firstime) THEN
6678 ! WRITE (6,'(a)')
6679 ! WRITE (6,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
6680 ! WRITE (6,'(a)')
6681 ! WRITE (90,'(a)')
6682 ! WRITE (90,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
6683 ! firstime = .FALSE.
6684 ! END IF
6685 ! CALL SOA_PANDIS(
6686 ! & LAYER,
6687 ! & BLKTA, BLKPRS,
6688 ! & ORGARO1RAT, ORGARO2RAT,
6689 ! & ORGALK1RAT, ORGOLE1RAT,
6690 ! & ORGBIO1RAT, ORGBIO2RAT,
6691 ! & ORGBIO3RAT, ORGBIO4RAT,
6692 ! & DROG, LDROG, NCV, NACV,
6693 ! & CBLK, BLKSIZE, NSPCSDA, NUMCELLS,
6694 ! & DT
6695 ! & )
6696 ELSE IF (orgaer==2) THEN
6697 ! IF (firstime) THEN
6698 ! WRITE (6,'(a)')
6699 ! WRITE (6,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
6700 ! WRITE (6,'(a)')
6701 ! WRITE (90,'(a)')
6702 ! WRITE (90,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
6703 ! firstime = .FALSE.
6704 ! END IF
6705 CALL soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
6706 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog, &
6707 ncv,nacv,cblk,blksize,nspcsda,numcells,dt)
6708 ELSE
6709 ! WRITE (6,'(a)')
6710 ! WRITE (6,'(a)') 'WRONG PARAMETER ORGAER !!'
6711 ! WRITE (6,90000) orgaer
6712 ! WRITE (6,'(a)') 'PROGRAM TERMINATED !!'
6713 ! WRITE (6,'(a)')
6714 ! STOP
6715 END IF
6716 !bs
6717 !bs ORGARO1RAT(1) = 0.
6718 !bs ORGARO2RAT(1) = 0.
6719 !bs ORGALK1RAT(1) = 0.
6720 !bs ORGOLE1RAT(1) = 0.
6721 !bs ORGBIO1RAT(1) = 0.
6722 !bs ORGBIO2RAT(1) = 0.
6723 !bs ORGBIO3RAT(1) = 0.
6724 !bs ORGBIO4RAT(1) = 0.
6725 !bs WRITE(6,'(a)') '!!! ORGRATs SET TO 0. !!!'
6726 !bs
6727 !bs * formats
6728 !bs
6729 90000 FORMAT ('ORGAER = ',I2)
6730 !bs
6731 !bs * end of SR SORGAM
6732 !bs
6733 RETURN
6734 END SUBROUTINE sorgam
6735 !****************************************************************
6736 !
6737 !
6738 !
6739 !
6740 ! ///////////////////////////////
6741 ! *** this routine calculates the dry deposition and sedimentation
6742 ! velocities for the three modes.
6743 ! coded 1/23/97 by Dr. Francis S. Binkowski. Follows
6744 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
6745 ! velocity but includes Marv Wesely's wstar contribution.
6746 !ia eliminated Stokes term for coarse mode deposition calcs.,
6747 !ia see comments below
6749 SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, &
6750 LAYER, &
6751 CBLK, &
6752 BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, &
6753 DGNUC, DGACC, DGCOR, &
6754 KNNUC, KNACC,KNCOR, &
6755 PDENSN, PDENSA, PDENSC, &
6756 VSED, VDEP )
6758 ! *** calculate size-averaged particle dry deposition and
6759 ! size-averaged sedimentation velocities.
6762 ! IMPLICIT NONE
6764 INTEGER BLKSIZE ! dimension of arrays
6765 INTEGER NSPCSDA ! number of species in CBLK
6766 INTEGER NUMCELLS ! actual number of cells in arrays
6767 INTEGER LAYER ! number of layer
6769 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6770 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
6771 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
6772 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
6773 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
6774 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
6775 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6776 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
6777 REAL DGACC( BLKSIZE ) ! accumulation
6778 REAL DGCOR( BLKSIZE ) ! coarse mode
6779 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
6780 REAL KNACC( BLKSIZE ) ! accumulation
6781 REAL KNCOR( BLKSIZE ) ! coarse mode
6782 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
6783 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
6784 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
6787 ! *** modal particle diffusivities for number and 3rd moment, or mass:
6789 REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
6790 REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
6792 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
6794 REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
6795 REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
6797 ! *** deposition and sedimentation velocities
6799 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
6800 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
6803 INTEGER LCELL
6804 REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
6805 REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
6806 REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
6807 REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
6808 REAL ST0N, ST0A, ST0C ! Stokes numbers for number
6809 REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
6810 REAL RD0N, RD0A, RD0C ! canopy resistance for number
6811 REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment
6812 REAL UTSCALE ! scratch function of USTAR and WSTAR.
6813 REAL NU !kinematic viscosity [ m**2 s**-1 ]
6814 REAL USTFAC ! scratch function of USTAR, NU, and GRAV
6815 REAL BHAT
6816 PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction.
6819 ! *** check layer value.
6821 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
6822 ! sedimentation velocities
6824 DO LCELL = 1, NUMCELLS
6826 DCONST1 = BOLTZ * BLKTA(LCELL) / &
6827 ( THREEPI * AMU(LCELL) )
6828 DCONST1N = DCONST1 / DGNUC( LCELL )
6829 DCONST1A = DCONST1 / DGACC( LCELL )
6830 DCONST1C = DCONST1 / DGCOR( LCELL )
6831 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6832 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6833 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6834 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6836 ! *** i-mode
6838 DCHAT0N(LCELL) = DCONST1N &
6839 * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
6841 DCHAT3N(LCELL) = DCONST1N &
6842 * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
6844 VGHAT0N(LCELL) = DCONST3N &
6845 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6847 VGHAT3N(LCELL) = DCONST3N &
6848 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6850 ! *** j-mode
6852 DCHAT0A(LCELL) = DCONST1A &
6853 * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
6855 DCHAT3A(LCELL) = DCONST1A &
6856 * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
6858 VGHAT0A(LCELL) = DCONST3A &
6859 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6861 VGHAT3A(LCELL) = DCONST3A &
6862 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6865 ! *** coarse mode
6867 DCHAT0C(LCELL)= DCONST1C &
6868 * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
6870 DCHAT3C(LCELL) = DCONST1C &
6871 * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
6873 VGHAT0C(LCELL) = DCONST3C &
6874 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6876 VGHAT3C(LCELL) = DCONST3C &
6877 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6879 END DO
6881 ! *** now calculate the deposition and sedmentation velocities
6883 !ia 07.05.98
6884 ! *** NOTE In the deposition velocity for coarse mode,
6885 ! the impaction term 10.0 ** (-3.0 / st) is eliminated because
6886 ! coarse particles are likely to bounce on impact and the current
6887 ! formulation does not account for this.
6890 DO LCELL = 1, NUMCELLS
6892 NU = AMU(LCELL) / BLKDENS(LCELL)
6893 USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
6894 UTSCALE = USTAR(LCELL) + &
6895 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
6897 ! *** first do number
6899 ! *** nuclei or Aitken mode ( no sedimentation velocity )
6901 SC0N = NU / DCHAT0N(LCELL)
6902 ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
6903 RD0N = 1.0 / ( UTSCALE * &
6904 ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
6906 VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + &
6907 1.0 / ( &
6908 RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
6910 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6912 ! *** accumulation mode
6914 SC0A = NU / DCHAT0A(LCELL)
6915 ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
6916 RD0A = 1.0 / ( UTSCALE * &
6917 ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
6919 VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + &
6920 1.0 / ( &
6921 RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
6923 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6925 ! *** coarse mode
6927 SC0C = NU / DCHAT0C(LCELL)
6928 !ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
6929 !ia RD0C = 1.0 / ( UTSCALE *
6930 !ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
6932 RD0C = 1.0 / ( UTSCALE * &
6933 ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term
6935 VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + &
6936 1.0 / ( &
6937 RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
6939 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6941 ! *** now do m3 for the deposition of mass
6943 ! *** nuclei or Aitken mode
6945 SC3N = NU / DCHAT3N(LCELL)
6946 ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
6947 RD3N = 1.0 / ( UTSCALE * &
6948 ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
6950 VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + &
6951 1.0 / ( &
6952 RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
6954 VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
6956 ! *** accumulation mode
6958 SC3A = NU / DCHAT3A(LCELL)
6959 ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
6960 RD3A = 1.0 / ( UTSCALE * &
6961 ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
6963 VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + &
6964 1.0 / ( &
6965 RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
6968 ! *** fine mass deposition velocity: combine Aitken and accumulation
6969 ! mode deposition velocities. Assume density is the same
6970 ! for both modes.
6973 ! VDEP(LCELL,VDMFINE) = (
6974 ! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
6975 ! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
6976 ! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
6979 ! *** fine mass sedimentation velocity
6981 ! VSED( LCELL, VSMFINE) = (
6982 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6983 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6984 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6986 VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
6988 ! *** coarse mode
6990 SC3C = NU / DCHAT3C(LCELL)
6991 !ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
6992 !ia RD3C = 1.0 / ( UTSCALE *
6993 !ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
6995 RD3C = 1.0 / ( UTSCALE * &
6996 ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
6997 VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + &
6998 1.0 / ( &
6999 RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
7001 ! *** coarse mode sedmentation velocity
7003 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
7007 END DO
7009 ELSE ! LAYER greater than 1
7011 ! *** for layer greater than 1 calculate sedimentation velocities only
7013 DO LCELL = 1, NUMCELLS
7015 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
7017 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
7018 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
7019 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
7021 VGHAT0N(LCELL) = DCONST3N &
7022 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
7024 ! *** nucleation mode number sedimentation velocity
7026 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
7028 VGHAT3N(LCELL) = DCONST3N &
7029 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
7031 ! *** nucleation mode volume sedimentation velocity
7033 VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
7035 VGHAT0A(LCELL) = DCONST3A &
7036 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
7038 ! *** accumulation mode number sedimentation velocity
7040 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
7042 VGHAT3A(LCELL) = DCONST3A &
7043 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
7045 ! *** fine mass sedimentation velocity
7047 ! VSED( LCELL, VSMFINE) = (
7048 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
7049 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
7050 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
7052 VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
7054 VGHAT0C(LCELL) = DCONST3C &
7055 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
7057 ! *** coarse mode sedimentation velocity
7059 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
7062 VGHAT3C(LCELL) = DCONST3C &
7063 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
7065 ! *** coarse mode mass sedimentation velocity
7067 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
7069 END DO
7071 END IF ! check on layer
7073 END SUBROUTINE VDVG
7074 !
7075 ! ///////////////////////////////
7076 ! *** this routine calculates the dry deposition and sedimentation
7077 ! velocities for the three modes.
7078 ! Stu McKeen 10/13/08
7079 ! Gaussian Quadrature numerical integration over diameter range for each mode.
7080 ! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10
7081 ! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv
7082 ! Numerical Integration allows more complete discription of the
7083 ! Cunningham Slip correction factor, Interception Term (not included previously),
7084 ! and the correction due to rebound for higher diameter particles.
7085 ! Sedimentation velocities the same as original Binkowski code, also the
7086 ! Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the
7087 ! same as Binkowski.
7088 ! Stokes number, and efficiency dependence on Stokes number now according to
7089 ! Peters and Eiden (1992). Interception term taken from Slinn (1982) with
7090 ! efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy
7091 ! for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction
7092 ! term is that of Slinn (1982)
7093 !
7094 ! Original code 1/23/97 by Dr. Francis S. Binkowski. Follows
7095 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
7096 ! velocity but includes Marv Wesely's wstar contribution.
7097 !ia eliminated Stokes term for coarse mode deposition calcs.,
7098 !ia see comments below
7100 SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, &
7101 LAYER, &
7102 CBLK, BLKTA, BLKDENS, &
7103 RA, USTAR, PBLH, ZNTT, RMOLM, AMU, &
7104 DGNUC, DGACC, DGCOR, XLM, &
7105 KNNUC, KNACC,KNCOR, &
7106 PDENSN, PDENSA, PDENSC, &
7107 VSED, VDEP)
7109 ! *** calculate size-averaged particle dry deposition and
7110 ! size-averaged sedimentation velocities.
7113 ! IMPLICIT NONE
7115 INTEGER BLKSIZE ! dimension of arrays
7116 INTEGER NSPCSDA ! number of species in CBLK
7117 INTEGER NUMCELLS ! actual number of cells in arrays
7118 INTEGER LAYER ! number of layer
7119 INTEGER, PARAMETER :: iprnt = 0
7121 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
7122 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
7123 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
7124 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
7125 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
7126 REAL PBLH( BLKSIZE ) ! PBL height (m)
7127 REAL ZNTT( BLKSIZE ) ! Surface roughness length (m)
7128 REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m)
7129 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
7130 REAL XLM( BLKSIZE ) ! mean freepath of dry air [ m ]
7131 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
7132 REAL DGACC( BLKSIZE ) ! accumulation
7133 REAL DGCOR( BLKSIZE ) ! coarse mode
7134 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
7135 REAL KNACC( BLKSIZE ) ! accumulation
7136 REAL KNCOR( BLKSIZE ) ! coarse mode
7137 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
7138 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
7139 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
7142 ! *** deposition and sedimentation velocities
7144 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
7145 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
7148 INTEGER LCELL,N
7149 REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C
7150 REAL UTSCALE,CZH ! scratch functions of USTAR and WSTAR.
7151 REAL NU !kinematic viscosity [ m**2 s**-1 ]
7152 REAL BHAT
7153 PARAMETER( BHAT = 1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction.
7154 REAL COLCTR_BIGD,COLCTR_SMALD
7155 PARAMETER( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6) ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest)
7156 REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim
7157 REAL Eff_dif, Eff_imp, Eff_int, RBcor
7158 INTEGER ISTOPvd0,IdoWesCor
7159 PARAMETER (ISTOPvd0 = 0) ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs.
7160 PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means dont do correction
7161 IF (ISTOPvd0.EQ.1)THEN
7162 RETURN
7163 ENDIF
7164 ! *** check layer value.
7166 IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER
7167 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
7168 ! sedimentation velocities
7170 DO LCELL = 1, NUMCELLS
7172 DCONST1 = BOLTZ * BLKTA(LCELL) / &
7173 ( THREEPI * AMU(LCELL) )
7174 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
7175 DCONST3 = USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD)
7177 ! *** now calculate the deposition velocities at layer 1
7179 NU = AMU(LCELL) / BLKDENS(LCELL)
7181 UTSCALE = 1.
7182 IF (IdoWesCor.EQ.1)THEN
7183 ! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08)
7184 IF(RMOLM(LCELL).LT.0.)THEN
7185 CZH = -1.*PBLH(LCELL)*RMOLM(LCELL)
7186 IF(CZH.GT.30.0)THEN
7187 UTSCALE=0.45*CZH**0.6667
7188 ELSE
7189 UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667
7190 ENDIF
7191 ENDIF
7192 ENDIF ! end of (IdoWesCor.EQ.1) test
7193 UTSCALE = USTAR(LCELL)*UTSCALE
7194 IF(iprnt.eq.1)THEN
7195 print *,'NGAUSdv,xxlsga,USTAR,UTSCALE'
7196 print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE
7197 print *,'DCONST2,PDENSA,DGACC,GRAV,AMU'
7198 print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL)
7199 endif
7201 ! *** nuclei mode
7203 SUM0=0.
7204 SUM3=0.
7205 DO N=1,NGAUSdv
7206 DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn) ! Diameter (m) at quadrature point
7207 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
7208 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
7209 VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
7210 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
7211 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
7212 STQ=DCONST3*PDENSN(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
7213 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
7214 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
7215 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
7216 RBcor=1. ! Rebound correction factor
7217 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
7218 ! vdplim=.002*UTSCALE
7219 vdplim=min(vdplim,.02)
7220 RSURFQ=RA(LCELL)+1./vdplim
7221 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
7222 !
7223 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
7224 !
7225 ! RSURFQ=max(RSURFQ,50.)
7226 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
7227 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
7228 ENDDO
7229 VDEP(LCELL, VDNNUC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
7230 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
7232 ! *** accumulation mode
7234 SUM0=0.
7235 SUM3=0.
7236 DO N=1,NGAUSdv
7237 DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga) ! Diameter (m) at quadrature point
7238 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
7239 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
7240 VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
7241 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
7242 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
7243 STQ=DCONST3*PDENSA(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
7244 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
7245 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
7246 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
7247 RBcor=1. ! Rebound correction factor
7248 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
7249 vdplim=min(vdplim,.02)
7250 RSURFQ=RA(LCELL)+1./vdplim
7251 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
7252 !
7253 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
7254 !
7255 ! RSURFQ=max(RSURFQ,50.)
7256 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
7257 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
7258 IF(iprnt.eq.1)THEN
7259 print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ'
7260 print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ
7261 print *,'N,Eff_dif,imp,int,SUM0,SUM3'
7262 print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3
7263 endif
7264 ENDDO
7265 VDEP(LCELL, VDNACC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
7266 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
7268 ! *** coarse mode
7270 SUM0=0.
7271 SUM3=0.
7272 DO N=1,NGAUSdv
7273 DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc) ! Diameter (m) at quadrature point
7274 KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point
7275 CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16)
7276 VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s
7277 SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar
7278 Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar
7279 STQ=DCONST3*PDENSC(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992)
7280 Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992)
7281 ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam.
7282 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
7283 EFF_int=min(1.,EFF_int)
7284 RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982)
7285 vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor
7286 vdplim=min(vdplim,.02)
7287 vdplim=max(vdplim,1e-35) !wig: add check since occasionally a lg particle causes overflow of rsurfq
7288 RSURFQ=RA(LCELL)+1./vdplim
7289 ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence
7290 !
7291 ! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986
7292 !
7293 ! RSURFQ=max(RSURFQ,50.)
7294 SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment
7295 SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment
7296 ENDDO
7297 VDEP(LCELL, VDNCOR) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume)
7298 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
7300 END DO
7302 ENDIF ! ENDOF LAYER = 1 test
7304 ! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995)
7306 DO LCELL = 1, NUMCELLS
7308 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
7309 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
7310 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
7311 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
7313 ! *** nucleation mode number and mass sedimentation velociticies
7314 VSED( LCELL, VSNNUC) = DCONST3N &
7315 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
7316 VSED( LCELL, VSMNUC) = DCONST3N &
7317 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
7319 ! *** accumulation mode number and mass sedimentation velociticies
7320 VSED( LCELL, VSNACC) = DCONST3A &
7321 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
7322 VSED( LCELL, VSMACC) = DCONST3A &
7323 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
7325 ! *** coarse mode number and mass sedimentation velociticies
7326 VSED( LCELL, VSNCOR) = DCONST3C &
7327 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
7328 VSED( LCELL, VSMCOR) = DCONST3C &
7329 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
7331 END DO
7334 END SUBROUTINE VDVG_2
7338 !
7339 SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, &
7340 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
7341 chem_in_opt,aer_ic_opt, is_aerosol, &
7342 ids,ide, jds,jde, kds,kde, &
7343 ims,ime, jms,jme, kms,kme, &
7344 its,ite, jts,jte, kts,kte, config_flags )
7346 USE module_configure,only: grid_config_rec_type
7347 !!! TUCCELLA (BUG, commented the line below)
7348 !USE module_prep_wetscav_sorgam,only: aerosols_sorgam_init_aercld_ptrs
7350 implicit none
7351 INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt
7352 INTEGER, INTENT(IN ) :: &
7353 ids,ide, jds,jde, kds,kde, &
7354 ims,ime, jms,jme, kms,kme, &
7355 its,ite, jts,jte, kts,kte
7356 LOGICAL, INTENT(OUT) :: is_aerosol(num_chem)
7357 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , &
7358 INTENT(INOUT ) :: &
7359 chem
7360 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7361 INTENT(INOUT ) :: &
7362 pm2_5_dry,pm2_5_water,pm2_5_dry_ec
7363 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7364 INTENT(IN ) :: &
7365 convfac
7366 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
7367 INTENT(IN ) :: &
7368 z_at_w
7369 TYPE (grid_config_rec_type) , INTENT (in) :: config_flags
7372 integer i,j,k,l,ii,jj,kk
7373 real tempfac,mwso4,zz
7374 ! real,dimension(its:ite,kts:kte,jts:jte) :: convfac
7375 REAL splitfac
7376 !between gas and aerosol phase
7377 REAL so4vaptoaer
7378 !factor for splitting initial conc. of SO4
7379 !3rd moment i-mode [3rd moment/m^3]
7380 REAL m3nuc
7381 !3rd MOMENT j-mode [3rd moment/m^3]
7382 REAL m3acc
7383 ! REAL ESN36
7384 REAL m3cor
7385 DATA splitfac/.98/
7386 DATA so4vaptoaer/.999/
7389 ! *** Compute these once and they will all be saved in COMMON
7390 xxlsgn = log(sginin)
7391 xxlsga = log(sginia)
7392 xxlsgc = log(sginic)
7394 l2sginin = xxlsgn**2
7395 l2sginia = xxlsga**2
7396 l2sginic = xxlsgc**2
7398 en1 = exp(0.125*l2sginin)
7399 ea1 = exp(0.125*l2sginia)
7400 ec1 = exp(0.125*l2sginic)
7402 esn04 = en1**4
7403 esa04 = ea1**4
7404 esc04 = ec1**4
7406 esn05 = esn04*en1
7407 esa05 = esa04*ea1
7409 esn08 = esn04*esn04
7410 esa08 = esa04*esa04
7411 esc08 = esc04*esc04
7413 esn09 = esn04*esn05
7414 esa09 = esa04*esa05
7416 esn12 = esn04*esn04*esn04
7417 esa12 = esa04*esa04*esa04
7418 esc12 = esc04*esc04*esc04
7420 esn16 = esn08*esn08
7421 esa16 = esa08*esa08
7422 esc16 = esc08*esc08
7424 esn20 = esn16*esn04
7425 esa20 = esa16*esa04
7426 esc20 = esc16*esc04
7428 esn24 = esn12*esn12
7429 esa24 = esa12*esa12
7430 esc24 = esc12*esc12
7432 esn25 = esn16*esn09
7433 esa25 = esa16*esa09
7435 esn28 = esn20*esn08
7436 esa28 = esa20*esa08
7437 esc28 = esc20*esc08
7440 esn32 = esn16*esn16
7441 esa32 = esa16*esa16
7442 esc32 = esc16*esc16
7444 esn36 = esn16*esn20
7445 esa36 = esa16*esa20
7446 esc36 = esc16*esc20
7448 esn49 = esn25*esn20*esn04
7449 esa49 = esa25*esa20*esa04
7451 esn52 = esn16*esn36
7452 esa52 = esa16*esa36
7454 esn64 = esn32*esn32
7455 esa64 = esa32*esa32
7456 esc64 = esc32*esc32
7458 esn100 = esn36*esn64
7460 esnm20 = 1.0/esn20
7461 esam20 = 1.0/esa20
7462 escm20 = 1.0/esc20
7464 esnm32 = 1.0/esn32
7465 esam32 = 1.0/esa32
7466 escm32 = 1.0/esc32
7469 xxm3 = 3.0*xxlsgn/ sqrt2
7470 ! factor used in error function cal
7471 nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
7473 nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
7475 nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
7477 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
7478 ! size distribution , then
7480 ! vol = (p/6) * density * num * (dgemv_xx**3) *
7481 ! exp(- 4.5 * log( sgem_xx)**2 ) )
7482 ! note minus sign!!
7484 factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
7485 factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
7486 factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
7487 ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
7488 ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
7489 mwso4=96.03
7491 ! initialize pointers used by aerosol-cloud-interaction routines
7493 ! TUCCELLA (BUG, now aerosols_sorgam_init_aercld_ptrs is called chemics_init.F !
7494 ! and was moved to module_prep_wetscav_sorgam.F)
7496 !call aerosols_sorgam_init_aercld_ptrs( &
7497 ! num_chem, is_aerosol, config_flags )
7500 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
7501 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
7502 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
7504 !SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv
7506 Y_GQ(1)=-2.651961356835233
7507 WGAUS(1)=0.0009717812450995
7508 Y_GQ(2)=-1.673551628767471
7509 WGAUS(2)=0.05451558281913
7510 Y_GQ(3)=-0.816287882858965
7511 WGAUS(3)=0.4256072526101
7512 Y_GQ(4)=-0.0
7513 WGAUS(4)=0.8102646175568
7514 Y_GQ(5)=0.816287882858965
7515 WGAUS(5)=WGAUS(3)
7516 Y_GQ(6)=1.673551628767471
7517 WGAUS(6)=WGAUS(2)
7518 Y_GQ(7)=2.651961356835233
7519 WGAUS(7)=WGAUS(1)
7520 !
7521 !
7522 ! IF USING OLD SIMULATION, DO NOT REINITIALIZE!
7523 !
7524 !
7525 if(chem_in_opt == 1 .OR. config_flags%restart) return
7526 do l=p_so4aj,num_chem
7527 chem(ims:ime,kms:kme,jms:jme,l)=epsilc
7528 enddo
7529 chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
7530 chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
7531 do j=jts,jte
7532 jj=min(jde-1,j)
7533 do k=kts,kte-1
7534 kk=min(kde-1,k)
7535 do i=its,ite
7536 ii=min(ide-1,i)
7538 !Option for alternate ic's
7539 if( aer_ic_opt == AER_IC_DEFAULT ) then
7540 chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer
7541 chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4* &
7542 (1.-splitfac)*so4vaptoaer
7543 chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
7544 chem(i,k,j,p_nh4aj) = 10.E-05
7545 chem(i,k,j,p_nh4ai) = 10.E-05
7546 chem(i,k,j,p_no3aj) = 10.E-05
7547 chem(i,k,j,p_no3ai) = 10.E-05
7548 chem(i,k,j,p_naaj) = 10.E-05
7549 chem(i,k,j,p_naai) = 10.E-05
7550 chem(i,k,j,p_claj) = 10.E-05
7551 chem(i,k,j,p_clai) = 10.E-05
7552 elseif( aer_ic_opt == AER_IC_PNNL ) then
7553 zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5
7554 call sorgam_init_aer_ic_pnnl( &
7555 chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
7556 else
7557 call wrf_error_fatal( &
7558 "aerosols_sorgam_init: unable to parse aer_ic_opt" )
7559 end if
7561 !... i-mode
7562 m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
7563 no3fac*chem(i,k,j,p_no3ai) + &
7564 nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) + &
7565 orgfac*chem(i,k,j,p_orgaro1i) + &
7566 orgfac*chem(i,k,j,p_orgaro2i) + orgfac*chem(i,k,j,p_orgalk1i) + &
7567 orgfac*chem(i,k,j,p_orgole1i) + orgfac*chem(i,k,j,p_orgba1i) + &
7568 orgfac*chem(i,k,j,p_orgba2i) + orgfac*chem(i,k,j,p_orgba3i) + &
7569 orgfac*chem(i,k,j,p_orgba4i) + orgfac*chem(i,k,j,p_orgpai) + &
7570 anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)
7572 !... j-mode
7573 m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + &
7574 no3fac*chem(i,k,j,p_no3aj) + &
7575 nafac*chem(i,k,j,p_naaj) + clfac*chem(i,k,j,p_claj) + &
7576 orgfac*chem(i,k,j,p_orgaro1j) + &
7577 orgfac*chem(i,k,j,p_orgaro2j) + orgfac*chem(i,k,j,p_orgalk1j) + &
7578 orgfac*chem(i,k,j,p_orgole1j) + orgfac*chem(i,k,j,p_orgba1j) + &
7579 orgfac*chem(i,k,j,p_orgba2j) + orgfac*chem(i,k,j,p_orgba3j) + &
7580 orgfac*chem(i,k,j,p_orgba4j) + orgfac*chem(i,k,j,p_orgpaj) + &
7581 anthfac*chem(i,k,j,p_p25j) + anthfac*chem(i,k,j,p_ecj)
7583 !...c-mode
7584 m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
7585 anthfac*chem(i,k,j,p_antha)
7588 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
7589 chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
7591 chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
7593 chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
7595 enddo
7596 enddo
7597 enddo
7600 return
7601 END SUBROUTINE aerosols_sorgam_init
7603 !****************************************************************
7604 ! *
7605 ! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE *
7606 ! aer_ic_opt == aer_ic_pnnl OPTION. *
7607 ! *
7608 ! wig, 21-Apr-2004, original version *
7609 ! rce, 25-apr-2004 - name changes for consistency with *
7610 ! new aer_ic constants in Registry *
7611 ! wig, 7-May-2004, added height dependance *
7612 ! *
7613 ! CALLS THE FOLLOWING SUBROUTINES: NONE *
7614 ! *
7615 ! CALLED BY : aerosols_sorgam_init *
7616 ! *
7617 !****************************************************************
7618 SUBROUTINE sorgam_init_aer_ic_pnnl( &
7619 chem, z, i,k,j, ims,ime, jms,jme, kms,kme )
7621 USE module_configure,only: num_chem, grid_config_rec_type
7622 implicit none
7624 INTEGER,INTENT(IN ) :: i,k,j, &
7625 ims,ime, jms,jme, kms,kme
7626 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),&
7627 INTENT(INOUT ) :: chem
7629 real, intent(in ) :: z
7630 real :: mult
7632 !
7633 ! Determine height multiplier...
7634 ! This should mimic the calculation in sorgam_set_aer_bc_pnnl,
7635 ! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic
7636 !!$! Height(m) Multiplier
7637 !!$! --------- ----------
7638 !!$! <=2000 1.0
7639 !!$! 2000<z<3000 linear transition zone to 0.5
7640 !!$! 3000<z<5000 linear transision zone to 0.25
7641 !!$! >=3000 0.25
7642 !!$!
7643 !!$! which translates to:
7644 !!$! 2000<z<3000 mult = 1.0 + (z-2000.)*(0.5-1.0)/(3000.-2000.)
7645 !!$! 3000<z<5000 mult = 0.5 + (z-3000.)*(0.25-0.5)/(5000.-3000.)
7646 !!$! or in reduced form:
7647 !!$ if( z <= 2000. ) then
7648 !!$ mult = 1.0
7649 !!$ elseif( z > 2000. &
7650 !!$ .and. z <= 3000. ) then
7651 !!$ mult = 1.0 - 0.0005*(z-2000.)
7652 !!$ elseif( z > 3000. &
7653 !!$ .and. z <= 5000. ) then
7654 !!$ mult = 0.5 - 1.25e-4*(z-3000.)
7655 !!$ else
7656 !!$ mult = 0.25
7657 !!$ end if
7658 ! Updated aerosol profile multiplier 1-Apr-2005:
7659 ! Height(m) Multiplier
7660 ! --------- ----------
7661 ! <=2000 1.0
7662 ! 2000<z<3000 linear transition zone to 0.25
7663 ! 3000<z<5000 linear transision zone to 0.125
7664 ! >=5000 0.125
7665 !
7666 ! which translates to:
7667 ! 2000<z<3000 mult = 1.00 + (z-2000.)*(0.25-1.0)/(3000.-2000.)
7668 ! 3000<z<5000 mult = 0.25 + (z-3000.)*(0.125-0.25)/(5000.-3000.)
7669 ! or in reduced form:
7670 !jdf comment these values and have another profile consistent with mosaic
7671 ! if( z <= 2000. ) then
7672 ! mult = 1.0
7673 ! elseif( z > 2000. &
7674 ! .and. z <= 3000. ) then
7675 ! mult = 1.0 - 0.00075*(z-2000.)
7676 ! elseif( z > 3000. &
7677 ! .and. z <= 5000. ) then
7678 ! mult = 0.25 - 4.166666667e-5*(z-3000.)
7679 ! else
7680 ! mult = 0.125
7681 ! end if
7682 if( z <= 500. ) then
7683 mult = 1.0
7684 elseif( z > 500. &
7685 .and. z <= 1000. ) then
7686 mult = 1.0 - 0.001074*(z-500.)
7687 elseif( z > 1000. &
7688 .and. z <= 5000. ) then
7689 mult = 0.463 - 0.000111*(z-1000.)
7690 else
7691 mult = 0.019
7692 end if
7694 ! These should match what is in sorgam_set_aer_bc_pnnl.
7695 ! Values as of 2-Dec-2004:
7696 !jdf comment these values and have another profile consistent with mosaic
7697 ! chem(i,k,j,p_sulf) = mult*conmin
7698 ! chem(i,k,j,p_so4aj) = mult*2.375
7699 ! chem(i,k,j,p_so4ai) = mult*0.179
7700 ! chem(i,k,j,p_nh4aj) = mult*0.9604
7701 ! chem(i,k,j,p_nh4ai) = mult*0.0196
7702 ! chem(i,k,j,p_no3aj) = mult*0.0650
7703 ! chem(i,k,j,p_no3ai) = mult*0.0050
7704 ! chem(i,k,j,p_ecj) = mult*0.1630
7705 ! chem(i,k,j,p_eci) = mult*0.0120
7706 ! chem(i,k,j,p_p25j) = mult*0.6350
7707 ! chem(i,k,j,p_p25i) = mult*0.0490
7708 ! chem(i,k,j,p_antha) = mult*2.2970
7709 ! chem(i,k,j,p_orgpaj) = mult*0.9300
7710 ! chem(i,k,j,p_orgpai) = mult*0.0700
7711 ! chem(i,k,j,p_orgaro1j) = conmin
7712 ! chem(i,k,j,p_orgaro1i) = conmin
7713 ! chem(i,k,j,p_orgaro2j) = conmin
7714 ! chem(i,k,j,p_orgaro2i) = conmin
7715 ! chem(i,k,j,p_orgalk1j) = conmin
7716 ! chem(i,k,j,p_orgalk1i) = conmin
7717 ! chem(i,k,j,p_orgole1j) = conmin
7718 ! chem(i,k,j,p_orgole1i) = conmin
7719 ! chem(i,k,j,p_orgba1j) = conmin
7720 ! chem(i,k,j,p_orgba1i) = conmin
7721 ! chem(i,k,j,p_orgba2j) = conmin
7722 ! chem(i,k,j,p_orgba2i) = conmin
7723 ! chem(i,k,j,p_orgba3j) = conmin
7724 ! chem(i,k,j,p_orgba3i) = conmin
7725 ! chem(i,k,j,p_orgba4j) = conmin
7726 ! chem(i,k,j,p_orgba4i) = conmin
7727 ! chem(i,k,j,p_seas) = mult*0.229
7728 chem(i,k,j,p_sulf) = mult*conmin
7729 chem(i,k,j,p_so4aj) = mult*0.300*0.97
7730 chem(i,k,j,p_so4ai) = mult*0.300*0.03
7731 chem(i,k,j,p_nh4aj) = mult*0.094*0.97
7732 chem(i,k,j,p_nh4ai) = mult*0.094*0.03
7733 chem(i,k,j,p_no3aj) = mult*0.001*0.97
7734 chem(i,k,j,p_no3ai) = mult*0.001*0.03
7735 chem(i,k,j,p_naaj) = 10.E-05
7736 chem(i,k,j,p_naai) = 10.E-05
7737 chem(i,k,j,p_claj) = 10.E-05
7738 chem(i,k,j,p_clai) = 10.E-05
7739 chem(i,k,j,p_ecj) = mult*0.013*0.97
7740 chem(i,k,j,p_eci) = mult*0.013*0.03
7741 chem(i,k,j,p_p25j) = mult*4.500*0.97
7742 chem(i,k,j,p_p25i) = mult*4.500*0.03
7743 chem(i,k,j,p_antha) = mult*4.500/2.0
7744 chem(i,k,j,p_orgpaj) = mult*0.088*0.97
7745 chem(i,k,j,p_orgpai) = mult*0.088*0.03
7746 chem(i,k,j,p_orgaro1j) = conmin
7747 chem(i,k,j,p_orgaro1i) = conmin
7748 chem(i,k,j,p_orgaro2j) = conmin
7749 chem(i,k,j,p_orgaro2i) = conmin
7750 chem(i,k,j,p_orgalk1j) = conmin
7751 chem(i,k,j,p_orgalk1i) = conmin
7752 chem(i,k,j,p_orgole1j) = conmin
7753 chem(i,k,j,p_orgole1i) = conmin
7754 chem(i,k,j,p_orgba1j) = conmin
7755 chem(i,k,j,p_orgba1i) = conmin
7756 chem(i,k,j,p_orgba2j) = conmin
7757 chem(i,k,j,p_orgba2i) = conmin
7758 chem(i,k,j,p_orgba3j) = conmin
7759 chem(i,k,j,p_orgba3i) = conmin
7760 chem(i,k,j,p_orgba4j) = conmin
7761 chem(i,k,j,p_orgba4i) = conmin
7762 chem(i,k,j,p_seas) = mult*1.75
7765 END SUBROUTINE sorgam_init_aer_ic_pnnl
7767 !------------------------------------------------------------------------
7769 SUBROUTINE sorgam_addemiss( &
7770 id, dtstep, u10, v10, alt, dz8w, xland, chem, &
7771 ebu, &
7772 slai,ust,smois,ivgtyp,isltyp, &
7773 emis_ant,dust_emiss_active, &
7774 seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, &
7775 dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, &
7776 ids,ide, jds,jde, kds,kde, &
7777 ims,ime, jms,jme, kms,kme, &
7778 its,ite, jts,jte, kts,kte )
7779 !
7780 ! Routine to apply aerosol emissions for MADE/SORGAM...
7781 ! William.Gustafson@pnl.gov; 3-May-2007
7782 ! Modified by
7783 ! steven.peckham@noaa.gov; 8-Jan-2008
7784 !------------------------------------------------------------------------
7786 USE module_state_description, only: num_chem
7788 INTEGER, INTENT(IN ) :: seasalt_emiss_active, kemit,emissopt, &
7789 dust_emiss_active,num_soil_layers,id, &
7790 ktau,dust_opt, &
7791 biom,ids,ide, jds,jde, kds,kde, &
7792 ims,ime, jms,jme, kms,kme, &
7793 its,ite, jts,jte, kts,kte
7795 REAL, INTENT(IN ) :: dtstep
7797 ! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air)
7798 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
7799 INTENT(INOUT ) :: chem
7800 !
7801 ! aerosol emissions arrays ((ug/m3)*m/s)
7802 !
7803 REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), &
7804 INTENT(IN ) :: &
7805 emis_ant
7806 !
7807 ! biomass burning aerosol emissions arrays ((ug/m3)*m/s)
7808 !
7809 REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), &
7810 INTENT(IN ) :: &
7811 ebu
7813 ! 1/(dry air density) and layer thickness (m)
7814 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
7815 INTENT(IN ) :: &
7816 alt, dz8w
7818 ! add for gocart dust
7819 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
7820 INTENT(IN ) :: p8w,u_phy,v_phy,rho_phy
7821 REAL, INTENT(IN ) :: dx, g
7822 REAL, DIMENSION( ims:ime, jms:jme, 3 ), &
7823 INTENT(IN ) :: erod
7824 !
7826 REAL, DIMENSION( ims:ime , jms:jme ), &
7827 INTENT(IN ) :: &
7828 u10, v10, xland, slai, ust
7829 INTEGER, DIMENSION( ims:ime , jms:jme ), &
7830 INTENT(IN ) :: ivgtyp, isltyp
7831 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ), &
7832 INTENT(INOUT) :: smois
7834 ! Local variables...
7835 real, dimension(its:ite,kts:kte,jts:jte) :: factor
7836 !
7837 ! Get the emissions unit conversion factor including the time step.
7838 ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep]
7839 !
7840 factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ &
7841 dz8w(its:ite,kts:kte,jts:jte)
7842 !
7843 ! Increment the aerosol numbers...
7844 if (emissopt .ne. 5) then
7845 !
7846 ! Aitken mode first...
7848 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7849 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7850 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7851 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + &
7852 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + &
7853 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + &
7854 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) + &
7855 so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i) + &
7856 no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i) )
7858 ! Accumulation mode next...
7860 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7861 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7862 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7863 anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + &
7864 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + &
7865 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + &
7866 orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) + &
7867 so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j) + &
7868 no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j))
7870 ! And now the coarse mode...
7872 chem(its:ite,kts:kemit,jts:jte,p_corn) = &
7873 chem(its:ite,kts:kemit,jts:jte,p_corn) + &
7874 factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac* &
7875 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)
7876 !
7877 ! Increment the aerosol masses...
7878 !
7879 chem(its:ite,kts:kemit,jts:jte,p_antha) = &
7880 chem(its:ite,kts:kemit,jts:jte,p_antha) + &
7881 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte)
7883 chem(its:ite,kts:kemit,jts:jte,p_p25j) = &
7884 chem(its:ite,kts:kemit,jts:jte,p_p25j) + &
7885 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte)
7887 chem(its:ite,kts:kemit,jts:jte,p_p25i) = &
7888 chem(its:ite,kts:kemit,jts:jte,p_p25i) + &
7889 emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte)
7891 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
7892 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
7893 emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte)
7895 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
7896 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
7897 emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte)
7898 chem(its:ite,kts:kemit,jts:jte,p_naaj) = &
7899 chem(its:ite,kts:kemit,jts:jte,p_naaj) + &
7900 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte)
7901 chem(its:ite,kts:kemit,jts:jte,p_naai) = &
7902 chem(its:ite,kts:kemit,jts:jte,p_naai) + &
7903 emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte)
7905 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
7906 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
7907 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte)
7909 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7910 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7911 emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte)
7913 chem(its:ite,kts:kemit,jts:jte,p_so4aj) = &
7914 chem(its:ite,kts:kemit,jts:jte,p_so4aj) + &
7915 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte)
7917 chem(its:ite,kts:kemit,jts:jte,p_so4ai) = &
7918 chem(its:ite,kts:kemit,jts:jte,p_so4ai) + &
7919 emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte)
7921 chem(its:ite,kts:kemit,jts:jte,p_no3aj) = &
7922 chem(its:ite,kts:kemit,jts:jte,p_no3aj) + &
7923 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte)
7925 chem(its:ite,kts:kemit,jts:jte,p_no3ai) = &
7926 chem(its:ite,kts:kemit,jts:jte,p_no3ai) + &
7927 emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte)
7928 elseif(emissopt == 5)then
7929 !
7930 ! Aitken mode first...
7932 chem(its:ite,kts:kemit,jts:jte,p_nu0) = &
7933 chem(its:ite,kts:kemit,jts:jte,p_nu0) + &
7934 factor(its:ite,kts:kemit,jts:jte)*factnumn*( &
7935 anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7936 orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7938 ! Accumulation mode next...
7940 chem(its:ite,kts:kemit,jts:jte,p_ac0) = &
7941 chem(its:ite,kts:kemit,jts:jte,p_ac0) + &
7942 factor(its:ite,kts:kemit,jts:jte)*factnuma*( &
7943 anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + &
7944 orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) )
7946 !
7947 ! Increment the aerosol masses...
7948 !
7950 chem(its:ite,kts:kemit,jts:jte,p_ecj) = &
7951 chem(its:ite,kts:kemit,jts:jte,p_ecj) + &
7952 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7954 chem(its:ite,kts:kemit,jts:jte,p_eci) = &
7955 chem(its:ite,kts:kemit,jts:jte,p_eci) + &
7956 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte)
7958 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = &
7959 chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + &
7960 .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7962 chem(its:ite,kts:kemit,jts:jte,p_orgpai) = &
7963 chem(its:ite,kts:kemit,jts:jte,p_orgpai) + &
7964 .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte)
7966 endif
7967 ! add biomass burning emissions if present
7968 !
7969 if(biom == 1 )then
7970 !
7971 ! Aitken mode first...
7973 chem(its:ite,kts:kte,jts:jte,p_nu0) = &
7974 chem(its:ite,kts:kte,jts:jte,p_nu0) + &
7975 factor(its:ite,kts:kte,jts:jte)*factnumn*( &
7976 anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7977 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7978 orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7980 ! Accumulation mode next...
7982 chem(its:ite,kts:kte,jts:jte,p_ac0) = &
7983 chem(its:ite,kts:kte,jts:jte,p_ac0) + &
7984 factor(its:ite,kts:kte,jts:jte)*factnuma*( &
7985 anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + &
7986 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + &
7987 orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) )
7988 ! coarse
7989 chem(its:ite,kts:kte,jts:jte,p_corn) = &
7990 chem(its:ite,kts:kte,jts:jte,p_corn) + &
7991 factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* &
7992 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)
7994 !
7995 ! Increment the aerosol masses...
7996 !
7998 chem(its:ite,kts:kte,jts:jte,p_ecj) = &
7999 chem(its:ite,kts:kte,jts:jte,p_ecj) + &
8000 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
8002 chem(its:ite,kts:kte,jts:jte,p_eci) = &
8003 chem(its:ite,kts:kte,jts:jte,p_eci) + &
8004 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte)
8006 chem(its:ite,kts:kte,jts:jte,p_orgpaj) = &
8007 chem(its:ite,kts:kte,jts:jte,p_orgpaj) + &
8008 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
8010 chem(its:ite,kts:kte,jts:jte,p_orgpai) = &
8011 chem(its:ite,kts:kte,jts:jte,p_orgpai) + &
8012 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte)
8014 chem(its:ite,kts:kte,jts:jte,p_antha) = &
8015 chem(its:ite,kts:kte,jts:jte,p_antha) + &
8016 ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte)
8018 chem(its:ite,kts:kte,jts:jte,p_p25j) = &
8019 chem(its:ite,kts:kte,jts:jte,p_p25j) + &
8020 .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
8022 chem(its:ite,kts:kte,jts:jte,p_p25i) = &
8023 chem(its:ite,kts:kte,jts:jte,p_p25i) + &
8024 .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte)
8026 endif !end biomass burning
8027 !
8028 ! Get the sea salt emissions...
8029 !
8030 if( seasalt_emiss_active == 1 ) then
8031 call sorgam_seasalt_emiss( &
8032 dtstep, u10, v10, alt, dz8w, xland, chem, &
8033 ids,ide, jds,jde, kds,kde, &
8034 ims,ime, jms,jme, kms,kme, &
8035 its,ite, jts,jte, kts,kte )
8036 end if
8037 if( seasalt_emiss_active == 2 ) then
8038 ! call Monahan_seasalt_emiss( &
8039 ! dtstep, u10, v10, alt, dz8w, xland, chem, &
8040 ! ids,ide, jds,jde, kds,kde, &
8041 ! ims,ime, jms,jme, kms,kme, &
8042 ! its,ite, jts,jte, kts,kte )
8043 end if
8044 if( dust_opt == 2 ) then
8045 !czhao+++++++++++++++++++++++++++
8046 call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13")
8047 !czhao---------------------------
8049 call sorgam_dust_emiss( &
8050 slai, ust, smois, ivgtyp, isltyp, &
8051 id, dtstep, u10, v10, alt, dz8w, &
8052 xland, num_soil_layers, chem, &
8053 ids,ide, jds,jde, kds,kde, &
8054 ims,ime, jms,jme, kms,kme, &
8055 its,ite, jts,jte, kts,kte )
8056 end if
8057 !czhao ++++++++++++++++++++++++++
8058 ! dust_opt changed to 13 since it conflicts with gocart/afwa
8059 if( dust_opt == 13 ) then
8060 !czhao --------------------------
8061 call sorgam_dust_gocartemis( &
8062 ktau,dtstep,num_soil_layers,alt,u_phy, &
8063 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
8064 ivgtyp,isltyp,xland,dx,g, &
8065 ids,ide, jds,jde, kds,kde, &
8066 ims,ime, jms,jme, kms,kme, &
8067 its,ite, jts,jte, kts,kte )
8068 end if
8070 END SUBROUTINE sorgam_addemiss
8072 !------------------------------------------------------------------------
8073 SUBROUTINE sorgam_seasalt_emiss( &
8074 dtstep, u10, v10, alt, dz8w, xland, chem, &
8075 ids,ide, jds,jde, kds,kde, &
8076 ims,ime, jms,jme, kms,kme, &
8077 its,ite, jts,jte, kts,kte )
8078 !
8079 ! Routine to calculate seasalt emissions for SORGAM over the time
8080 ! dtstep...
8081 ! William.Gustafson@pnl.gov; 10-May-2007
8082 !------------------------------------------------------------------------
8084 USE module_mosaic_addemiss, only: seasalt_emitfactors_1bin
8086 IMPLICIT NONE
8088 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
8089 ims,ime, jms,jme, kms,kme, &
8090 its,ite, jts,jte, kts,kte
8092 REAL, INTENT(IN ) :: dtstep
8094 ! 10-m wind speed components (m/s)
8095 REAL, DIMENSION( ims:ime , jms:jme ), &
8096 INTENT(IN ) :: u10, v10, xland
8098 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
8099 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8100 INTENT(INOUT ) :: chem
8102 ! alt = 1.0/(dry air density) in (m3/kg)
8103 ! dz8w = layer thickness in (m)
8104 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
8105 INTENT(IN ) :: alt, dz8w
8107 ! local variables
8108 integer :: i, j, k, l, l_na, l_cl, n
8109 integer :: p1st
8111 real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10
8112 real :: factaa, factbb, fraccl, fracna
8114 real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c
8115 real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c
8118 ! Compute emissions factors for the Aitken mode...
8119 ! Nope, we won't because the parameterization is only valid down to
8120 ! 0.1 microns.
8121 ! Setup in units of cm.
8122 ! dumdlo = 0.039e-4
8123 ! dumdhi = 0.078e-4
8124 ssemfact_numb_i = 0.
8125 ssemfact_mass_i = 0.
8127 ! Compute emissions factors for the accumulation mode...
8128 ! Potentially, we could go down to 0.078 microns to match the bin
8129 ! boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end
8130 ! has been chosen to match the MOSAIC bin boundary closest to two
8131 ! standard deviations from the default bin mean diameter for the coarse
8132 ! mode.
8133 dumdlo = 0.1e-4
8134 dumdhi = 1.250e-4
8135 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
8136 ssemfact_numb_j, dum, ssemfact_mass_j )
8138 ! Compute emissions factors for the coarse mode...
8139 dumdlo = 1.25e-4
8140 dumdhi = 10.0e-4
8141 call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, &
8142 ssemfact_numb_c, dum, ssemfact_mass_c )
8144 ! Convert mass emissions factor from (g/m2/s) to (ug/m2/s)
8145 ssemfact_mass_i = ssemfact_mass_i*1.0e6
8146 ssemfact_mass_j = ssemfact_mass_j*1.0e6
8147 ssemfact_mass_c = ssemfact_mass_c*1.0e6
8149 ! Loop over i,j and apply seasalt emissions
8150 k = kts
8151 do j = jts, jte
8152 do i = its, ite
8154 !Skip this point if over land. xland=1 for land and 2 for water.
8155 !Also, there is no way to differentiate fresh from salt water.
8156 !Currently, this assumes all water is salty.
8157 if( xland(i,j) < 1.5 ) cycle
8159 !wig: As far as I can tell, only real.exe knows the fractional breakdown
8160 ! of land use. So, in wrf.exe, dumoceanfrac will always be 1.
8161 dumoceanfrac = 1. !fraction of grid i,j that is salt water
8162 dumspd10 = dumoceanfrac* &
8163 ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) )
8165 ! factaa is (s*m2/kg-air)
8166 ! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air
8167 ! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air
8168 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
8169 factbb = factaa * dumspd10
8171 ! Apportion seasalt mass emissions assumming that seasalt is pure NaCl
8172 fracna = mw_na_aer / (mw_na_aer + mw_cl_aer)
8173 fraccl = 1.0 - fracna
8175 ! Add the emissions into the chem array...
8176 chem(i,k,j,p_naai) = chem(i,k,j,p_naai) + &
8177 factbb * ssemfact_mass_i * fracna
8178 chem(i,k,j,p_clai) = chem(i,k,j,p_clai) + &
8179 factbb * ssemfact_mass_i * fraccl
8180 chem(i,k,j,p_nu0) = chem(i,k,j,p_nu0) + &
8181 factbb * ssemfact_numb_i
8183 chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) + &
8184 factbb * ssemfact_mass_j * fracna
8185 chem(i,k,j,p_claj) = chem(i,k,j,p_claj) + &
8186 factbb * ssemfact_mass_j * fraccl
8187 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + &
8188 factbb * ssemfact_numb_j
8190 chem(i,k,j,p_seas) = chem(i,k,j,p_seas) + &
8191 factbb * ssemfact_mass_c
8192 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + &
8193 factbb * ssemfact_numb_c
8194 end do !i
8195 end do !j
8196 END SUBROUTINE sorgam_seasalt_emiss
8197 !----------------------------------------------------------------------
8199 subroutine sorgam_dust_emiss( slai,ust, smois, ivgtyp, isltyp, &
8200 id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers, &
8201 chem, &
8202 ids,ide, jds,jde, kds,kde, &
8203 ims,ime, jms,jme, kms,kme, &
8204 its,ite, jts,jte, kts,kte )
8205 !
8206 ! adds dust emissions for mosaic aerosol species (i.e. emission tendencies
8207 ! over time dtstep are applied to the aerosol mixing ratios)
8208 !
8209 ! This is a simple dust scheme based on Shaw et al. (2008) to appear in
8210 ! Atmospheric Environment, recoded by Jerome Fast
8211 !
8212 ! NOTE:
8213 ! 1) This version only works with the 8-bin version of MOSAIC.
8214 ! 2) Dust added to MOSAIC's other inorganic specie, OIN. If Ca and CO3 are
8215 ! activated in the Registry, a small fraction also added to Ca and CO3.
8216 ! 3) The main departure from Shaw et al., is now alphamask is computed since
8217 ! the land-use categories in that paper and in WRF differ. WRF currently
8218 ! does not have that many land-use categories and adhoc assumptions had to
8219 ! be made. This version was tested for Mexico in the dry season. The main
8220 ! land-use categories in WRF that are likely dust sources are grass, shrub,
8221 ! and savannna (that WRF has in the desert regions of NW Mexico). Having
8222 ! dust emitted from these types for other locations and other times of the
8223 ! year is not likely to be valid.
8224 ! 4) An upper bound on ustar was placed because the surface parameterizations
8225 ! in WRF can produce unrealistically high values that lead to very high
8226 ! dust emission rates.
8227 ! 5) Other departures' from Shaw et al. noted below, but are probably not as
8228 ! important as 2) and 3).
8229 !
8231 USE module_configure, only: grid_config_rec_type
8232 USE module_state_description, only: num_chem, param_first_scalar
8233 USE module_data_mosaic_asect
8235 IMPLICIT NONE
8237 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
8239 INTEGER, INTENT(IN ) :: id,num_soil_layers, &
8240 ids,ide, jds,jde, kds,kde, &
8241 ims,ime, jms,jme, kms,kme, &
8242 its,ite, jts,jte, kts,kte
8244 REAL, INTENT(IN ) :: dtstep
8246 ! 10-m wind speed components (m/s)
8247 REAL, DIMENSION( ims:ime , jms:jme ), &
8248 INTENT(IN ) :: u10, v10, xland, slai, ust
8249 INTEGER, DIMENSION( ims:ime , jms:jme ), &
8250 INTENT(IN ) :: ivgtyp, isltyp
8252 ! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg)
8253 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8254 INTENT(INOUT ) :: chem
8256 ! alt = 1.0/(dry air density) in (m3/kg)
8257 ! dz8w = layer thickness in (m)
8258 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
8259 INTENT(IN ) :: alt, dz8w
8261 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
8262 INTENT(INOUT) :: smois
8264 ! local variables
8265 integer i, j, k, l, l_oin, l_ca, l_co3, n, ii
8266 integer iphase, itype, izob
8267 integer p1st
8269 real dum, dumdlo, dumdhi, dumlandfrac, dumspd10
8270 real factaa, factbb, fracoin, fracca, fracco3, fractot
8271 real ustart, ustar1, ustart0
8272 real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot
8273 real smois_grav, wp, pclay
8274 real :: beta(4,7)
8275 real :: gamma(4), delta(4)
8276 real :: sz(8)
8277 real :: dustflux, densdust, mass1part
8278 real :: dp_meanvol_tmp
8279 !
8280 ! from Nickovic et al., JGR, 2001 and Shaw et al. 2007
8281 ! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7)
8282 ! beta (1,*) for 0.5-1 um
8283 ! beta (2,*) for 1-10 um
8284 ! beta (3,*) for 10-25 um
8285 ! beta (4,*) for 25-50 um
8286 !
8287 beta(1,1)=0.12
8288 beta(2,1)=0.04
8289 beta(3,1)=0.04
8290 beta(4,1)=0.80
8291 beta(1,2)=0.34
8292 beta(2,2)=0.28
8293 beta(3,2)=0.28
8294 beta(4,2)=0.10
8295 beta(1,3)=0.45
8296 beta(2,3)=0.15
8297 beta(3,3)=0.15
8298 beta(4,3)=0.25
8299 beta(1,4)=0.12
8300 beta(2,4)=0.09
8301 beta(3,4)=0.09
8302 beta(4,4)=0.70
8303 beta(1,5)=0.40
8304 beta(2,5)=0.05
8305 beta(3,5)=0.05
8306 beta(4,5)=0.50
8307 beta(1,6)=0.34
8308 beta(2,6)=0.18
8309 beta(3,6)=0.18
8310 beta(4,6)=0.30
8311 beta(1,7)=0.22
8312 beta(2,7)=0.09
8313 beta(3,7)=0.09
8314 beta(4,7)=0.60
8315 gamma(1)=0.08
8316 gamma(2)=1.00
8317 gamma(3)=1.00
8318 gamma(4)=0.12
8319 !
8320 ! * Mass fractions for each size bin. These values were recommended by
8321 ! Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM.
8322 ! * Changed slightly since Natelie's estimates do not add up to 1.0
8323 ! * This would need to be made more generic for other bin sizes.
8324 ! sz(1)=0
8325 ! sz(2)=1.78751e-06
8326 ! sz(3)=0.000273786
8327 ! sz(4)=0.00847978
8328 ! sz(5)=0.056055
8329 ! sz(6)=0.0951896
8330 ! sz(7)=0.17
8331 ! sz(8)=0.67
8332 sz(1)=0.0
8333 sz(2)=0.0
8334 sz(3)=0.0005
8335 sz(4)=0.0095
8336 sz(5)=0.03
8337 sz(6)=0.10
8338 sz(7)=0.18
8339 sz(8)=0.68
8341 ! for now just do itype=1
8342 itype = 1
8343 iphase = ai_phase
8345 ! loop over i,j and apply dust emissions
8346 k = kts
8347 do 1830 j = jts, jte
8348 do 1820 i = its, ite
8350 if( xland(i,j) > 1.5 ) cycle
8352 ! compute wind speed anyway, even though ustar is used below
8354 dumlandfrac = 1.
8355 dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5)
8356 if(dumspd10 >= 5.0) then
8357 dumspd10 = dumlandfrac* &
8358 ( dumspd10*dumspd10*(dumspd10-5.0))
8359 else
8360 dumspd10=0.
8361 endif
8363 ! part1 - compute vegetation mask
8364 !
8365 ! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories
8366 ! for desert, sand desert, grass aemi-desert, and shrub semi-desert
8367 ! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna
8368 ! that are dominate types in Mexico and probably have some erodable surface
8369 ! during the dry season
8370 ! * currently modified these values so that only a small fraction of cell
8371 ! area is erodable
8372 ! * these values are highly tuneable!
8374 alphamask=0.001
8375 if (ivgtyp(i,j) .eq. 7) then
8376 f8=0.005
8377 f50=0.00
8378 f51=0.10
8379 f51=0.066
8380 f52=0.00
8381 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
8382 endif
8383 if (ivgtyp(i,j) .eq. 8) then
8384 f8=0.010
8385 f50=0.00
8386 f51=0.00
8387 f52=0.15
8388 f52=0.10
8389 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
8390 endif
8391 if (ivgtyp(i,j) .eq. 10) then
8392 f8=0.00
8393 f50=0.00
8394 f51=0.01
8395 f52=0.00
8396 alphamask=(f8+f50)*1.0+(f51+f52)*0.5
8397 endif
8399 ! part2 - zobler
8400 !
8401 ! * in Shaw's paper, dust is computed for 4 size ranges:
8402 ! 0.5-1 um
8403 ! 1-10 um
8404 ! 10-25 um
8405 ! 25-50 um
8406 ! * Shaw's paper also accounts for sub-grid variability in soil
8407 ! texture, but here we just assume the same soil texture for each
8408 ! grid cell
8409 ! * since MOSAIC is currently has a maximum size range up to 10 um,
8410 ! neglect upper 2 size ranges and lowest size range (assume small)
8411 ! * map WRF soil classes arbitrarily to Zolber soil textural classes
8412 ! * skip dust computations for WRF soil classes greater than 13, i.e.
8413 ! do not compute dust over water, bedrock, and other surfaces
8414 ! * should be skipping for water surface at this point anyway
8415 !
8416 izob=0
8417 if(isltyp(i,j).eq.1) izob=1
8418 if(isltyp(i,j).eq.2) izob=1
8419 if(isltyp(i,j).eq.3) izob=4
8420 if(isltyp(i,j).eq.4) izob=2
8421 if(isltyp(i,j).eq.5) izob=2
8422 if(isltyp(i,j).eq.6) izob=2
8423 if(isltyp(i,j).eq.7) izob=7
8424 if(isltyp(i,j).eq.8) izob=2
8425 if(isltyp(i,j).eq.9) izob=6
8426 if(isltyp(i,j).eq.10) izob=5
8427 if(isltyp(i,j).eq.11) izob=2
8428 if(isltyp(i,j).eq.12) izob=3
8429 if(isltyp(i,j).ge.13) izob=0
8430 if(izob.eq.0) goto 1840
8431 !
8432 ! part3 - dustprod
8433 !
8434 do ii=1,4
8435 delta(ii)=0.0
8436 enddo
8437 sumdelta=0.0
8438 do ii=1,4
8439 delta(ii)=beta(ii,izob)*gamma(ii)
8440 if(ii.lt.4) then
8441 sumdelta=sumdelta+delta(ii)
8442 endif
8443 enddo
8444 do ii=1,4
8445 delta(ii)=delta(ii)/sumdelta
8446 enddo
8448 ! part4 - wetness
8449 !
8450 ! * assume dry for now, have passed in soil moisture to this routine
8451 ! but needs to be included here
8452 ! * wetfactor less than 1 would reduce dustflux
8453 ! * convert model soil moisture (m3/m3) to gravimetric soil moisture
8454 ! (mass of water / mass of soil in %) assuming a constant density
8455 ! for soil
8456 pclay=beta(1,izob)*100.
8457 wp=0.0014*pclay*pclay+0.17*pclay
8458 smois_grav=(smois(i,1,j)/2.6)*100.
8459 if(smois_grav.gt.wp) then
8460 wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68)
8461 else
8462 wetfactor=1.0
8463 endif
8464 ! wetfactor=1.0
8466 ! part5 - dustflux
8467 ! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper
8468 ! bound to 100 cm/s
8470 ustar1=ust(i,j)*100.0
8471 if(ustar1.gt.100.0) ustar1=100.0
8472 ustart0=20.0
8473 ustart=ustart0*wetfactor
8474 if(ustar1.le.ustart) then
8475 dustflux=0.0
8476 else
8477 dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1))
8478 endif
8479 dustflux=dustflux*10.0
8480 ! units kg m-2 s-1
8481 ftot=0.0
8482 do ii=1,2
8483 ftot=ftot+dustflux*alphamask*delta(ii)
8484 enddo
8485 ! convert to ug m-2 s-1
8486 ftot=ftot*1.0e+09
8488 ! apportion other inorganics only
8489 factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j)
8490 factbb = factaa * ftot
8491 fracoin = 1.00
8492 ! fracca = 0.03*0.4
8493 ! fracco3 = 0.03*0.6
8494 fracca = 0.0
8495 fracco3 = 0.0
8496 fractot = fracoin + fracca + fracco3
8497 ! if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot
8498 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + &
8499 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot
8500 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot
8501 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + &
8502 factbb * (sz(7)+sz(8)) * fractot
8503 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot
8504 ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3
8505 densdust=2.5
8506 dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum
8507 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
8508 chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) + &
8509 factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part
8510 !jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part
8511 dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse
8512 mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06
8513 chem(i,k,j,p_corn)=chem(i,k,j,p_corn) + &
8514 factbb * (sz(7)+sz(8)) * fractot / mass1part
8515 !jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part
8517 1840 continue
8519 1820 continue
8520 1830 continue
8522 return
8524 END subroutine sorgam_dust_emiss
8526 !====================================================================================
8527 !add another dust emission scheme following GOCART mechanism --czhao 09/17/2009
8528 !====================================================================================
8529 subroutine sorgam_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, &
8530 v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, &
8531 ivgtyp,isltyp,xland,dx,g, &
8532 ids,ide, jds,jde, kds,kde, &
8533 ims,ime, jms,jme, kms,kme, &
8534 its,ite, jts,jte, kts,kte )
8535 USE module_data_gocart_dust
8536 USE module_configure
8537 USE module_state_description
8538 USE module_model_constants, ONLY: mwdry
8539 USE module_data_mosaic_asect
8540 IMPLICIT NONE
8542 INTEGER, INTENT(IN ) :: ktau, num_soil_layers, &
8543 ids,ide, jds,jde, kds,kde, &
8544 ims,ime, jms,jme, kms,kme, &
8545 its,ite, jts,jte, kts,kte
8546 INTEGER,DIMENSION( ims:ime , jms:jme ) , &
8547 INTENT(IN ) :: &
8548 ivgtyp, &
8549 isltyp
8550 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8551 INTENT(INOUT ) :: chem
8552 REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , &
8553 INTENT(INOUT) :: smois
8554 REAL, DIMENSION( ims:ime , jms:jme, 3 ) , &
8555 INTENT(IN ) :: erod
8556 REAL, DIMENSION( ims:ime , jms:jme ) , &
8557 INTENT(IN ) :: &
8558 u10, &
8559 v10, &
8560 xland
8561 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
8562 INTENT(IN ) :: &
8563 alt, &
8564 dz8w,p8w, &
8565 u_phy,v_phy,rho_phy
8567 REAL, INTENT(IN ) :: dt,dx,g
8568 !
8569 ! local variables
8570 !
8571 integer :: nmx,i,j,k,ndt,imx,jmx,lmx
8572 integer ilwi, start_month
8573 real*8, DIMENSION (3) :: erodin
8574 real*8, DIMENSION (5) :: bems
8575 real*8 w10m,gwet,airden,airmas
8576 real*8 cdustemis,jdustemis,cdustcon,jdustcon
8577 real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp
8578 real*8 dxy
8579 real*8 conver,converi
8580 real dttt
8581 real soilfacj,rhosoilj,rhosoilc
8582 real totalemis,accfrac,corfrac,rscale1,rscale2
8584 accfrac=0.07 ! assign 7% to accumulation mode
8585 corfrac=0.93 ! assign 93% to coarse mode
8586 rscale1=1.00 ! to account for the dust larger than 10um in radius
8587 rscale2=1.02 ! to account for the dust larger than 10um in radius
8588 accfrac=accfrac*rscale1
8589 corfrac=corfrac*rscale2
8591 rhosoilj=2.5e3
8592 rhosoilc=2.6e3
8593 soilfacj=soilfac*rhosoilj/rhosoilc
8595 conver=1.e-9
8596 converi=1.e9
8597 !
8598 ! number of dust bins
8599 nmx=5
8600 k=kts
8601 do j=jts,jte
8602 do i=its,ite
8603 !
8604 ! don't do dust over water!!!
8605 if(xland(i,j).lt.1.5)then
8607 ilwi=1
8608 start_month = 3 ! it doesn't matter, ch_dust is not a month dependent now, a constant
8609 w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
8610 airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! kg
8612 ! we don't trust the u10,v10 values, if model layers are very thin near surface
8613 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))
8614 !erodin(1)=erod(i,j,1)/dx/dx ! czhao erod shouldn't be scaled to the area, because it's a fraction
8615 !erodin(2)=erod(i,j,2)/dx/dx
8616 !erodin(3)=erod(i,j,3)/dx/dx
8617 erodin(1)=erod(i,j,1)
8618 erodin(2)=erod(i,j,2)
8619 erodin(3)=erod(i,j,3)
8620 !
8621 ! volumetric soil moisture over porosity
8622 gwet=smois(i,1,j)/porosity(isltyp(i,j))
8623 ndt=ifix(dt)
8624 airden=rho_phy(i,kts,j)
8625 dxy=dx*dx
8627 call sorgam_source_du( nmx, dt,i,j, &
8628 erodin, ilwi, dxy, w10m, gwet, airden, airmas, &
8629 bems,start_month,g)
8631 !bems: kg/timestep/cell
8632 !sum up the dust emission from 0.1-10 um in radius
8633 ! unit change from kg/timestep/cell to ug/m2/s
8634 totalemis=(sum(bems(1:5))/dt)*converi/dxy
8635 ! to account for the particles larger than 10 um radius
8636 ! based on assumed size distribution
8637 jdustemis = totalemis*accfrac ! accumulation mode
8638 cdustemis = totalemis*corfrac ! coarse mode
8640 cdustcon = sum(bems(1:5))*corfrac/airmas ! kg/kg-dryair
8641 cdustcon = cdustcon * converi ! ug/kg-dryair
8642 jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair
8643 jdustcon = jdustcon * converi ! ug/kg-dryair
8645 chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon
8646 chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon
8648 ! czhao doing dust number emission following pm10
8649 ! use soilfacj for accumulation mode because GOCART assign a less dense dust in
8650 ! accumulation mode
8651 chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj
8652 chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac
8654 endif
8655 enddo
8656 enddo
8658 end subroutine sorgam_dust_gocartemis
8660 SUBROUTINE sorgam_source_du( nmx, dt1,i,j, &
8661 erod, ilwi, dxy, w10m, gwet, airden, airmas, &
8662 bems,month,g0)
8664 ! ****************************************************************************
8665 ! * Evaluate the source of each dust particles size classes (kg/m3)
8666 ! * by soil emission.
8667 ! * Input:
8668 ! * EROD Fraction of erodible grid cell (-)
8669 ! * for 1: Sand, 2: Silt, 3: Clay
8670 ! * DUSTDEN Dust density (kg/m3)
8671 ! * DXY Surface of each grid cell (m2)
8672 ! * AIRVOL Volume occupy by each grid boxes (m3)
8673 ! * NDT1 Time step (s)
8674 ! * W10m Velocity at the anemometer level (10meters) (m/s)
8675 ! * u_tresh Threshold velocity for particule uplifting (m/s)
8676 ! * CH_dust Constant to fudge the total emission of dust (s2/m2)
8677 ! *
8678 ! * Output:
8679 ! * DSRC Source of each dust type (kg/timestep/cell)
8680 ! *
8681 ! * Working:
8682 ! * SRC Potential source (kg/m/timestep/cell)
8683 ! *
8684 ! ****************************************************************************
8686 USE module_data_gocart_dust
8688 INTEGER, INTENT(IN) :: nmx
8689 REAL*8, INTENT(IN) :: erod(ndcls)
8690 INTEGER, INTENT(IN) :: ilwi,month
8692 REAL*8, INTENT(IN) :: w10m, gwet
8693 REAL*8, INTENT(IN) :: dxy
8694 REAL*8, INTENT(IN) :: airden, airmas
8695 REAL*8, INTENT(OUT) :: bems(nmx)
8697 REAL*8 :: den(nmx), diam(nmx)
8698 REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce
8699 REAL, intent(in) :: g0
8700 REAL :: rhoa, g,dt1
8701 INTEGER :: i, j, n, m, k
8703 ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5
8704 !ch_dust(:,:)=0.8D-9 ! ch_dust is defined here instead of in the chemics_ini.F if with SORGAM -czhao
8705 ch_dust(:,:)=1.0D-9 ! default
8706 !ch_dust(:,:)=0.65D-9 ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara
8707 !ch_dust(:,:)=1.0D-9*0.36 ! ch_dust is scaled to sorgam total dust emission
8709 ! executable statemenst
8710 DO n = 1, nmx
8711 ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941)
8712 den(n) = den_dust(n)*1.0D-3
8713 diam(n) = 2.0*reff_dust(n)*1.0D2
8714 g = g0*1.0E2
8715 ! Pointer to the 3 classes considered in the source data files
8716 m = ipoint(n)
8717 tsrc = 0.0
8718 rhoa = airden*1.0D-3
8719 u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* &
8720 SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ &
8721 SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0)
8723 ! Case of surface dry enough to erode
8724 IF (gwet < 0.5) THEN ! Pete's modified value
8725 ! IF (gwet < 0.2) THEN
8726 u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet))))
8727 ELSE
8728 ! Case of wet surface, no erosion
8729 u_ts = 100.0
8730 END IF
8731 srce = frac_s(n)*erod(m)*dxy ! (m2)
8732 IF (ilwi == 1 ) THEN
8733 dsrc = ch_dust(n,month)*srce*w10m**2 &
8734 * (w10m - u_ts)*dt1 ! (kg)
8735 ELSE
8736 dsrc = 0.0
8737 END IF
8738 IF (dsrc < 0.0) dsrc = 0.0
8740 ! Update dust mixing ratio at first model level.
8741 !tc(n) = tc(n) + dsrc / airmas !kg/kg-dryair -czhao
8742 bems(n) = dsrc ! kg/timestep/cell
8744 ENDDO
8746 END SUBROUTINE sorgam_source_du
8748 !===========================================================================
8752 !===========================================================================
8753 !!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F)
8755 ! subroutine wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, &
8756 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
8757 ! qlsink,precr,preci,precs,precg,qsrflx, &
8758 ! gas_aqfrac, numgas_aqfrac, &
8759 ! ids,ide, jds,jde, kds,kde, &
8760 ! ims,ime, jms,jme, kms,kme, &
8761 ! its,ite, jts,jte, kts,kte )
8763 ! wet removal by grid-resolved precipitation
8764 ! scavenging of cloud-phase aerosols and gases by collection, freezing, ...
8765 ! scavenging of interstitial-phase aerosols by impaction
8766 ! scavenging of gas-phase gases by mass transfer and reaction
8768 !----------------------------------------------------------------------
8769 ! USE module_configure
8770 ! USE module_state_description
8771 ! USE module_data_sorgam
8772 ! USE module_mosaic_wetscav,only: wetscav
8774 !----------------------------------------------------------------------
8775 ! IMPLICIT NONE
8777 ! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags
8779 ! INTEGER, INTENT(IN ) :: &
8780 ! ids,ide, jds,jde, kds,kde, &
8781 ! ims,ime, jms,jme, kms,kme, &
8782 ! its,ite, jts,jte, kts,kte, &
8783 ! id, ktau, ktauc, numgas_aqfrac
8784 ! REAL, INTENT(IN ) :: dtstep,dtstepc
8785 !
8786 ! all advected chemical species
8787 !
8788 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
8789 ! INTENT(INOUT ) :: chem
8791 ! fraction of gas species in cloud water
8792 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), &
8793 ! INTENT(IN ) :: gas_aqfrac
8795 !
8796 !
8797 ! input from meteorology
8798 ! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
8799 ! INTENT(IN ) :: &
8800 ! alt, &
8801 ! t_phy, &
8802 ! p_phy, &
8803 ! t8w,p8w, &
8804 ! qlsink,precr,preci,precs,precg, &
8805 ! rho_phy,cldfra
8806 ! REAL, DIMENSION( ims:ime, jms:jme, num_chem ), &
8807 ! INTENT(OUT ) :: qsrflx ! column change due to scavening
8809 ! call wetscav (id,ktau,dtstep,ktauc,config_flags, &
8810 ! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, &
8811 ! qlsink,precr,preci,precs,precg,qsrflx, &
8812 ! gas_aqfrac, numgas_aqfrac, &
8813 ! ntype_aer, nsize_aer, ncomp_aer, &
8814 ! massptr_aer, dens_aer, numptr_aer, &
8815 ! maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, &
8816 ! volumcen_sect, volumlo_sect, volumhi_sect, &
8817 ! waterptr_aer, dens_water_aer, &
8818 ! scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, &
8819 ! ids,ide, jds,jde, kds,kde, &
8820 ! ims,ime, jms,jme, kms,kme, &
8821 ! its,ite, jts,jte, kts,kte )
8823 ! end subroutine wetscav_sorgam_driver
8825 END Module module_aerosols_sorgam