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