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