module_aerosols_sorgam.F
References to this file elsewhere.
1
2 MODULE module_aerosols_sorgam
3 !
4 USE module_state_description
5 USE module_data_radm2
6 USE module_data_sorgam
7 USE module_radm
8 !
9 IMPLICIT NONE
10
11 CONTAINS
12 SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, &
13 t8w,alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, &
14 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
15 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,vcsulf_old, &
16 e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, &
17 e_so4i,e_so4j,e_no3i,e_no3j, &
18 vdrog3, &
19 kemit, &
20 ids,ide, jds,jde, kds,kde, &
21 ims,ime, jms,jme, kms,kme, &
22 its,ite, jts,jte, kts,kte )
23
24 INTEGER, INTENT(IN ) :: &
25 ids,ide, jds,jde, kds,kde, &
26 ims,ime, jms,jme, kms,kme, &
27 its,ite, jts,jte, kts,kte, &
28 kemit, &
29 id,ktau
30
31 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
32 INTENT(IN ) :: moist
33
34 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
35 INTENT(INOUT ) :: chem
36 !
37 ! following are aerosol arrays that are not advected
38 !
39 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
40 INTENT(INOUT ) :: &
41 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
42 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
43
44 ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
45 REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), &
46 INTENT(INOUT ) :: &
47 e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_pm10, &
48 e_so4i,e_so4j,e_no3i,e_no3j
49
50 REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog), &
51 INTENT(IN ) :: &
52 VDROG3
53 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
54 INTENT(IN ) :: &
55 t_phy, &
56 alt, &
57 p_phy, &
58 dz8w, &
59 z , &
60 t8w,p8w,z_at_w , &
61 aerwrf , &
62 rho_phy
63 REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , &
64 INTENT(IN ) :: &
65 vcsulf_old
66 REAL, INTENT(IN ) :: &
67 dtstep
68
69 REAL drog_in(ldrog) ! anthropogenic AND
70 ! biogenic organic
71 ! aerosol precursor [ug m**-3 s**-1]
72
73 REAL condvap_in(lspcv) !bs
74 !rs
75 ! condensable vapors [ug m**-3]
76 REAL rgas
77 DATA rgas/8.314510/
78 REAL convfac,convfac2
79 !...BLKSIZE set to one in column model ciarev02
80
81 INTEGER blksize
82 PARAMETER (blksize=1)
83
84 !...number of aerosol species
85 ! number of species (gas + aerosol)
86 INTEGER nspcsda
87 PARAMETER (nspcsda=l1ae) !bs
88 ! (internal aerosol dynamics)
89 !bs # of anth. cond. vapors in SORGAM
90 INTEGER nacv
91 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
92 !bs total # of cond. vapors in SORGAM
93 INTEGER ncv
94 PARAMETER (ncv=lspcv) !bs
95 !bs total # of cond. vapors in CTM
96 REAL cblk(blksize,nspcsda) ! main array of variables
97 ! particles [ug/m^3/s]
98 REAL soilrat_in
99 ! emission rate of soil derived coars
100 ! input HNO3 to CBLK [ug/m^3]
101 REAL nitrate_in
102 ! input NH3 to CBLK [ug/m^3]
103 REAL nh3_in
104 ! input SO4 vapor [ug/m^3]
105 REAL vsulf_in
106
107 REAL so4rat_in
108 ! input SO4 formation[ug/m^3/sec]
109 REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize)
110 ! Emission rate of i-mode EC [ug m**-3 s**-1]
111 REAL eeci_in
112 ! Emission rate of j-mode EC [ug m**-3 s**-1]
113 REAL eecj_in
114 ! Emission rate of j-mode org. aerosol [ug m**-
115 REAL eorgi_in
116
117 REAL eorgj_in
118 ! Emission rate of j-mode org. aerosol [ug m**-
119 ! pressure in cb
120 REAL pres
121 ! temperature in K
122 REAL temp
123 !bs
124 REAL relhum
125 ! rel. humidity (0,1)
126 REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1)
127
128 !...molecular weights ciarev02
129
130 ! molecular weight for SO4
131 REAL mwso4
132 PARAMETER (mwso4=96.0576)
133
134 ! molecular weight for HNO3
135 REAL mwhno3
136 PARAMETER (mwhno3=63.01287)
137
138 ! molecular weight for NH3
139 REAL mwnh3
140 PARAMETER (mwnh3=17.03061)
141
142 !bs molecular weight for Organic Spec
143 ! REAL mworg
144 ! PARAMETER (mworg=175.0)
145
146 !bs molecular weight for Elemental Ca
147 REAL mwec
148 PARAMETER (mwec=12.0)
149
150 !rs molecular weight
151 REAL mwaro1
152 PARAMETER (mwaro1=150.0)
153
154 !rs molecular weight
155 REAL mwaro2
156 PARAMETER (mwaro2=150.0)
157
158 !rs molecular weight
159 REAL mwalk1
160 PARAMETER (mwalk1=140.0)
161
162 !rs molecular weight
163 REAL mwalk2
164 PARAMETER (mwalk2=140.0)
165
166 !rs molecular weight
167 !rs molecular weight
168 REAL mwole1
169 PARAMETER (mwole1=140.0)
170
171 !rs molecular weight
172 REAL mwapi1
173 PARAMETER (mwapi1=200.0)
174
175 !rs molecular weight
176 REAL mwapi2
177 PARAMETER (mwapi2=200.0)
178
179 !rs molecular weight
180 REAL mwlim1
181 PARAMETER (mwlim1=200.0)
182
183 !rs molecular weight
184 REAL mwlim2
185 PARAMETER (mwlim2=200.0)
186
187
188 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
189
190 INTEGER :: i,j,k,kk,l,debug_level
191
192 !
193 ! convert advected aerosol variables to ug/m3 from mixing ratio
194 ! they will be converted back at the end of this driver
195 !
196 do l=p_so4aj,num_chem
197 do j=jts,jte
198 do k=kts,kte
199 kk=min(k,kte-1)
200 do i=its,ite
201 chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)/alt(i,kk,j))
202 enddo
203 enddo
204 enddo
205 enddo
206 do 100 j=jts,jte
207 do 100 i=its,ite
208 debug_level=0
209 do k=kts,kte-1
210 t(k) = t_phy(i,k,j)
211 p(k) = .001*p_phy(i,k,j)
212 rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / &
213 (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
214 (t_phy(i,k,j)-36.))/.01*p_phy(i,k,j)) )
215 rh(k)=max(.1,0.01*rh(k))
216 ! rh(k) = .10
217 enddo
218 do k=kts,kte-1
219 ! if(timer.gt.2.)then
220 ! if((i.eq.12.and.j.eq.17.and.k.eq.1).or. &
221 ! (i.eq.12.and.j.eq.7.and.k.eq.2).or. &
222 ! (i.eq.1.and.j.eq.17.and.k.eq.2))iprt=1
223 ! 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)
224 ! endif
225 cblk=0.
226 do l=1,ldrog
227 drog_in(l)=0.
228 enddo
229 do l=1,lspcv
230 condvap_in(l)=0.
231 enddo
232 convfac = p(k)/rgas/t(k)*1000.
233 so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4
234 soilrat_in = 0.
235 nitrate_in =max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3)
236 nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3)
237 vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4)
238
239 !rs
240 !rs * organic aerosol precursors
241 !rs * anthropogenic organics DeltaROG
242 drog_in(PXYL ) = VDROG3(i,k,j,PXYL )
243 drog_in(PTOL ) = VDROG3(i,k,j,PTOL )
244 drog_in(PCSL1) = VDROG3(i,k,j,PCSL1)
245 drog_in(PCSL2) = VDROG3(i,k,j,PCSL2)
246 drog_in(PHC8 ) = VDROG3(i,k,j,PHC8 )
247 drog_in(POLI1) = VDROG3(i,k,j,POLI1)
248 drog_in(POLI2) = VDROG3(i,k,j,POLI2)
249 drog_in(POLI3) = VDROG3(i,k,j,POLI3)
250 drog_in(POLT1) = VDROG3(i,k,j,POLT1)
251 drog_in(POLT2) = VDROG3(i,k,j,POLT2)
252 drog_in(POLT3) = VDROG3(i,k,j,POLT3)
253 !rs * biogenic organics DeltaROG
254 if(p_ete.eq.1)then
255 drog_in(PAPI1) = 0.
256 drog_in(PAPI2) = 0.
257 drog_in(PAPI3) = 0.
258 drog_in(PLIM1) = 0.
259 drog_in(PLIM2) = 0.
260 drog_in(PLIM3) = 0.
261 condvap_in(PSOAAPI1) = 0.
262 condvap_in(PSOAAPI2) = 0.
263 condvap_in(PSOALIM1) = 0.
264 condvap_in(PSOALIM2) = 0.
265 elseif(p_ete.gt.1)then
266 drog_in(PAPI1) = VDROG3(i,k,j,PAPI1)
267 drog_in(PAPI2) = VDROG3(i,k,j,PAPI2)
268 drog_in(PAPI3) = VDROG3(i,k,j,PAPI3)
269 drog_in(PLIM1) = VDROG3(i,k,j,PLIM1)
270 drog_in(PLIM2) = VDROG3(i,k,j,PLIM2)
271 drog_in(PLIM3) = VDROG3(i,k,j,PLIM3)
272 condvap_in(PSOAAPI1) = max(epsilc,cvapi1(i,k,j))
273 condvap_in(PSOAAPI2) = max(epsilc,cvapi2(i,k,j))
274 condvap_in(PSOALIM1) = max(epsilc,cvlim1(i,k,j))
275 condvap_in(PSOALIM2) = max(epsilc,cvlim2(i,k,j))
276 endif
277 condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j))
278 condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j))
279 condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j))
280 condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j))
281 cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j)
282 cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i)
283 cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j)
284 cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i)
285 cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j)
286 cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i)
287 cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j)
288 cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i)
289 cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j)
290 cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i)
291 cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j)
292 cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i)
293 cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j)
294 cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i)
295 cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j)
296 cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i)
297 cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj)
298 cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai)
299 cblk(1,VECJ ) = chem(i,k,j,p_ecj)
300 cblk(1,VECI ) = chem(i,k,j,p_eci)
301 cblk(1,VP25AJ ) = chem(i,k,j,p_p25j)
302 cblk(1,VP25AI ) = chem(i,k,j,p_p25i)
303 cblk(1,VANTHA ) = chem(i,k,j,p_antha)
304 cblk(1,VSEAS ) = chem(i,k,j,p_seas)
305 cblk(1,VSOILA ) = chem(i,k,j,p_soila)
306 cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j))
307 cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j))
308 cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j))
309 cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j))
310 cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j))
311 cblk(1,VCVARO1 ) = max(epsilc,cvaro1(i,k,j))
312 cblk(1,VCVARO2 ) = max(epsilc,cvaro2(i,k,j))
313 cblk(1,VCVALK1 ) = max(epsilc,cvalk1(i,k,j))
314 cblk(1,VCVOLE1 ) = max(epsilc,cvole1(i,k,j))
315 cblk(1,VCVAPI1 ) = 0.
316 cblk(1,VCVAPI2 ) = 0.
317 cblk(1,VCVLIM1 ) = 0.
318 cblk(1,VCVLIM2 ) = 0.
319 !
320 ! Set emissions to zero when above level kemit.
321 !
322 if( k > kemit ) then
323 epmcoarse(1) = 0.
324 epm25i(1) = 0.
325 epm25j (1) = 0.
326 eeci_in = 0.
327 eecj_in = 0.
328 eorgi_in = 0.
329 eorgj_in = 0.
330 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)
331 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)
332 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)
333 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)
334 else
335 epmcoarse(1) = e_pm10(i,k,j)/dz8w(i,k,j)
336 epm25i(1) = e_pm25i(i,k,j)/dz8w(i,k,j)
337 epm25j(1) = e_pm25j(i,k,j)/dz8w(i,k,j)
338 eeci_in = e_eci(i,k,j)/dz8w(i,k,j)
339 eecj_in = e_ecj(i,k,j)/dz8w(i,k,j)
340 eorgi_in = e_orgi(i,k,j)/dz8w(i,k,j)
341 eorgj_in = e_orgj(i,k,j)/dz8w(i,k,j)
342 cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj)+e_so4j(i,k,j)/dz8w(i,k,j)*dtstep
343 cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai)+e_so4i(i,k,j)/dz8w(i,k,j)*dtstep
344 cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj)+e_no3j(i,k,j)/dz8w(i,k,j)*dtstep
345 cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai)+e_no3i(i,k,j)/dz8w(i,k,j)*dtstep
346 end if
347 !rs. nitrate, nh3, sulf
348 cblk(1,vsulf) = vsulf_in
349 cblk(1,vhno3) = nitrate_in
350 cblk(1,vnh3) = nh3_in
351 cblk(1,VNH4AJ ) = chem(i,k,j,p_nh4aj)
352 cblk(1,VNH4AI ) = chem(i,k,j,p_nh4ai)
353 cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0))
354 cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0))
355 cblk(1,VCORN ) = chem(i,k,j,p_corn)
356
357
358 ! if(debug_level.ge.1)then
359 ! print*,'in a_mechanisms',i,j,k
360 ! print*,'NSPCSDA, BLKSIZE',NSPCSDA, BLKSIZE
361 ! print*,'k,DTA,PRES,TEMP,RELHUM',k,DTstep,10.*P(k),T(k),RH(k)
362 ! print*,'nitrate_in, nh3_in, vsulf_in, so4rat_in', &
363 ! nitrate_in, nh3_in, vsulf_in, so4rat_in
364 ! print*,'drog_in,ldrog',drog_in,ldrog
365 ! print*,'condvap_in,NCV,NACV',condvap_in,NCV,NACV
366 ! print*,'eeci_in, eecj_in, eorgi_in, eorgj_in,convfac' &
367 ! ,eeci_in, eecj_in, eorgi_in, eorgj_in,convfac
368 ! print*,'CBLK',CBLK
369 ! endif
370 CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh(k),nitrate_in,nh3_in, &
371 vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv,nacv,eeci_in,eecj_in, &
372 eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k)
373 chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ )
374 chem(i,k,j,p_so4ai) = cblk(1,VSO4AI )
375 chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ )
376 chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI )
377 chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ )
378 chem(i,k,j,p_no3ai) = cblk(1,VNO3AI )
379 chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J)
380 chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I)
381 chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J)
382 chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I)
383 chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J)
384 chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I)
385 chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J)
386 chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I)
387 chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J )
388 chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I )
389 chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J )
390 chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I )
391 chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J )
392 chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I )
393 chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J )
394 chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I )
395 chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ )
396 chem(i,k,j,p_orgpai) = cblk(1,VORGPAI )
397 chem(i,k,j,p_ecj) = cblk(1,VECJ )
398 chem(i,k,j,p_eci) = cblk(1,VECI )
399 chem(i,k,j,p_p25j) = cblk(1,VP25AJ )
400 chem(i,k,j,p_p25i) = cblk(1,VP25AI )
401 chem(i,k,j,p_antha) =cblk(1,VANTHA )
402 chem(i,k,j,p_seas) = cblk(1,VSEAS )
403 chem(i,k,j,p_soila) = cblk(1,VSOILA )
404 chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 ))
405 chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 ))
406 ! chem(i,k,j,p_ac0) = cblk(1,VAC0 )
407 chem(i,k,j,p_corn) = cblk(1,VCORN )
408 h2oaj(i,k,j) = cblk(1,VH2OAJ )
409 h2oai(i,k,j) = cblk(1,VH2OAI )
410 nu3(i,k,j) = cblk(1,VNU3 )
411 ac3(i,k,j) = cblk(1,VAC3 )
412 cor3(i,k,j) = cblk(1,VCOR3 )
413 cvaro1(i,k,j) = cblk(1,VCVARO1 )
414 cvaro2(i,k,j) = cblk(1,VCVARO2 )
415 cvalk1(i,k,j) = cblk(1,VCVALK1 )
416 cvole1(i,k,j) = cblk(1,VCVOLE1 )
417 cvapi1(i,k,j) = 0.
418 cvapi2(i,k,j) = 0.
419 cvlim1(i,k,j) = 0.
420 cvlim2(i,k,j) = 0.
421 chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4)
422 chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3)
423 chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3)
424 enddo ! k-loop
425 100 continue ! i,j-loop
426
427 !
428 ! convert aerosol variables back to mixing ratio from ug/m3
429 !
430 do l=p_so4aj,num_chem
431 do j=jts,jte
432 do k=kts,kte
433 kk=min(k,kte-1)
434 do i=its,ite
435 chem(i,k,j,l)=max(epsilc,chem(i,kk,j,l)*alt(i,kk,j))
436 enddo
437 enddo
438 enddo
439 enddo
440
441 END SUBROUTINE sorgam_driver
442 ! ///////////////////////////////////////////////////
443 SUBROUTINE sum_pm_sorgam ( &
444 alt, chem, h2oaj, h2oai, &
445 pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, &
446 ids,ide, jds,jde, kds,kde, &
447 ims,ime, jms,jme, kms,kme, &
448 its,ite, jts,jte, kts,kte )
449
450 INTEGER, INTENT(IN ) :: &
451 ids,ide, jds,jde, kds,kde, &
452 ims,ime, jms,jme, kms,kme, &
453 its,ite, jts,jte, kts,kte
454
455 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
456 INTENT(IN ) :: chem
457
458 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
459 INTENT(IN ) :: alt,h2oaj,h2oai
460
461 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
462 INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10
463
464 INTEGER :: i,ii,j,jj,k,kk,n
465 !
466 ! sum up pm2_5 and pm10 output
467 !
468 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
469 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
470 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
471 do j=jts,jte
472 jj=min(jde-1,j)
473 do k=kts,kte-1
474 kk=min(kde-1,k)
475 do i=its,ite
476 ii=min(ide-1,i)
477 do n=p_so4aj,p_p25i
478 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,kk,jj,n)
479 enddo
480 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,kk,jj,p_ecj) &
481 + chem(ii,kk,jj,p_eci)
482 pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) &
483 + h2oai(i,k,j)
484
485 !Convert the units from mixing ratio to concentration (ug m^-3)
486 pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,kk,jj)
487 pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,kk,jj)
488 pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,kk,jj)
489 enddo
490 enddo
491 enddo
492 do j=jts,jte
493 jj=min(jde-1,j)
494 do k=kts,kte-1
495 kk=min(kde-1,k)
496 do i=its,ite
497 ii=min(ide-1,i)
498 pm10(i,k,j) = pm2_5_dry(i,k,j) &
499 + ( chem(ii,kk,jj,p_antha) &
500 + chem(ii,kk,jj,p_soila) &
501 + chem(ii,kk,jj,p_seas) ) / alt(ii,kk,jj)
502 enddo
503 enddo
504 enddo
505 END SUBROUTINE sum_pm_sorgam
506 ! ///////////////////////////////////////////////////
507 SUBROUTINE sorgam_depdriver (id,ktau,dtstep, &
508 ust,t_phy,moist,p8w,t8w, &
509 alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, &
510 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
511 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, &
512 aer_res,vgsa, &
513 numaer, &
514 ids,ide, jds,jde, kds,kde, &
515 ims,ime, jms,jme, kms,kme, &
516 its,ite, jts,jte, kts,kte )
517 INTEGER, INTENT(IN ) :: &
518 numaer, &
519 ids,ide, jds,jde, kds,kde, &
520 ims,ime, jms,jme, kms,kme, &
521 its,ite, jts,jte, kts,kte, &
522 id,ktau
523
524 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), &
525 INTENT(IN ) :: moist
526 REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), &
527 INTENT(INOUT ) :: chem
528 !
529 ! following are aerosol arrays that are not advected
530 !
531 REAL, DIMENSION( its:ite, jts:jte, numaer ), &
532 INTENT(INOUT ) :: &
533 vgsa
534 REAL, DIMENSION( its:ite, jts:jte ), &
535 INTENT(INOUT ) :: &
536 aer_res
537 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
538 INTENT(INOUT ) :: &
539 h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, &
540 cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2
541 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
542 INTENT(IN ) :: &
543 t_phy, &
544 alt, &
545 p_phy, &
546 dz8w, &
547 z , &
548 t8w,p8w,z_at_w , &
549 rho_phy
550 REAL, DIMENSION( ims:ime , jms:jme ) , &
551 INTENT(IN ) :: &
552 ust
553 REAL, INTENT(IN ) :: &
554 dtstep
555
556 REAL rgas
557 DATA rgas/8.314510/
558 REAL convfac,convfac2
559 !...BLKSIZE set to one in column model ciarev02
560
561 INTEGER blksize
562 PARAMETER (blksize=1)
563
564 !...number of aerosol species
565 ! number of species (gas + aerosol)
566 INTEGER nspcsda
567 PARAMETER (nspcsda=l1ae) !bs
568 ! (internal aerosol dynamics)
569 !bs # of anth. cond. vapors in SORGAM
570 INTEGER nacv
571 PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM
572 !bs total # of cond. vapors in SORGAM
573 INTEGER ncv
574 PARAMETER (ncv=lspcv) !bs
575 !bs total # of cond. vapors in CTM
576 REAL cblk(blksize,nspcsda) ! main array of variables
577 ! particles [ug/m^3/s]
578 REAL soilrat_in
579 ! emission rate of soil derived coars
580 ! input HNO3 to CBLK [ug/m^3]
581 REAL nitrate_in
582 ! input NH3 to CBLK [ug/m^3]
583 REAL nh3_in
584 ! input SO4 vapor [ug/m^3]
585 REAL vsulf_in
586
587 REAL so4rat_in
588 ! input SO4 formation[ug/m^3/sec]
589 ! pressure in cb
590 REAL pres
591 ! temperature in K
592 REAL temp
593 !bs
594 REAL relhum
595 ! rel. humidity (0,1)
596 REAL ::p(kts:kte-1),t(kts:kte-1),rh(kts:kte-1)
597
598 !...molecular weights ciarev02
599
600 ! molecular weight for SO4
601 REAL mwso4
602 PARAMETER (mwso4=96.0576)
603
604 ! molecular weight for HNO3
605 REAL mwhno3
606 PARAMETER (mwhno3=63.01287)
607
608 ! molecular weight for NH3
609 REAL mwnh3
610 PARAMETER (mwnh3=17.03061)
611
612 !bs molecular weight for Organic Spec
613 ! REAL mworg
614 ! PARAMETER (mworg=175.0)
615
616 !bs molecular weight for Elemental Ca
617 REAL mwec
618 PARAMETER (mwec=12.0)
619
620 !rs molecular weight
621 REAL mwaro1
622 PARAMETER (mwaro1=150.0)
623
624 !rs molecular weight
625 REAL mwaro2
626 PARAMETER (mwaro2=150.0)
627
628 !rs molecular weight
629 REAL mwalk1
630 PARAMETER (mwalk1=140.0)
631
632 !rs molecular weight
633 REAL mwalk2
634 PARAMETER (mwalk2=140.0)
635
636 !rs molecular weight
637 !rs molecular weight
638 REAL mwole1
639 PARAMETER (mwole1=140.0)
640
641 !rs molecular weight
642 REAL mwapi1
643 PARAMETER (mwapi1=200.0)
644
645 !rs molecular weight
646 REAL mwapi2
647 PARAMETER (mwapi2=200.0)
648
649 !rs molecular weight
650 REAL mwlim1
651 PARAMETER (mwlim1=200.0)
652
653 !rs molecular weight
654 REAL mwlim2
655 PARAMETER (mwlim2=200.0)
656 INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model)
657 !ia kept to 1 in current version of column model
658
659 PARAMETER( NUMCELLS = 1)
660
661
662 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
663 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
664 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
665
666 REAL BLKPRS(BLKSIZE) ! pressure in cb
667 REAL BLKTA(BLKSIZE) ! temperature in K
668 REAL BLKDENS(BLKSIZE) ! Air density in kg/m3
669
670 !
671 ! *** OUTPUT:
672 !
673 ! *** atmospheric properties
674
675 REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ]
676 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ]
677
678 ! *** followng is for future version
679 REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ]
680 REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ]
681
682 ! *** modal diameters: [ m ]
683
684 REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ]
685 REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ]
686 REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ]
687
688
689 ! *** aerosol properties:
690
691 ! *** Modal mass concentrations [ ug m**3 ]
692
693 REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode
694 REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode
695 REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode
696
697 ! *** average modal particle densities [ kg/m**3 ]
698
699 REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode
700 REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode
701 REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode
702
703 ! *** average modal Knudsen numbers
704
705 REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number
706 REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number
707 REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number
708
709
710 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
711
712 INTEGER :: i,j,k,l
713 !
714 ! print *,'in sorgdepdriver ',its,ite,jts,jte
715 do l=1,numaer
716 do i=its,ite
717 do j=jts,jte
718 vgsa(i,j,l)=0.
719 enddo
720 enddo
721 enddo
722 vdep=0.
723 do 100 j=jts,jte
724 do 100 i=its,ite
725 cblk=epsilc
726 do k=kts,kte-1
727 t(k) = t_phy(i,k,j)
728 p(k) = .001*p_phy(i,k,j)
729 rh(k) = MIN( 100.,100. * moist(i,k,j,p_qv) / &
730 (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
731 (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))))
732 rh(k)=max(.05,0.01*rh(k))
733 enddo
734 ! do k=kts,kte-1
735 k=kts
736 convfac = p(k)/rgas/t(k)*1000.
737 nitrate_in =chem(i,k,j,p_hno3)*convfac*mwhno3
738 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3
739 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4
740
741 !rs. nitrate, nh3, sulf
742 BLKPRS(BLKSIZE) = P(K) ! pressure in hPa
743 BLKTA(BLKSIZE) = T(K) ! temperature in K
744 BLKDENS(BLKSIZE)=BLKPRS(BLKSIZE)/(RDGAS * BLKTA(BLKSIZE))
745 USTAR(BLKSIZE) = max(1.e-8,UST(i,j))
746 WSTAR(BLKSIZE) = 0.
747 convfac2=1./alt(i,k,j)
748 cblk(1,vsulf) = max(epsilc,vsulf_in)
749 cblk(1,vhno3) = max(epsilc,nitrate_in)
750 cblk(1,vnh3) = max(epsilc,nh3_in)
751 cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2)
752 cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2)
753 cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2)
754 cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2)
755 cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2)
756 cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2)
757 cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2)
758 cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2)
759 cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2)
760 cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2)
761 cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2)
762 cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2)
763 cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2)
764 cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2)
765 cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2)
766 cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2)
767 cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2)
768 cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2)
769 cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2)
770 cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2)
771 cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2)
772 cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2)
773 cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2)
774 cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2)
775 cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2)
776 cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2)
777 cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2)
778 cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2)
779 cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2)
780 cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2)
781 cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2)
782 cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2)
783 cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2)
784 cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2)
785 cblk(1,VH2OAJ ) = h2oaj(i,k,j)
786 cblk(1,VH2OAI ) = h2oai(i,k,j)
787 cblk(1,VNU3 ) = nu3(i,k,j)
788 cblk(1,VAC3 ) = ac3(i,k,j)
789 cblk(1,VCOR3 ) = cor3(i,k,j)
790 cblk(1,VCVARO1 ) = cvaro1(i,k,j)
791 cblk(1,VCVARO2 ) = cvaro2(i,k,j)
792 cblk(1,VCVALK1 ) = cvalk1(i,k,j)
793 cblk(1,VCVOLE1 ) = cvole1(i,k,j)
794 cblk(1,VCVAPI1 ) = 0.
795 cblk(1,VCVAPI2 ) = 0.
796 cblk(1,VCVLIM1 ) = 0.
797 cblk(1,VCVLIM2 ) = 0.
798 ! cblk(1,VCVAPI1 ) = cvapi1(i,k,j)
799 ! cblk(1,VCVAPI2 ) = cvapi2(i,k,j)
800 ! cblk(1,VCVLIM1 ) = cvlim1(i,k,j)
801 ! cblk(1,VCVLIM2 ) = cvlim2(i,k,j)
802 !
803 !rs. get size distribution information
804 !
805 ! if(i.eq.126.and.j.eq.99)then
806 ! print *,'in modpar ',i,j
807 ! print *,cblk,BLKTA,BLKPRS,USTAR
808 ! print *,'BLKSIZE, NSPCSDA, NUMCELLS'
809 ! print *,BLKSIZE, NSPCSDA, NUMCELLS
810 ! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC'
811 ! print *,XLM, AMU,PDENSN, PDENSA, PDENSC
812 ! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai
813 ! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)
814 ! endif
815
816 CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, &
817 CBLK, &
818 BLKTA, BLKPRS, &
819 PMASSN, PMASSA, PMASSC, &
820 PDENSN, PDENSA, PDENSC, &
821 XLM, AMU, &
822 DGNUC, DGACC, DGCOR, &
823 KNNUC, KNACC,KNCOR )
824 ! print *,'out modpar ',i,j
825 CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, &
826 BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, &
827 DGNUC, DGACC, DGCOR, &
828 KNNUC, KNACC,KNCOR, &
829 PDENSN, PDENSA, PDENSC, &
830 VSED, VDEP )
831 VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC )
832 VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC )
833 VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ )
834 VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI )
835 VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ )
836 VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI )
837 VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ )
838 VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI )
839 VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ )
840 VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI )
841 VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ )
842 VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI )
843 VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ )
844 VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI )
845 VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ )
846 VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI )
847 VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ )
848 VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI )
849 VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ )
850 VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI )
851 VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ )
852 VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI )
853 VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ )
854 VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI )
855 VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ )
856 VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI )
857 VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ )
858 VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI )
859 VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR )
860 VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA )
861 VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA )
862 VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC )
863 VGSA(i, j, VAC0 ) = VDEP(1, VDNACC )
864 VGSA(i, j, VCORN ) = VDEP(1, VDNCOR )
865 ! enddo ! k-loop
866 100 continue ! i,j-loop
867
868 END SUBROUTINE sorgam_depdriver
869 ! ///////////////////////////////////////////////////
870 SUBROUTINE actcof(cat,an,gama,molnu,phimult)
871
872 !-----------------------------------------------------------------------
873
874 ! DESCRIPTION:
875
876 ! This subroutine computes the activity coefficients of (2NH4+,SO4--),
877 ! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous
878 ! multicomponent solution, using Bromley's model and Pitzer's method.
879
880 ! REFERENCES:
881
882 ! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes
883 ! in aqueous solutions. AIChE J. 19, 313-320.
884
885 ! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of
886 ! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673.
887
888 ! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures
889 ! of strong acids over saline solutions - I HNO3,
890 ! Atmos. Environ. (22): 91-100
891
892 ! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures
893 ! and mean activity and osmotic coefficients of 0-100% nitric acid
894 ! as a function of temperature, J. Phys. Chem (94): 5369 - 5380
895
896 ! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a
897 ! general equilibrium model for inorganic multicomponent atmospheric
898 ! aerosols. Atmos. Environ. 21(11), 2453-2466.
899
900
901
902
903 ! ARGUMENT DESCRIPTION:
904
905 ! CAT(1) : conc. of H+ (moles/kg)
906 ! CAT(2) : conc. of NH4+ (moles/kg)
907 ! AN(1) : conc. of SO4-- (moles/kg)
908 ! AN(2) : conc. of NO3- (moles/kg)
909 ! AN(3) : conc. of HSO4- (moles/kg)
910 ! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--)
911 ! GAMA(2,2) : (NH4+,NO3-)
912 ! GAMA(2,3) : (NH4+. HSO4-)
913 ! GAMA(1,1) : (2H+,SO4--)
914 ! GAMA(1,2) : (H+,NO3-)
915 ! GAMA(1,3) : (H+,HSO4-)
916 ! MOLNU : the total number of moles of all ions.
917 ! PHIMULT : the multicomponent paractical osmotic coefficient.
918
919 ! REVISION HISTORY:
920 ! Who When Detailed description of changes
921 ! --------- -------- -------------------------------------------
922 ! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this
923 ! new routine using a method described by Pilini
924 ! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24
925 ! S.Roselle 7/30/97 Modified for use in Models-3
926 ! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA
927
928 !-----------------------------------------------------------------------
929
930 ! IMPLICIT NONE
931
932 !...........INCLUDES and their descriptions
933
934 ! INCLUDE SUBST_XSTAT ! M3EXIT status codes
935 !....................................................................
936
937 ! Normal, successful completion
938 INTEGER xstat0
939 PARAMETER (xstat0=0)
940 ! File I/O error
941 INTEGER xstat1
942 PARAMETER (xstat1=1)
943 ! Execution error
944 INTEGER xstat2
945 PARAMETER (xstat2=2)
946 ! Special error
947 INTEGER xstat3
948 PARAMETER (xstat3=3)
949
950 CHARACTER*120 xmsg
951
952 !...........PARAMETERS and their descriptions:
953
954 ! number of cations
955 INTEGER ncat
956 PARAMETER (ncat=2)
957
958 ! number of anions
959 INTEGER nan
960 PARAMETER (nan=3)
961
962 !...........ARGUMENTS and their descriptions
963
964 ! tot # moles of all ions
965 REAL molnu
966 ! multicomponent paractical osmo
967 REAL phimult
968 REAL cat(ncat) ! cation conc in moles/kg (input
969 REAL an(nan) ! anion conc in moles/kg (input)
970 REAL gama(ncat,nan)
971 !...........SCRATCH LOCAL VARIABLES and their descriptions:
972
973 ! mean molal ionic activity coef
974 CHARACTER*16 & ! driver program name
975 pname
976 SAVE pname
977
978 ! anion indX
979 INTEGER ian
980
981 INTEGER icat
982 ! cation indX
983
984 REAL fgama
985 ! ionic strength
986 REAL i
987
988 REAL r
989
990 REAL s
991
992 REAL ta
993
994 REAL tb
995
996 REAL tc
997
998 REAL texpv
999
1000 REAL trm
1001 ! 2*ionic strength
1002 REAL twoi
1003 ! 2*sqrt of ionic strength
1004 REAL twosri
1005
1006 REAL zbar
1007
1008 REAL zbar2
1009
1010 REAL zot1
1011 ! square root of ionic strength
1012 REAL sri
1013 REAL f2(ncat)
1014 REAL f1(nan)
1015 REAL zp(ncat) ! absolute value of charges of c
1016 REAL zm(nan) ! absolute value of charges of a
1017 REAL bgama(ncat,nan)
1018 REAL x(ncat,nan)
1019 REAL m(ncat,nan) ! molality of each electrolyte
1020 REAL lgama0(ncat,nan) ! binary activity coefficients
1021 REAL y(nan,ncat)
1022 REAL beta0(ncat,nan) ! binary activity coefficient pa
1023 REAL beta1(ncat,nan) ! binary activity coefficient pa
1024 REAL cgama(ncat,nan) ! binary activity coefficient pa
1025 REAL v1(ncat,nan) ! number of cations in electroly
1026 REAL v2(ncat,nan)
1027 ! number of anions in electrolyt
1028 DATA zp/1.0, 1.0/
1029 DATA zm/2.0, 1.0, 1.0/
1030 DATA xmsg/' '/
1031 DATA pname/'ACTCOF'/
1032
1033 ! *** Sources for the coefficients BETA0, BETA1, CGAMA:
1034
1035 ! *** (1,1);(1,3) - Clegg & Brimblecombe (1988)
1036 ! *** (2,3) - Pilinis & Seinfeld (1987), cgama different
1037 ! *** (1,2) - Clegg & Brimblecombe (1990)
1038 ! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992)
1039
1040 ! *** now set the basic constants, BETA0, BETA1, CGAMA
1041
1042 DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 &
1043 /
1044 ! 2H+SO4
1045 DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 &
1046 /
1047 ! HNO3
1048 DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 &
1049 /
1050 ! H+HSO4
1051 DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/, &
1052 cgama(2,1)/ -1.2683E-3 &
1053 /
1054 ! (NH4)2
1055 DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/, &
1056 cgama(2,2)/3.51217E-5 &
1057 /
1058 ! NH4NO3
1059 DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 &
1060 /
1061 ! NH4HSO
1062 DATA v1(1,1), v2(1,1)/2.0, 1.0 & ! 2H+SO4-
1063 /
1064 DATA v1(2,1), v2(2,1)/2.0, 1.0 & ! (NH4)2SO4
1065 /
1066 DATA v1(1,2), v2(1,2)/1.0, 1.0 & ! HNO3
1067 /
1068 DATA v1(2,2), v2(2,2)/1.0, 1.0 & ! NH4NO3
1069 /
1070 DATA v1(1,3), v2(1,3)/1.0, 1.0 & ! H+HSO4-
1071 /
1072 DATA v1(2,3), v2(2,3)/1.0, 1.0 &
1073 /
1074 !-----------------------------------------------------------------------
1075 ! begin body of subroutine ACTCOF
1076
1077 !...compute ionic strength
1078
1079 ! NH4HSO4
1080 i = 0.0
1081
1082 DO icat = 1, ncat
1083 i = i + cat(icat)*zp(icat)*zp(icat)
1084 END DO
1085
1086 DO ian = 1, nan
1087 i = i + an(ian)*zm(ian)*zm(ian)
1088 END DO
1089
1090 i = 0.5*i
1091
1092 !...check for problems in the ionic strength
1093
1094 IF (i==0.0) THEN
1095
1096 DO ian = 1, nan
1097 DO icat = 1, ncat
1098 gama(icat,ian) = 0.0
1099 END DO
1100 END DO
1101
1102 ! xmsg = 'Ionic strength is zero...returning zero activities'
1103 ! WRITE (6,*) xmsg
1104 RETURN
1105
1106 ELSE IF (i<0.0) THEN
1107 ! xmsg = 'Ionic strength below zero...negative concentrations'
1108 CALL wrf_error_fatal ( xmsg )
1109 END IF
1110
1111 !...compute some essential expressions
1112
1113 sri = sqrt(i)
1114 twosri = 2.0*sri
1115 twoi = 2.0*i
1116 texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi)
1117 r = 1.0 + 0.75*i
1118 s = 1.0 + 1.5*i
1119 zot1 = 0.511*sri/(1.0+sri)
1120
1121 !...Compute binary activity coeffs
1122
1123 fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri)))
1124
1125 DO icat = 1, ncat
1126 DO ian = 1, nan
1127
1128 bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) &
1129 )*texpv
1130
1131 !...compute the molality of each electrolyte for given ionic strength
1132
1133 m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** &
1134 (1.0/(v1(icat,ian)+v2(icat,ian)))
1135
1136 !...calculate the binary activity coefficients
1137
1138 lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, &
1139 ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, &
1140 ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* &
1141 v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, &
1142 ian)))/2.302585093
1143
1144 END DO
1145 END DO
1146
1147 !...prepare variables for computing the multicomponent activity coeffs
1148
1149 DO ian = 1, nan
1150 DO icat = 1, ncat
1151 zbar = (zp(icat)+zm(ian))*0.5
1152 zbar2 = zbar*zbar
1153 y(ian,icat) = zbar2*an(ian)/i
1154 x(icat,ian) = zbar2*cat(icat)/i
1155 END DO
1156 END DO
1157
1158 DO ian = 1, nan
1159 f1(ian) = 0.0
1160 DO icat = 1, ncat
1161 f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + &
1162 zot1*zp(icat)*zm(ian)*x(icat,ian)
1163 END DO
1164 END DO
1165
1166 DO icat = 1, ncat
1167 f2(icat) = 0.0
1168 DO ian = 1, nan
1169 f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + &
1170 zot1*zp(icat)*zm(ian)*y(ian,icat)
1171 END DO
1172 END DO
1173
1174 !...now calculate the multicomponent activity coefficients
1175
1176 DO ian = 1, nan
1177 DO icat = 1, ncat
1178
1179 ta = -zot1*zp(icat)*zm(ian)
1180 tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
1181 tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian))
1182 trm = ta + tb*tc
1183
1184 IF (trm>30.0) THEN
1185 gama(icat,ian) = 1.0E+30
1186 ! xmsg = 'Multicomponent activity coefficient is extremely large'
1187 ! WRITE (6,*) xmsg
1188 ELSE
1189 gama(icat,ian) = 10.0**trm
1190 END IF
1191
1192 END DO
1193 END DO
1194
1195 RETURN
1196 !ia*********************************************************************
1197 END SUBROUTINE actcof
1198 !ia
1199 !ia AEROSOL DYNAMICS DRIVER ROUTINE *
1200 !ia based on MODELS3 formulation by FZB
1201 !ia Modified by IA in November 97
1202 !ia
1203 !ia Revision history
1204 !ia When WHO WHAT
1205 !ia ---- ---- ----
1206 !ia ???? FZB BEGIN
1207 !ia 05/97 IA Adapted for use in CTM2-S
1208 !ia 11/97 IA Modified for new model version
1209 !ia see comments under iarev02
1210 !ia
1211 !ia Called BY: RPMMOD3
1212 !ia
1213 !ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP
1214 !ia GETVSED
1215 !ia
1216 !ia*********************************************************************
1217 ! actcof
1218 SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, &
1219 blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat, &
1220 orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,epm25i, &
1221 epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, &
1222 dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, &
1223 kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, &
1224 ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid)
1225
1226
1227
1228
1229 ! IMPLICIT NONE
1230 ! dimension of arrays
1231 INTEGER blksize
1232 ! number of species in CBLK
1233 INTEGER nspcsda
1234 ! actual number of cells in arrays
1235 INTEGER numcells
1236 ! number of k-level
1237 INTEGER layer
1238 ! of organic aerosol precursor
1239 INTEGER ldrog
1240 REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a
1241
1242 REAL dt
1243 ! *** Meteorological information:
1244
1245 ! synchronization time [s]
1246 REAL blkta(blksize) ! Air temperature [ K ]
1247 REAL blkprs(blksize) ! Air pressure in [ Pa ]
1248 REAL blkdens(blksize) ! Air density [ kg/ m**3 ]
1249 REAL blkrh(blksize)
1250 ! *** Chemical production rates: [ ug / m**3 s ]
1251
1252 ! Fractional relative humidity
1253 REAL so4rat(blksize)
1254 !bs
1255 ! sulfate gas-phase production rate
1256 ! total # of cond. vapors & SOA species
1257 INTEGER ncv
1258 !bs
1259 INTEGER nacv
1260 !bs * organic condensable vapor production rate
1261 ! # of anthrop. cond. vapors & SOA speci
1262 REAL drog(blksize,ldrog) !bs
1263 ! *** anthropogenic organic aerosol mass production rates from aromatics
1264 ! Delta ROG conc. [ppm]
1265 REAL orgaro1rat(blksize)
1266
1267 ! *** anthropogenic organic aerosol mass production rates from aromatics
1268 REAL orgaro2rat(blksize)
1269
1270 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1271 REAL orgalk1rat(blksize)
1272
1273 ! *** anthropogenic organic aerosol mass production rates from alkenes &
1274 REAL orgole1rat(blksize)
1275
1276 ! *** biogenic organic aerosol production rates
1277 REAL orgbio1rat(blksize)
1278
1279 ! *** biogenic organic aerosol production rates
1280 REAL orgbio2rat(blksize)
1281
1282 ! *** biogenic organic aerosol production rates
1283 REAL orgbio3rat(blksize)
1284
1285 ! *** biogenic organic aerosol production rates
1286 REAL orgbio4rat(blksize)
1287
1288 ! *** Primary emissions rates: [ ug / m**3 s ]
1289
1290 ! *** emissions rates for unidentified PM2.5 mass
1291 REAL epm25i(blksize) ! Aitken mode
1292 REAL epm25j(blksize)
1293 ! *** emissions rates for primary organic aerosol
1294 ! Accumululaton mode
1295 REAL eorgi(blksize) ! Aitken mode
1296 REAL eorgj(blksize)
1297 ! *** emissions rates for elemental carbon
1298 ! Accumululaton mode
1299 REAL eeci(blksize) ! Aitken mode
1300 REAL eecj(blksize)
1301 ! *** emissions rates for coarse mode particles
1302 ! Accumululaton mode
1303 REAL esoil(blksize) ! soil derived coarse aerosols
1304 REAL eseas(blksize) ! marine coarse aerosols
1305 REAL epmcoarse(blksize)
1306
1307 ! *** OUTPUT:
1308
1309 ! *** atmospheric properties
1310
1311 ! anthropogenic coarse aerosols
1312 REAL xlm(blksize) ! atmospheric mean free path [ m ]
1313 REAL amu(blksize)
1314 ! *** modal diameters: [ m ]
1315
1316 ! atmospheric dynamic viscosity [ kg
1317 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
1318 REAL dgacc(blksize) ! accumulation geometric mean diamet
1319 REAL dgcor(blksize)
1320
1321 ! *** aerosol properties:
1322
1323 ! *** Modal mass concentrations [ ug m**3 ]
1324
1325 ! coarse mode geometric mean diamete
1326 REAL pmassn(blksize) ! mass concentration in Aitken mode
1327 REAL pmassa(blksize) ! mass concentration in accumulation
1328 REAL pmassc(blksize)
1329 ! *** average modal particle densities [ kg/m**3 ]
1330
1331 ! mass concentration in coarse mode
1332 REAL pdensn(blksize) ! average particle density in nuclei
1333 REAL pdensa(blksize) ! average particle density in accumu
1334 REAL pdensc(blksize)
1335 ! *** average modal Knudsen numbers
1336
1337 ! average particle density in coarse
1338 REAL knnuc(blksize) ! nuclei mode Knudsen number
1339 REAL knacc(blksize) ! accumulation Knudsen number
1340 REAL kncor(blksize)
1341 ! *** modal condensation factors ( see comments in NUCLCOND )
1342
1343 ! coarse mode Knudsen number
1344 REAL fconcn(blksize)
1345 REAL fconca(blksize)
1346 !bs
1347 REAL fconcn_org(blksize)
1348 REAL fconca_org(blksize)
1349 !bs
1350
1351 ! *** Rates for secondary particle formation:
1352
1353 ! *** production of new mass concentration [ ug/m**3 s ]
1354 REAL dmdt(blksize) ! by particle formation
1355
1356 ! *** production of new number concentration [ number/m**3 s ]
1357
1358 ! rate of production of new mass concen
1359 REAL dndt(blksize) ! by particle formation
1360
1361 ! *** growth rate for third moment by condensation of precursor
1362 ! vapor on existing particles [ 3rd mom/m**3 s ]
1363
1364 ! rate of producton of new particle num
1365 REAL cgrn3(blksize) ! Aitken mode
1366 REAL cgra3(blksize)
1367 ! *** Rates for coaglulation: [ m**3/s ]
1368
1369 ! *** Unimodal Rates:
1370
1371 ! Accumulation mode
1372 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
1373 REAL ura00(blksize)
1374
1375 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
1376
1377 ! accumulation mode 0th moment self-coagulat
1378 REAL brna01(blksize)
1379 ! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS
1380 ! rate for 0th moment
1381 REAL c30(blksize) ! by intermodal c
1382
1383 ! *** other processes
1384
1385 ! intermodal 3rd moment transfer r
1386 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
1387
1388
1389 ! INTEGER NN, VV ! loop indICES
1390
1391 ! increment of concentration added to
1392 ! ////////////////////// Begin code ///////////////////////////////////
1393
1394
1395
1396
1397 ! concentration lower limit
1398 CHARACTER*16 pname
1399 PARAMETER (pname=' AEROPROC ')
1400
1401 INTEGER unit
1402 PARAMETER (unit=20)
1403 integer igrid,jgrid,kgrid
1404
1405
1406
1407
1408 ! *** get water, ammonium and nitrate content:
1409 ! for now, don't call if temp is below -40C (humidity
1410 ! for this wrf version is already limited to 10 percent)
1411
1412 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
1413 CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
1414 endif
1415
1416 ! *** get size distribution information:
1417
1418 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1419 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1420 kncor)
1421
1422 ! *** Calculate coagulation rates for fine particles:
1423
1424 CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
1425 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
1426
1427
1428 ! *** get condensation and particle formation (nucleation) rates:
1429
1430 CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, &
1431 so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
1432 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
1433 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)
1434
1435 if(dndt(1).lt.-10.)print*,'dndt in aeroproc',dndt
1436
1437 ! *** advance forward in time DT seconds:
1438 CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,orgaro1rat, &
1439 orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat, &
1440 orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, &
1441 dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, &
1442 dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid)
1443
1444
1445 ! *** get new distribution information:
1446
1447 CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, &
1448 pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, &
1449 kncor)
1450
1451 RETURN
1452 END SUBROUTINE aeroproc
1453 !//////////////////////////////////////////////////////////////////
1454 ! *** Time stepping code advances the aerosol moments one timestep;
1455
1456
1457 SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat &
1458 ,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat,orgbio2rat &
1459 ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas &
1460 ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn &
1461 ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, &
1462 igrid,jgrid,kgrid &
1463 )
1464
1465 !***********************************************************************
1466
1467 ! NOTE:
1468
1469 ! *** DESCRIPTION: Integrate the Number and Mass equations
1470 ! for each mode over the time interval DT.
1471
1472 ! PRECONDITIONS:
1473 ! AEROSTEP() must follow calls to all other dynamics routines.
1474
1475 ! *** Revision history:
1476 ! Adapted 3/95 by UAS and CJC from EAM2's code.
1477 ! Revised 7/29/96 by FSB to use block structure
1478 ! Revised 11/15/96 by FSB dropped flow-through and cast
1479 ! number solver into Riccati equation form.
1480 ! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mo
1481 ! each predicted rather than total mass and
1482 ! Aitken mode mass. Also used a local approximati
1483 ! the error function. Also added coarse mode.
1484 ! Revised 9/18/97 by FSB to fix mass transfer from Aitken to
1485 ! accumulation mode by coagulation
1486 ! Revised 10/27/97 by FSB to modify code to use primay emissions
1487 ! and to correct 3rd moment updates.
1488 ! Also added coarse mode.
1489 ! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5
1490 ! Revised 11/5/97 by FSB to fix error in MSTRNSFR
1491 ! Revised 11/6/97 FSB to correct the expression for FACTRANS to
1492 ! remove the 6/pi coefficient. UAS found this.
1493 ! Revised 12/15/97 by FSB to change equations for mass concentrati
1494 ! to a chemical production form with analytic
1495 ! solutions for the Aitken mode and to remove
1496 ! time stepping of the 3rd moments. The mass conc
1497 ! in the accumulation mode is updated with a forw
1498 ! Euler step.
1499 ! Revised 1/6/98 by FSB Lowered minimum concentration for
1500 ! sulfate aerosol to 0.1 [ ng / m**3 ].
1501 ! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represen
1502 ! intermodal transfer rate of 3rd moment in place
1503 ! of 3rd moment coagulation rate.
1504 ! Revised 5/5/98 added new renaming criterion based on diameters
1505 ! Added 3/23/98 by BS condensational groth factors for organics
1506
1507 !**********************************************************************
1508
1509 ! IMPLICIT NONE
1510
1511 ! Includes:
1512
1513
1514
1515 ! *** ARGUMENTS:
1516
1517 ! dimension of arrays
1518 INTEGER blksize
1519 ! actual number of cells in arrays
1520 INTEGER numcells
1521 ! nmber of species in CBLK
1522 INTEGER nspcsda
1523 ! model layer
1524 INTEGER layer
1525 REAL cblk(blksize,nspcsda) ! main array of variables
1526 INTEGER igrid,jgrid,kgrid
1527 REAL dt
1528 ! *** Chemical production rates: [ ug / m**3 s ]
1529
1530 ! time step [sec]
1531 REAL so4rat(blksize)
1532 ! *** anthropogenic organic aerosol mass production rates from aromatics
1533 ! sulfate gas-phase production rate
1534 REAL orgaro1rat(blksize)
1535 REAL orgaro2rat(blksize)
1536
1537 ! *** anthropogenic organic aerosol mass production rates from alkanes &
1538 REAL orgalk1rat(blksize)
1539 REAL orgole1rat(blksize)
1540
1541 ! *** biogenic organic aerosol production rates
1542 REAL orgbio1rat(blksize)
1543 REAL orgbio2rat(blksize)
1544 REAL orgbio3rat(blksize)
1545 REAL orgbio4rat(blksize)
1546
1547 ! *** Primary emissions rates: [ ug / m**3 s ]
1548
1549 ! *** emissions rates for unidentified PM2.5 mass
1550 REAL epm25i(blksize) ! Aitken mode
1551 REAL epm25j(blksize)
1552 ! *** emissions rates for primary organic aerosol
1553 ! Accumululaton mode
1554 REAL eorgi(blksize) ! Aitken mode
1555 REAL eorgj(blksize)
1556 ! *** emissions rates for elemental carbon
1557 ! Accumululaton mode
1558 REAL eeci(blksize) ! Aitken mode
1559 REAL eecj(blksize)
1560 ! *** emissions rates for coarse mode particles
1561 ! Accumululaton mode
1562 REAL esoil(blksize) ! soil derived coarse aerosols
1563 REAL eseas(blksize) ! marine coarse aerosols
1564 REAL epmcoarse(blksize)
1565 ! anthropogenic coarse aerosols
1566 REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ]
1567 REAL dgacc(blksize)
1568 ! accumulation
1569 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
1570 ! reciprocal condensation rate
1571 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
1572 ! reciprocal condensation rate
1573 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
1574 ! reciprocal condensation rate for organ
1575 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
1576 ! reciprocal condensation rate for organ
1577 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
1578 ! rate of production of new mass concent
1579 REAL dndt(blksize) ! by particle formation [ number/m**3 /s
1580 ! rate of producton of new particle numb
1581 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
1582 ! increment of concentration added to
1583 REAL urn00(blksize) ! Aitken intramodal coagulation rate
1584 REAL ura00(blksize) ! Accumulation mode intramodal coagulati
1585 REAL brna01(blksize) ! bimodal coagulation rate for number
1586 REAL c30(blksize) ! by intermodal coagulation
1587 ! intermodal 3rd moment transfer rate by
1588 REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken
1589 REAL cgra3(blksize)
1590 ! *** Modal mass concentrations [ ug m**3 ]
1591
1592 ! growth rate for 3rd moment for Accumul
1593 REAL pmassn(blksize) ! mass concentration in Aitken mode
1594 REAL pmassa(blksize) ! mass concentration in accumulation
1595 REAL pmassc(blksize)
1596
1597 ! *** Local Variables
1598
1599 ! mass concentration in coarse mode
1600 INTEGER l, lcell, &
1601 spc
1602 ! ** following scratch variables are used for solvers
1603
1604
1605
1606 ! *** variables needed for modal dynamics solvers:
1607
1608 ! Loop indices
1609 REAL*8 a, b, c
1610 REAL*8 m1, m2, y0, y
1611 REAL*8 dhat, p, pexpdt, expdt
1612 REAL*8 loss, prod, pol, lossinv
1613 ! mass intermodal transfer by coagulation
1614 REAL mstrnsfr
1615
1616 REAL factrans
1617
1618 ! *** CODE additions for renaming
1619 REAL getaf2
1620 REAL aaa, xnum, xm3, fnum, fm3, phnum, & ! Defined below
1621 phm3
1622 REAL erf, & ! Error and complementary error function
1623 erfc
1624
1625 REAL xx
1626 ! dummy argument for ERF and ERFC
1627 ! a numerical value for a minimum concentration
1628
1629 ! *** This value is smaller than any reported tropospheric concentration
1630
1631
1632 ! :::::::::::::::::::::::::::::::::::::
1633 ! *** Statement function given for error function. Source is
1634 ! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet
1635 ! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec
1636 ! 20:253-265. They cite Reasearch & Education Asociation (REA), (19
1637 ! Handbook of Mathematical, Scientific, and Engineering Formulas,
1638 ! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49
1639
1640 erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs))
1641 erfc(xx) = 1.0 - erf(xx)
1642 ! ::::::::::::::::::::::::::::::::::::::::
1643
1644
1645 ! ///// begin code
1646
1647
1648
1649
1650 ! *** set up time-step integration
1651
1652 DO l = 1, numcells
1653
1654 ! *** code to move number forward by one time step.
1655 ! *** solves the Ricatti equation:
1656
1657 ! dY/dt = C - A * Y ** 2 - B * Y
1658
1659 ! Coded 11/21/96 by Dr. Francis S. Binkowski
1660
1661 ! *** Aitken mode:
1662
1663 ! *** coefficients
1664
1665 a = urn00(l)
1666 b = brna01(l)*cblk(l,vac0)
1667 c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l))
1668
1669 ! includes primary emissions
1670 y0 = cblk(l,vnu0)
1671 ! *** trap on C = 0
1672
1673 ! initial condition
1674 IF (c>0.0D0) THEN
1675
1676 dhat = sqrt(b*b+4.0D0*a*c)
1677
1678 m1 = 2.0D0*a*c/(b+dhat)
1679
1680 m2 = -0.5D0*(b+dhat)
1681
1682 p = -(m1-a*y0)/(m2-a*y0)
1683
1684 pexpdt = p*exp(-dhat*dt)
1685
1686 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1687 ! solution
1688 ELSE
1689
1690 ! *** rearrange solution for NUMERICAL stability
1691 ! note If B << A * Y0, the following form, although
1692 ! seemingly awkward gives the correct answer.
1693
1694 expdt = exp(-b*dt)
1695 IF (expdt<1.0D0) THEN
1696 y = b*y0*expdt/(b+a*y0*(1.0D0-expdt))
1697 ELSE
1698 y = y0
1699 END IF
1700
1701 END IF
1702 if(y.lt.nummin_i)then
1703 print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)'
1704 print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid
1705 print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)
1706 endif
1707
1708 cblk(l,vnu0) = max(nummin_i,y)
1709
1710 ! *** now do accumulation mode number
1711
1712 ! *** coefficients
1713
1714 ! update
1715 a = ura00(l)
1716 b = & ! NOTE B = 0.0
1717 0.0D0
1718 c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l))
1719 ! includes primary emissi
1720 y0 = cblk(l,vac0)
1721 ! *** this equation requires special handling, because C can be zero.
1722 ! if this happens, the form of the equation is different:
1723
1724 ! initial condition
1725 ! print *,vac0,y0,c,nummin_j,a
1726 IF (c>0.0D0) THEN
1727
1728 dhat = sqrt(4.0D0*a*c)
1729
1730 m1 = 2.0D0*a*c/dhat
1731
1732 m2 = -0.5D0*dhat
1733
1734 p = -(m1-a*y0)/(m2-a*y0)
1735
1736 pexpdt = p*exp(-dhat*dt)
1737
1738 y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt))
1739 ! solution
1740 ELSE
1741
1742 ! y = y0/(1.0D0+dt*a*y0)
1743 ! print *,dhat,y0,dt,a
1744 y = y0/(1.+dt*a*y0)
1745 ! print *,y
1746 ! correct solution to equatio
1747 END IF
1748
1749 cblk(l,vac0) = max(nummin_j,y)
1750 ! *** now do coarse mode number neglecting coagulation
1751 ! update
1752 ! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l)
1753 prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l)
1754
1755 ! print *,cblk(l,vcorn),factnumc,prod
1756 cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt
1757
1758
1759 ! *** Prepare to advance modal mass concentration one time step.
1760
1761 ! *** Set up production and and intermodal transfer terms terms:
1762 ! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l)
1763 cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l)
1764
1765 ! includes growth from pri
1766 cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + &
1767 orgfac*eorgj(l) ! and transfer of 3rd momen
1768 ! intermodal coagulation
1769
1770 ! *** set up transfer coefficients for coagulation between Aitken and ac
1771
1772
1773 ! *** set up special factors for mass transfer from the Aitken to accumu
1774 ! intermodal coagulation. The mass transfer rate is proportional to
1775 ! transfer rate, C30. The proportionality factor is p/6 times the th
1776 ! density. The average particle density for a species is the species
1777 ! divided by the particle volume concentration, pi/6 times the 3rd m
1778 ! The p/6 coefficients cancel.
1779
1780 ! includes growth from prim
1781 ! print *,'loss',vnu3,c30(l),cblk(l,vnu3)
1782 loss = c30(l)/cblk(l,vnu3)
1783
1784 ! Normalized coagulation transfer r
1785 factrans = loss* & ! yields an estimate of the amount of mass t
1786 dt
1787 ! the Aitken to the accumulation mode in the
1788
1789 ! Multiplying this factor by the species con
1790 ! print *,'factrans = ',factrans,loss
1791 expdt = exp(-factrans) ! decay term is common to all Aitken mode
1792 ! print *,'factrans = ',factrans,loss,expdt
1793 ! variable name is re-used here. This expo
1794 lossinv = 1.0/ &
1795 loss
1796 ! *** now advance mass concentrations one time step.
1797
1798
1799 ! *** update sulfuric acid vapor concentration by removing mass concent
1800 ! condensed sulfate and newly produced particles.
1801 ! *** The method follows Youngblood and Kreidenweis, Further Development
1802 ! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep
1803 ! Atmospheric Science Paper Number 550, April,1994, pp 85-89.
1804 ! set up for multiplication rather than divi
1805 cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt))
1806
1807
1808 ! *** Solve Aitken-mode equations of form: dc/dt = P - L*c
1809 ! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt)
1810
1811 ! *** sulfate:
1812
1813 mstrnsfr = cblk(l,vso4ai)*factrans
1814 prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass +
1815 pol = prod*lossinv
1816 ! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr
1817
1818 cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt
1819
1820 cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai))
1821
1822 cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr
1823
1824 ! *** anthropogenic secondary organic:
1825 !bs * anthropogenic secondary organics from aromatic precursors
1826
1827 mstrnsfr = cblk(l,vorgaro1i)*factrans
1828 prod = orgaro1rat(l)*fconcn_org(l)
1829 pol = prod*lossinv
1830
1831 cblk(l,vorgaro1i) = pol + (cblk(l,vorgaro1i)-pol)*expdt
1832
1833 cblk(l,vorgaro1i) = max(conmin,cblk(l,vorgaro1i))
1834
1835 cblk(l,vorgaro1j) = cblk(l,vorgaro1j) + orgaro1rat(l)*fconca_org(l)*dt &
1836 + mstrnsfr
1837 !bs * second species from aromatics
1838 mstrnsfr = cblk(l,vorgaro2i)*factrans
1839 prod = orgaro2rat(l)*fconcn_org(l)
1840 pol = prod*lossinv
1841
1842 cblk(l,vorgaro2i) = pol + (cblk(l,vorgaro2i)-pol)*expdt
1843
1844 cblk(l,vorgaro2i) = max(conmin,cblk(l,vorgaro2i))
1845
1846 cblk(l,vorgaro2j) = cblk(l,vorgaro2j) + orgaro2rat(l)*fconca_org(l)*dt &
1847 + mstrnsfr
1848
1849 !bs * anthropogenic secondary organics from alkanes & other precursors
1850 !bs * higher alkanes
1851 mstrnsfr = cblk(l,vorgalk1i)*factrans
1852 prod = orgalk1rat(l)*fconcn_org(l)
1853 pol = prod*lossinv
1854
1855 cblk(l,vorgalk1i) = pol + (cblk(l,vorgalk1i)-pol)*expdt
1856
1857 cblk(l,vorgalk1i) = max(conmin,cblk(l,vorgalk1i))
1858
1859 cblk(l,vorgalk1j) = cblk(l,vorgalk1j) + orgalk1rat(l)*fconca_org(l)*dt &
1860 + mstrnsfr
1861 !bs * higher olefines
1862 mstrnsfr = cblk(l,vorgole1i)*factrans
1863 prod = orgole1rat(l)*fconcn_org(l)
1864 pol = prod*lossinv
1865
1866 cblk(l,vorgole1i) = pol + (cblk(l,vorgole1i)-pol)*expdt
1867
1868 cblk(l,vorgole1i) = max(conmin,cblk(l,vorgole1i))
1869
1870 cblk(l,vorgole1j) = cblk(l,vorgole1j) + orgole1rat(l)*fconca_org(l)*dt &
1871 + mstrnsfr
1872
1873 ! *** biogenic secondary organic
1874
1875 mstrnsfr = cblk(l,vorgba1i)*factrans
1876 prod = orgbio1rat(l)*fconcn_org(l)
1877 pol = prod*lossinv
1878
1879 cblk(l,vorgba1i) = pol + (cblk(l,vorgba1i)-pol)*expdt
1880
1881 cblk(l,vorgba1i) = max(conmin,cblk(l,vorgba1i))
1882
1883 cblk(l,vorgba1j) = cblk(l,vorgba1j) + orgbio1rat(l)*fconca_org(l)*dt + &
1884 mstrnsfr
1885 !bs * second biogenic species
1886 mstrnsfr = cblk(l,vorgba2i)*factrans
1887 prod = orgbio2rat(l)*fconcn_org(l)
1888 pol = prod*lossinv
1889
1890 cblk(l,vorgba2i) = pol + (cblk(l,vorgba2i)-pol)*expdt
1891
1892 cblk(l,vorgba2i) = max(conmin,cblk(l,vorgba2i))
1893
1894 cblk(l,vorgba2j) = cblk(l,vorgba2j) + orgbio2rat(l)*fconca_org(l)*dt + &
1895 mstrnsfr
1896
1897 !bs * third biogenic species
1898 mstrnsfr = cblk(l,vorgba3i)*factrans
1899 prod = orgbio3rat(l)*fconcn_org(l)
1900 pol = prod*lossinv
1901
1902 cblk(l,vorgba3i) = pol + (cblk(l,vorgba3i)-pol)*expdt
1903
1904 cblk(l,vorgba3i) = max(conmin,cblk(l,vorgba3i))
1905
1906 cblk(l,vorgba3j) = cblk(l,vorgba3j) + orgbio3rat(l)*fconca_org(l)*dt + &
1907 mstrnsfr
1908
1909 !bs * fourth biogenic species
1910 mstrnsfr = cblk(l,vorgba4i)*factrans
1911 prod = orgbio4rat(l)*fconcn_org(l)
1912 pol = prod*lossinv
1913
1914 cblk(l,vorgba4i) = pol + (cblk(l,vorgba4i)-pol)*expdt
1915
1916 cblk(l,vorgba4i) = max(conmin,cblk(l,vorgba4i))
1917
1918 cblk(l,vorgba4j) = cblk(l,vorgba4j) + orgbio4rat(l)*fconca_org(l)*dt + &
1919 mstrnsfr
1920
1921 ! *** primary anthropogenic organic
1922
1923 mstrnsfr = cblk(l,vorgpai)*factrans
1924 prod = eorgi(l)
1925 pol = prod*lossinv
1926
1927 cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt
1928
1929 cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai))
1930
1931 cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr
1932
1933 ! *** other anthropogenic PM2.5
1934
1935 mstrnsfr = cblk(l,vp25ai)*factrans
1936 prod = epm25i(l)
1937 pol = prod*lossinv
1938
1939 cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt
1940
1941 cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai))
1942
1943 cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr
1944
1945 ! *** elemental carbon
1946
1947 mstrnsfr = cblk(l,veci)*factrans
1948 prod = eeci(l)
1949 pol = prod*lossinv
1950
1951 cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt
1952
1953 cblk(l,veci) = max(conmin,cblk(l,veci))
1954
1955 cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr
1956
1957
1958 ! *** coarse mode
1959
1960 ! *** soil dust
1961
1962 cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt
1963 cblk(l,vsoila) = max(conmin,cblk(l,vsoila))
1964
1965 ! *** sea salt
1966
1967 cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt
1968 cblk(l,vseas) = max(conmin,cblk(l,vseas))
1969
1970 ! *** anthropogenic PM10 coarse fraction
1971
1972 cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt
1973 cblk(l,vantha) = max(conmin,cblk(l,vantha))
1974
1975
1976
1977 END DO
1978
1979
1980 ! *** Check for mode merging,if Aitken mode is growing faster than j-mod
1981 ! then merge modes by renaming.
1982
1983 ! *** use Binkowski-Kreidenweis paradigm, now including emissions
1984
1985
1986 ! end of time-step loop for total mass
1987 DO lcell = 1, numcells
1988
1989 ! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND.
1990 ! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer
1991 IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( &
1992 lcell,vnu0)>cblk(lcell,vac0)) &
1993 THEN
1994
1995 ! check if mer
1996 aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), &
1997 dgacc(lcell),xxlsgn,xxlsga,sqrt2)
1998
1999 ! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where
2000 ! dd is the diameter at which the Aitken-mode and accumulation-mo
2001 ! distributions intersect (overap).
2002
2003
2004 xnum = max(aaa,xxm3) ! this means that no more than one ha
2005 ! total Aitken mode number may be tra
2006 ! per call.
2007
2008 ! do not let XNUM become negative bec
2009 xm3 = xnum - &
2010 xxm3
2011 ! set up for 3rd moment and mass tran
2012 IF (xm3>0.0) &
2013 THEN
2014 ! do mode merging if overlap is corr
2015 phnum = 0.5*(1.0+erf(xnum))
2016 phm3 = 0.5*(1.0+erf(xm3))
2017 fnum = 0.5*erfc(xnum)
2018 fm3 = 0.5*erfc(xm3)
2019
2020
2021 ! In the Aitken mode:
2022
2023 ! *** FNUM and FM3 are the fractions of the number and 3rd moment
2024 ! distributions with diameters greater than dd respectively.
2025
2026
2027 ! *** PHNUM and PHM3 are the fractions of the number and 3rd moment
2028 ! distributions with diameters less than dd.
2029
2030
2031 ! *** rename the Aitken mode particle number as accumulation mode
2032 ! particle number
2033
2034 cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0)
2035
2036
2037 ! *** adjust the Aitken mode number
2038
2039 cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0)
2040
2041 ! *** Rename mass from Aitken mode to acumulation mode. The mass transfe
2042 ! to the accumulation mode is proportional to the amount of 3rd mome
2043 ! transferred, therefore FM3 is used for mass transfer.
2044
2045 cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3
2046
2047 cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3
2048
2049 cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3
2050
2051 cblk(lcell,vorgaro1j) = cblk(lcell,vorgaro1j) + &
2052 cblk(lcell,vorgaro1i)*fm3
2053
2054 cblk(lcell,vorgaro2j) = cblk(lcell,vorgaro2j) + &
2055 cblk(lcell,vorgaro2i)*fm3
2056
2057 cblk(lcell,vorgalk1j) = cblk(lcell,vorgalk1j) + &
2058 cblk(lcell,vorgalk1i)*fm3
2059
2060 cblk(lcell,vorgole1j) = cblk(lcell,vorgole1j) + &
2061 cblk(lcell,vorgole1i)*fm3
2062
2063 cblk(lcell,vorgba1j) = cblk(lcell,vorgba1j) + &
2064 cblk(lcell,vorgba1i)*fm3
2065
2066 cblk(lcell,vorgba2j) = cblk(lcell,vorgba2j) + &
2067 cblk(lcell,vorgba2i)*fm3
2068
2069 cblk(lcell,vorgba3j) = cblk(lcell,vorgba3j) + &
2070 cblk(lcell,vorgba3i)*fm3
2071
2072 cblk(lcell,vorgba4j) = cblk(lcell,vorgba4j) + &
2073 cblk(lcell,vorgba4i)*fm3
2074
2075 cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + &
2076 cblk(lcell,vorgpai)*fm3
2077
2078 cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3
2079
2080 cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3
2081
2082 ! *** update Aitken mode for mass loss to accumulation mode
2083
2084 cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3
2085
2086
2087 cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3
2088
2089 cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3
2090
2091 cblk(lcell,vorgaro1i) = cblk(lcell,vorgaro1i)*phm3
2092
2093 cblk(lcell,vorgaro2i) = cblk(lcell,vorgaro2i)*phm3
2094
2095 cblk(lcell,vorgalk1i) = cblk(lcell,vorgalk1i)*phm3
2096
2097 cblk(lcell,vorgole1i) = cblk(lcell,vorgole1i)*phm3
2098
2099 cblk(lcell,vorgba1i) = cblk(lcell,vorgba1i)*phm3
2100
2101 cblk(lcell,vorgba2i) = cblk(lcell,vorgba2i)*phm3
2102
2103 cblk(lcell,vorgba3i) = cblk(lcell,vorgba3i)*phm3
2104
2105 cblk(lcell,vorgba4i) = cblk(lcell,vorgba4i)*phm3
2106
2107 cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3
2108
2109 cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3
2110
2111 cblk(lcell,veci) = cblk(lcell,veci)*phm3
2112
2113
2114 END IF
2115 ! end check on whether modal overlap is OK
2116
2117 END IF
2118 ! end check on necessity for merging
2119
2120 END DO
2121 ! set min value for all concentrations
2122
2123 ! loop for merging
2124 DO spc = 1, nspcsda
2125 DO lcell = 1, numcells
2126 cblk(lcell,spc) = max(cblk(lcell,spc),conmin)
2127 END DO
2128 END DO
2129
2130
2131 RETURN
2132
2133 !#######################################################################
2134 END SUBROUTINE aerostep
2135 ! aerostep
2136 SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o)
2137 ! NOTE!!! wh2o is returned in micrograms / cubic meter
2138 ! mso4,mnh4,mno3 are in microMOLES / cubic meter
2139
2140 ! This version uses polynomials rather than tables, and uses empirical
2141 ! polynomials for the mass fraction of solute (mfs) as a function of wat
2142 ! where:
2143
2144 ! mfs = ms / ( ms + mw)
2145 ! ms is the mass of solute
2146 ! mw is the mass of water.
2147
2148 ! Define y = mw/ ms
2149
2150 ! then mfs = 1 / (1 + y)
2151
2152 ! y can then be obtained from the values of mfs as
2153
2154 ! y = (1 - mfs) / mfs
2155
2156
2157 ! the aerosol is assumed to be in a metastable state if the rh is
2158 ! is below the rh of deliquescence, but above the rh of crystallizat
2159
2160 ! ZSR interpolation is used for sulfates with x ( the molar ratio of
2161 ! ammonium to sulfate in eh range 0 <= x <= 2, by sections.
2162 ! section 1: 0 <= x < 1
2163 ! section 2: 1 <= x < 1.5
2164 ! section 3: 1.5 <= x < 2.0
2165 ! section 4: 2 <= x
2166 ! In sections 1 through 3, only the sulfates can affect the amount o
2167 ! on the particles.
2168 ! In section 4, we have fully neutralized sulfate, and extra ammoniu
2169 ! allows more nitrate to be present. Thus, the ammount of water is c
2170 ! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati
2171 ! assumed to occur in sections 2,3,and 4. See detailed discussion be
2172
2173
2174
2175 ! definitions:
2176 ! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of
2177 ! for sulfate, ammonium, and nitrate respectively
2178 ! irhx is the relative humidity (%)
2179 ! wh2o is the returned water amount in micrograms / cubic meter of a
2180 ! x is the molar ratio of ammonium to sulfate
2181 ! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol
2182 ! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively
2183 ! y3 is the value of the mass ratio of water to solute for
2184 ! a pure ammonium nitrate solution.
2185
2186
2187 !oded by Dr. Francis S. Binkowski, 4/8/96.
2188
2189 ! IMPLICIT NONE
2190 INTEGER irhx, irh
2191 REAL mso4, mnh4, mno3
2192 REAL tso4, tnh4, tno3, wh2o, x
2193 REAL aw, awc
2194 ! REAL poly4, poly6
2195 REAL mfs0, mfs1, mfs15, mfs2
2196 REAL c0(4), c1(4), c15(4), c2(4)
2197 REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc
2198 REAL kso4(6), kno3(6), mfsso4, mfsno3
2199
2200
2201
2202 REAL mwso4, mwnh4, mwno3, mw2, mwano3
2203
2204 ! *** molecular weights:
2205 PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, &
2206 mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4)
2207
2208 ! The polynomials use data for aw as a function of mfs from Tang and
2209 ! Munkelwitz, JGR 99: 18801-18808, 1994.
2210 ! The polynomials were fit to Tang's values of water activity as a
2211 ! function of mfs.
2212
2213 ! *** coefficients of polynomials fit to Tang and Munkelwitz data
2214 ! now give mfs as a function of water activity.
2215
2216 DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/
2217 DATA c15/1.697092, -4.045936, 5.833688, -3.463783/
2218 DATA c2/2.085067, -6.024139, 8.967967, -5.002934/
2219
2220 ! *** the following coefficients are a fit to the data in Table 1 of
2221 ! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975
2222 ! data c0/0.8258941, -1.899205, 3.296905, -2.214749 /
2223 ! *** New data fit to data from
2224 ! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975
2225 ! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960
2226 ! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200
2227 DATA c0/0.798079, -1.574367, 2.536686, -1.735297/
2228
2229
2230 ! *** polynomials for ammonium nitrate and ammonium sulfate are from:
2231 ! Chan et al.1992, Atmospheric Environment (26A): 1661-1673.
2232
2233 DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/
2234 DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/
2235
2236
2237 ! *** check range of per cent relative humidity
2238 irh = irhx
2239 irh = max(1,irh)
2240 irh = min(irh,100)
2241 aw = float(irh)/ & ! water activity = fractional relative h
2242 100.0
2243 tso4 = max(mso4,0.0)
2244 tnh4 = max(mnh4,0.0)
2245 tno3 = max(mno3,0.0)
2246 x = 0.0
2247 ! *** if there is non-zero sulfate calculate the molar ratio
2248 IF (tso4>0.0) THEN
2249 x = tnh4/tso4
2250 ELSE
2251 ! *** otherwise check for non-zero nitrate and ammonium
2252 IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0
2253 END IF
2254
2255
2256
2257 ! *** begin screen on x for calculating wh2o
2258 IF (x<1.0) THEN
2259
2260 mfs0 = poly4(c0,aw)
2261 mfs1 = poly4(c1,aw)
2262 y0 = (1.0-mfs0)/mfs0
2263 y1 = (1.0-mfs1)/mfs1
2264 y = (1.0-x)*y0 + x*y1
2265
2266
2267 ELSE IF (x<1.5) THEN
2268
2269 IF (irh>=40) THEN
2270 mfs1 = poly4(c1,aw)
2271 mfs15 = poly4(c15,aw)
2272 y1 = (1.0-mfs1)/mfs1
2273 y15 = (1.0-mfs15)/mfs15
2274 y = 2.0*(y1*(1.5-x)+y15*(x-1.0))
2275 ELSE
2276 ! *** set up for crystalization
2277
2278 ! *** Crystallization is done as follows:
2279 ! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4
2280 ! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01
2281 ! and since the code does not allow ar rh < 0.01, crystallization
2282 ! is assumed not to occur in this range.
2283 ! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line
2284 ! from a value of y15 at rh = 0.4 to a value of zero at y1. From
2285 ! point B to point A in the diagram.
2286 ! The algorithm does a double interpolation to calculate the amount
2287 ! water.
2288
2289 ! y1(0.40) y15(0.40)
2290 ! + + Point B
2291
2292
2293
2294
2295 ! +--------------------+
2296 ! x=1 x=1.5
2297 ! Point A
2298
2299
2300
2301 awc = 0.80*(x-1.0) ! rh along the crystallization curve.
2302 y = 0.0
2303 IF (aw>=awc) & ! interpolate using crystalization
2304 THEN
2305 mfs1 = poly4(c1,0.40)
2306 mfs15 = poly4(c15,0.40)
2307 y140 = (1.0-mfs1)/mfs1
2308 y1540 = (1.0-mfs15)/mfs15
2309 y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0))
2310 yc = 2.0*y1540*(x-1.0) ! y along crystallization cur
2311 y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc)
2312 ! end of checking for aw
2313 END IF
2314
2315 END IF
2316 ! end of checking on irh
2317 ELSE IF (x<1.9999) THEN
2318
2319 y = 0.0
2320 IF (irh>=40) THEN
2321 mfs15 = poly4(c15,aw)
2322 mfs2 = poly4(c2,aw)
2323 y15 = (1.0-mfs15)/mfs15
2324 y2 = (1.0-mfs2)/mfs2
2325 y = 2.0*(y15*(2.0-x)+y2*(x-1.5))
2326
2327 END IF
2328
2329
2330
2331 ! end of check for crystallization
2332
2333 ELSE
2334 ! regime where ammonium sulfate and ammonium nitrate are in solution.
2335
2336 ! *** following cf&s for both ammonium sulfate and ammonium nitrate
2337 ! *** check for crystallization here. their data indicate a 40% value
2338 ! is appropriate.
2339 ! 1.9999 < x
2340 y2 = 0.0
2341 y3 = 0.0
2342 IF (irh>=40) THEN
2343 mfsso4 = poly6(kso4,aw)
2344 mfsno3 = poly6(kno3,aw)
2345 y2 = (1.0-mfsso4)/mfsso4
2346 y3 = (1.0-mfsno3)/mfsno3
2347
2348 END IF
2349
2350
2351 END IF
2352 ! *** now set up output of wh2o
2353
2354 ! wh2o units are micrograms (liquid water) / cubic meter of air
2355
2356 ! end of checking on x
2357 IF (x<1.9999) THEN
2358
2359 wh2o = y*(tso4*mwso4+mwnh4*tnh4)
2360
2361 ELSE
2362
2363 ! *** this is the case that all the sulfate is ammonium sulfate
2364 ! and the excess ammonium forms ammonum nitrate
2365
2366 wh2o = y2*tso4*mw2 + y3*tno3*mwano3
2367
2368 END IF
2369
2370 RETURN
2371 END SUBROUTINE awater
2372 !//////////////////////////////////////////////////////////////////////
2373
2374 SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, &
2375 dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30)
2376 !***********************************************************************
2377 !** DESCRIPTION: calculates aerosol coagulation rates for unimodal
2378 ! and bimodal coagulation using E. Whitby 1990's prescription.
2379
2380 !....... Rates for coaglulation:
2381 !....... Unimodal Rates:
2382 !....... URN00: nuclei mode 0th moment self-coagulation rate
2383 !....... URA00: accumulation mode 0th moment self-coagulation rate
2384
2385 !....... Bimodal Rates: (only 1st order coeffs appear)
2386 !....... NA-- nuclei with accumulation coagulation rates,
2387 !....... AN-- accumulation with nuclei coagulation rates
2388 !....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term)
2389 !....... BRNA31: 3rd ( d(nuclei mode 3) / dt term)
2390 !**
2391 !**
2392 !** Revision history:
2393 ! prototype 1/95 by Uma and Carlie
2394 ! Revised 8/95 by US for calculation of density from stmt func
2395 ! and collect met variable stmt funcs in one include fil
2396 ! REVISED 7/25/96 by FSB to use block structure
2397 ! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only.
2398 ! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs
2399 ! changed. All coagulation coefficients
2400 ! returned with positive signs. Their
2401 ! linearization is also abandoned.
2402 ! Fixed values are used for the corrections
2403 ! to the free-molecular coagulation integra
2404 ! The code forces the harmonic means to be
2405 ! evaluated in 64 bit arithmetic on 32 bit
2406 ! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit
2407
2408 ! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa
2409 ! because BRNA31 can become zero on a works
2410 ! because of limited precision. With the ch
2411 ! aerostep to omit update of the 3rd moment
2412 ! C30 is the only variable now needed.
2413 ! the logic using ONE88 to force REAL*8 ari
2414 ! has been removed and all intermediates ar
2415 ! REAL*8.
2416
2417 ! IMPLICIT NONE
2418
2419 ! dimension of arrays
2420 INTEGER blksize
2421 ! actual number of cells in arrays
2422 INTEGER numcells
2423
2424 INTEGER nspcsda
2425
2426 ! nmber of species in CBLK
2427 REAL cblk(blksize,nspcsda) ! main array of variables
2428 REAL blkta(blksize) ! Air temperature [ K ]
2429 REAL pdensn(blksize) ! average particel density in Aitk
2430 REAL pdensa(blksize) ! average particel density in accu
2431 REAL amu(blksize) ! atmospheric dynamic viscosity [
2432 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
2433 REAL dgacc(blksize) ! accumulation mode mean diameter
2434 REAL knnuc(blksize) ! Aitken mode Knudsen number
2435 REAL knacc(blksize)
2436 ! *** output:
2437
2438 ! accumulation mode Knudsen number
2439 REAL urn00(blksize) ! intramodal coagulation rate (Ait
2440 REAL ura00(blksize)
2441 ! intramodal coagulation rate (acc
2442 REAL brna01(blksize) ! intermodal coagulaton rate (numb
2443 REAL c30(blksize) ! by inter
2444
2445 ! *** Local variables:
2446 ! intermodal 3rd moment transfer r
2447 REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate
2448 kncacc
2449 REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate
2450 kfmacc
2451 REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate
2452 kfm
2453 REAL*8 bencnn, & ! NC 0th moment coag rate (both modes)
2454 bencna
2455 REAL*8 & ! NC 3rd moment coag rate (nuc mode)
2456 bencm3n
2457 REAL*8 befmnn, & ! FM 0th moment coag rate (both modes)
2458 befmna
2459 REAL*8 & ! FM 3rd moment coag rate (nuc mode)
2460 befm3n
2461 REAL*8 betann, & ! composite coag rates, mom 0 (both mode
2462 betana
2463 REAL*8 & ! intermodal coagulation rate for 3rd mo
2464 brna31
2465 REAL*8 & ! scratch subexpression
2466 s1
2467 REAL*8 t1, & ! scratch subexpressions
2468 t2
2469 REAL*8 t16, & ! T1**6, T2**6
2470 t26
2471 REAL*8 rat, & ! ratio of acc to nuc size and its inver
2472 rin
2473 REAL*8 rsqt, & ! sqrt( rat ), rsqt**4
2474 rsq4
2475 REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 )
2476 rsqi3
2477 REAL*8 & ! dgnuc**3
2478 dgn3
2479 REAL*8 & ! in 64 bit arithmetic
2480 dga3
2481
2482 ! dgacc**3
2483
2484 INTEGER lcell
2485 ! *** Fixed values for correctionss to coagulation
2486 ! integrals for free-molecular case.
2487 ! loop counter
2488 REAL*8 bm0
2489 PARAMETER (bm0=0.8D0)
2490 REAL*8 bm0i
2491 PARAMETER (bm0i=0.9D0)
2492 REAL*8 bm3i
2493 PARAMETER (bm3i=0.9D0)
2494 REAL*8 & ! approx Cunningham corr. factor
2495 a
2496 PARAMETER (a=1.246D0)
2497
2498 !.......................................................................
2499 ! begin body of subroutine COAGRATE
2500
2501 !........... Main computational grid-traversal loops
2502 !........... for computing coagulation rates.
2503
2504 ! *** Both modes have fixed std devs.
2505 DO lcell = 1, &
2506 numcells
2507 ! *** moment independent factors
2508
2509 ! loop on LCELL
2510 s1 = two3*boltz*blkta(lcell)/amu(lcell)
2511
2512 ! For unimodal coagualtion:
2513
2514 kncnuc = s1
2515 kncacc = s1
2516
2517 kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell))
2518 kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell))
2519
2520 ! For bimodal coagulation:
2521
2522 knc = s1
2523 kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell)))
2524
2525
2526
2527 !........... Begin unimodal coagulation rate calculations:
2528
2529 !........... Near-continuum regime.
2530
2531 dgn3 = dgnuc(lcell)**3
2532 dga3 = dgacc(lcell)**3
2533
2534 t1 = sqrt(dgnuc(lcell))
2535 t2 = sqrt(dgacc(lcell))
2536 t16 = & ! = T1**6
2537 dgn3
2538 t26 = &
2539 dga3
2540 !....... Note rationalization of fractions and subsequent cancellation
2541 !....... from the formulation in Whitby et al. (1990)
2542
2543 ! = T2**6
2544 bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20))
2545
2546 bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20))
2547
2548
2549 !........... Free molecular regime. Uses fixed value for correction
2550 ! factor BM0
2551
2552
2553 befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0
2554
2555 befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0
2556
2557
2558 !........... Calculate half the harmonic mean between unimodal rates
2559 !........... free molecular and near-continuum regimes
2560
2561 ! FSB 64 bit evaluation
2562
2563 betann = bencnn*befmnn/(bencnn+befmnn)
2564 betana = bencna*befmna/(bencna+befmna)
2565
2566
2567
2568 urn00(lcell) = betann
2569 ura00(lcell) = betana
2570
2571
2572 ! *** End of unimodal coagulation calculations.
2573
2574 !........... Begin bimodal coagulation rate calculations:
2575
2576 rat = dgacc(lcell)/dgnuc(lcell)
2577 rin = 1.0D0/rat
2578 rsqt = sqrt(rat)
2579 rsq4 = rat**2
2580
2581 rsqti = 1.0D0/rsqt
2582 rsqi3 = rin*rsqti
2583
2584 !........... Near-continuum coeffs:
2585 !........... 0th moment nuc mode bimodal coag coefficient
2586
2587 bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell &
2588 )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04)
2589
2590 !........... 3rd moment nuc mode bimodal coag coefficient
2591
2592 bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a &
2593 *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ &
2594 rin*esn64*esa04)
2595
2596
2597
2598 !........... Free molecular regime coefficients:
2599 !........... Uses fixed value for correction
2600 ! factor BM0I, BM3I
2601
2602
2603 !........... 0th moment nuc mode coeff
2604
2605
2606
2607 befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ &
2608 rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1)
2609
2610 !........... 3rd moment nuc mode coeff
2611
2612 befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ &
2613 rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1)
2614
2615
2616 !........... Calculate half the harmonic mean between bimodal rates
2617 !........... free molecular and near-continuum regimes
2618
2619 ! FSB Force 64 bit evaluation
2620
2621
2622 brna01(lcell) = bencnn*befmnn/(bencnn+befmnn)
2623
2624 brna31 = bencm3n* & ! BRNA31 now is a scala
2625 befm3n/(bencm3n+befm3n)
2626 c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0)
2627 ! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0)
2628 ! 3d moment transfer by intermodal coagula
2629
2630 ! End bimodal coagulation rate.
2631
2632
2633
2634 END DO
2635 ! end of main lop over cells
2636 RETURN
2637 !------------------------------------------------------------------
2638 END SUBROUTINE coagrate
2639 ! subroutine to find the roots of a cubic equation / 3rd order polynomi
2640 ! formulae can be found in numer. recip. on page 145
2641 ! kiran developed this version on 25/4/1990
2642 ! dr. francis binkowski modified the routine on 6/24/91, 8/7/97
2643 ! ***
2644 !234567
2645 ! coagrate
2646 SUBROUTINE cubic(a2,a1,a0,nr,crutes)
2647 ! IMPLICIT NONE
2648 INTEGER nr
2649 REAL*8 a2, a1, a0
2650 REAL crutes(3)
2651 REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd
2652 REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3
2653 REAL*8 costh, sinth
2654 DATA sqrt3/1.732050808/, one3rd/0.333333333/
2655 !bs
2656 REAL*8 onebs
2657 PARAMETER (onebs=1.0)
2658 !bs
2659 a2sq = a2*a2
2660 qq = (a2sq-3.*a1)/9.
2661 rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54.
2662 ! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT
2663 dum1 = qq*qq*qq
2664 rrsq = rr*rr
2665 dum2 = dum1 - rrsq
2666 IF (dum2>=0.) THEN
2667 ! NOW WE HAVE THREE REAL ROOTS
2668 phi = sqrt(dum1)
2669 IF (abs(phi)<1.E-20) THEN
2670 print *, ' cubic phi small, phi = ',phi
2671 crutes(1) = 0.0
2672 crutes(2) = 0.0
2673 crutes(3) = 0.0
2674 nr = 0
2675 CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE')
2676 END IF
2677 theta = acos(rr/phi)/3.0
2678 costh = cos(theta)
2679 sinth = sin(theta)
2680 ! *** use trig identities to simplify the expressions
2681 ! *** binkowski's modification
2682 part1 = sqrt(qq)
2683 yy1 = part1*costh
2684 yy2 = yy1 - a2/3.0
2685 yy3 = sqrt3*part1*sinth
2686 crutes(3) = -2.0*yy1 - a2/3.0
2687 crutes(2) = yy2 + yy3
2688 crutes(1) = yy2 - yy3
2689 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2690 IF (crutes(1)<0.0) crutes(1) = 1.0E9
2691 IF (crutes(2)<0.0) crutes(2) = 1.0E9
2692 IF (crutes(3)<0.0) crutes(3) = 1.0E9
2693 ! *** put smallest positive root in crutes(1)
2694 crutes(1) = min(crutes(1),crutes(2),crutes(3))
2695 nr = 3
2696 ! NOW HERE WE HAVE ONLY ONE REAL ROOT
2697 ELSE
2698 ! dum IS NEGATIVE
2699 part1 = sqrt(rrsq-dum1)
2700 part2 = abs(rr)
2701 part3 = (part1+part2)**one3rd
2702 crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3.
2703 !bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3.
2704 crutes(2) = 0.
2705 crutes(3) = 0.
2706 !IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS
2707 ! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE
2708 ! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9
2709 nr = 1
2710 END IF
2711 RETURN
2712 !///////////////////////////////////////////////////////////////////////
2713 END SUBROUTINE cubic
2714
2715 ! Calculate the aerosol chemical speciation and water content.
2716
2717 ! cubic
2718 SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh)
2719 !***********************************************************************
2720 !** DESCRIPTION:
2721 ! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate,
2722 ! and water between the gas and aerosol phases as the total sulfate,
2723 ! ammonia, and nitrate concentrations, relative humidity and
2724 ! temperature change. The evolution of the aerosol mass concentration
2725 ! due to the change in aerosol chemical composition is calculated.
2726 !** REVISION HISTORY:
2727 ! prototype 1/95 by Uma and Carlie
2728 ! Revised 8/95 by US to calculate air density in stmt func
2729 ! and collect met variable stmt funcs in one include fil
2730 ! Revised 7/26/96 by FSB to use block concept.
2731 ! Revise 12/1896 to do do i-mode calculation.
2732 !**********************************************************************
2733
2734 ! IMPLICIT NONE
2735
2736
2737 ! dimension of arrays
2738 INTEGER blksize
2739 ! actual number of cells in arrays
2740 INTEGER numcells
2741 ! nmber of species in CBLK
2742 INTEGER nspcsda
2743 REAL cblk(blksize,nspcsda)
2744 ! *** Meteorological information in blocked arays:
2745
2746 ! main array of variables
2747 REAL blkta(blksize) ! Air temperature [ K ]
2748 REAL blkrh(blksize)
2749
2750 ! Fractional relative humidity
2751
2752 INTEGER lcell
2753 ! loop counter
2754 ! air temperature
2755 REAL temp
2756 !iamodels3
2757 REAL rh
2758 ! relative humidity
2759 REAL so4, no3, nh3, nh4, hno3
2760 REAL aso4, ano3, ah2o, anh4, gnh3, gno3
2761 ! Fraction of dry sulfate mass in i-mode
2762 REAL fraci
2763 !.......................................................................
2764 REAL fracj
2765
2766 ! WRITE(20,*) ' IN EQL 3 '
2767
2768
2769
2770 ! Fraction of dry sulfate mass in j-mode
2771 DO lcell = 1, &
2772 numcells
2773 ! *** Fetch temperature, fractional relative humidity, and
2774 ! air density
2775
2776 ! loop on cells
2777 temp = blkta(lcell)
2778 rh = blkrh(lcell)
2779
2780 ! *** the following is an interim procedure. Assume the i-mode has the
2781 ! same relative mass concentrations as the total mass. Use SO4 as
2782 ! the surrogate. The results of this should be the same as those
2783 ! from the original RPM.
2784
2785 ! *** do total aerosol
2786
2787 so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)
2788
2789 !iamodels3
2790 no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)
2791 ! & + CBLK(LCELL, VHNO3)
2792
2793 hno3 = cblk(lcell,vhno3)
2794
2795 !iamodels3
2796
2797 nh3 = cblk(lcell,vnh3)
2798
2799 nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)
2800 ! & + CBLK(LCELL, VNH3)
2801
2802 !bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP,
2803 !bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3)
2804 !bs
2805 !bs * call old version of rpmares
2806 !bs
2807 CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
2808 gnh3,gno3)
2809 !bs
2810
2811 ! *** get modal fraction
2812 fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai))
2813 fracj = 1.0 - fraci
2814
2815 ! *** update do i-mode
2816
2817 cblk(lcell,vh2oai) = fraci*ah2o
2818 cblk(lcell,vnh4ai) = fraci*anh4
2819 cblk(lcell,vno3ai) = fraci*ano3
2820
2821 ! *** update accumulation mode:
2822
2823 cblk(lcell,vh2oaj) = fracj*ah2o
2824 cblk(lcell,vnh4aj) = fracj*anh4
2825 cblk(lcell,vno3aj) = fracj*ano3
2826
2827
2828 ! *** update gas / vapor phase
2829
2830 cblk(lcell,vnh3) = gnh3
2831 cblk(lcell,vhno3) = gno3
2832
2833 END DO
2834 ! end loop on cells
2835 RETURN
2836
2837 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2838 END SUBROUTINE eql3
2839 ! eql3
2840 SUBROUTINE fdjac(n,x,fjac,ct,cs,imw)
2841 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2842 !bs !
2843 !bs Description: !
2844 !bs !
2845 !bs Get the Jacobian of the function !
2846 !bs !
2847 !bs ( a1 * X1^2 + b1 * X1 + c1 ) !
2848 !bs ( a2 * X2^2 + b2 * X1 + c2 ) !
2849 !bs ( a3 * X3^2 + b3 * X1 + c3 ) !
2850 !bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. !
2851 !bs ( a5 * X5^2 + b5 * X1 + c5 ) !
2852 !bs ( a6 * X6^2 + b6 * X1 + c6 ) !
2853 !bs !
2854 !bs a_i = IMW_i !
2855 !bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i !
2856 !bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] !
2857 !bs !
2858 !bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j !
2859 !bs J_ij = ----------- = ( !
2860 !bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j !
2861 !bs !
2862 !bs !
2863 !bs Called by: NEWT !
2864 !bs !
2865 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2866 !bs
2867 ! IMPLICIT NONE
2868 !bs
2869 !bs
2870 !dimension of problem
2871 INTEGER n
2872 REAL x(n) !bs
2873 ! INTEGER NP !bs maximum expected value of N
2874 ! PARAMETER (NP = 6)
2875 !bs initial guess of CAER
2876 REAL ct(np)
2877 REAL cs(np)
2878 REAL imw(np)
2879 !bs
2880 REAL fjac(n,n)
2881 !bs
2882 INTEGER i, & !bs loop index
2883 j
2884 REAL a(np)
2885 REAL b(np)
2886 REAL b1(np)
2887 REAL b2(np)
2888 REAL sum_jnei
2889 !bs
2890 DO i = 1, n
2891 a(i) = imw(i)
2892 sum_jnei = 0.
2893 DO j = 1, n
2894 sum_jnei = sum_jnei + x(j)*imw(j)
2895 END DO
2896 b1(i) = sum_jnei - (x(i)*imw(i))
2897 b2(i) = cs(i)*imw(i) - ct(i)*imw(i)
2898 b(i) = b1(i) + b2(i)
2899 END DO
2900 DO j = 1, n
2901 DO i = 1, n
2902 IF (i==j) THEN
2903 fjac(i,j) = 2.*a(i)*x(i) + b(i)
2904 ELSE
2905 fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j)
2906 END IF
2907 END DO
2908 END DO
2909 !bs
2910 RETURN
2911 END SUBROUTINE fdjac
2912 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2913 FUNCTION fmin(x,fvec,n,ct,cs,imw,m)
2914 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2915 !bs !
2916 !bs Description: !
2917 !bs !
2918 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
2919 !bs !
2920 !bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, !
2921 !bs user-supplied routine that returns the vector of functions at X. !
2922 !bs The common block NEWTV communicates the function values back to !
2923 !bs NEWT. !
2924 !bs !
2925 !bs Called by: NEWT !
2926 !bs !
2927 !bs Calls: FUNCV !
2928 !bs !
2929 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2930
2931 ! IMPLICIT NONE
2932
2933 !bs
2934 !bs
2935 INTEGER n
2936 ! INTEGER NP
2937 ! PARAMETER (NP = 6)
2938 REAL ct(np)
2939 REAL cs(np)
2940 REAL imw(np)
2941 REAL m,fmin
2942 REAL x(*), fvec(np)
2943
2944
2945 INTEGER i
2946 REAL sum
2947
2948 CALL funcv(n,x,fvec,ct,cs,imw,m)
2949 sum = 0.
2950 DO i = 1, n
2951 sum = sum + fvec(i)**2
2952 END DO
2953 fmin = 0.5*sum
2954 RETURN
2955 END FUNCTION fmin
2956 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2957 SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m)
2958 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2959 !bs !
2960 !bs Description: !
2961 !bs !
2962 !bs Called by: FMIN !
2963 !bs !
2964 !bs Calls: None !
2965 !bs !
2966 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
2967 !bs
2968 ! IMPLICIT NONE
2969 !bs
2970 !bs
2971 INTEGER n
2972 REAL x(*)
2973 REAL fvec(n)
2974 !bs
2975 ! INTEGER NP
2976 ! PARAMETER (NP = 6)
2977 REAL ct(np)
2978 REAL cs(np)
2979 REAL imw(np)
2980 REAL m
2981 !bs
2982 INTEGER i, j
2983 REAL sum_jnei
2984 REAL a(np)
2985 REAL b(np)
2986 REAL c(np)
2987 !bs
2988 DO i = 1, n
2989 a(i) = imw(i)
2990 sum_jnei = 0.
2991 DO j = 1, n
2992 sum_jnei = sum_jnei + x(j)*imw(j)
2993 END DO
2994 sum_jnei = sum_jnei - (x(i)*imw(i))
2995 b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i)
2996 c(i) = -ct(i)*(sum_jnei+m)
2997 fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i)
2998 END DO
2999 !bs
3000 RETURN
3001 END SUBROUTINE funcv
3002 REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2)
3003 ! *** set up new processor for renaming of particles from i to j modes
3004 ! IMPLICIT NONE
3005 REAL aa, bb, cc, disc, qq, alfa, l, yji
3006 REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2
3007
3008 alfa = xlsgi/xlsgj
3009 yji = log(dgnj/dgni)/(sqrt2*xlsgi)
3010 aa = 1.0 - alfa*alfa
3011 l = log(alfa*nj/ni)
3012 bb = 2.0*yji*alfa*alfa
3013 cc = l - yji*yji*alfa*alfa
3014 disc = bb*bb - 4.0*aa*cc
3015 IF (disc<0.0) THEN
3016 getaf = - & ! error in intersection
3017 5.0
3018 RETURN
3019 END IF
3020 qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc))
3021 getaf = cc/qq
3022 RETURN
3023 ! *** subroutine to implement Kulmala, Laaksonen, Pirjola
3024 END FUNCTION getaf
3025 ! Parameterization for sulfuric acid/water
3026 ! nucleation rates, J. Geophys. Research (103), pp 8301-8307,
3027 ! April 20, 1998.
3028
3029 !ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f
3030 !ia rev02 27.04.99 security check on MDOT > SO4RAT
3031
3032
3033 !ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT)
3034 ! getaf
3035 SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat)
3036 ! IMPLICIT NONE
3037
3038
3039 ! *** Input:
3040
3041 ! ambient temperature [ K ]
3042 REAL temp
3043 ! fractional relative humidity
3044 REAL rh
3045 ! sulfuric acid concentration [ ug / m**3 ]
3046 REAL h2so4
3047
3048 REAL so4rat
3049 ! *** Output:
3050
3051 !sulfuric acid production rate [ ug / ( m**3 s )]
3052 ! particle number production rate [ # / ( m**3 s )]
3053 REAL ndot1
3054 ! particle mass production rate [ ug / ( m**3 s )]
3055 REAL mdot1
3056 ! [ m**2 / ( m**3 s )]
3057 REAL m2dot
3058
3059 ! *** Internal:
3060
3061 ! *** NOTE, all units are cgs internally.
3062 ! particle second moment production rate
3063
3064 REAL ra
3065 ! fractional relative acidity
3066 ! sulfuric acid vaper concentration [ cm ** -3 ]
3067 REAL nav
3068 ! water vapor concentration [ cm ** -3 ]
3069 REAL nwv
3070 ! equilibrium sulfuric acid vapor conc. [ cm ** -3 ]
3071 REAL nav0
3072 ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1
3073 REAL nac
3074 ! critical sulfuric acid vapor concentration [ cm ** -3
3075 ! mole fractio of the critical nucleus
3076 REAL xal
3077 REAL nsulf, & ! see usage
3078 delta
3079 REAL*8 & ! factor to calculate Jnuc
3080 chi
3081 REAL*8 &
3082 jnuc
3083 ! nucleation rate [ cm ** -3 s ** -1 ]
3084 REAL tt, & ! dummy variables for statement functions
3085 rr
3086 REAL pi
3087 PARAMETER (pi=3.14159265)
3088
3089 REAL pid6
3090 PARAMETER (pid6=pi/6.0)
3091
3092 ! avogadro's constant [ 1/mol ]
3093 REAL avo
3094 PARAMETER (avo=6.0221367E23)
3095
3096 ! universal gas constant [ j/mol-k ]
3097 REAL rgasuniv
3098 PARAMETER (rgasuniv=8.314510)
3099
3100 ! 1 atmosphere in pascals
3101 REAL atm
3102 PARAMETER (atm=1013.25E+02)
3103
3104 ! formula weight for h2so4 [ g mole **-1 ]
3105 REAL mwh2so4
3106 PARAMETER (mwh2so4=98.07948)
3107
3108 ! diameter of a 3.5 nm particle in cm
3109 REAL d35
3110 PARAMETER (d35=3.5E-07)
3111 REAL d35sq
3112 PARAMETER (d35sq=d35*d35)
3113 ! volume of a 3.5 nm particle in cm**3
3114 REAL v35
3115 PARAMETER (v35=pid6*d35*d35sq)
3116 !ia rev01
3117
3118 REAL mp
3119 ! *** conversion factors:
3120 ! mass of sulfate in a 3.5 nm particle
3121 ! number per cubic cm.
3122 REAL ugm3_ncm3
3123 ! micrograms per cubic meter to
3124 PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12)
3125 !ia rev01
3126 ! molecules to micrograms
3127 REAL nc_ug
3128 PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo)
3129
3130
3131
3132 ! *** statement functions **************
3133
3134 REAL pdens, &
3135 rho_p
3136 ! particle density [ g / cm**3]
3137 REAL ad0, ad1, ad2, &
3138 ad3
3139 ! coefficients for density expression
3140 PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427)
3141 ! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets
3142 ! as a function of relative humidity,
3143 ! J. Aerosol Science, 6, pp 265-271, 1975.
3144
3145 !ia rev01
3146
3147 ! fit to Nair & Vohra data
3148 ! the mass of sulfate in a 3.5 nm particle
3149 REAL mp35
3150 ! arithmetic statement function to compute
3151 REAL a0, a1, a2, & ! coefficients for cubic in mp35
3152 a3
3153 PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2)
3154
3155 REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ]
3156 ph2o
3157
3158
3159 ! arithmetic statement functions
3160 pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3))
3161
3162 ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03)
3163
3164 ph2so4(tt) = exp(27.78492066-10156.0/tt)
3165
3166 ! *** both ph2o and ph2so4 are as in Kulmala et al. paper
3167
3168 !ia rev01
3169
3170 ! *** function for the mass of sulfate in a 3.5 nm sphere
3171 ! *** obtained from a fit to the number of sulfate monomers in
3172 ! a 3.5 nm particle. Uses data from Nair & Vohra
3173 mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3)))
3174
3175
3176
3177 ! *** begin code:
3178
3179 ! The 1.0e-6 factor in the following converts from MKS to cgs units
3180
3181 ! *** get water vapor concentration [ molecles / cm **3 ]
3182
3183 nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6
3184
3185 ! *** calculate the equilibrium h2so4 vapor concentration.
3186
3187 ! *** use Kulmala corrections:
3188
3189
3190 ! ***
3191
3192 nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6
3193
3194 ! *** convert sulfuric acid vapor concentration from micrograms
3195 ! per cubic meter to molecules per cubic centimeter.
3196
3197 nav = ugm3_ncm3*h2so4
3198
3199
3200 ! *** calculate critical concentration of sulfuric acid vapor
3201
3202 nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp)
3203
3204 ! *** calculate relative acidity
3205
3206 ra = nav/nav0
3207
3208 ! *** calculate temperature correction
3209
3210 delta = 1.0 + (temp-273.15)/273.14
3211
3212 ! *** calculate molar fraction
3213
3214 xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + &
3215 0.0016*temp
3216
3217 ! *** calculate Nsulf
3218 nsulf = log(nav/nac)
3219
3220 ! *** calculate particle produtcion rate [ # / cm**3 ]
3221
3222 chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - &
3223 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh
3224
3225 jnuc = exp(chi)
3226 ! [ # / cm**3 ]
3227 ndot1 = (1.0E06)*jnuc
3228 ! write(91,*) ' inside klpnuc '
3229 ! write(91,*) ' Jnuc = ', Jnuc
3230 ! write(91,*) ' NDOT = ', NDOT1
3231
3232 ! *** calculate particle density
3233
3234
3235 rho_p = pdens(rh)
3236
3237 ! write(91,*) ' rho_p =', rho_p
3238
3239 ! *** get the mass of sulfate in a 3.5 nm particle
3240
3241 mp = mp35(rh) ! in a 3.5 nm particle at ambient RH
3242
3243 ! *** calculate mass production rate [ ug / m**3]
3244 ! assume that the particles are 3.5 nm in diameter.
3245
3246
3247 ! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc
3248
3249 !ia rev01
3250
3251 ! number of micrograms of sulfate
3252 mdot1 = mp*ndot1
3253
3254 !ia rev02
3255
3256 IF (mdot1>so4rat) THEN
3257
3258 mdot1 = &
3259 so4rat
3260 ! limit nucleated mass by available ma
3261 ndot1 = mdot1/ &
3262 mp
3263 ! adjust DNDT to this
3264 END IF
3265
3266
3267 IF (mdot1==0.) ndot1 = 0.
3268
3269 ! *** calculate M2 production rate [ m**2 / (m**3 s)]
3270
3271 m2dot = 1.0E-04*d35sq*ndot1
3272
3273 RETURN
3274
3275 END SUBROUTINE klpnuc
3276 SUBROUTINE lnsrch(ctot,n,xold,fold,g,p,x,f,stpmax,check,func, &
3277 fvec,ct,cs,imw,m)
3278 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3279 !bs !
3280 !bs Description: !
3281 !bs !
3282 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3283 !bs !
3284 !bs Given an n-dimensional point XOLD(1:N), the value of the function !
3285 !bs and gradient there, FOLD and G(1:N), and a direction P(1:N), !
3286 !bs finds a new point X(1:N) along the direction P from XOLD where !
3287 !bs the function FUNC has decreased 'sufficiently'. The new function !
3288 !bs value is returned in F. STPMAX is an input quantity that limits !
3289 !bs the length of the steps so that you do not try to evaluate the !
3290 !bs function in regions where it is undefined or subject to overflow. !
3291 !bs P is usually the Newton direction. The output quantity CHECK is !
3292 !bs false on a normal; exit. It is true when X is too close to XOLD. !
3293 !bs In a minimization algorithm, this usually signals convergence and !
3294 !bs can be ignored. However, in a zero-finding algorithm the calling !
3295 !bs program should check whether the convergence is spurious. !
3296 !bs !
3297 !bs Called by: NEWT !
3298 !bs !
3299 !bs Calls: FUNC !
3300 !bs !
3301 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3302
3303 ! IMPLICIT NONE
3304 !bs
3305 !bs
3306 INTEGER n
3307 LOGICAL check
3308 REAL f, fold, stpmax
3309 REAL g(n), p(n), x(n), xold(n)
3310 REAL func
3311 REAL ctot(n)
3312 REAL alf
3313 REAL ct(np)
3314 REAL cs(np)
3315 REAL imw(np)
3316 REAL fvec(n)
3317 REAL m
3318
3319 PARAMETER (alf=1.E-04)
3320
3321 EXTERNAL func
3322
3323 INTEGER i
3324 REAL a, alam, alam2, alamin, b, disc
3325 REAL f2, fold2, rhs1, rhs2, slope
3326 REAL sum, temp, test, tmplam
3327
3328 check = .FALSE.
3329 sum = 0.
3330 DO i = 1, n
3331 sum = sum + p(i)*p(i)
3332 END DO
3333 sum = sqrt(sum)
3334 IF (sum>stpmax) THEN
3335 DO i = 1, n
3336 p(i) = p(i)*stpmax/sum
3337 END DO
3338 END IF
3339 slope = 0.
3340 DO i = 1, n
3341 slope = slope + g(i)*p(i)
3342 END DO
3343 test = 0.
3344 DO i = 1, n
3345 temp = abs(p(i))/max(abs(xold(i)),1.)
3346 IF (temp>test) test = temp
3347 END DO
3348 alamin = tolx/test
3349 alam = 1.
3350
3351 10 CONTINUE
3352
3353 !bs
3354 !bs * avoid negative concentrations and set upper limit given by CTOT.
3355 !bs
3356 DO i = 1, n
3357 x(i) = xold(i) + alam*p(i)
3358 IF (x(i)<=0.) x(i) = conmin
3359 IF (x(i)>ctot(i)) x(i) = ctot(i)
3360 END DO
3361 f = func(x,fvec,n,ct,cs,imw,m)
3362 IF (alam<alamin) THEN
3363 DO i = 1, n
3364 x(i) = xold(i)
3365 END DO
3366 check = .TRUE.
3367 RETURN
3368 ELSE IF (f<=fold+alf*alam*slope) THEN
3369 RETURN
3370 ELSE
3371 IF (alam==1.) THEN
3372 tmplam = -slope/(2.*(f-fold-slope))
3373 ELSE
3374 rhs1 = f - fold - alam*slope
3375 rhs2 = f2 - fold2 - alam2*slope
3376 a = (rhs1/alam**2-rhs2/alam2**2)/(alam-alam2)
3377 b = (-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2)
3378 IF (a==0.) THEN
3379 tmplam = -slope/(2.*b)
3380 ELSE
3381 disc = b*b - 3.*a*slope
3382 tmplam = (-b+sqrt(disc))/(3.*a)
3383 END IF
3384 IF (tmplam>0.5*alam) tmplam = 0.5*alam
3385 END IF
3386 END IF
3387 alam2 = alam
3388 f2 = f
3389 fold2 = fold
3390 alam = max(tmplam,0.1*alam)
3391 GO TO 10
3392
3393 END SUBROUTINE lnsrch
3394 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3395 SUBROUTINE lubksb(a,n,np,indx,b)
3396 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3397 !bs !
3398 !bs Description: !
3399 !bs !
3400 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. !
3401 !bs !
3402 !bs Solves the set of N linear equations A * X = B. Here A is input, !
3403 !bs not as the matrix A but rather as its LU decomposition, !
3404 !bs determined by the routine LUDCMP. B(1:N) is input as the right- !
3405 !bs hand side vector B, and returns with the solution vector X. A, N, !
3406 !bs NP, and INDX are not modified by this routine and can be left in !
3407 !bs place for successive calls with different right-hand sides B. !
3408 !bs This routine takes into account the possibilitythat B will begin !
3409 !bs with many zero elements, so it is efficient for use in matrix !
3410 !bs inversion. !
3411 !bs !
3412 !bs Called by: NEWT !
3413 !bs !
3414 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3415 !bs
3416 ! IMPLICIT NONE
3417 !bs
3418 INTEGER n, np, indx(n)
3419 REAL a(np,np), b(n)
3420
3421 INTEGER i, ii, j, ll
3422 REAL sum
3423
3424 ii = 0
3425 DO i = 1, n
3426 ll = indx(i)
3427 sum = b(ll)
3428 b(ll) = b(i)
3429 IF (ii/=0) THEN
3430 DO j = ii, i - 1
3431 sum = sum - a(i,j)*b(j)
3432 END DO
3433 ELSE IF (sum/=0) THEN
3434 ii = i
3435 END IF
3436 b(i) = sum
3437 END DO
3438 DO i = n, 1, -1
3439 sum = b(i)
3440 DO j = i + 1, n
3441 sum = sum - a(i,j)*b(j)
3442 END DO
3443 b(i) = sum/a(i,i)
3444 END DO
3445
3446 RETURN
3447 END SUBROUTINE lubksb
3448 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3449 SUBROUTINE ludcmp(a,n,np,indx,d,klev)
3450 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3451 !bs !
3452 !bs Description: !
3453 !bs !
3454 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 2.3, 2nd ed. !
3455 !bs !
3456 !bs Equation (2.3.14) Numerical Recipes, p 36: !
3457 !bs | b_11 b_12 b_13 b_14 | !
3458 !bs | a_21 b_22 b_23 b_24 | !
3459 !bs | a_31 a_32 b_33 b_34 | !
3460 !bs | a_41 a_42 a_43 b_44 | !
3461 !bs !
3462 !bs Given a matrix A(1:N,1:N), with physical dimension NP by NP, this !
3463 !bs routine replaces it by the LU decomposition of a rowwise !
3464 !bs permutation of itself. A and N are input. A is output arranged as !
3465 !bs in equation (2.3.14) above; INDX(1:N) is an output vector that !
3466 !bs records vector that records the row permutation effected by the !
3467 !bs partial pivoting; D is output as +-1 depending on whether the !
3468 !bs number of row interchanges was even or odd, respectively. This !
3469 !bs routine is used in combination with SR LUBKSB to solve linear !
3470 !bs equations or invert a matrix. !
3471 !bs !
3472 !bs Called by: NEWT !
3473 !bs !
3474 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3475 !bs
3476 ! IMPLICIT NONE
3477 !bs
3478 INTEGER n, np, indx(n)
3479 INTEGER nmax
3480 PARAMETER (nmax=10) !largest expected N
3481 REAL d, a(np,np)
3482 REAL tiny
3483 PARAMETER (tiny=1.0E-20)
3484
3485 INTEGER i, imax, j, k
3486 REAL aamax, dum, sum, vv(nmax)
3487 integer klev
3488
3489 d = 1
3490 DO i = 1, n
3491 aamax = 0.
3492 DO j = 1, n
3493 IF (abs(a(i,j))>aamax) aamax = abs(a(i,j))
3494 END DO
3495 IF (aamax==0) THEN
3496 print *, 'Singular matrix in ludcmp, klev = ',klev
3497 a(1,1)=epsilc
3498 ! STOP
3499 END IF
3500 vv(i) = 1./aamax
3501 END DO
3502 DO j = 1, n
3503 DO i = 1, j - 1
3504 sum = a(i,j)
3505 DO k = 1, i - 1
3506 sum = sum - a(i,k)*a(k,j)
3507 END DO
3508 a(i,j) = sum
3509 END DO
3510 aamax = 0.
3511 DO i = j, n
3512 sum = a(i,j)
3513 DO k = 1, j - 1
3514 sum = sum - a(i,k)*a(k,j)
3515 END DO
3516 a(i,j) = sum
3517 dum = vv(i)*abs(sum)
3518 IF (dum>=aamax) THEN
3519 imax = i
3520 aamax = dum
3521 END IF
3522 END DO
3523 IF (j/=imax) THEN
3524 DO k = 1, n
3525 dum = a(imax,k)
3526 a(imax,k) = a(j,k)
3527 a(j,k) = dum
3528 END DO
3529 d = -d
3530 vv(imax) = vv(j)
3531 END IF
3532 indx(j) = imax
3533 IF (a(j,j)==0.) a(j,j) = tiny
3534 IF (j/=n) THEN
3535 dum = 1./a(j,j)
3536 DO i = j + 1, n
3537 a(i,j) = a(i,j)*dum
3538 END DO
3539 END IF
3540 END DO
3541
3542 RETURN
3543 END SUBROUTINE ludcmp
3544
3545 ! //////////////////////////////////////////////////////////////////
3546
3547 SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, &
3548 pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, &
3549 knacc,kncor)
3550 !***********************************************************************
3551
3552
3553
3554 !** DESCRIPTION:
3555 ! Calculates modal parameters and derived variables,
3556 ! log-squared of std deviation, mode mean size, Knudsen number)
3557 ! based on current values of moments for the modes.
3558 ! FSB Now calculates the 3rd moment, mass, and density in all 3 modes.
3559 !**
3560 !** Revision history:
3561 ! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3
3562 ! Revised 7/23/96 by FSB to use COMMON blocks and small blocks
3563 ! instead of large 3-d arrays, and to assume a fixed std.
3564 ! Revised 12/06/96 by FSB to include coarse mode
3565 ! Revised 1/10/97 by FSB to have arrays passed in call vector
3566 !**********************************************************************
3567
3568 ! IMPLICIT NONE
3569
3570 ! Includes:
3571
3572
3573 ! *** input:
3574
3575 ! dimension of arrays
3576 INTEGER blksize
3577 ! actual number of cells in arrays
3578 INTEGER numcells
3579
3580 INTEGER nspcsda
3581
3582 ! nmber of species in CBLK
3583 REAL cblk(blksize,nspcsda) ! main array of variables
3584 REAL blkta(blksize) ! Air temperature [ K ]
3585 REAL blkprs(blksize)
3586 ! *** output:
3587
3588 ! Air pressure in [ Pa ]
3589 ! concentration lower limit [ ug/m*
3590 ! lowest particle diameter ( m )
3591 REAL dgmin
3592 PARAMETER (dgmin=1.0E-09)
3593
3594 ! lowest particle density ( Kg/m**3
3595 REAL densmin
3596 PARAMETER (densmin=1.0E03)
3597
3598 REAL pmassn(blksize) ! mass concentration in nuclei mode
3599 REAL pmassa(blksize) ! mass concentration in accumulation
3600 REAL pmassc(blksize) ! mass concentration in coarse mode
3601 REAL pdensn(blksize) ! average particel density in Aitken
3602 REAL pdensa(blksize) ! average particel density in accumu
3603 REAL pdensc(blksize) ! average particel density in coarse
3604 REAL xlm(blksize) ! atmospheric mean free path [ m]
3605 REAL amu(blksize) ! atmospheric dynamic viscosity [ kg
3606 REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ]
3607 REAL dgacc(blksize) ! accumulation
3608 REAL dgcor(blksize) ! coarse mode
3609 REAL knnuc(blksize) ! Aitken mode Knudsen number
3610 REAL knacc(blksize) ! accumulation
3611 REAL kncor(blksize)
3612
3613 ! coarse mode
3614
3615 INTEGER lcell
3616 ! WRITE(20,*) ' IN MODPAR '
3617
3618 ! *** set up aerosol 3rd moment, mass, density
3619
3620 ! loop counter
3621 DO lcell = 1, numcells
3622
3623 ! *** Aitken-mode
3624 cblk(lcell,vnu3) = so4fac*cblk(lcell, &
3625 vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, &
3626 vh2oai)+no3fac*cblk(lcell,vno3ai)+orgfac*cblk(lcell, &
3627 vorgaro1i)+orgfac*cblk(lcell,vorgaro2i)+orgfac*cblk(lcell, &
3628 vorgalk1i)+orgfac*cblk(lcell,vorgole1i)+orgfac*cblk(lcell, &
3629 vorgba1i)+orgfac*cblk(lcell,vorgba2i)+orgfac*cblk(lcell, &
3630 vorgba3i)+orgfac*cblk(lcell,vorgba4i)+orgfac*cblk(lcell, &
3631 vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci)
3632
3633
3634
3635 ! *** Accumulation-mode
3636
3637 cblk(lcell,vac3) = so4fac*cblk(lcell, &
3638 vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, &
3639 vh2oaj)+no3fac*cblk(lcell,vno3aj)+orgfac*cblk(lcell, &
3640 vorgaro1j)+orgfac*cblk(lcell,vorgaro2j)+orgfac*cblk(lcell, &
3641 vorgalk1j)+orgfac*cblk(lcell,vorgole1j)+orgfac*cblk(lcell, &
3642 vorgba1j)+orgfac*cblk(lcell,vorgba2j)+orgfac*cblk(lcell, &
3643 vorgba3j)+orgfac*cblk(lcell,vorgba4j)+orgfac*cblk(lcell, &
3644 vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj)
3645
3646 ! *** coarse mode
3647
3648 cblk(lcell,vcor3) = soilfac*cblk(lcell, &
3649 vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha)
3650
3651 ! *** now get particle mass and density
3652
3653 ! *** Aitken-mode:
3654
3655 pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, &
3656 vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, &
3657 vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, &
3658 vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, &
3659 vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, &
3660 vp25ai)+cblk(lcell,veci)))
3661
3662
3663 ! *** Accumulation-mode:
3664
3665 pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, &
3666 vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, &
3667 vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, &
3668 vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, &
3669 vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, &
3670 vp25aj)+cblk(lcell,vecj)))
3671
3672
3673 ! *** coarse mode:
3674
3675 pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( &
3676 lcell,vantha))
3677
3678
3679
3680 END DO
3681 ! *** now get particle density, mean free path, and dynamic viscosity
3682
3683 ! aerosol 3rd moment and mass
3684 DO lcell = 1, &
3685 numcells
3686 ! *** density in [ kg m**-3 ]
3687
3688 ! Density and mean free path
3689 pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3)))
3690 pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3)))
3691 pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3)))
3692
3693 ! *** Calculate mean free path [ m ]:
3694
3695 xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell))
3696
3697 ! *** 6.6328E-8 is the sea level values given in Table I.2.8
3698 ! *** on page 10 of U.S. Standard Atmosphere 1962
3699
3700 ! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]:
3701
3702 ! *** U.S. Standard Atmosphere 1962 page 14 expression
3703 ! for dynamic viscosity is:
3704 ! dynamic viscosity = beta * T * sqrt(T) / ( T + S)
3705 ! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ].
3706
3707 amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ &
3708 (blkta(lcell)+110.4)
3709
3710
3711 END DO
3712
3713 !............... Standard deviation fixed in both modes, so
3714 !............... diagnose diameter from 3rd moment and number concentr
3715
3716
3717 ! density and mean free path
3718 DO lcell = 1, &
3719 numcells
3720
3721 ! calculate diameters
3722 dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** &
3723 one3)
3724
3725
3726 dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** &
3727 one3)
3728
3729
3730 dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) &
3731 **one3)
3732
3733
3734 END DO
3735 ! end loop on diameters
3736 DO lcell = 1, &
3737 numcells
3738 ! Calculate Knudsen numbers
3739 knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell)
3740
3741 knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell)
3742
3743 kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell)
3744
3745
3746 END DO
3747
3748 ! end loop for Knudsen numbers
3749 RETURN
3750
3751 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3752 END SUBROUTINE modpar
3753 ! modpar
3754 SUBROUTINE newt(layer,x,n,check,ctot,csat,imwcv,minitw,its)
3755 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3756 !bs !
3757 !bs Description: !
3758 !bs !
3759 !bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. !
3760 !bs !
3761 !bs Given an initial guess X(1:N) for a root in N dimensions, find !
3762 !bs the root by globally convergent Newton's method. The vector of !
3763 !bs functions to be zeroed, called FVEC(1:N) in the routine below. is !
3764 !bs retuned by a user-supplied function that must be called FUNCV and !
3765 !bs have the declaration SUBROUTINE FUNCV(NX,FVEC). The output !
3766 !bs quantity CHECK is false on a normal return and true if the !
3767 !bs routine has converged to a local minimum of the function FMIN !
3768 !bs defined below. In this case try restarting from a different !
3769 !bs initial guess. !
3770 !bs !
3771 !bs PARAMETERS !
3772 !bs NP : maximum expected value of N !
3773 !bs MAXITS : maximum number of iterations !
3774 !bs TOLF : convergence criterion on function values !
3775 !bs TOLMIN : criterion for decidingwhether spurios convergence to a !
3776 !bs minimum of FMIN has ocurred !
3777 !bs TOLX : convergence criterion on delta_X !
3778 !bs STPMX : scaled maximum step length allowed in line searches !
3779 !bs !
3780 !bs Called by: SOA_PART !
3781 !bs !
3782 !bs Calls: FDJAC !
3783 !bs FMIN !
3784 !bs LNSRCH !
3785 !bs LUBKSB !
3786 !bs LUDCMP !
3787 !bs !
3788 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
3789 !bs
3790 ! IMPLICIT NONE
3791 !bs
3792 !bs * includes
3793 !bs
3794 !bs
3795 !bs * input variables
3796 !bs
3797 !bs model layer
3798 INTEGER layer
3799 !bs dimension of problem
3800 INTEGER n
3801 REAL x(n) !bs initial guess of CAER
3802 LOGICAL check
3803 REAL ctot(n) !bs total concentration GAS + AER + PROD
3804 REAL csat(n) !bs saturation conc. of cond. vapor [ug/m^
3805 REAL imwcv(n) !bs inverse molecular weights
3806 !bs
3807 REAL minitw
3808 !bs * following Numerical recipes
3809 !bs
3810 !bs weighted initial mass
3811 INTEGER nn
3812 ! INTEGER NP
3813 ! PARAMETER (NP = 6)
3814 REAL fvec(np) !bs
3815 !bs
3816 !bs vector of functions to be zeroed
3817 REAL ct(np)
3818 REAL cs(np)
3819 REAL imw(np)
3820 REAL m
3821 !bs
3822 INTEGER i, its, j, indx(np)
3823 REAL d, den, f, fold, stpmax, sum, temp, test
3824 REAL fjac(np,np)
3825 REAL g(np), p(np), xold(np)
3826 !bs
3827 ! EXTERNAL fmin
3828 !bs
3829 !bs * begin code
3830 !bs
3831 m = minitw
3832 DO i = 1, n
3833 ct(i) = ctot(i)
3834 cs(i) = csat(i)
3835 imw(i) = imwcv(i)
3836 END DO
3837 !bs
3838 nn = n
3839 f = fmin(x,fvec,nn,ct,cs,imw,m) !The vector FVEC is
3840 test = & !Test for initial guess being a root. Us
3841 0.
3842 DO i = 1, & !stringent test than simply TOLF.
3843 n
3844 IF (abs(fvec(i))>test) test = abs(fvec(i))
3845 END DO
3846 IF (test<0.01*tolf) RETURN
3847 sum = & !Calculate STPMAX for line searches
3848 0.
3849 DO i = 1, n
3850 sum = sum + x(i)**2
3851 END DO
3852 stpmax = stpmx*max(sqrt(sum),float(n))
3853 DO its = 1, & !start of iteration loop
3854 maxits
3855 CALL fdjac(n,x,fjac,ct,cs,imw) !get Jacobian
3856 DO i = 1, & !compute Delta f for line search
3857 n
3858 sum = 0.
3859 DO j = 1, n
3860 sum = sum + fjac(j,i)*fvec(j)
3861 END DO
3862 g(i) = sum
3863 END DO
3864 DO i = 1, & !store X
3865 n
3866 xold(i) = x(i)
3867 END DO
3868 fold = & !store F
3869 f
3870 DO i = 1, & !right-hand side for linear equations
3871 n
3872 p(i) = -fvec(i)
3873 END DO
3874 CALL ludcmp(fjac,n,np,indx,d,layer) !solve linear equations by LU dec
3875 CALL lubksb(fjac,n,np,indx,p)
3876 CALL lnsrch(ctot,n,xold,fold,g, & !LNSRCH returns new X and F. It a
3877 p,x,f,stpmax, & !calculates FVEC at the new X whe
3878 check,fmin,fvec,ct,cs,imw,m) !calls FMIN
3879 test = 0.
3880 DO i = 1, n
3881 IF (abs(fvec(i))>test) test = abs(fvec(i))
3882 END DO
3883 IF (test<tolf) THEN
3884 check = .FALSE.
3885 RETURN
3886 END IF
3887 IF (check) & !Check for gradient of F zero,
3888 THEN
3889 test = & !i.e., superious convergence.
3890 0.
3891 den = max(f,0.5*n)
3892 DO i = 1, n
3893 temp = abs(g(i))*max(abs(x(i)),1.)/den
3894 IF (temp>test) test = temp
3895 END DO
3896 IF (test<tolmin) THEN
3897 check = .TRUE.
3898 ELSE
3899 check = .FALSE.
3900 END IF
3901 RETURN
3902 END IF
3903 test = & !Test for convergence on delta_x
3904 0.
3905 DO i = 1, n
3906 temp = (abs(x(i)-xold(i)))/max(abs(x(i)),1.)
3907 IF (temp>test) test = temp
3908 END DO
3909 IF (test<tolx) RETURN
3910 END DO
3911 ! WRITE (6,'(a,i2)') 'MAXITS exceeded in newt.F ! Layer: ', layer
3912 !bs
3913 END SUBROUTINE newt
3914 ! //////////////////////////////////////////////////////////////////
3915
3916 SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, &
3917 blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat,orgole1rat,orgbio1rat, &
3918 orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv,nacv,dgnuc,dgacc, &
3919 fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3)
3920 !***********************************************************************
3921 !** DESCRIPTION: calculates aerosol nucleation and condensational
3922 !** growth rates using Binkowski and Shankar (1995) method.
3923
3924 ! *** In this version, the method od RPM is followed where
3925 ! the diffusivity, the average molecular ve3locity, and
3926 ! the accomodation coefficient for sulfuric acid are used for
3927 ! the organics. This is for consistency.
3928 ! Future versions will use the correct values. FSB 12/12/96
3929
3930
3931 !**
3932 !** Revision history:
3933 ! prototype 1/95 by Uma and Carlie
3934 ! Corrected 7/95 by Uma for condensation of mass not nucleated
3935 ! and mass conservation check
3936 ! Revised 8/95 by US to calculate air density in stmt function
3937 ! and collect met variable stmt funcs in one include fil
3938 ! Revised 7/25/96 by FSB to use block structure.
3939 ! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism
3940 ! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units.
3941 ! Revised 1/13/97 by FSB to pass arrays and simplify code.
3942 ! Added 23/03/99 by BS growth factors for organics
3943 !**********************************************************************
3944
3945 ! IMPLICIT NONE
3946
3947 ! Includes:
3948
3949
3950 ! *** arguments
3951
3952 ! *** input;
3953
3954 ! dimension of arrays
3955 INTEGER blksize
3956 INTEGER layer
3957 ! number of species in CBLK
3958 INTEGER nspcsda
3959 ! actual number of cells in arrays
3960 INTEGER numcells
3961
3962 INTEGER ldrog
3963 ! # of organic aerosol precursor
3964 REAL cblk(blksize,nspcsda) ! main array of variables
3965 ! model time step in SECONDS
3966 REAL dt
3967 REAL blkta(blksize) ! Air temperature [ K ]
3968 REAL blkprs(blksize) ! Air pressure in [ Pa ]
3969 REAL blkrh(blksize) ! Fractional relative humidity
3970 REAL so4rat(blksize) ! rate [ ug/m**3 /s ]
3971 !bs
3972 ! sulfate gas-phase production
3973 ! total # of cond. vapors & SOA spe
3974 INTEGER ncv
3975 !bs
3976 INTEGER nacv
3977 !bs * anthropogenic organic condensable vapor production rate
3978 ! # of anthrop. cond. vapors & SOA
3979 REAL drog(blksize,ldrog) !bs
3980 ! Delta ROG conc. [ppm]
3981 REAL orgaro1rat(blksize) ! production rate from aromatics [ug/m**
3982 ! anthropogenic organic aerosol mass
3983 REAL orgaro2rat(blksize) ! production rate from aromatics [ug/m**
3984 ! anthropogenic organic aerosol mass
3985 REAL orgalk1rat(blksize) ! production rate from alkanes & others
3986 ! anthropogenic organic aerosol mass
3987 REAL orgole1rat(blksize) ! production rate from alkenes & others
3988 !bs * biogenic organic condensable vapor production rate
3989 ! anthropogenic organic aerosol mass
3990 REAL orgbio1rat(blksize) ! rate [ ug/m**3 /s ]
3991 ! biogenic organic aerosol production
3992 REAL orgbio2rat(blksize) ! rate [ ug/m**3 /s ]
3993 ! biogenic organic aerosol production
3994 REAL orgbio3rat(blksize) ! rate [ ug/m**3 /s ]
3995 ! biogenic organic aerosol production
3996 REAL orgbio4rat(blksize) ! rate [ ug/m**3 /s ]
3997 !bs
3998 ! biogenic organic aerosol production
3999 REAL dgnuc(blksize) ! accumulation
4000 REAL dgacc(blksize)
4001 ! *** output:
4002
4003 ! coarse mode
4004 REAL fconcn(blksize) ! Aitken mode [ 1 / s ]
4005 ! reciprocal condensation rate
4006 REAL fconca(blksize) ! acclumulation mode [ 1 / s ]
4007 ! reciprocal condensation rate
4008 REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ]
4009 ! reciprocal condensation rate
4010 REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ]
4011 ! reciprocal condensation rate
4012 REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ]
4013 ! rate of production of new mass concent
4014 REAL dndt(blksize) ! concentration by particle formation [#
4015 ! rate of producton of new particle numb
4016 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m
4017 ! increment of concentration added to
4018 REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ]
4019 ! growth rate for 3rd moment for
4020 REAL cgra3(blksize) ! Accumulation mode
4021
4022 !........... SCRATCH local variables and their descriptions:
4023
4024 ! growth rate for 3rd moment for
4025
4026 INTEGER lcell
4027
4028 ! LOOP INDEX
4029 ! conv rate so2 --> so4 [mom-3/g/s]
4030 REAL chemrat
4031 ! conv rate for organics [mom-3/g/s]
4032 REAL chemrat_org
4033 REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_
4034 am1a
4035 REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_
4036 am2a
4037 REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den
4038 gnc3a
4039 REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den
4040 gfm3a
4041 ! total reciprocal condensation rate
4042 REAL fconc
4043
4044 REAL td
4045 ! d * tinf (cgs)
4046 REAL*8 & ! Cnstant to force 64 bit evaluation of
4047 one88
4048 PARAMETER (one88=1.0D0)
4049 ! *** variables to set up sulfate and organic condensation rates
4050
4051 ! sulfuric acid vapor at current time step
4052 REAL vapor1
4053 ! chemistry and emissions
4054 REAL vapor2
4055 ! Sulfuric acid vapor prior to addition from
4056 !bs
4057 REAL deltavap
4058 !bs * start update
4059 !bs
4060 ! change to vapor at previous time step
4061 REAL diffcorr
4062
4063 !bs *
4064 REAL csqt_org
4065 !bs * end update
4066 !bs
4067
4068 REAL csqt
4069 !.......................................................................
4070 ! begin body of subroutine NUCLCOND
4071
4072
4073 !........... Main computational grid-traversal loop nest
4074 !........... for computing condensation and nucleation:
4075
4076 DO lcell = 1, &
4077 numcells
4078 ! *** First moment:
4079
4080 ! 1st loop over NUMCELLS
4081 am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04
4082 am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04
4083
4084 !.............. near-continuum factors [ 1 / sec ]
4085 !bs
4086 !bs * adopted from code of FSB
4087 !bs * correction to DIFFSULF and DIFFORG for temperature and pressure
4088 !bs
4089 diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1.
4090 !bs
4091 gnc3n = cconc*am1n*diffcorr
4092 gnc3a = cconc*am1a*diffcorr
4093
4094
4095 ! *** Second moment:
4096
4097 am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16
4098 am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16
4099
4100 csqt = ccofm*sqrt(blkta(lcell))
4101 !............... free molecular factors [ 1 / sec ]
4102
4103 ! put in temperature fac
4104 gfm3n = csqt*am2n
4105 gfm3a = csqt*am2a
4106
4107 ! *** Condensation factors in [ s**-1] for h2so4
4108 ! *** In the future, separate factors for condensing organics will
4109 ! be included. In this version, the h2so4 values are used.
4110
4111 !............... Twice the harmonic mean of fm, nc functions:
4112
4113 ! *** Force 64 bit evaluation:
4114
4115 fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4116 fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4117 fconc = fconcn(lcell) + fconca(lcell)
4118
4119 ! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<<
4120 !bs
4121 !bs * start modifications for organcis
4122 !bs
4123 gnc3n = cconc_org*am1n*diffcorr
4124 gnc3a = cconc_org*am1a*diffcorr
4125 !bs
4126 csqt_org = ccofm_org*sqrt(blkta(lcell))
4127 gfm3n = csqt_org*am2n
4128 gfm3a = csqt_org*am2a
4129 !bs
4130 fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n)
4131 fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a)
4132 !bs
4133 !bs * end modifications for organics
4134 !bs
4135 ! *** calculate the total change to sulfuric acid vapor from production
4136 ! and condensation
4137
4138 vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor
4139 vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* &
4140 dt
4141 ! vapor at prev
4142 vapor2 = max(0.0,vapor2)
4143
4144 deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt)))
4145
4146 ! *** Calculate increment in total sufate aerosol mass concentration
4147
4148 ! *** This follows the method of Youngblood & Kreidenweis.
4149
4150 !bs
4151 !bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP)
4152 !bs
4153 !bs * allow DELTASO4A to be negative, but the change must not be larger
4154 !bs * than the amount of vapor available.
4155 !bs
4156 deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), &
4157 so4rat(lcell)*dt-deltavap)
4158 !bs
4159
4160 ! *** zero out growth coefficients
4161
4162 cgrn3(lcell) = 0.0
4163 cgra3(lcell) = 0.0
4164
4165
4166 END DO
4167
4168 ! *** Select method of nucleation
4169
4170 ! End 1st loop over NUMCELLS
4171 IF (inucl==1) THEN
4172
4173 ! *** Do Youngblood & Kreidenweis Nucleation
4174
4175 ! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4176 ! & DNDT,DMDT,NUMCELLS,BLKSIZE,
4177 ! & VAPOR1)
4178 ! IF (firstime) THEN
4179 ! WRITE (6,*)
4180 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4181 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4182 ! firstime = .FALSE.
4183 ! END IF
4184
4185 ELSE IF (inucl==0) THEN
4186
4187 ! *** Do Kerminen & Wexler Nucleation
4188
4189 ! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH,
4190 ! & DNDT,DMDT,NUMCELLS,BLKSIZE)
4191 ! IF (firstime) THEN
4192 ! WRITE (6,*)
4193 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4194 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4195 ! firstime = .FALSE.
4196 ! END IF
4197
4198
4199 ELSE IF (inucl==2) THEN
4200
4201 !bs ** Do Kulmala et al. Nucleation
4202 ! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)
4203
4204 if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then
4205 CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4206 else
4207 dndt(1)=0.
4208 dmdt(1)=0.
4209 endif
4210
4211
4212 ! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1))
4213 if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1)
4214 IF (dndt(1)==0.) dmdt(1) = 0.
4215 IF (dmdt(1)==0.) dndt(1) = 0.
4216 ! IF (firstime) THEN
4217 ! WRITE (6,*)
4218 ! WRITE (6,'(a,i2)') 'INUCL =', inucl
4219 ! WRITE (90,'(a,i2)') 'INUCL =', inucl
4220 ! firstime = .FALSE.
4221 ! END IF
4222 ! ELSE
4223 ! WRITE (6,'(a)') '*************************************'
4224 ! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!'
4225 ! WRITE (6,'(a)') ' PROGRAM TERMINATED !!'
4226 ! WRITE (6,'(a)') '*************************************'
4227 ! STOP
4228
4229 END IF
4230 !bs
4231 !bs * Secondary organic aerosol module (SORGAM)
4232 !bs
4233 ! end of selection of nucleation method
4234 CALL sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
4235 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
4236 nacv,cblk,blksize,nspcsda,numcells,dt)
4237 !bs
4238 !bs * Secondary organic aerosol module (SORGAM)
4239 !bs
4240
4241 DO lcell = 1, numcells
4242
4243 ! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL
4244 ! condensation factors
4245
4246 td = 1.0/(fconcn(lcell)+fconca(lcell))
4247 fconcn(lcell) = td*fconcn(lcell)
4248 fconca(lcell) = td*fconca(lcell)
4249 !bs
4250 td = 1.0/(fconcn_org(lcell)+fconca_org(lcell))
4251 fconcn_org(lcell) = td*fconcn_org(lcell)
4252 fconca_org(lcell) = td*fconca_org(lcell)
4253 !bs
4254 END DO
4255
4256 ! *** Begin second loop over cells
4257
4258 DO lcell = 1, &
4259 numcells
4260 ! *** note CHEMRAT includes species other than sulfate.
4261
4262 ! 3rd loop on NUMCELLS
4263 chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s-
4264 chemrat_org = orgfac*(orgaro1rat(lcell)+orgaro2rat(lcell)+orgalk1rat( &
4265 lcell)+orgole1rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ &
4266 orgbio3rat(lcell)+orgbio4rat(lcell))
4267 ! *** Calculate the production rates for new particle
4268
4269 ! [mom3 m**-3 s-
4270 cgrn3(lcell) = so4fac*dmdt(lcell)
4271 ! Rate of increase of 3rd
4272 chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro
4273
4274 !bs Remove the rate of new pa
4275 chemrat = max(chemrat,0.0)
4276 ! *** Now calculate the rate of condensation on existing particles.
4277
4278 ! Prevent CHEMRAT from being negativ
4279 cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + &
4280 chemrat_org*fconcn_org(lcell)
4281
4282 cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell)
4283
4284 ! ***
4285
4286 END DO
4287 ! end 2nd loop over NUMCELLS
4288 RETURN
4289
4290 END SUBROUTINE nuclcond
4291 !23456789012345678901234567890123456789012345678901234567890123456789012
4292
4293 ! nuclcond
4294 REAL FUNCTION poly4(a,x)
4295 REAL a(4), x
4296
4297 poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4))))
4298 RETURN
4299 END FUNCTION poly4
4300 REAL FUNCTION poly6(a,x)
4301 REAL a(6), x
4302
4303 poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6))))))
4304 RETURN
4305 END FUNCTION poly6
4306
4307
4308 !-----------------------------------------------------------------------
4309
4310
4311
4312 SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, &
4313 gnh3,gno3)
4314
4315 !-----------------------------------------------------------------------
4316
4317 ! Description:
4318
4319 ! ARES calculates the chemical composition of a sulfate/nitrate/
4320 ! ammonium/water aerosol based on equilibrium thermodynamics.
4321
4322 ! This code considers two regimes depending upon the molar ratio
4323 ! of ammonium to sulfate.
4324
4325 ! For values of this ratio less than 2,the code solves a cubic for
4326 ! hydrogen ion molality, HPLUS, and if enough ammonium and liquid
4327 ! water are present calculates the dissolved nitric acid. For molal
4328 ! ionic strengths greater than 50, nitrate is assumed not to be presen
4329
4330 ! For values of the molar ratio of 2 or greater, all sulfate is assume
4331 ! to be ammonium sulfate and a calculation is made for the presence of
4332 ! ammonium nitrate.
4333
4334 ! The Pitzer multicomponent approach is used in subroutine ACTCOF to
4335 ! obtain the activity coefficients. Abandoned -7/30/97 FSB
4336
4337 ! The Bromley method of calculating the activity coefficients is s use
4338 ! in this version
4339
4340 ! The calculation of liquid water
4341 ! is done in subroutine water. Details for both calculations are given
4342 ! in the respective subroutines.
4343
4344 ! Based upon MARS due to
4345 ! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld,
4346 ! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986.
4347
4348 ! and SCAPE due to
4349 ! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology,
4350 ! Vol 19, number 2, pages 157-181 and pages 182-198, 1993.
4351
4352 ! NOTE: All concentrations supplied to this subroutine are TOTAL
4353 ! over gas and aerosol phases
4354
4355 ! Parameters:
4356
4357 ! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN)
4358 ! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN)
4359 ! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN)
4360 ! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN)
4361 ! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN)
4362 ! RH : Fractional relative humidity (IN)
4363 ! TEMP : Temperature in Kelvin (IN)
4364 ! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT)
4365 ! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT)
4366 ! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT)
4367 ! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT)
4368 ! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT)
4369 ! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT)
4370 ! NITR : Number of iterations for obtaining activity coefficients (OU
4371 ! NR : Number of real roots to the cubic in the low ammonia case (OU
4372
4373 ! Revision History:
4374 ! Who When Detailed description of changes
4375 ! --------- -------- -------------------------------------------
4376 ! S.Roselle 11/10/87 Received the first version of the MARS code
4377 ! S.Roselle 12/30/87 Restructured code
4378 ! S.Roselle 2/12/88 Made correction to compute liquid-phase
4379 ! concentration of H2O2.
4380 ! S.Roselle 5/26/88 Made correction as advised by SAI, for
4381 ! computing H+ concentration.
4382 ! S.Roselle 3/1/89 Modified to operate with EM2
4383 ! S.Roselle 5/19/89 Changed the maximum ionic strength from
4384 ! 100 to 20, for numerical stability.
4385 ! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case
4386 ! using equations for nitrate budget.
4387 ! F.Binkowski 6/18/91 New ammonia poor case which
4388 ! omits letovicite.
4389 ! F.Binkowski 7/25/91 Rearranged entire code, restructured
4390 ! ammonia poor case.
4391 ! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output
4392 ! as SO4--
4393 ! F.Binkowski 12/6/91 Changed the ammonia defficient case so that
4394 ! there is only neutralized sulfate (ammonium
4395 ! sulfate) and sulfuric acid.
4396 ! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen
4397 ! with the Cohen et al. (1987) maximum molalit
4398 ! of 36.2 in Table III.( J. Phys Chem (91) page
4399 ! 4569, and Table IV p 4587.)
4400 ! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem
4401 ! possibility for denomenator becoming zero;
4402 ! this involved solving for HPLUS first.
4403 ! Note that for a relative humidity
4404 ! less than 50%, the model assumes that there i
4405 ! aerosol nitrate.
4406 ! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System
4407 ! Redid logic as follows
4408 ! 1. Water algorithm now follows Spann & Richard
4409 ! 2. Pitzer Multicomponent method used
4410 ! 3. Multicomponent practical osmotic coefficien
4411 ! use to close iterations.
4412 ! 4. The model now assumes that for a water
4413 ! mass fraction WFRAC less than 50% there is
4414 ! no aerosol nitrate.
4415 ! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p
4416 ! case, and changed the WFRAC criterion to 40%.
4417 ! For ammonium to sulfate ratio less than 1.0
4418 ! all ammonium is aerosol and no nitrate aerosol
4419 ! exists.
4420 ! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case
4421 ! allow gas-phase ammonia to exist.
4422 ! F.Binkowski 7/26/95 Changed equilibrium constants to values from
4423 ! Kim et al. (1993)
4424 ! F.Binkowski 6/27/96 Changed to new water format
4425 ! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent
4426 ! activity coefficients. The binary activity coe
4427 ! are the same as the previous version
4428 ! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e
4429 ! 1 picogram per cubic meter
4430
4431 !-----------------------------------------------------------------------
4432
4433 ! IMPLICIT NONE
4434
4435 !...........INCLUDES and their descriptions
4436
4437 !cc INCLUDE SUBST_CONST ! constants
4438
4439 !...........PARAMETERS and their descriptions:
4440
4441 ! molecular weight for NaCl
4442 REAL mwnacl
4443 PARAMETER (mwnacl=58.44277)
4444
4445 ! molecular weight for NO3
4446 REAL mwno3
4447 PARAMETER (mwno3=62.0049)
4448
4449 ! molecular weight for HNO3
4450 REAL mwhno3
4451 PARAMETER (mwhno3=63.01287)
4452
4453 ! molecular weight for SO4
4454 REAL mwso4
4455 PARAMETER (mwso4=96.0576)
4456
4457 ! molecular weight for HSO4
4458 REAL mwhso4
4459 PARAMETER (mwhso4=mwso4+1.0080)
4460
4461 ! molecular weight for H2SO4
4462 REAL mh2so4
4463 PARAMETER (mh2so4=98.07354)
4464
4465 ! molecular weight for NH3
4466 REAL mwnh3
4467 PARAMETER (mwnh3=17.03061)
4468
4469 ! molecular weight for NH4
4470 REAL mwnh4
4471 PARAMETER (mwnh4=18.03858)
4472
4473 ! molecular weight for Organic Specie
4474 REAL mworg
4475 PARAMETER (mworg=16.0)
4476
4477 ! molecular weight for Chloride
4478 REAL mwcl
4479 PARAMETER (mwcl=35.453)
4480
4481 ! molecular weight for AIR
4482 REAL mwair
4483 PARAMETER (mwair=28.964)
4484
4485 ! molecular weight for Letovicite
4486 REAL mwlct
4487 PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080)
4488
4489 ! molecular weight for Ammonium Sulfa
4490 REAL mwas
4491 PARAMETER (mwas=2.0*mwnh4+mwso4)
4492
4493 ! molecular weight for Ammonium Bisul
4494 REAL mwabs
4495 PARAMETER (mwabs=mwnh4+mwso4+1.0080)
4496
4497 !...........ARGUMENTS and their descriptions
4498
4499 !iamodels3
4500 REAL so4
4501 ! Total sulfate in micrograms / m**3
4502 ! Total nitric acid in micrograms / m
4503 REAL hno3
4504 ! Total nitrate in micrograms / m**3
4505 REAL no3
4506 ! Total ammonia in micrograms / m**3
4507 REAL nh3
4508 ! Total ammonium in micrograms / m**3
4509 REAL nh4
4510 ! Fractional relative humidity
4511 REAL rh
4512 ! Temperature in Kelvin
4513 REAL temp
4514 ! Aerosol sulfate in micrograms / m**
4515 REAL aso4
4516 ! Aerosol nitrate in micrograms / m**
4517 REAL ano3
4518 ! Aerosol liquid water content water
4519 REAL ah2o
4520 ! Aerosol ammonium in micrograms / m*
4521 REAL anh4
4522 ! Gas-phase nitric acid in micrograms
4523 REAL gno3
4524
4525 REAL gnh3
4526 !...........SCRATCH LOCAL VARIABLES and their descriptions:
4527
4528 ! Gas-phase ammonia in micrograms / m
4529 ! Index set to percent relative humid
4530 INTEGER irh
4531 ! Number of iterations for activity c
4532 INTEGER nitr
4533 ! Loop index for iterations
4534 INTEGER nnn
4535
4536 INTEGER nr
4537 ! Number of roots to cubic equation f
4538 REAL*8 & ! Coefficients and roots of
4539 a0
4540 REAL*8 & ! Coefficients and roots of
4541 a1
4542 REAL*8 & ! Coefficients and roots of
4543 a2
4544 ! Coefficients and discriminant for q
4545 REAL aa
4546 ! internal variables ( high ammonia c
4547 REAL bal
4548 ! Coefficients and discriminant for q
4549 REAL bb
4550 ! Variables used for ammonia solubili
4551 REAL bhat
4552 ! Coefficients and discriminant for q
4553 REAL cc
4554 ! Factor for conversion of units
4555 REAL convt
4556 ! Coefficients and discriminant for q
4557 REAL dd
4558 ! Coefficients and discriminant for q
4559 REAL disc
4560 ! Relative error used for convergence
4561 REAL eror
4562 ! Free ammonia concentration , that
4563 REAL fnh3
4564 ! Activity Coefficient for (NH4+, HSO
4565 REAL gamaab
4566 ! Activity coefficient for (NH4+, NO3
4567 REAL gamaan
4568 ! Variables used for ammonia solubili
4569 REAL gamahat
4570 ! Activity coefficient for (H+ ,NO3-)
4571 REAL gamana
4572 ! Activity coefficient for (2H+, SO4-
4573 REAL gamas1
4574 ! Activity coefficient for (H+, HSO4-
4575 REAL gamas2
4576 ! used for convergence of iteration
4577 REAL gamold
4578 ! internal variables ( high ammonia c
4579 REAL gasqd
4580 ! Hydrogen ion (low ammonia case) (mo
4581 REAL hplus
4582 ! Equilibrium constant for ammoniua t
4583 REAL k1a
4584 ! Equilibrium constant for sulfate-bi
4585 REAL k2sa
4586 ! Dissociation constant for ammonium
4587 REAL k3
4588 ! Equilibrium constant for ammonium n
4589 REAL kan
4590 ! Variables used for ammonia solubili
4591 REAL khat
4592 ! Equilibrium constant for nitric aci
4593 REAL kna
4594 ! Henry's Law Constant for ammonia
4595 REAL kph
4596 ! Equilibrium constant for water diss
4597 REAL kw
4598 ! Internal variable using KAN
4599 REAL kw2
4600 ! Nitrate (high ammonia case) (moles
4601 REAL man
4602 ! Sulfate (high ammonia case) (moles
4603 REAL mas
4604 ! Bisulfate (low ammonia case) (moles
4605 REAL mhso4
4606 ! Nitrate (low ammonia case) (moles /
4607 REAL mna
4608 ! Ammonium (moles / kg water)
4609 REAL mnh4
4610 ! Total number of moles of all ions
4611 REAL molnu
4612 ! Sulfate (low ammonia case) (moles /
4613 REAL mso4
4614 ! Practical osmotic coefficient
4615 REAL phibar
4616 ! Previous value of practical osmotic
4617 REAL phiold
4618 ! Molar ratio of ammonium to sulfate
4619 REAL ratio
4620 ! Internal variable using K2SA
4621 REAL rk2sa
4622 ! Internal variables using KNA
4623 REAL rkna
4624 ! Internal variables using KNA
4625 REAL rknwet
4626 REAL rr1
4627 REAL rr2
4628 ! Ionic strength
4629 REAL stion
4630 ! Internal variables for temperature
4631 REAL t1
4632 ! Internal variables for temperature
4633 REAL t2
4634 ! Internal variables of convenience (
4635 REAL t21
4636 ! Internal variables of convenience (
4637 REAL t221
4638 ! Internal variables for temperature
4639 REAL t3
4640 ! Internal variables for temperature
4641 REAL t4
4642 ! Internal variables for temperature
4643 REAL t6
4644 ! Total ammonia and ammonium in micro
4645 REAL tnh4
4646 ! Total nitrate in micromoles / meter
4647 REAL tno3
4648 ! Tolerances for convergence test
4649 REAL toler1
4650 ! Tolerances for convergence test
4651 REAL toler2
4652 ! Total sulfate in micromoles / meter
4653 REAL tso4
4654 ! 2.0 * TSO4 (high ammonia case) (mo
4655 REAL twoso4
4656 ! Water mass fraction
4657 REAL wfrac
4658 ! micrograms / meter **3 on output
4659 REAL wh2o
4660 ! internally it is 10 ** (-6) kg (wat
4661 ! the conversion factor (1000 g = 1 k
4662 ! for AH2O output
4663 ! Aerosol liquid water content (inter
4664 ! internal variables ( high ammonia c
4665 REAL wsqd
4666 ! Nitrate aerosol concentration in mi
4667 REAL xno3
4668 ! Variable used in quadratic solution
4669 REAL xxq
4670 ! Ammonium aerosol concentration in m
4671 REAL ynh4
4672 ! Water variable saved in case ionic
4673 REAL zh2o
4674
4675 REAL zso4
4676 ! Total sulfate molality - mso4 + mhs
4677 REAL cat(2) ! Array for cations (1, H+); (2, NH4+
4678 REAL an(3) ! Array for anions (1, SO4--); (2, NO
4679 REAL crutes(3) ! Coefficients and roots of
4680 REAL gams(2,3) ! Array of activity coefficients
4681 ! Minimum value of sulfate laerosol c
4682 REAL minso4
4683 PARAMETER (minso4=1.0E-6/mwso4)
4684 REAL floor
4685 PARAMETER (floor=1.0E-30)
4686 !-----------------------------------------------------------------------
4687 ! begin body of subroutine RPMARES
4688
4689 !...convert into micromoles/m**3
4690 !cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3
4691 !iamodels3 merge NH3/NH4 , HNO3,NO3 here
4692 ! minimum concentration
4693 tso4 = max(0.0,so4/mwso4)
4694 tno3 = max(0.0,(no3/mwno3+hno3/mwhno3))
4695 tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4))
4696 !cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH
4697
4698 !...now set humidity index IRH as a percent
4699
4700 irh = nint(100.0*rh)
4701
4702 !...Check for valid IRH
4703
4704 irh = max(1,irh)
4705 irh = min(99,irh)
4706 !cc WRITE(10,*)'RH,IRH ',RH,IRH
4707
4708 !...Specify the equilibrium constants at correct
4709 !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA
4710 !... KPH, and K3 )
4711 !... Values from Kim et al. (1993) except as noted.
4712
4713 convt = 1.0/(0.082*temp)
4714 t6 = 0.082E-9*temp
4715 t1 = 298.0/temp
4716 t2 = alog(t1)
4717 t3 = t1 - 1.0
4718 t4 = 1.0 + t2 - t1
4719 kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6
4720 k1a = 1.805E-05*exp(-1.50*t3+26.92*t4)
4721 k2sa = 1.015E-02*exp(8.85*t3+25.14*t4)
4722 kw = 1.010E-14*exp(-22.52*t3+26.92*t4)
4723 kph = 57.639*exp(13.79*t3-5.39*t4)*t6
4724 !cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6
4725 khat = kph*k1a/kw
4726 kan = kna*khat
4727
4728 !...Compute temperature dependent equilibrium constant for NH4NO3
4729 !... ( from Mozurkewich, 1993)
4730
4731 k3 = exp(118.87-24084.0/temp-6.025*alog(temp))
4732
4733 !...Convert to (micromoles/m**3) **2
4734
4735 k3 = k3*convt*convt
4736
4737 wh2o = 0.0
4738 stion = 0.0
4739 ah2o = 0.0
4740 mas = 0.0
4741 man = 0.0
4742 hplus = 0.0
4743 toler1 = 0.00001
4744 toler2 = 0.001
4745 nitr = 0
4746 nr = 0
4747 ratio = 0.0
4748 gamaan = 1.0
4749 gamold = 1.0
4750
4751 !...set the ratio according to the amount of sulfate and nitrate
4752 IF (tso4>minso4) THEN
4753 ratio = tnh4/tso4
4754
4755 !...If there is no sulfate and no nitrate, there can be no ammonium
4756 !... under the current paradigm. Organics are ignored in this version.
4757
4758 ELSE
4759
4760 IF (tno3==0.0) THEN
4761
4762 ! *** If there is very little sulfate and no nitrate set concentrations
4763 ! to a very small value and return.
4764 aso4 = max(floor,aso4)
4765 ano3 = max(floor,ano3)
4766 wh2o = 0.0
4767 ah2o = 0.0
4768 gnh3 = max(floor,gnh3)
4769 gno3 = max(floor,gno3)
4770 RETURN
4771 END IF
4772
4773 !...For the case of no sulfate and nonzero nitrate, set ratio to 5
4774 !... to send the code to the high ammonia case
4775
4776 ratio = 5.0
4777 END IF
4778
4779 !....................................
4780 !......... High Ammonia Case ........
4781 !....................................
4782
4783 IF (ratio>2.0) THEN
4784
4785 gamaan = 0.1
4786
4787 !...Set up twice the sulfate for future use.
4788
4789 twoso4 = 2.0*tso4
4790 xno3 = 0.0
4791 ynh4 = twoso4
4792
4793 !...Treat different regimes of relative humidity
4794
4795 !...ZSR relationship is used to set water levels. Units are
4796 !... 10**(-6) kg water/ (cubic meter of air)
4797 !... start with ammomium sulfate solution without nitrate
4798
4799 CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3
4800 wh2o = 1.0E-3*ah2o
4801 aso4 = tso4*mwso4
4802 ano3 = 0.0
4803 anh4 = ynh4*mwnh4
4804 wfrac = ah2o/(aso4+anh4+ah2o)
4805 !cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water
4806 IF (wfrac<0.2) THEN
4807
4808 !... dry ammonium sulfate and ammonium nitrate
4809 !... compute free ammonia
4810
4811 fnh3 = tnh4 - twoso4
4812 cc = tno3*fnh3 - k3
4813
4814 !...check for not enough to support aerosol
4815
4816 IF (cc<=0.0) THEN
4817 xno3 = 0.0
4818 ELSE
4819 aa = 1.0
4820 bb = -(tno3+fnh3)
4821 disc = bb*bb - 4.0*cc
4822
4823 !...Check for complex roots of the quadratic
4824 !... set nitrate to zero and RETURN if complex roots are found
4825
4826 IF (disc<0.0) THEN
4827 xno3 = 0.0
4828 ah2o = 1000.0*wh2o
4829 ynh4 = twoso4
4830 gno3 = tno3*mwhno3
4831 gnh3 = (tnh4-ynh4)*mwnh3
4832 aso4 = tso4*mwso4
4833 ano3 = 0.0
4834 anh4 = ynh4*mwnh4
4835 RETURN
4836 END IF
4837
4838 !...to get here, BB .lt. 0.0, CC .gt. 0.0 always
4839
4840 dd = sqrt(disc)
4841 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4842
4843 !...Since both roots are positive, select smaller root.
4844
4845 xno3 = min(xxq/aa,cc/xxq)
4846
4847 END IF
4848 ah2o = 1000.0*wh2o
4849 ynh4 = 2.0*tso4 + xno3
4850 gno3 = (tno3-xno3)*mwhno3
4851 gnh3 = (tnh4-ynh4)*mwnh3
4852 aso4 = tso4*mwso4
4853 ano3 = xno3*mwno3
4854 anh4 = ynh4*mwnh4
4855 RETURN
4856
4857 END IF
4858
4859 !...liquid phase containing completely neutralized sulfate and
4860 !... some nitrate. Solve for composition and quantity.
4861
4862 mas = tso4/wh2o
4863 man = 0.0
4864 xno3 = 0.0
4865 ynh4 = twoso4
4866 phiold = 1.0
4867
4868 !...Start loop for iteration
4869
4870 !...The assumption here is that all sulfate is ammonium sulfate,
4871 !... and is supersaturated at lower relative humidities.
4872
4873 DO nnn = 1, 150
4874 nitr = nnn
4875 gasqd = gamaan*gamaan
4876 wsqd = wh2o*wh2o
4877 kw2 = kan*wsqd/gasqd
4878 aa = 1.0 - kw2
4879 bb = twoso4 + kw2*(tno3+tnh4-twoso4)
4880 cc = -kw2*tno3*(tnh4-twoso4)
4881
4882 !...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut
4883
4884 disc = bb*bb - 4.0*aa*cc
4885
4886 !...Check for complex roots, if so set nitrate to zero and RETURN
4887
4888 IF (disc<0.0) THEN
4889 xno3 = 0.0
4890 ah2o = 1000.0*wh2o
4891 ynh4 = twoso4
4892 gno3 = tno3*mwhno3
4893 gnh3 = (tnh4-ynh4)*mwnh3
4894 aso4 = tso4*mwso4
4895 ano3 = 0.0
4896 anh4 = ynh4*mwnh4
4897 !cc WRITE( 10, * ) ' COMPLEX ROOTS '
4898 RETURN
4899 END IF
4900
4901 dd = sqrt(disc)
4902 xxq = -0.5*(bb+sign(1.0,bb)*dd)
4903 rr1 = xxq/aa
4904 rr2 = cc/xxq
4905
4906 !...choose minimum positve root
4907
4908 IF ((rr1*rr2)<0.0) THEN
4909 xno3 = max(rr1,rr2)
4910 ELSE
4911 xno3 = min(rr1,rr2)
4912 END IF
4913
4914 xno3 = min(xno3,tno3)
4915
4916 !...This version assumes no solid sulfate forms (supersaturated )
4917 !... Now update water
4918
4919 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4920
4921 !...ZSR relationship is used to set water levels. Units are
4922 !... 10**(-6) kg water/ (cubic meter of air)
4923 !... The conversion from micromoles to moles is done by the units of WH
4924
4925 wh2o = 1.0E-3*ah2o
4926
4927 !...Ionic balance determines the ammonium in solution.
4928
4929 man = xno3/wh2o
4930 mas = tso4/wh2o
4931 mnh4 = 2.0*mas + man
4932 ynh4 = mnh4*wh2o
4933
4934 !...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate
4935 !... and ammonium in molal units (moles/(kg water) ).
4936
4937 stion = 3.0*mas + man
4938 cat(1) = 0.0
4939 cat(2) = mnh4
4940 an(1) = mas
4941 an(2) = man
4942 an(3) = 0.0
4943 CALL actcof(cat,an,gams,molnu,phibar)
4944 gamaan = gams(2,2)
4945
4946 !...Use GAMAAN for convergence control
4947
4948 eror = abs(gamold-gamaan)/gamold
4949 gamold = gamaan
4950
4951 !...Check to see if we have a solution
4952
4953 IF (eror<=toler1) THEN
4954 !cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS
4955 !cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR
4956
4957 aso4 = tso4*mwso4
4958 ano3 = xno3*mwno3
4959 anh4 = ynh4*mwnh4
4960 gno3 = (tno3-xno3)*mwhno3
4961 gnh3 = (tnh4-ynh4)*mwnh3
4962 ah2o = 1000.0*wh2o
4963 RETURN
4964 END IF
4965
4966 END DO
4967
4968 !...If after NITR iterations no solution is found, then:
4969
4970 aso4 = tso4*mwso4
4971 ano3 = 0.0
4972 ynh4 = twoso4
4973 anh4 = ynh4*mwnh4
4974 CALL awater(irh,tso4,ynh4,xno3,ah2o)
4975 gno3 = tno3*mwhno3
4976 gnh3 = (tnh4-ynh4)*mwnh3
4977 RETURN
4978
4979 ELSE
4980
4981 !......................................
4982 !......... Low Ammonia Case ...........
4983 !......................................
4984
4985 !...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95)
4986
4987 !...All cases covered by this logic
4988 wh2o = 0.0
4989 CALL awater(irh,tso4,tnh4,tno3,ah2o)
4990 wh2o = 1.0E-3*ah2o
4991 zh2o = ah2o
4992 !...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
4993 !... per cubic meter of air (1000 g = 1 kg)
4994
4995 aso4 = tso4*mwso4
4996 anh4 = tnh4*mwnh4
4997 ano3 = 0.0
4998 gno3 = tno3*mwhno3
4999 gnh3 = 0.0
5000
5001 !...Check for zero water.
5002
5003 IF (wh2o==0.0) RETURN
5004 zso4 = tso4/wh2o
5005
5006 !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4
5007
5008 !cc IF ( ZSO4 .GT. 11.0 ) THEN
5009
5010 !...do not solve for aerosol nitrate for total sulfate molality
5011 !... greater than 11.0 because the model parameters break down
5012 !... greater than 9.0 because the model parameters break down
5013
5014 IF (zso4>9.0) & ! 18 June 97
5015 THEN
5016 RETURN
5017 END IF
5018
5019 !...First solve with activity coeffs of 1.0, then iterate.
5020
5021 phiold = 1.0
5022 gamana = 1.0
5023 gamas1 = 1.0
5024 gamas2 = 1.0
5025 gamaab = 1.0
5026 gamold = 1.0
5027
5028 !...All ammonia is considered to be aerosol ammonium.
5029
5030 mnh4 = tnh4/wh2o
5031
5032 !...MNH4 is the molality of ammonium ion.
5033
5034 ynh4 = tnh4
5035 !...loop for iteration
5036
5037 DO nnn = 1, 150
5038 nitr = nnn
5039
5040 !...set up equilibrium constants including activities
5041 !... solve the system for hplus first then sulfate & nitrate
5042 ! print*,'gamas,gamana',gamas1,gamas2,gamana
5043 rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
5044 rkna = kna/(gamana*gamana)
5045 rknwet = rkna*wh2o
5046 t21 = zso4 - mnh4
5047 t221 = zso4 + t21
5048
5049 !...set up coefficients for cubic
5050
5051 a2 = rk2sa + rknwet - t21
5052 a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3
5053 a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
5054
5055
5056 CALL cubic(a2,a1,a0,nr,crutes)
5057
5058 !...Code assumes the smallest positive root is in CRUTES(1)
5059
5060 hplus = crutes(1)
5061 bal = hplus**3 + a2*hplus**2 + a1*hplus + a0
5062 mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat
5063 mhso4 = zso4 - & ! molality of bisulf
5064 mso4
5065 mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat
5066 mna = max(0.0,mna)
5067 mna = min(mna,tno3/wh2o)
5068 xno3 = mna*wh2o
5069 ano3 = mna*wh2o*mwno3
5070 gno3 = (tno3-xno3)*mwhno3
5071 !...Calculate ionic strength
5072
5073 stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4)
5074
5075 !...Update water
5076
5077 CALL awater(irh,tso4,ynh4,xno3,ah2o)
5078
5079 !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate
5080 !... per cubic meter of air (1000 g = 1 kg)
5081
5082 wh2o = 1.0E-3*ah2o
5083 cat(1) = hplus
5084 cat(2) = mnh4
5085 an(1) = mso4
5086 an(2) = mna
5087 an(3) = mhso4
5088 ! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar
5089 CALL actcof(cat,an,gams,molnu,phibar)
5090
5091 gamana = gams(1,2)
5092 gamas1 = gams(1,1)
5093 gamas2 = gams(1,3)
5094 gamaan = gams(2,2)
5095
5096 gamahat = (gamas2*gamas2/(gamaab*gamaab))
5097 bhat = khat*gamahat
5098 !cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD )
5099 !cc PHIOLD = PHIBAR
5100 eror = abs(gamold-gamahat)/gamold
5101 gamold = gamahat
5102
5103 !...write out molalities and activity coefficient
5104 !... and return with good solution
5105
5106 IF (eror<=toler2) THEN
5107 !cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA
5108 !cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3),
5109 !cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR
5110 RETURN
5111 END IF
5112
5113 END DO
5114
5115 !...after NITR iterations, failure to solve the system, no ANO3
5116
5117 gno3 = tno3*mwhno3
5118 ano3 = 0.0
5119 CALL awater(irh,tso4,tnh4,tno3,ah2o)
5120 RETURN
5121
5122
5123 END IF
5124 ! ratio .gt. 2.0
5125 ! ///////////////////////////////////////////////////
5126 END SUBROUTINE rpmares_old
5127 !ia*********************************************************
5128 !ia *
5129 !ia BEGIN OF AEROSOL ROUTINE *
5130 !ia *
5131 !ia*********************************************************
5132
5133 !***********************************************************************
5134
5135 ! BEGIN OF AEROSOL CALCULATIONS
5136
5137 !***********************************************************************
5138
5139
5140 !ia*********************************************************************
5141 !ia *
5142 !ia MAIN AEROSOL DYNAMICS ROUTINE *
5143 !ia based on MODELS3 formulation by FZB *
5144 !ia Modified by IA in May 97 *
5145 !ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE
5146 !ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND
5147 !ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL
5148 !ia CALCULATIONS.
5149 !ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR
5150 !ia ONE GRID CELL!!!!
5151 !ia and passed to dynamics calcs. subroutines.
5152 !ia *
5153 !ia Revision history *
5154 !ia When WHO WHAT *
5155 !ia ---- ---- ---- *
5156 !ia ???? FZB BEGIN *
5157 !ia 05/97 IA Adapted for use in CTM2-S *
5158 !ia Modified renaming/bug fixing *
5159 !ia 11/97 IA Modified for new model version
5160 !ia see comments under iarev02
5161 !ia 03/98 IA corrected error on pressure units
5162 !ia *
5163 !ia Called BY: CHEM *
5164 !ia *
5165 !ia Calls to: OUTPUT1,AEROPRC *
5166 !ia *
5167 !ia*********************************************************************
5168
5169 ! end RPMares
5170 SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, &
5171 nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog,condvap_in,ncv, &
5172 nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, &
5173 soilrat_in,cblk,igrid,jgrid,kgrid)
5174
5175
5176
5177 ! IMPLICIT NONE
5178
5179 ! Includes:
5180
5181 !iarev02 INCLUDE AEROINCL.EXT
5182 ! block size, set to 1 in column model ciarev0
5183 INTEGER blksize
5184 !ia kept to 1 in current version of column model
5185 INTEGER numcells
5186
5187 ! actual number of cells in arrays ( default is
5188 PARAMETER (numcells=1)
5189
5190
5191 INTEGER layer
5192 ! number of layer (default is 1 in
5193
5194 INTEGER ncell
5195 ! index for cell in blocked array (default is 1 in
5196 PARAMETER (ncell=1)
5197 ! *** inputs
5198 ! Input temperature [ K ]
5199 REAL temp
5200 ! Input relative humidity [ fraction ]
5201 REAL relhum
5202 ! Input pressure [ hPa ]
5203 REAL pres
5204 ! Input number for Aitken mode [ m**-3 ]
5205 REAL numnuc_in
5206 ! Input number for accumulation mode [ m**-3 ]
5207 REAL numacc_in
5208 ! Input number for coarse mode [ m**-3 ]
5209 REAL numcor_in
5210 ! sulfuric acid [ ug m**-3 ]
5211 REAL vsulf_in
5212 ! total sulfate vapor as sulfuric acid as
5213 ! sulfuric acid [ ug m**-3 ]
5214 REAL asulf_in
5215 ! total sulfate aerosol as sulfuric acid as
5216 ! i-mode sulfate input as sulfuric acid [ ug m*
5217 REAL asulfi_in
5218 ! ammonia gas [ ug m**-3 ]
5219 REAL nh3_in
5220 ! input value of nitric acid vapor [ ug m**-3 ]
5221 REAL nitrate_in
5222 ! Production rate of sulfuric acid [ ug m**-3
5223 REAL so4rat_in
5224 ! aerosol [ ug m**-3 s**-1 ]
5225 REAL soilrat_in
5226 ! Production rate of soil derived coarse
5227 ! Emission rate of i-mode EC [ug m**-3 s**-1]
5228 REAL eeci_in
5229 ! Emission rate of j-mode EC [ug m**-3 s**-1]
5230 REAL eecj_in
5231 ! Emission rate of j-mode org. aerosol [ug m**-
5232 REAL eorgi_in
5233
5234 REAL eorgj_in
5235 !bs
5236 ! Emission rate of j-mode org. aerosol [ug m**-
5237 ! total # of cond. vapors & SOA species
5238 INTEGER ncv
5239 ! # of anthrop. cond. vapors & SOA speci
5240 INTEGER nacv
5241 ! # of organic aerosol precursor
5242 INTEGER ldrog
5243 REAL drog_in(ldrog) ! organic aerosol precursor [ppm]
5244 ! Input delta ROG concentration of
5245 REAL condvap_in(ncv) ! cond. vapor input [ug m^-3]
5246 REAL drog(blksize,ldrog) ! organic aerosol precursor [ppm]
5247 !bs
5248 ! *** Primary emissions rates: [ ug / m**3 s ]
5249
5250 ! *** emissions rates for unidentified PM2.5 mass
5251 ! Delta ROG concentration of
5252 REAL epm25i(blksize) ! Aitken mode
5253 REAL epm25j(blksize)
5254 ! *** emissions rates for primary organic aerosol
5255 ! Accumululaton mode
5256 REAL eorgi(blksize) ! Aitken mode
5257 REAL eorgj(blksize)
5258 ! *** emissions rates for elemental carbon
5259 ! Accumululaton mode
5260 REAL eeci(blksize) ! Aitken mode
5261 REAL eecj(blksize)
5262 ! *** Primary emissions rates [ ug m**-3 s -1 ] :
5263
5264 ! Accumululaton mode
5265 REAL epm25(blksize) ! emissions rate for PM2.5 mass
5266 REAL esoil(blksize) ! emissions rate for soil derived coarse a
5267 REAL eseas(blksize) ! emissions rate for marine coarse aerosol
5268 REAL epmcoarse(blksize)
5269 ! emissions rate for anthropogenic coarse
5270
5271 REAL dtsec
5272
5273 ! time step [ s ], PASSED FROM MAIN COLUMN MODE
5274
5275 REAL newm3
5276
5277 REAL totaersulf
5278 ! total aerosol sulfate
5279 ! loop index for time steps
5280 INTEGER numsteps
5281
5282 REAL step
5283
5284 ! *** arrays for aerosol model codes:
5285
5286 ! synchronization time [s]
5287
5288 INTEGER nspcsda
5289
5290 ! number of species in CBLK ciarev02
5291 REAL cblk(blksize,nspcsda)
5292
5293 ! *** Meteorological information in blocked arays:
5294
5295 ! *** Thermodynamic variables:
5296
5297 ! main array of variables
5298 REAL blkta(blksize) ! Air temperature [ K ]
5299 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5300 REAL blkdens(blksize) ! Air density [ kg m^-3 ]
5301 REAL blkrh(blksize)
5302
5303
5304 ! *** Chemical production rates [ ug m**-3 s -1 ] :
5305
5306 ! Fractional relative humidity
5307 REAL so4rat(blksize) ! rate [ug/m^3/s]
5308 ! sulfuric acid vapor-phase production
5309 REAL orgaro1rat(blksize) ! production rate from aromatics [ ug /
5310 ! anthropogenic organic aerosol mass
5311 REAL orgaro2rat(blksize) ! production rate from aromatics [ ug /
5312 ! anthropogenic organic aerosol mass
5313 REAL orgalk1rat(blksize) ! rate from alkanes & others [ ug / m^3
5314 ! anthropogenic organic aerosol mass pro
5315 REAL orgole1rat(blksize) ! rate from alkanes & others [ ug / m^3
5316 ! anthropogenic organic aerosol mass pro
5317 REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ]
5318 ! biogenic organic aerosol production
5319 REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ]
5320 ! biogenic organic aerosol production
5321 REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ]
5322 ! biogenic organic aerosol production
5323 REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ]
5324 !bs
5325 ! *** atmospheric properties
5326
5327 ! biogenic organic aerosol production
5328 REAL xlm(blksize) ! atmospheric mean free path [ m ]
5329 REAL amu(blksize)
5330 ! *** aerosol properties:
5331
5332
5333 ! *** modal diameters:
5334
5335 ! atmospheric dynamic viscosity [ kg
5336 REAL dgnuc(blksize) ! nuclei mode geometric mean diamete
5337 REAL dgacc(blksize) ! accumulation geometric mean diamet
5338 REAL dgcor(blksize)
5339
5340 ! *** Modal mass concentrations [ ug m**3 ]
5341
5342 ! coarse mode geometric mean diamete
5343 REAL pmassn(blksize) ! mass concentration in Aitken mode
5344 REAL pmassa(blksize) ! mass concentration in accumulation
5345 REAL pmassc(blksize)
5346 ! *** average modal particle densities [ kg/m**3 ]
5347
5348 ! mass concentration in coarse mode
5349 REAL pdensn(blksize) ! average particle density in nuclei
5350 REAL pdensa(blksize) ! average particle density in accumu
5351 REAL pdensc(blksize)
5352 ! *** average modal Knudsen numbers
5353
5354 ! average particle density in coarse
5355 REAL knnuc(blksize) ! nuclei mode Knudsen number
5356 REAL knacc(blksize) ! accumulation Knudsen number
5357 REAL kncor(blksize)
5358 ! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ]
5359
5360 ! coarse mode Knudsen number
5361 REAL fconcn(blksize)
5362 ! reciprocal condensation rate Aitke
5363 REAL fconca(blksize) !bs
5364 ! reciprocal condensation rate acclu
5365 REAL fconcn_org(blksize)
5366 REAL fconca_org(blksize)
5367 !bs
5368
5369 ! *** Rates for secondary particle formation:
5370
5371 ! *** production of new mass concentration [ ug/m**3 s ]
5372 REAL dmdt(blksize) ! by particle formation
5373
5374 ! *** production of new number concentration [ number/m**3 s ]
5375
5376 ! rate of production of new mass concen
5377 REAL dndt(blksize) ! by particle formation
5378 ! *** growth rate for third moment by condensation of precursor
5379 ! vapor on existing particles [ 3rd mom/m**3 s ]
5380
5381 ! rate of producton of new particle num
5382 REAL cgrn3(blksize) ! Aitken mode
5383 REAL cgra3(blksize)
5384 ! *** Rates for coaglulation: [ m**3/s ]
5385
5386 ! *** Unimodal Rates:
5387
5388 ! Accumulation mode
5389 REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra
5390 REAL ura00(blksize)
5391
5392 ! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod
5393
5394 ! accumulation mode 0th moment self-coagulat
5395 REAL brna01(blksize) ! rate for 0th moment
5396 REAL brna31(blksize)
5397 ! *** other processes
5398
5399 ! rate for 3rd moment
5400 REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u
5401
5402
5403 ! *** housekeeping variables:
5404
5405 ! increment of concentration added to
5406 INTEGER unit
5407 PARAMETER (unit=30)
5408
5409 CHARACTER*16 pname
5410 PARAMETER (pname=' BOX ')
5411
5412
5413
5414
5415 INTEGER isp,igrid,jgrid,kgrid
5416
5417 ! loop index for species.
5418 INTEGER ii, iimap(8)
5419 DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/
5420
5421
5422 ! begin body of program box
5423
5424 ! *** Set up files and other info
5425
5426
5427 ! *** set up experimental conditions
5428
5429 ! *** initialize model variables
5430
5431 !ia *** not required any more
5432
5433 !ia DO ISP = 1, NSPCSDA
5434 !ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number
5435 !ia END DO
5436
5437 step = & ! set time step
5438 dtsec
5439 blkta(blksize) = & ! T in Kelvin
5440 temp
5441 blkprs(blksize) = pres* & ! P in Pa (pres is given in
5442 100.
5443 blkrh(blksize) = & ! fractional RH
5444 relhum
5445 blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in
5446 !rs CBLK(BLKSIZE,VHNO3) = nitrate_in
5447 !rs CBLK(BLKSIZE,VNH3) = nh3_in
5448 !bs
5449 !rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1)
5450 !rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2)
5451 !rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1)
5452 !rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1)
5453 !rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1)
5454 !rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2)
5455 !rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1)
5456 !rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2)
5457 ! dr
5458 DO isp = 1, ldrog
5459 drog(blksize,isp) = drog_in(isp)
5460 END DO
5461 ! print*,'drog in rpm',drog
5462 !bs
5463 !ia *** 27/05/97 the following variables are transported quantities
5464 !ia *** of the column-model now and thuse do not need this init.
5465 !ia *** step.
5466
5467 ! CBLK(BLKSIZE,VNU0) = numnuc_in
5468 ! CBLK(BLKSIZE,VAC0) = numacc_in
5469 ! CBLK(BLKSIZE,VSO4A) = asulf_in
5470 ! CBLK(BLKSIZE,VSO4AI) = asulfi_in
5471 ! CBLK(BLKSIZE, VCORN) = numcor_in
5472
5473
5474 so4rat(blksize) = so4rat_in
5475
5476 !...INITIALISE EMISSION RATES
5477
5478 ! epm25i(blksize) = & ! unidentified PM2.5 mass
5479 ! 0.0
5480 ! epm25j(blksize) = &
5481 ! 0.0
5482 ! unidentified PM2.5 m
5483 eorgi(blksize) = & ! primary organic
5484 eorgi_in
5485 eorgj(blksize) = &
5486 eorgi_in
5487 ! primary organic
5488 eeci(blksize) = & ! elemental carbon
5489 eeci_in
5490 eecj(blksize) = &
5491 eecj_in
5492 ! elemental carbon
5493 epm25(blksize) = & !currently from input file ACTIONIA
5494 0.0
5495 esoil(blksize) = & ! ACTIONIA
5496 soilrat_in
5497 eseas(blksize) = & !currently from input file ACTIONIA
5498 0.0
5499 ! epmcoarse(blksize) = & !currently from input file ACTIONIA
5500 ! 0.0
5501 dgnuc(blksize) = dginin
5502 dgacc(blksize) = dginia
5503 dgcor(blksize) = dginic
5504 newm3 = 0.0
5505
5506
5507
5508 ! *** Set up initial total 3rd moment factors
5509
5510 totaersulf = 0.0
5511 newm3 = 0.0
5512 ! *** time loop
5513
5514 ! write(50,*) ' numsteps dgnuc dgacc ',
5515 ! & ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j'
5516
5517
5518 ! *** Call aerosol routines
5519
5520 CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, &
5521 blkdens,blkrh,so4rat,orgaro1rat,orgaro2rat,orgalk1rat, &
5522 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
5523 nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, &
5524 amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, &
5525 knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, &
5526 urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid)
5527
5528 ! *** write output
5529
5530 ! WRITE(UNIT,*) ' AFTER AEROPROC '
5531 ! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS
5532
5533 ! *** Write out file for graphing.
5534
5535 ! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8)
5536
5537
5538 ! *** update sulfuric acid vapor
5539 !ia 21.04.98 this update is not required here
5540 !ia artefact from box model
5541 ! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) +
5542 ! & SO4RAT(BLKSIZE) * STEP
5543
5544 RETURN
5545
5546 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
5547 END SUBROUTINE rpmmod3
5548 ! main box model
5549 SUBROUTINE soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
5550 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
5551 nacv,cblk,blksize,nspcsda,numcells,dt)
5552 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
5553 !bs !
5554 !bs Description: !
5555 !bs !
5556 !bs SOA_PART calculates the formation and partitioning of secondary !
5557 !bs organic aerosol based on (pseudo-)ideal solution thermodynamics. !
5558 !bs !
5559 !bs This code considers two cases: !
5560 !bs i) initil absorbing mass is existend in the aerosol phase !
5561 !bs ii) a threshold has to be exeeded before partitioning (even below !
5562 !bs saturation) will take place. !
5563 !bs !
5564 !bs The temperature dependence of the saturation concentrations are !
5565 !bs calculated using the Clausius-Clapeyron equation. !
5566 !bs !
5567 !bs It is assumed that the condensable vapors also evaporate if the !
5568 !bs saturation concentraion lowers e.g. due to temperature effects. !
5569 !bs Therefor negative production rates (= evaporation rates) are !
5570 !bs possible. !
5571 !bs !
5572 !bs If there is no absorbing mass at all the Pandis method is applied !
5573 !bs for the first steps. !
5574 !bs !
5575 !bs References: !
5576 !bs Pankow (1994): !
5577 !bs An absorption model of the gas/aerosol !
5578 !bs partitioning involved in the formation of !
5579 !bs secondary organic aerosol, Atmos. Environ. 28(2), !
5580 !bs 189-193. !
5581 !bs Odum et al. (1996): !
5582 !bs Gas/particle partitioning and secondary organic !
5583 !bs aerosol yields, Environ. Sci. Technol. 30, !
5584 !bs 2580-2585. !
5585 !bs see also !
5586 !bs Bowman et al. (1997): !
5587 !bs Mathematical model for gas-particle partitioning !
5588 !bs of secondary organic aerosols, Atmos. Environ. !
5589 !bs 31(23), 3921-3931. !
5590 !bs Seinfeld and Pandis (1998): !
5591 !bs Atmospheric Chemistry and Physics (0-471-17816-0) !
5592 !bs chapter 13.5.2 Formation of binary ideal solution !
5593 !bs with -- preexisting aerosol !
5594 !bs -- other organic vapor !
5595 !bs !
5596 !bs Called by: SORGAM !
5597 !bs !
5598 !bs Calls: None !
5599 !bs !
5600 !bs Arguments: LAYER, !
5601 !bs BLKTA, BLKPRS, !
5602 !bs ORGARO1RAT, ORGARO2RAT, !
5603 !bs ORGALK1RAT, ORGOLE1RAT, !
5604 !bs ORGBIO1RAT, ORGBIO2RAT, !
5605 !bs ORGBIO3RAT, ORGBIO4RAT, !
5606 !bs DROG, LDROG, NCV, NACV, !
5607 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
5608 !bs DT !
5609 !bs !
5610 !bs Include files: AEROSTUFF.EXT !
5611 !bs AERO_internal.EXT !
5612 !bs !
5613 !bs Data: None !
5614 !bs !
5615 !bs Input files: None !
5616 !bs !
5617 !bs Output files: None !
5618 !bs !
5619 !bs--------------------------------------------------------------------!
5620 !bs !
5621 !bs History: !
5622 !bs No Date Author Change !
5623 !bs ____ ______ ________________ _________________________________ !
5624 !bs 01 170399 B.Schell Set up !
5625 !bs 02 050499 B.Schell introduced SR NEWT !
5626 !bs 03 040599 B.Schell include-file sorgam.inc !
5627 !bs !
5628 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
5629 !bs
5630 ! IMPLICIT NONE
5631 !bs
5632 !bs * includes
5633 !bs
5634 !bs
5635 !bs * input variables
5636 !bs
5637 ! model layer
5638 INTEGER layer
5639 ! dimension of arrays
5640 INTEGER blksize
5641 ! number of species in CBLK
5642 INTEGER nspcsda
5643 ! actual number of cells in arrays
5644 INTEGER numcells
5645 ! # of organic aerosol precursor
5646 INTEGER ldrog
5647 ! total # of cond. vapors & SOA sp
5648 INTEGER ncv
5649 ! # of anthrop. cond. vapors & SOA
5650 INTEGER nacv
5651 REAL cblk(blksize,nspcsda) ! main array of variables
5652 ! model time step in SECONDS
5653 REAL dt
5654 REAL blkta(blksize) ! Air temperature [ K ]
5655 REAL blkprs(blksize) ! Air pressure in [ Pa ]
5656 REAL orgaro1rat(blksize) ! rates from aromatics
5657 ! anth. organic vapor production
5658 REAL orgaro2rat(blksize) ! rates from aromatics
5659 ! anth. organic vapor production
5660 REAL orgalk1rat(blksize) ! rates from alkenes and others
5661 ! anth. organic vapor production
5662 REAL orgole1rat(blksize) ! rates from alkanes and others
5663 ! anth. organic vapor production
5664 REAL orgbio1rat(blksize) ! bio. organic vapor production ra
5665 REAL orgbio2rat(blksize) ! bio. organic vapor production ra
5666 REAL orgbio3rat(blksize) ! bio. organic vapor production ra
5667 REAL orgbio4rat(blksize) ! bio. organic vapor production ra
5668 REAL drog(blksize,ldrog) !bs
5669 !bs * local variable declaration
5670 !bs
5671 ! Delta ROG conc. [ppm]
5672 !bs numerical value for a minimum thresh
5673 REAL thrsmin
5674 PARAMETER (thrsmin=1.E-19)
5675 !bs numerical value for a minimum thresh
5676 !bs
5677 !bs universal gas constant [J/mol-K]
5678 REAL rgas
5679 PARAMETER (rgas=8.314510)
5680 !bs reference temperature T0 = 298 K
5681 REAL tnull
5682 PARAMETER (tnull=298.)
5683 !bs molecular weight for C
5684 REAL mwc
5685 PARAMETER (mwc=12.0)
5686 !bs molecular weight for organic species
5687 REAL mworg
5688 PARAMETER (mworg=175.0)
5689 !bs molecular weight for SO4
5690 REAL mwso4
5691 PARAMETER (mwso4=96.0576)
5692 !bs molecular weight for NH4
5693 REAL mwnh4
5694 PARAMETER (mwnh4=18.03858)
5695 !bs molecular weight for NO3
5696 REAL mwno3
5697 PARAMETER (mwno3=62.01287)
5698 !bs relative tolerance for mass check
5699 REAL rtol
5700 PARAMETER (rtol=1.E-04)
5701 !bs REAL DTMIN !bs minimum time step in seconds
5702 !bs PARAMETER (DTMIN = 0.1)
5703 !bs
5704 !bs loop index
5705 INTEGER lcell
5706 INTEGER l, & !bs loop index
5707 n
5708 !bs conversion factor ppm --> ug/m^3
5709 REAL convfac
5710 !bs difference of inverse temperatures
5711 REAL ttinv
5712 !bs weighted initial organic mass [10^-6
5713 REAL minitw
5714 !bs weighted total organic mass [10^-6 m
5715 REAL mtotw
5716 !bs weighted inorganic mass [10^-6 mol/m
5717 REAL mnonow
5718 !bs 1. / MTOTW
5719 REAL imtotw
5720 !bs initial organic mass [ug/m^3]
5721 REAL minit
5722 !bs inorganic mass [ug/m^3]
5723 REAL mnono
5724 !bs total organic mass [ug/m^3]
5725 REAL mtot
5726 !bs threshold for SOA formatio for low M
5727 REAL thres
5728 !bs mass check ratio of input/output mas
5729 REAL mcheck
5730 REAL msum(ncv) !bs input total mass [ug/m^3]
5731 REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/
5732 REAL imwcv(ncv) !bs 1. / MWCV(NCV)
5733 REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa]
5734 REAL dhvap(ncv) !bs heat of vaporisation of compound i [
5735 REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa]
5736 REAL ctot(ncv) !bs total conc. of cond. vapor aerosol +
5737 REAL cgas(ncv) !bs gasphase concentration of cond. vapo
5738 REAL caer(ncv) !bs aerosolphase concentration of cond.
5739 REAL asav(ncv) !bs saved CAER for iteration
5740 REAL aold(ncv) !bs saved CAER for rate determination
5741 REAL csat(ncv) !bs saturation conc. of cond. vapor [ug/
5742 REAL alpha(ncv) !bs molar yield for condensable vapors
5743 REAL prod(ncv) !bs production of condensable vapor [ug/
5744 REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3]
5745 REAL f(ldrog) !bs scaling factor for ind. oxidant
5746 !bs check convergence of SR NEWT
5747 LOGICAL check
5748 !bs
5749 INTEGER its
5750 !bs * initialisation
5751 !bs
5752 !bs * DVAP data: average value calculated from C14-C18 monocarboxylic
5753 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5754 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5755 !bs * average value is 156 kJ/mol
5756 !bs
5757 !bs number of iterations in NEWT
5758 dhvap(psoaaro1) = 156.0E03
5759 dhvap(psoaaro2) = 156.0E03
5760 dhvap(psoaalk1) = 156.0E03
5761 dhvap(psoaole1) = 156.0E03
5762 dhvap(psoaapi1) = 156.0E03
5763 dhvap(psoaapi2) = 156.0E03
5764 dhvap(psoalim1) = 156.0E03
5765 dhvap(psoalim2) = 156.0E03
5766 !bs
5767 !bs * MWCV data: average value calculated from C14-C18 monocarboxylic
5768 !bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989):
5769 !bs * Eniron. Sci. Technol. 1989, 23, 1519-1523.
5770 !bs * average value is 222.5 g/mol
5771 !bs *
5772 !bs * molecular weights used are estimates taking the origin (reactants)
5773 !bs * into account. This should be updated if more information abou
5774 !bs * the products is available.
5775 !bs * First hints are taken from Forstner et al. (1997), Environ. S
5776 !bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmo
5777 !bs * Environ. 31(13), 1953-1964.
5778 !bs *
5779 !bs * !! these molecular weights should be identical with WTM in CTM !!
5780 !bs
5781 mwcv(psoaaro1) = 150.
5782 mwcv(psoaaro2) = 150.
5783 mwcv(psoaalk1) = 140.
5784 mwcv(psoaole1) = 140.
5785 mwcv(psoaapi1) = 184.
5786 mwcv(psoaapi2) = 184.
5787 mwcv(psoalim1) = 200.
5788 mwcv(psoalim2) = 200.
5789 !bs
5790 !bs * aromatic yields from:
5791 !bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, R.C. Flagan, and
5792 !bs * J.H. Seinfeld: The atmospheric aerosol-forming potential of whol
5793 !bs * gasoline vapor, Science 276, 96-99, 1997.
5794 !bs * Odum J.R., T.P.W. Jungkamp, R.J. Griffin, H.J.L. Forstner, R.C. Fl
5795 !bs * and J.H. Seinfeld: Aromatics, reformulated gasoline, and atmosph
5796 !bs * organic aerosol formation, Environ. Sci. Technol. 31, 1890-1897,
5797 !bs *
5798 !bs * !! yields provided by Odum are mass-based stoichiometric coefficen
5799 !bs * average for high and low yield aromatics
5800 !bs * alpha1 = 0.0545 K1 = 0.0475 m^3/ug
5801 !bs * alpha2 = 0.1525 K2 = 0.00165 m^3/ug
5802 !bs * change to molar yields using the model MW
5803 !bs * alpha1 * MW(XYL) / MW(PSOAARO1) = alpha1 * 106 / 150 = 0.0385
5804 !bs * alpha2 * MW(XYL) / MW(PSOAARO2) = alpha2 * 106 / 150 = 0.1077
5805 !bs * ALPHA(PSOAARO1) = 0.0385; ALPHA(PSOAARO2) = 0.1077
5806 !bs *
5807 !bs
5808 !bs * alkane and alkene yields from:
5809 !bs * Moucheron M.C. and J. Milford: Development and testing of a proces
5810 !bs * model for secondary organic aerosols. Air & Waste Manag. Assoc.
5811 !bs * for presentation at the 89th Annual Meeting & Exhibition, Nashv
5812 !bs * Tennessee, June 23-28, 96-FA130B.03, 1996.
5813 !bs * molar yields used instead of [ ug m^-3 / ppm ], calculation
5814 !bs * at T=298K, P=1.0133*10^5 Pa
5815 !bs * ALPHA(PSOAALK1) = 0.048; ALPHA(PSOAOLE1) = 0.008
5816 !bs
5817 !bs * biogenic yields from:
5818 !bs * Griffin R.J., D.R. Cocker III, R.C. Flagan, and J.H. Seinfeld:
5819 !bs * Organic aerosol formation from the oxidation of biogenic hydro-
5820 !bs * carbons, JGR, 1999 in press.
5821 !bs * the yields given in Table 3 are mass yields [ ug m^-3 / ug m^-3
5822 !bs * change to molar yields via:
5823 !bs * molar yield = mass yield * ((R*T/M_soa*p) / (R*T/M_terp*p))
5824 !bs * = mass yield * (M_terp / M_soa)
5825 !bs * = mass yield * ( M(Terpenes) / M(pinonic acid) )
5826 !bs * = mass yield * 136 / 184
5827 !bs * average for a-Pinene and Limonene, maybe splitted in future versio
5828 !bs * 0.138 * 0.739 = 0.102; 0.345 * 0.739 = 0.254
5829 !bs * values for a-Pinene (molar yield) alpha1 = 0.028, alpha2 = 0.241
5830 !bs * values for limonene (molar yield) alpha1 = 0.163, alpha2 = 0.247
5831 !bs
5832 alpha(psoaaro1) = 0.039
5833 alpha(psoaaro2) = 0.108
5834 alpha(psoaalk1) = 0.048
5835 alpha(psoaole1) = 0.008
5836 !bs ALPHA(PSOAAPI1) = 0.028
5837 !bs ALPHA(PSOAAPI2) = 0.241
5838 alpha(psoaapi1) = & !bs API + O3 only Griffin '99
5839 0.092
5840 alpha(psoaapi2) = & !bs API + O3 only Griffin '99
5841 0.075
5842 alpha(psoalim1) = 0.163
5843 alpha(psoalim2) = 0.247
5844 !bs
5845 !bs * P0 data in Pa for T = 298K:
5846 !bs * aromatics: Odum et al. (1997) using R = 8.314 J/(mol*K),
5847 !bs * DHvap = 156 kJ/mol, T = 313K, MW = 150 g/mol and averaged
5848 !bs * Ki's of high and low aromatics.
5849 !bs * T = 313 => PNULL(ARO1) = 1.7E-05, PNULL(ARO2) = 5.1E-04
5850 !bs * T = 307.4 => PNULL(ARO1) = 5.7E-05, PNULL(ARO2) = 1.6E-03
5851 !bs * biogenics: Hoffmann et al. (1997); Griffin et al. (1999);
5852 !bs * using R = 8.314 J/(mol*K),
5853 !bs * DHvap = 156 kJ/mol, T = 313, MW = 184 g/mol, and
5854 !bs * averaged Ki's of a-pinene and limonene
5855 !bs * p1(298K) = 6.1E-06; p2(298K) = 1.5E-04
5856 !bs * Ki's for a-pinene p1(298K) = 4.0E-06; p2(298K) = 1.7E-04
5857 !bs * Ki's for limonene p1(298K) = 2.5E-05; p2(298K) = 1.2E-04
5858 !bs * alkanes and alkenes: no data available, use low value to get cl
5859 !bs * to the Pandis yields, 1 ppt = 1*10^-7 Pa.
5860 !bs
5861 pnull(psoaaro1) = 5.7E-05
5862 pnull(psoaaro2) = 1.6E-03
5863 pnull(psoaalk1) = 5.0E-06
5864 pnull(psoaole1) = 5.0E-06
5865 !bs PNULL(PSOAAPI1) = 4.0E-06
5866 !bs PNULL(PSOAAPI2) = 1.7E-04
5867 pnull(psoaapi1) = & !bs API + O3 only Griffin '99
5868 2.488E-05
5869 pnull(psoaapi2) = & !bs API + O3 only Griffin '99
5870 2.778E-05
5871 pnull(psoalim1) = 2.5E-05
5872 pnull(psoalim2) = 1.2E-04
5873 !bs
5874 !bs * scaling of contribution of individual oxidants to aerosol formatio
5875 !bs
5876 f(pxyl) = & !bs * XYL + OH
5877 1.
5878 f(ptol) = & !bs * TOL + OH
5879 1.
5880 f(pcsl1) = & !bs * CSL + OH
5881 1.
5882 f(pcsl2) = & !bs * CSL + NO
5883 1.
5884 f(phc8) = & !bs * HC + OH
5885 1.
5886 f(poli1) = & !bs * OLI + OH
5887 1.
5888 f(poli2) = & !bs * OLI + NO
5889 1.
5890 f(poli3) = & !bs * OLI + O3
5891 1.
5892 f(polt1) = & !bs * OLT + OH
5893 1.
5894 f(polt2) = & !bs * OLT + NO
5895 1.
5896 f(polt3) = & !bs F(PAPI1) = 0.228 !bs * API + OH
5897 1.
5898 !bs F(PAPI2) = 0. !bs * API + NO
5899 !bs F(PAPI3) = 0.771 !bs * API + O3
5900 !bs * OLT + O3
5901 f(papi1) = & !bs * API + OH
5902 0.
5903 f(papi2) = & !bs * API + NO
5904 0.
5905 f(papi3) = & !bs * API + O3
5906 1.
5907 f(plim1) = & !bs * LIM + OH
5908 0.228
5909 f(plim2) = & !bs * LIM + NO
5910 0.
5911 f(plim3) = & !bs
5912 0.771
5913 !bs * begin code -------------------------------------------------------
5914 !bs
5915 !bs * LIM + O3
5916 DO lcell = 1, numcells
5917 DO l = 1, ldrog
5918 drog(lcell,l) = f(l)*drog(lcell,l)
5919 END DO
5920 ttinv = 1./tnull - 1./blkta(lcell)
5921 convfac = blkprs(lcell)/(rgas*blkta(lcell))
5922 cgas(psoaaro1) = cblk(lcell,vcvaro1)
5923 cgas(psoaaro2) = cblk(lcell,vcvaro2)
5924 cgas(psoaalk1) = cblk(lcell,vcvalk1)
5925 cgas(psoaole1) = cblk(lcell,vcvole1)
5926 cgas(psoaapi1) = cblk(lcell,vcvapi1)
5927 cgas(psoaapi2) = cblk(lcell,vcvapi2)
5928 cgas(psoalim1) = cblk(lcell,vcvlim1)
5929 cgas(psoalim2) = cblk(lcell,vcvlim2)
5930 caer(psoaaro1) = cblk(lcell,vorgaro1j) + cblk(lcell,vorgaro1i)
5931 caer(psoaaro2) = cblk(lcell,vorgaro2j) + cblk(lcell,vorgaro2i)
5932 caer(psoaalk1) = cblk(lcell,vorgalk1j) + cblk(lcell,vorgalk1i)
5933 caer(psoaole1) = cblk(lcell,vorgole1j) + cblk(lcell,vorgole1i)
5934 caer(psoaapi1) = cblk(lcell,vorgba1j) + cblk(lcell,vorgba1i)
5935 caer(psoaapi2) = cblk(lcell,vorgba2j) + cblk(lcell,vorgba2i)
5936 caer(psoalim1) = cblk(lcell,vorgba3j) + cblk(lcell,vorgba3i)
5937 caer(psoalim2) = cblk(lcell,vorgba4j) + cblk(lcell,vorgba4i)
5938 !bs
5939 prod(psoaaro1) = drog(lcell,pxyl) + drog(lcell,ptol) + &
5940 drog(lcell,pcsl1) + drog(lcell,pcsl2)
5941 prod(psoaaro2) = drog(lcell,pxyl) + drog(lcell,ptol) + &
5942 drog(lcell,pcsl1) + drog(lcell,pcsl2)
5943 prod(psoaalk1) = drog(lcell,phc8)
5944 prod(psoaole1) = drog(lcell,poli1) + drog(lcell,poli2) + &
5945 drog(lcell,poli3) + drog(lcell,polt1) + drog(lcell,poli2) + &
5946 drog(lcell,polt3)
5947 prod(psoaapi1) = drog(lcell,papi1) + drog(lcell,papi2) + &
5948 drog(lcell,papi3)
5949 prod(psoaapi2) = drog(lcell,papi1) + drog(lcell,papi2) + &
5950 drog(lcell,papi3)
5951 prod(psoalim1) = drog(lcell,plim1) + drog(lcell,plim2) + &
5952 drog(lcell,plim3)
5953 prod(psoalim2) = drog(lcell,plim1) + drog(lcell,plim2) + &
5954 drog(lcell,plim3)
5955 !bs
5956 !bs * calculate actual production from gasphase reactions [ug/m^3]
5957 !bs * calculate vapor pressure of pure compound as a liquid
5958 !bs * using the Clausius-Clapeyromn equation and the actual
5959 !bs * saturation concentration.
5960 !bs * calculate the threshold for partitioning if no initial mass
5961 !bs * is present to partition into.
5962 !bs
5963 thres = 0.
5964 mtot = 0.
5965 mtotw = 0.
5966 DO l = 1, ncv
5967 prod(l) = convfac*mwcv(l)*alpha(l)*prod(l)
5968 ctot(l) = prod(l) + cgas(l) + caer(l) !bs redefined below
5969 p(l) = prod(l)
5970 msum(l) = cgas(l) + caer(l) + prod(l)
5971 aold(l) = caer(l)
5972 imwcv(l) = 1./mwcv(l)
5973 pvap(l) = pnull(l)*exp(dhvap(l)/rgas*ttinv)
5974 csat(l) = pvap(l)*mwcv(l)*1.0E06/(rgas*blkta(lcell))
5975 thres = thres + ((cgas(l)+prod(l))/csat(l))
5976 mtot = mtot + caer(l)
5977 mtotw = mtotw + caer(l)*imwcv(l)
5978 END DO
5979 !bs
5980 !bs * small amount of non-volatile absorbing mass is assumed to be
5981 !bs * present (following Bowman et al. (1997) 0.01% of the inorganic
5982 !bs * mass in each size section, here mode)
5983 !bs
5984 mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+cblk(lcell, &
5985 vno3aj))
5986 mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+cblk( &
5987 lcell,vno3ai))
5988 mnonow = 0.0001*(cblk(lcell,vso4aj)/mwso4+cblk(lcell,vnh4aj)/mwnh4+ &
5989 cblk(lcell,vno3aj)/mwno3)
5990 mnonow = mnonow + 0.0001*(cblk(lcell,vso4ai)/mwso4+cblk(lcell,vnh4ai)/ &
5991 mwnh4+cblk(lcell,vno3ai)/mwno3)
5992 mnono = max(mnono,conmin)
5993 mnonow = max(mnonow,conmin)
5994 !bs
5995 !bs MNONOW = 0.
5996 !bs MNONO = 0.
5997 !bs
5998 minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + &
5999 cblk(lcell,vorgpai) + mnono
6000 minitw = (cblk(lcell,vecj)+cblk(lcell,veci))/mwc + &
6001 (cblk(lcell,vorgpaj)+cblk(lcell,vorgpai))/mworg + mnonow
6002 !bs
6003 !bs * If MINIT is set to zero partitioning will occur if the pure
6004 !bs * saturation concentation is exceeded (Pandis et al. 1992).
6005 !bs * If some amount of absorbing organic mass is formed gas/particle
6006 !bs * partitioning will follow the ideal solution approach.
6007 !bs
6008 minit = 0.
6009 minitw = 0.
6010 !bs
6011 mtot = mtot + minit
6012 mtotw = mtotw + minitw
6013 imtotw = 1./mtotw
6014 !bs
6015 !bs * do the gas/particle partitioning
6016 !bs
6017 IF ((thres>1 .AND. minitw<thrsmin) .OR. (minitw>thrsmin) .OR. &
6018 (mtot>thrsmin)) THEN
6019 !bs
6020 DO l = 1, ncv
6021 ctot(l) = p(l) + cgas(l) + caer(l)
6022 caer(l) = ctot(l) !bs 'initial' guess
6023 END DO
6024 !bs
6025 !bs * globally convergent method for nonlinear system of equations
6026 !bs * adopted from Numerical Recipes 2nd Edition
6027 !bs
6028 CALL newt(layer,caer,ncv,check,ctot,csat,imwcv,minitw,its)
6029 !bs
6030 IF (check) THEN
6031 ! WRITE (6,'(a,i2)') '!! Problems in SR NEWT !! K: ', layer
6032 END IF
6033 !bs
6034 !bs IF (layer==1) WRITE (76,'(i3)') its
6035 !bs
6036 DO l = 1, ncv
6037 IF (caer(l)<=tolmin) THEN
6038 ! IF (abs(caer(l))>tolmin) WRITE (6,90000) l, caer(l)
6039 caer(l) = conmin
6040 END IF
6041 IF (caer(l)>ctot(l)) THEN
6042 IF (caer(l)-ctot(l)>tolmin) THEN
6043 ! WRITE (6,90010)
6044 END IF
6045 caer(l) = ctot(l)
6046 END IF
6047 cgas(l) = ctot(l) - caer(l)
6048 END DO
6049 !bs
6050 !90000 FORMAT ('!! PROBLEMS WITH CAER, CAER < 0. !!',1X,I1,1PE14.6)
6051 !90010 FORMAT ('!! PROBLEMS WITH CAER, CAER > CTOT !!')
6052 !bs
6053 !bs * assign values to CBLK array
6054 !bs
6055 cblk(lcell,vcvaro1) = max(cgas(psoaaro1),conmin)
6056 cblk(lcell,vcvaro2) = max(cgas(psoaaro2),conmin)
6057 cblk(lcell,vcvalk1) = max(cgas(psoaalk1),conmin)
6058 cblk(lcell,vcvole1) = max(cgas(psoaole1),conmin)
6059 cblk(lcell,vcvapi1) = max(cgas(psoaapi1),conmin)
6060 cblk(lcell,vcvapi2) = max(cgas(psoaapi2),conmin)
6061 cblk(lcell,vcvlim1) = max(cgas(psoalim1),conmin)
6062 cblk(lcell,vcvlim2) = max(cgas(psoalim2),conmin)
6063 orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
6064 orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
6065 orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
6066 orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
6067 orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
6068 orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
6069 orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
6070 orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
6071 !bs
6072 !bs
6073 ELSE
6074 !bs WRITE(6,'(a)') 'Pandis method in SR SOA_PART.F used!'
6075 !bs WRITE(6,1010) THRES, MINITW
6076 !bs 1010 FORMAT('THRES =',1pe14.6,1X,'MINITW =',1pe14.6)
6077 !bs
6078 !bs do Pandis method
6079 DO l = 1, ncv
6080 caer(l) = ctot(l) - csat(l)
6081 caer(l) = max(caer(l),0.)
6082 cgas(l) = ctot(l) - caer(l)
6083 END DO
6084 !bs
6085 cblk(lcell,vcvaro1) = cgas(psoaaro1)
6086 cblk(lcell,vcvaro2) = cgas(psoaaro2)
6087 cblk(lcell,vcvalk1) = cgas(psoaalk1)
6088 cblk(lcell,vcvole1) = cgas(psoaole1)
6089 cblk(lcell,vcvapi1) = cgas(psoaapi1)
6090 cblk(lcell,vcvapi2) = cgas(psoaapi2)
6091 cblk(lcell,vcvlim1) = cgas(psoalim1)
6092 cblk(lcell,vcvlim2) = cgas(psoalim2)
6093 orgaro1rat(lcell) = (caer(psoaaro1)-aold(psoaaro1))/dt
6094 orgaro2rat(lcell) = (caer(psoaaro2)-aold(psoaaro2))/dt
6095 orgalk1rat(lcell) = (caer(psoaalk1)-aold(psoaalk1))/dt
6096 orgole1rat(lcell) = (caer(psoaole1)-aold(psoaole1))/dt
6097 orgbio1rat(lcell) = (caer(psoaapi1)-aold(psoaapi1))/dt
6098 orgbio2rat(lcell) = (caer(psoaapi2)-aold(psoaapi2))/dt
6099 orgbio3rat(lcell) = (caer(psoalim1)-aold(psoalim1))/dt
6100 orgbio4rat(lcell) = (caer(psoalim2)-aold(psoalim2))/dt
6101 !bs
6102 END IF
6103 !bs
6104 !bs * check mass conservation
6105 !bs
6106 DO l = 1, ncv
6107 !rs check is component exits
6108 IF (cgas(l)==0. .AND. caer(l)==0. .AND. msum(l)==0) THEN
6109 mcheck = 1.
6110 ELSE
6111 mcheck = (cgas(l)+caer(l))/msum(l)
6112 END IF
6113 IF ((mcheck<1.-rtol) .OR. (mcheck>1.+rtol)) THEN
6114 ! WRITE (6,'(/,a)') 'Problems with mass conservation!'
6115 ! WRITE (6,90020) layer, l, mcheck, cgas(l) + caer(l)
6116 ! WRITE (6,'(a)') '!! CHECK RESULTS !!'
6117 90020 FORMAT ('LAYER = ',I2,', L = ',I2,', MCHECK = ',E12.6,', MASS = ', &
6118 E12.6)
6119 END IF
6120 END DO
6121 !bs
6122 !bs
6123 END DO
6124 !bs * end of SR SOA_PART
6125 !bs
6126 !bs loop over NUMCELLS
6127 RETURN
6128 END SUBROUTINE soa_part
6129 SUBROUTINE sorgam(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
6130 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog,ncv, &
6131 nacv,cblk,blksize,nspcsda,numcells,dt)
6132 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
6133 !bs !
6134 !bs Description: Secondary organic aerosol module !
6135 !bs This module calculates the gas/particle parti- !
6136 !bs tioning of semi-volatile organic vapors !
6137 !bs !
6138 !bs Called by: RPMMOD3 !
6139 !bs !
6140 !bs Calls: SOA_PANDIS !
6141 !bs SOA_PART !
6142 !bs !
6143 !bs Arguments: LAYER, BLKTA, !
6144 !bs ORGARO1RAT, ORGARO2RAT, !
6145 !bs ORGALK1RAT, ORGOLE1RAT, !
6146 !bs ORGBIO1RAT, ORGBIO2RAT, !
6147 !bs DROG, LDROG, !
6148 !bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, !
6149 !bs DT !
6150 !bs !
6151 !bs Include files: AEROSTUFF.EXT !
6152 !bs AERO_internal.EXT !
6153 !bs !
6154 !bs Data: !
6155 !bs !
6156 !bs Input files: None !
6157 !bs !
6158 !bs Output files: UNIT 90: control output !
6159 !bs !
6160 !bs--------------------------------------------------------------------!
6161 !bs !
6162 !bs History: !
6163 !bs No Date Author Change !
6164 !bs ____ ______ ________________ _________________________________ !
6165 !bs 01 040299 B.Schell Set up !
6166 !bs !
6167 !bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *!
6168 !bs
6169 !bs * Literature:
6170 !bs * Pandis et al. (1992): Secondary organic aerosol formation and
6171 !bs * transport. Atmos Environ. 26A, 2453-2466.
6172 !bs * Seinfeld and Pandis (1998): Atmospheric Chemistry and Physics
6173 !bs * chapter 13.5.2 Noninteracting SOA compounds. (0-471-17816-0)
6174 !bs * STI Report (Sonoma Technology, Inc.) (1998):
6175 !bs * Development of gas-phase chemistry, secondary organic aerosol,
6176 !bs * and aqueous-phase chemistry modules for PM modeling.
6177 !bs * By: R. Strader, C. Gurciullo, S. Pandis, N. Kumar, F. Lurmann
6178 !bs * Prepared for: Coordinating Research Council, Atlanta, Aug 24 1
6179 !bs * Tao and McMurray (1989): Vapor pressures and surface free energies
6180 !bs * C14-C18 monocarboxylic acids and C5 and C6 dicarboxylic acids.
6181 !bs * Eniron. Sci. Technol. 23, 1519-1523.
6182 !bs * Pankow (1994): An absorption model of gas/particle partitioning of
6183 !bs * organic compounds in the atmosphere. Atmos. Environ. 28, 185-1
6184 !bs * Pankow (1994): An absorption model of gas/aerosol partitioning inv
6185 !bs * in the formation of secondary organic aerosol.
6186 !bs * Atmos. Environ. 28, 189-193.
6187 !bs * Odum et al. (1996): Gas/particle partitioning and secondary organi
6188 !bs * aerosol yields. Environ. Sci. Technol. 30(8), 2580-2585.
6189 !bs
6190 ! IMPLICIT NONE
6191 !bs
6192 !bs
6193 !bs * variable declaration
6194 !bs
6195 !bs
6196 !bs * inputs
6197 !bs
6198 ! dimension of arrays
6199 INTEGER blksize
6200 ! number of species in CBLK
6201 INTEGER nspcsda
6202 ! actual number of cells in arrays
6203 INTEGER numcells
6204 ! model layer
6205 INTEGER layer
6206 ! # of organic aerosol precursor
6207 INTEGER ldrog
6208 ! total # of cond. vapors & SOA sp
6209 INTEGER ncv
6210 ! # of anthrop. cond. vapors & SOA
6211 INTEGER nacv
6212 ! model time step in SECONDS
6213 REAL dt
6214 REAL cblk(blksize,nspcsda) ! main array of variables
6215 REAL blkta(blksize) ! Air temperature [ K ]
6216 REAL blkprs(blksize) ! Air pressure in [ Pa ]
6217 REAL orgaro1rat(blksize) ! rates from aromatics
6218 ! anth. organic vapor production
6219 REAL orgaro2rat(blksize) ! rates from aromatics
6220 ! anth. organic vapor production
6221 REAL orgalk1rat(blksize) ! rates from alkanes and others
6222 ! anth. organic vapor production
6223 REAL orgole1rat(blksize) ! rates from alkenes and others
6224 ! anth. organic vapor production
6225 REAL orgbio1rat(blksize) ! bio. organic vapor production ra
6226 REAL orgbio2rat(blksize) ! bio. organic vapor production ra
6227 REAL orgbio3rat(blksize) ! bio. organic vapor production ra
6228 REAL orgbio4rat(blksize) ! bio. organic vapor production ra
6229 REAL drog(blksize,ldrog) !bs
6230 !bs * get some infos
6231 !bs
6232 !bs INTEGER LL
6233 !bs IF (LAYER .EQ. 1) THEN
6234 !bs WRITE(75,4711) (CBLK(1,LL), LL = VORGARO1J, VORGOLE1I)
6235 !bs WRITE(75,4711) (CBLK(1,LL), LL = VORGBA1J , VORGBA4I )
6236 !bs WRITE(75,4712) (CBLK(1,LL), LL = VCVARO1, VCVLIM2)
6237 !bs WRITE(75,4712) (DROG(1,LL), LL = 1, 8)
6238 !bs WRITE(75,4712) (DROG(1,LL), LL = 9, 16)
6239 !bs WRITE(75,4714) (DROG(1,LL), LL = 17,LDROG)
6240 !bs ENDIF
6241 !bs 4711 FORMAT(8(e12.6,1X))
6242 !bs 4712 FORMAT(8(e12.6,1X))
6243 !bs 4713 FORMAT(17(e12.6,1X))
6244 !bs 4714 FORMAT(e12.6,/)
6245 !bs
6246 !bs * begin code
6247 !bs
6248 ! ROG production rate [ug m^-3 s^-
6249 IF (orgaer==1) THEN
6250 ! IF (firstime) THEN
6251 ! WRITE (6,'(a)')
6252 ! WRITE (6,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
6253 ! WRITE (6,'(a)')
6254 ! WRITE (90,'(a)')
6255 ! WRITE (90,'(a)') 'METHOD OF PANDIS USED FOR SOA FORMATION!'
6256 ! firstime = .FALSE.
6257 ! END IF
6258 ! CALL SOA_PANDIS(
6259 ! & LAYER,
6260 ! & BLKTA, BLKPRS,
6261 ! & ORGARO1RAT, ORGARO2RAT,
6262 ! & ORGALK1RAT, ORGOLE1RAT,
6263 ! & ORGBIO1RAT, ORGBIO2RAT,
6264 ! & ORGBIO3RAT, ORGBIO4RAT,
6265 ! & DROG, LDROG, NCV, NACV,
6266 ! & CBLK, BLKSIZE, NSPCSDA, NUMCELLS,
6267 ! & DT
6268 ! & )
6269 ELSE IF (orgaer==2) THEN
6270 ! IF (firstime) THEN
6271 ! WRITE (6,'(a)')
6272 ! WRITE (6,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
6273 ! WRITE (6,'(a)')
6274 ! WRITE (90,'(a)')
6275 ! WRITE (90,'(a)') 'PANKOW/ODUM METHOD USED FOR SOA FORMATION!'
6276 ! firstime = .FALSE.
6277 ! END IF
6278 CALL soa_part(layer,blkta,blkprs,orgaro1rat,orgaro2rat,orgalk1rat, &
6279 orgole1rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog, &
6280 ncv,nacv,cblk,blksize,nspcsda,numcells,dt)
6281 ELSE
6282 ! WRITE (6,'(a)')
6283 ! WRITE (6,'(a)') 'WRONG PARAMETER ORGAER !!'
6284 ! WRITE (6,90000) orgaer
6285 ! WRITE (6,'(a)') 'PROGRAM TERMINATED !!'
6286 ! WRITE (6,'(a)')
6287 ! STOP
6288 END IF
6289 !bs
6290 !bs ORGARO1RAT(1) = 0.
6291 !bs ORGARO2RAT(1) = 0.
6292 !bs ORGALK1RAT(1) = 0.
6293 !bs ORGOLE1RAT(1) = 0.
6294 !bs ORGBIO1RAT(1) = 0.
6295 !bs ORGBIO2RAT(1) = 0.
6296 !bs ORGBIO3RAT(1) = 0.
6297 !bs ORGBIO4RAT(1) = 0.
6298 !bs WRITE(6,'(a)') '!!! ORGRATs SET TO 0. !!!'
6299 !bs
6300 !bs * formats
6301 !bs
6302 90000 FORMAT ('ORGAER = ',I2)
6303 !bs
6304 !bs * end of SR SORGAM
6305 !bs
6306 RETURN
6307 END SUBROUTINE sorgam
6308 !****************************************************************
6309 !
6310 !
6311 !
6312 !
6313 ! ///////////////////////////////
6314 ! *** this routine calculates the dry deposition and sedimentation
6315 ! velocities for the three modes.
6316 ! coded 1/23/97 by Dr. Francis S. Binkowski. Follows
6317 ! FSB's original method, i.e. uses Jon Pleim's expression for deposition
6318 ! velocity but includes Marv Wesely's wstar contribution.
6319 !ia eliminated Stokes term for coarse mode deposition calcs.,
6320 !ia see comments below
6321
6322 SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, &
6323 LAYER, &
6324 CBLK, &
6325 BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, &
6326 DGNUC, DGACC, DGCOR, &
6327 KNNUC, KNACC,KNCOR, &
6328 PDENSN, PDENSA, PDENSC, &
6329 VSED, VDEP )
6330
6331 ! *** calculate size-averaged particle dry deposition and
6332 ! size-averaged sedimentation velocities.
6333
6334
6335 ! IMPLICIT NONE
6336
6337 INTEGER BLKSIZE ! dimension of arrays
6338 INTEGER NSPCSDA ! number of species in CBLK
6339 INTEGER NUMCELLS ! actual number of cells in arrays
6340 INTEGER LAYER ! number of layer
6341
6342 REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables
6343 REAL BLKTA( BLKSIZE ) ! Air temperature [ K ]
6344 REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ]
6345 REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ]
6346 REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ]
6347 REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ]
6348 REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ]
6349 REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ]
6350 REAL DGACC( BLKSIZE ) ! accumulation
6351 REAL DGCOR( BLKSIZE ) ! coarse mode
6352 REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number
6353 REAL KNACC( BLKSIZE ) ! accumulation
6354 REAL KNCOR( BLKSIZE ) ! coarse mode
6355 REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ]
6356 REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ]
6357 REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ]
6358
6359
6360 ! *** modal particle diffusivities for number and 3rd moment, or mass:
6361
6362 REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE)
6363 REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE)
6364
6365 ! *** modal sedimentation velocities for number and 3rd moment, or mass:
6366
6367 REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE)
6368 REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE)
6369
6370 ! *** deposition and sedimentation velocities
6371
6372 REAL VDEP( BLKSIZE, NASPCSDEP) ! sedimantation velocity [ m s**-1 ]
6373 REAL VSED( BLKSIZE, NASPCSSED) ! deposition velocity [ m s**-1 ]
6374
6375
6376 INTEGER LCELL
6377 REAL DCONST1, DCONST1N, DCONST1A, DCONST1C
6378 REAL DCONST2, DCONST3N, DCONST3A,DCONST3C
6379 REAL SC0N, SC0A, SC0C ! Schmidt numbers for number
6380 REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment
6381 REAL ST0N, ST0A, ST0C ! Stokes numbers for number
6382 REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment
6383 REAL RD0N, RD0A, RD0C ! canopy resistance for number
6384 REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment
6385 REAL UTSCALE ! scratch function of USTAR and WSTAR.
6386 REAL NU !kinematic viscosity [ m**2 s**-1 ]
6387 REAL USTFAC ! scratch function of USTAR, NU, and GRAV
6388 REAL BHAT
6389 PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction.
6390
6391
6392 ! *** check layer value.
6393
6394 IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and
6395 ! sedimentation velocities
6396
6397 DO LCELL = 1, NUMCELLS
6398
6399 DCONST1 = BOLTZ * BLKTA(LCELL) / &
6400 ( THREEPI * AMU(LCELL) )
6401 DCONST1N = DCONST1 / DGNUC( LCELL )
6402 DCONST1A = DCONST1 / DGACC( LCELL )
6403 DCONST1C = DCONST1 / DGCOR( LCELL )
6404 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6405 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6406 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6407 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6408
6409 ! *** i-mode
6410
6411 DCHAT0N(LCELL) = DCONST1N &
6412 * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 )
6413
6414 DCHAT3N(LCELL) = DCONST1N &
6415 * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 )
6416
6417 VGHAT0N(LCELL) = DCONST3N &
6418 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6419
6420 VGHAT3N(LCELL) = DCONST3N &
6421 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6422
6423 ! *** j-mode
6424
6425 DCHAT0A(LCELL) = DCONST1A &
6426 * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 )
6427
6428 DCHAT3A(LCELL) = DCONST1A &
6429 * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 )
6430
6431 VGHAT0A(LCELL) = DCONST3A &
6432 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6433
6434 VGHAT3A(LCELL) = DCONST3A &
6435 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6436
6437
6438 ! *** coarse mode
6439
6440 DCHAT0C(LCELL)= DCONST1C &
6441 * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 )
6442
6443 DCHAT3C(LCELL) = DCONST1C &
6444 * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 )
6445
6446 VGHAT0C(LCELL) = DCONST3C &
6447 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6448
6449 VGHAT3C(LCELL) = DCONST3C &
6450 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6451
6452 END DO
6453
6454 ! *** now calculate the deposition and sedmentation velocities
6455
6456 !ia 07.05.98
6457 ! *** NOTE In the deposition velocity for coarse mode,
6458 ! the impaction term 10.0 ** (-3.0 / st) is eliminated because
6459 ! coarse particles are likely to bounce on impact and the current
6460 ! formulation does not account for this.
6461
6462
6463 DO LCELL = 1, NUMCELLS
6464
6465 NU = AMU(LCELL) / BLKDENS(LCELL)
6466 USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU)
6467 UTSCALE = USTAR(LCELL) + &
6468 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL)
6469
6470 ! *** first do number
6471
6472 ! *** nuclei or Aitken mode ( no sedimentation velocity )
6473
6474 SC0N = NU / DCHAT0N(LCELL)
6475 ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01)
6476 RD0N = 1.0 / ( UTSCALE * &
6477 ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) )
6478
6479 VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + &
6480 1.0 / ( &
6481 RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) )
6482
6483 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6484
6485 ! *** accumulation mode
6486
6487 SC0A = NU / DCHAT0A(LCELL)
6488 ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01)
6489 RD0A = 1.0 / ( UTSCALE * &
6490 ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) )
6491
6492 VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + &
6493 1.0 / ( &
6494 RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) )
6495
6496 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6497
6498 ! *** coarse mode
6499
6500 SC0C = NU / DCHAT0C(LCELL)
6501 !ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 )
6502 !ia RD0C = 1.0 / ( UTSCALE *
6503 !ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) )
6504
6505 RD0C = 1.0 / ( UTSCALE * &
6506 ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term
6507
6508 VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + &
6509 1.0 / ( &
6510 RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) )
6511
6512 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6513
6514 ! *** now do m3 for the deposition of mass
6515
6516 ! *** nuclei or Aitken mode
6517
6518 SC3N = NU / DCHAT3N(LCELL)
6519 ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01)
6520 RD3N = 1.0 / ( UTSCALE * &
6521 ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) )
6522
6523 VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + &
6524 1.0 / ( &
6525 RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) )
6526
6527 VSED(LCELL, VSMNUC) = VGHAT3N(LCELL)
6528
6529 ! *** accumulation mode
6530
6531 SC3A = NU / DCHAT3A(LCELL)
6532 ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 )
6533 RD3A = 1.0 / ( UTSCALE * &
6534 ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) )
6535
6536 VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + &
6537 1.0 / ( &
6538 RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) )
6539
6540
6541 ! *** fine mass deposition velocity: combine Aitken and accumulation
6542 ! mode deposition velocities. Assume density is the same
6543 ! for both modes.
6544
6545
6546 ! VDEP(LCELL,VDMFINE) = (
6547 ! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) +
6548 ! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) /
6549 ! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) )
6550
6551
6552 ! *** fine mass sedimentation velocity
6553
6554 ! VSED( LCELL, VSMFINE) = (
6555 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6556 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6557 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6558
6559 VSED( LCELL, VSMACC ) = VGHAT3A(LCELL)
6560
6561 ! *** coarse mode
6562
6563 SC3C = NU / DCHAT3C(LCELL)
6564 !ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 )
6565 !ia RD3C = 1.0 / ( UTSCALE *
6566 !ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) )
6567
6568 RD3C = 1.0 / ( UTSCALE * &
6569 ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term
6570 VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + &
6571 1.0 / ( &
6572 RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL))
6573
6574 ! *** coarse mode sedmentation velocity
6575
6576 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6577
6578
6579
6580 END DO
6581
6582 ELSE ! LAYER greater than 1
6583
6584 ! *** for layer greater than 1 calculate sedimentation velocities only
6585
6586 DO LCELL = 1, NUMCELLS
6587
6588 DCONST2 = GRAV / ( 18.0 * AMU(LCELL) )
6589
6590 DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2
6591 DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2
6592 DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2
6593
6594 VGHAT0N(LCELL) = DCONST3N &
6595 * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 )
6596
6597 ! *** nucleation mode number sedimentation velocity
6598
6599 VSED( LCELL, VSNNUC) = VGHAT0N(LCELL)
6600
6601 VGHAT3N(LCELL) = DCONST3N &
6602 * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 )
6603
6604 ! *** nucleation mode volume sedimentation velocity
6605
6606 VSED( LCELL, VSMNUC) = VGHAT3N(LCELL)
6607
6608 VGHAT0A(LCELL) = DCONST3A &
6609 * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 )
6610
6611 ! *** accumulation mode number sedimentation velocity
6612
6613 VSED( LCELL, VSNACC) = VGHAT0A(LCELL)
6614
6615 VGHAT3A(LCELL) = DCONST3A &
6616 * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 )
6617
6618 ! *** fine mass sedimentation velocity
6619
6620 ! VSED( LCELL, VSMFINE) = (
6621 ! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) +
6622 ! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) /
6623 ! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) )
6624
6625 VSED( LCELL, VSMACC) = VGHAT3A(LCELL)
6626
6627 VGHAT0C(LCELL) = DCONST3C &
6628 * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 )
6629
6630 ! *** coarse mode sedimentation velocity
6631
6632 VSED( LCELL, VSNCOR) = VGHAT0C(LCELL)
6633
6634
6635 VGHAT3C(LCELL) = DCONST3C &
6636 * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 )
6637
6638 ! *** coarse mode mass sedimentation velocity
6639
6640 VSED( LCELL, VSMCOR) = VGHAT3C(LCELL)
6641
6642 END DO
6643
6644 END IF ! check on layer
6645
6646 END SUBROUTINE vdvg
6647 !
6648 !
6649 SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, &
6650 pm2_5_dry,pm2_5_water,pm2_5_dry_ec, &
6651 chem_in_opt,aer_ic_opt, &
6652 ids,ide, jds,jde, kds,kde, &
6653 ims,ime, jms,jme, kms,kme, &
6654 its,ite, jts,jte, kts,kte )
6655 implicit none
6656 INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt
6657 INTEGER, INTENT(IN ) :: &
6658 ids,ide, jds,jde, kds,kde, &
6659 ims,ime, jms,jme, kms,kme, &
6660 its,ite, jts,jte, kts,kte
6661 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , &
6662 INTENT(INOUT ) :: &
6663 chem
6664 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6665 INTENT(INOUT ) :: &
6666 pm2_5_dry,pm2_5_water,pm2_5_dry_ec
6667 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6668 INTENT(IN ) :: &
6669 convfac
6670 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
6671 INTENT(IN ) :: &
6672 z_at_w
6673 integer i,j,k,l,ii,jj,kk
6674 real tempfac,mwso4,zz
6675 ! real,dimension(its:ite,kts:kte,jts:jte) :: convfac
6676 REAL splitfac
6677 !between gas and aerosol phase
6678 REAL so4vaptoaer
6679 !factor for splitting initial conc. of SO4
6680 !3rd moment i-mode [3rd moment/m^3]
6681 REAL m3nuc
6682 !3rd MOMENT j-mode [3rd moment/m^3]
6683 REAL m3acc
6684 ! REAL ESN36
6685 REAL m3cor
6686 DATA splitfac/.98/
6687 DATA so4vaptoaer/.999/
6688
6689 pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0.
6690 pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0.
6691 pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0.
6692
6693 ! *** Compute these once and they will all be saved in COMMON
6694 xxlsgn = log(sginin)
6695 xxlsga = log(sginia)
6696 xxlsgc = log(sginic)
6697
6698 l2sginin = xxlsgn**2
6699 l2sginia = xxlsga**2
6700 l2sginic = xxlsgc**2
6701
6702 en1 = exp(0.125*l2sginin)
6703 ea1 = exp(0.125*l2sginia)
6704 ec1 = exp(0.125*l2sginic)
6705
6706
6707 esn04 = en1**4
6708 esa04 = ea1**4
6709 esc04 = ec1**4
6710
6711 esn05 = esn04*en1
6712 esa05 = esa04*ea1
6713
6714 esn08 = esn04*esn04
6715 esa08 = esa04*esa04
6716 esc08 = esc04*esc04
6717
6718 esn09 = esn04*esn05
6719 esa09 = esa04*esa05
6720
6721 esn12 = esn04*esn04*esn04
6722 esa12 = esa04*esa04*esa04
6723 esc12 = esc04*esc04*esc04
6724
6725 esn16 = esn08*esn08
6726 esa16 = esa08*esa08
6727 esc16 = esc08*esc08
6728
6729 esn20 = esn16*esn04
6730 esa20 = esa16*esa04
6731 esc20 = esc16*esc04
6732
6733 esn24 = esn12*esn12
6734 esa24 = esa12*esa12
6735 esc24 = esc12*esc12
6736
6737 esn25 = esn16*esn09
6738 esa25 = esa16*esa09
6739
6740 esn28 = esn20*esn08
6741 esa28 = esa20*esa08
6742 esc28 = esc20*esc08
6743
6744
6745 esn32 = esn16*esn16
6746 esa32 = esa16*esa16
6747 esc32 = esc16*esc16
6748
6749 esn36 = esn16*esn20
6750 esa36 = esa16*esa20
6751 esc36 = esc16*esc20
6752
6753 esn49 = esn25*esn20*esn04
6754 esa49 = esa25*esa20*esa04
6755
6756 esn52 = esn16*esn36
6757 esa52 = esa16*esa36
6758
6759 esn64 = esn32*esn32
6760 esa64 = esa32*esa32
6761 esc64 = esc32*esc32
6762
6763 esn100 = esn36*esn64
6764
6765 esnm20 = 1.0/esn20
6766 esam20 = 1.0/esa20
6767 escm20 = 1.0/esc20
6768
6769 esnm32 = 1.0/esn32
6770 esam32 = 1.0/esa32
6771 escm32 = 1.0/esc32
6772
6773
6774 xxm3 = 3.0*xxlsgn/ sqrt2
6775 ! factor used in error function cal
6776 nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36)
6777
6778 nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36)
6779
6780 nummin_c = anthfac*aeroconcmin/(dginic**3*esc36)
6781
6782 ! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume)
6783 ! size distribution , then
6784
6785 ! vol = (p/6) * density * num * (dgemv_xx**3) *
6786 ! exp(- 4.5 * log( sgem_xx)**2 ) )
6787 ! note minus sign!!
6788
6789 factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3
6790 factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3
6791 factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3
6792 ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4))
6793 ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg))
6794 mwso4=96.03
6795 !
6796 !
6797 ! IF USING OLD SIMULATION, DO NOT REINITIALIZE!
6798 !
6799 !
6800 if(chem_in_opt == 1 ) return
6801 do l=p_so4aj,num_chem
6802 chem(ims:ime,kms:kme,jms:jme,l)=epsilc
6803 enddo
6804 chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8
6805 chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8
6806 do j=jts,jte
6807 jj=min(jde-1,j)
6808 do k=kts,kte-1
6809 kk=min(kde-1,k)
6810 do i=its,ite
6811 ii=min(ide-1,i)
6812
6813 !Option for alternate ic's
6814 if( aer_ic_opt == AER_IC_DEFAULT ) then
6815 chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4*splitfac*so4vaptoaer
6816 chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(i,k,j)*MWSO4* &
6817 (1.-splitfac)*so4vaptoaer
6818 chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer)
6819 chem(i,k,j,p_nh4aj) = 10.E-05
6820 chem(i,k,j,p_nh4ai) = 10.E-05
6821 chem(i,k,j,p_no3aj) = 10.E-05
6822 chem(i,k,j,p_no3ai) = 10.E-05
6823 elseif( aer_ic_opt == AER_IC_PNNL ) then
6824 zz = (z_at_w(i,k,j)+z_at_w(i,k+1,j))*0.5
6825 call sorgam_init_aer_ic_pnnl( &
6826 chem, zz, i,k,j, ims,ime,jms,jme,kms,kme )
6827 else
6828 call wrf_error_fatal( &
6829 "aerosols_sorgam_init: unable to parse aer_ic_opt" )
6830 end if
6831
6832 !... i-mode
6833 m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + &
6834 no3fac*chem(i,k,j,p_no3ai) + orgfac*chem(i,k,j,p_orgaro1i) + &
6835 orgfac*chem(i,k,j,p_orgaro2i) + orgfac*chem(i,k,j,p_orgalk1i) + &
6836 orgfac*chem(i,k,j,p_orgole1i) + orgfac*chem(i,k,j,p_orgba1i) + &
6837 orgfac*chem(i,k,j,p_orgba2i) + orgfac*chem(i,k,j,p_orgba3i) + &
6838 orgfac*chem(i,k,j,p_orgba4i) + orgfac*chem(i,k,j,p_orgpai) + &
6839 anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci)
6840
6841 !... j-mode
6842 m3acc = so4fac*(chem(i,k,j,p_so4aj)) + nh4fac*(chem(i,k,j,p_nh4aj)) + &
6843 no3fac*(chem(i,k,j,p_no3aj)) + orgfac*(chem(i,k,j,p_orgaro1j)) + &
6844 orgfac*(chem(i,k,j,p_orgaro2j)) + orgfac*(chem(i,k,j,p_orgalk1j)) + &
6845 orgfac*(chem(i,k,j,p_orgole1j)) + orgfac*(chem(i,k,j,p_orgba1j)) + &
6846 orgfac*(chem(i,k,j,p_orgba2j)) + orgfac*(chem(i,k,j,p_orgba3j)) + &
6847 orgfac*(chem(i,k,j,p_orgba4j)) + orgfac*(chem(i,k,j,p_orgpaj)) + &
6848 anthfac*(chem(i,k,j,p_p25j)) + anthfac*(chem(i,k,j,p_ecj))
6849
6850 !...c-mode
6851 m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + &
6852 anthfac*chem(i,k,j,p_antha)
6853
6854
6855 !...NOW CALCULATE INITIAL NUMBER CONCENTRATION
6856 chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36)
6857
6858 chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36)
6859
6860 chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36)
6861
6862 !jdf, added if statement, don't want to overide specified values for PNNL case
6863 if( aer_ic_opt == AER_IC_DEFAULT ) then
6864 chem(i,k,j,p_so4aj)=chem(i,k,j,p_so4aj)
6865 chem(i,k,j,p_so4ai)=chem(i,k,j,p_so4ai)
6866 chem(i,k,j,p_nh4aj) = 10.E-05
6867 chem(i,k,j,p_nh4ai) = 10.E-05
6868 chem(i,k,j,p_no3aj) = 10.E-05
6869 chem(i,k,j,p_no3ai) = 10.E-05
6870 endif
6871 !jdf
6872 enddo
6873 enddo
6874 enddo
6875
6876
6877 return
6878 END SUBROUTINE aerosols_sorgam_init
6879
6880 !****************************************************************
6881 ! *
6882 ! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE *
6883 ! aer_ic_opt == aer_ic_pnnl OPTION. *
6884 ! *
6885 ! wig, 21-Apr-2004, original version *
6886 ! rce, 25-apr-2004 - name changes for consistency with *
6887 ! new aer_ic constants in Registry *
6888 ! wig, 7-May-2004, added height dependance *
6889 ! *
6890 ! CALLS THE FOLLOWING SUBROUTINES: NONE *
6891 ! *
6892 ! CALLED BY : aerosols_sorgam_init *
6893 ! *
6894 !****************************************************************
6895 SUBROUTINE sorgam_init_aer_ic_pnnl( &
6896 chem, z, i,k,j, ims,ime, jms,jme, kms,kme )
6897
6898 USE module_configure,only:num_chem
6899 implicit none
6900
6901 INTEGER,INTENT(IN ) :: i,k,j, &
6902 ims,ime, jms,jme, kms,kme
6903 REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),&
6904 INTENT(INOUT ) :: chem
6905
6906 real, intent(in ) :: z
6907 real :: mult
6908
6909 !
6910 ! Determine height multiplier...
6911 ! This should mimic the calculation in sorgam_set_aer_bc_pnnl,
6912 ! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic
6913 !!$! Height(m) Multiplier
6914 !!$! --------- ----------
6915 !!$! <=2000 1.0
6916 !!$! 2000<z<3000 linear transition zone to 0.5
6917 !!$! 3000<z<5000 linear transision zone to 0.25
6918 !!$! >=3000 0.25
6919 !!$!
6920 !!$! which translates to:
6921 !!$! 2000<z<3000 mult = 1.0 + (z-2000.)*(0.5-1.0)/(3000.-2000.)
6922 !!$! 3000<z<5000 mult = 0.5 + (z-3000.)*(0.25-0.5)/(5000.-3000.)
6923 !!$! or in reduced form:
6924 !!$ if( z <= 2000. ) then
6925 !!$ mult = 1.0
6926 !!$ elseif( z > 2000. &
6927 !!$ .and. z <= 3000. ) then
6928 !!$ mult = 1.0 - 0.0005*(z-2000.)
6929 !!$ elseif( z > 3000. &
6930 !!$ .and. z <= 5000. ) then
6931 !!$ mult = 0.5 - 1.25e-4*(z-3000.)
6932 !!$ else
6933 !!$ mult = 0.25
6934 !!$ end if
6935 ! Updated aerosol profile multiplier 1-Apr-2005:
6936 ! Height(m) Multiplier
6937 ! --------- ----------
6938 ! <=2000 1.0
6939 ! 2000<z<3000 linear transition zone to 0.25
6940 ! 3000<z<5000 linear transision zone to 0.125
6941 ! >=5000 0.125
6942 !
6943 ! which translates to:
6944 ! 2000<z<3000 mult = 1.00 + (z-2000.)*(0.25-1.0)/(3000.-2000.)
6945 ! 3000<z<5000 mult = 0.25 + (z-3000.)*(0.125-0.25)/(5000.-3000.)
6946 ! or in reduced form:
6947 if( z <= 2000. ) then
6948 mult = 1.0
6949 elseif( z > 2000. &
6950 .and. z <= 3000. ) then
6951 mult = 1.0 - 0.00075*(z-2000.)
6952 elseif( z > 3000. &
6953 .and. z <= 5000. ) then
6954 mult = 0.25 - 4.166666667e-5*(z-3000.)
6955 else
6956 mult = 0.125
6957 end if
6958
6959 ! These should match what is in sorgam_set_aer_bc_pnnl.
6960 ! Values as of 2-Dec-2004:
6961 chem(i,k,j,p_sulf) = mult*conmin
6962 chem(i,k,j,p_so4aj) = mult*2.375
6963 chem(i,k,j,p_so4ai) = mult*0.179
6964 chem(i,k,j,p_nh4aj) = mult*0.9604
6965 chem(i,k,j,p_nh4ai) = mult*0.0196
6966 chem(i,k,j,p_no3aj) = mult*0.0650
6967 chem(i,k,j,p_no3ai) = mult*0.0050
6968 chem(i,k,j,p_ecj) = mult*0.1630
6969 chem(i,k,j,p_eci) = mult*0.0120
6970 chem(i,k,j,p_p25j) = mult*0.6350
6971 chem(i,k,j,p_p25i) = mult*0.0490
6972 chem(i,k,j,p_antha) = mult*2.2970
6973 chem(i,k,j,p_orgpaj) = mult*0.9300
6974 chem(i,k,j,p_orgpai) = mult*0.0700
6975 chem(i,k,j,p_orgaro1j) = conmin
6976 chem(i,k,j,p_orgaro1i) = conmin
6977 chem(i,k,j,p_orgaro2j) = conmin
6978 chem(i,k,j,p_orgaro2i) = conmin
6979 chem(i,k,j,p_orgalk1j) = conmin
6980 chem(i,k,j,p_orgalk1i) = conmin
6981 chem(i,k,j,p_orgole1j) = conmin
6982 chem(i,k,j,p_orgole1i) = conmin
6983 chem(i,k,j,p_orgba1j) = conmin
6984 chem(i,k,j,p_orgba1i) = conmin
6985 chem(i,k,j,p_orgba2j) = conmin
6986 chem(i,k,j,p_orgba2i) = conmin
6987 chem(i,k,j,p_orgba3j) = conmin
6988 chem(i,k,j,p_orgba3i) = conmin
6989 chem(i,k,j,p_orgba4j) = conmin
6990 chem(i,k,j,p_orgba4i) = conmin
6991 chem(i,k,j,p_seas) = mult*0.229
6992
6993 END SUBROUTINE sorgam_init_aer_ic_pnnl
6994
6995 END Module module_aerosols_sorgam